diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 448fbc98..643dfac6 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -4,6 +4,7 @@ on: push: branches: - main + - v8.21 - v8.20 - v8.19 - v8.18 @@ -13,6 +14,7 @@ on: pull_request: branches: - main + - v8.21 - v8.20 - v8.19 - v8.18 diff --git a/CHANGES.md b/CHANGES.md index 041c4479..801654be 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,80 @@ +# unreleased +------------ + + - [deps] merge serlib into coq-lsp. This allow us to drop the SerAPI + dependency, and will greatly easy the development of tools that + require AST manipulation (@ejgallego, #698) + - [fleche] Remove 8.16 compatibility layer (@ejgallego, #747) + - [fleche] Preserve view hint across document changes. With this + change, we get local continuous checking mode when the view-port + heuristic is enabled (@ejgallego, #748) + - [memo] More precise hashing for Coq states, this improves cache + performance quite a bit (@ejgallego, #751) + - [fleche] Enable sharing of `.vo` file parsing. This enables better + sharing, achieving an almost 50% memory reduction for example when + opening all of HoTT .v files (@ejgallego, @SkySkimmer, @bhaktishh, + #744) + - [memo] Provide API to query Hashtbl stats (@ejgallego, #753) + - [nix] Add `pet-server` deps to flake.nix (Léo Stefanesco, #754) + - [coq-lsp] Fix crash on `--help` option (Léo Stefanesco, @ejgallego, + #754) + - [vscode] Fix focus race when a Coq file is in column 2 (@ejgallego, + #755, cc: #722, #725) + - [hover] Show input howto for unicode characters on hover + (@ejgallego, Léo Stefanesco, #756) + - [lsp] [definition] Support for jump to definition across workspace + files. The location information is obtained from `.glob` files, so + it is often not perfect. (@ejgallego, #762, fixes #317) + - [lsp] [hover] Show full name and provenance of identifiers + (@ejgallego, #762) + - [lsp] [definition] Try also to resolve and locate module imports + (@ejgallego, #764) + - [code] Don't start server on extension activation, unless an editor + we own is active. We also auto-start the server if a document that + we own is opened later (@ejgallego, #758, fixes #750) + - [petanque] Allow `init` to be called multiple times (@ejgallego, + @gbdrt, #766) + - [petanque] Faster query for goals status after `run_tac` + (@ejgallego, #768) + - [petanque] New parameter `pre_commands` to `start` which allows + instrumenting the goal before starting the proof (@ejgallego, Alex + Sanchez-Stern #769) + - [petanque] New `http_headers={yes,no}` parameter for `pet` json + shell, plus some improvements on protocol handling (@ejgallego, + #770) + - [petanque] Make agent agnostic of environment, allowing embedding + inside LSP (@ejgallego, #771) + - [diagnostics] Ensure extra diagnostics info is present in all + errors, not only on those sentences that did parse successfully + (@ejgallego, Diego Rivera, #772) + - [hover] New option `show_universes_on_hover` that will display + universe data on hover (@ejgallego, @SkySkimmer, #666) + - [hover] New plugin `unidiff` that will elaborate a summary of + universe data a file, in particular regarding universes added at + `Qed` time (@ejgallego, #773) + - [fleche] Support meta-command `Abort All` (@ejgallego, #774, fixes + #550) + - [petanque] Allow memoization control on `petanque/run` via a new + parameter `memo` (@ejgallego, #780) + - [lsp] [petanque] Allow acces to `petanque` protocol from the lsp + server (@ejgallego, #778) + - [petanque] Always initialize a workspace. This made `pet` crash if + `--root` was not used and client didn't issue the optimal + `setWorkspace` call (#782, @ejgallego, @gbdrt) + - [lsp] [petanque] New methods `state/eq` and `state/hash`; this + allows clients to implement a client-side hash; equality is + configurable with different methods; moreover, `petanque/run` can + compute some extra data like state hashing without a round-trip + (@ejgallego @gbdrt, #779) + +# coq-lsp 0.1.10: Hasta el 40 de Mayo _en effect_... +---------------------------------------------------- + + - [code] Add `.v.tex` file extension to contributed language support + (@ejgallego, #740). + - [code] Don't show the panel on extension activation (@ejgallego, + #741, fix #737) + # coq-lsp 0.1.9: Hasta el 40 de Mayo... --------------------------------------- diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index b4abacf5..4ddf2a7b 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -70,7 +70,7 @@ Source Install](https://github.com/coq/platform/blob/main/doc/README_Windows.md#installation-by-compiling-from-sources-using-opam-on-cygwin) The default development environment for `coq-lsp` is a "composed" -build that includes git submodules for `coq` and `coq-serapi` in the +build that includes a git submodules for `coq` in the `vendor/` directory. This allows us to easily work with PRs using experimental Coq branches, and some other advantages like a better CI build cache and easier bisects. @@ -116,11 +116,26 @@ This setup will build Coq and `coq-lsp` and install them to the current OPAM switch. This is a good setup for people looking to try out `coq-lsp` development versions with other OPAM packages. -1. Install vendored Coq and SerAPI: +You can just do: +``` +make opam-update-and-reinstall +``` + +or alternatively, do it step by step + +0. Be sure submodules and `coq-lsp` are up to date:a + + ```sh + git pull --recurse-submodules + ``` + + alternatively you can use `make submodules-init` to refresh the + submodules. + +1. Install vendored Coq ```sh - opam install vendor/coq/coq{-core,-stdlib,}.opam - opam install vendor/coq-serapi + opam install vendor/coq/coq{-core,-stdlib,ide-server,}.opam ``` 2. Install `coq-lsp`: @@ -190,8 +205,7 @@ coq-lsp.packages.${system}.default The `coq-lsp` server consists of several components, we present them bottom-up -- `vendor/coq`: [vendored] Coq version to build coq-lsp against -- `vendor/coq-serapi`: [vendored] improved utility functions to handle Coq AST +- `serlib`: utility functions to handle Coq AST - `coq`: Utility library / abstracted Coq API. This is the main entry point for communication with Coq, and it reifies Coq calls as to present a purely functional interface to Coq. @@ -386,11 +400,12 @@ The checklist for the release as of today is the following: The above can be done with: ``` -export COQLSPV=0.1.8 +export COQLSPV=0.2.0 git checkout main && make && dune-release tag ${COQLSPV} -git checkout v8.18 && git merge main && make && dune-release tag ${COQLSPV}+8.18 && dune-release +git checkout v8.20 && git merge main && make && dune-release tag ${COQLSPV}+8.20 && dune-release +git checkout v8.19 && git merge v8.20 && make && dune-release tag ${COQLSPV}+8.19 && dune-release +git checkout v8.18 && git merge v8.19 && make && dune-release tag ${COQLSPV}+8.18 && dune-release git checkout v8.17 && git merge v8.18 && make && dune-release tag ${COQLSPV}+8.17 && dune-release -git checkout v8.16 && git merge v8.17 && make && dune-release tag ${COQLSPV}+8.16 && dune-release ``` ## Emacs diff --git a/Makefile b/Makefile index 57c6cd02..b6a968ae 100644 --- a/Makefile +++ b/Makefile @@ -113,7 +113,6 @@ submodules-deinit: .PHONY: submodules-update submodules-update: (cd vendor/coq && git checkout master && git pull upstream master) - (cd vendor/coq-serapi && git checkout main && git pull upstream main) # Build the vscode extension .PHONY: extension @@ -127,3 +126,9 @@ ts-fmt: .PHONY: make-fmt make-fmt: build fmt + +# Helper for users that want a global opam install +.PHONY: opam-update-and-reinstall +opam-update-and-reinstall: + git pull + opam install . diff --git a/README.md b/README.md index e9162961..8980bb94 100644 --- a/README.md +++ b/README.md @@ -42,7 +42,7 @@ and web native usage, providing quite a few extra features from vanilla Coq. - [👁 On-demand, Follow The Viewport Document Checking](#-on-demand-follow-the-viewport-document-checking) - [🧠 Smart, Cache-Aware Error Recovery](#-smart-cache-aware-error-recovery) - [🥅 Whole-Document Goal Display](#-whole-document-goal-display) - - [🗒️ Markdown Support](#️-markdown-support) + - [🗒️ Markdown Support](#️-markdown-and-latex-support) - [👥 Document Outline](#-document-outline) - [🐝 Document Hover](#-document-hover) - [📁 Multiple Workspaces](#-multiple-workspaces) @@ -125,16 +125,17 @@ pending obligations, open bullets and their goals. Goal display behavior is configurable in case you'd like to trigger goal display more conservatively. -### 🗒️ Markdown Support +### 🗒️ Markdown and LaTeX Support -Open a markdown file with a `.mv` extension, `coq-lsp` will check the code parts -that are enclosed into `coq` language blocks! `coq-lsp` places human-friendly -documents at the core of its design ideas. +Open a markdown file with a `.mv` extension, or a `TeX` file ending in `.lv` or +`.v.tex`, then `coq-lsp` will check the code parts that are enclosed into `coq` +language blocks! `coq-lsp` places human-friendly documents at the core of its +design ideas. Coq + Markdown Editing -Moreover, you can use Visual Studio Code Markdown preview to render your -markdown documents nicely! +Moreover, you can use the usual Visual Studio Code Markdown or LaTeX preview +facilities to render your markdown documents nicely! ### 👥 Document Outline @@ -249,11 +250,6 @@ We recommended using Coq 8.19 or `master` version. For other Coq versions, we recommend users to install the custom Coq tree as detailed in [Coq Upstream Bugs](#coq-upstream-bugs). -Support for Coq 8.15 and 8.16 has been phased out due to lack of development -resources, but if you are interested it should possible to bring it back with -reasonable effort. Support for older Coq versions is also possible, with a bit -more effort; `coq-lsp` should work with Coq versions back to Coq 8.10/8.9. - Note that this section covers user installs, if you would like to contribute to `coq-lsp` and build a development version, please check our [contributing guide](./CONTRIBUTING.md) @@ -278,12 +274,12 @@ guide](./CONTRIBUTING.md) This provides a Windows native binary that can be executed from VSCode normally. As of today a bit of configuration is still needed: - In VSCode, set the `Coq-lsp: Path` to: - + `C:\Coq-Platform~8.17-lsp\bin\coq-lsp.exe` + + `C:\Coq-Platform~8.20-lsp\bin\coq-lsp.exe` - In VSCode, set the `Coq-lsp: Args` to: - + `--coqlib=C:\Coq-Platform~8.17-lsp\lib\coq\` - + `--coqcorelib=C:\Coq-Platform~8.17-lsp\lib\coq-core\` - + `--ocamlpath=C:\Coq-Platform~8.17-lsp\lib\` - - Replace `C:\Coq-Platform~8.17-lsp\` by the path you have installed Coq above as needed + + `--coqlib=C:\Coq-Platform~8.20-lsp\lib\coq\` + + `--coqcorelib=C:\Coq-Platform~8.20-lsp\lib\coq-core\` + + `--ocamlpath=C:\Coq-Platform~8.20-lsp\lib\` + - Replace `C:\Coq-Platform~8.20-lsp\` by the path you have installed Coq above as needed - Note that the installers are unsigned (for now), so you'll have to click on "More info" then "Run anyway" inside the "Windows Protected your PC" dialog - Also note that the installers are work in progress, and may change often. @@ -316,13 +312,14 @@ guide](./CONTRIBUTING.md) ### 🐍 Python -- Interact programmatically with Coq files by using the [Python `coq-lsp` client](https://github.com/sr-lab/coq-lsp-pyclient) +- Interact programmatically with Coq files by using the [Coqpyt](https://github.com/sr-lab/coqpyt) by Pedro Carrott and Nuno Saavedra. ## ⇨ `coq-lsp` users and extensions The below projects are using `coq-lsp`, we recommend you try them! +- [Coqpyt, a Python client for coq-lsp](https://github.com/sr-lab/coqpyt) - [CoqPilot uses Large Language Models to generate multiple potential proofs and then uses coq-lsp to typecheck them](https://github.com/JetBrains-Research/coqpilot). - [jsCoq: use Coq from your browser](https://github.com/jscoq/jscoq) - [Pytanque: a Python library implementing RL Environments](https://github.com/LLM4Coq/pytanque) @@ -358,7 +355,6 @@ that have some fixes backported: - For 8.19: `opam pin add coq-core https://github.com/ejgallego/coq.git#v8.19+lsp` - For 8.18: `opam pin add coq-core https://github.com/ejgallego/coq.git#v8.18+lsp` - For 8.17: `opam pin add coq-core https://github.com/ejgallego/coq.git#v8.17+lsp` -- For 8.16: `opam pin add coq https://github.com/ejgallego/coq.git#v8.16+lsp` ### Known problems @@ -386,19 +382,6 @@ that have some fixes backported: which should contain some important information; the content of this channel is controlled by the `Coq LSP > Trace: Server` option. -### 📂 Working With Multiple Files - -`coq-lsp` can't work with more than one file at the same time, due to problems -with parsing state management upstream. This was fixed in Coq 8.17. - -As this is very inconvenient for users in older Coq versions, we do provide a -fixed Coq branch that you can install using `opam pin`: - -- For Coq 8.16: - ``` - opam pin add coq https://github.com/ejgallego/coq.git#v8.16+lsp - ``` - ## 📔 Planned Features See [planned features and contribution ideas](etc/ContributionIdeas.md) for a diff --git a/compiler/compile.ml b/compiler/compile.ml index 263817d0..c09b8255 100644 --- a/compiler/compile.ml +++ b/compiler/compile.ml @@ -6,14 +6,10 @@ let workspace_of_uri ~io ~uri ~workspaces ~default = let file = Lang.LUri.File.to_string_file uri in match List.find_opt (fun (dir, _) -> is_in_dir ~dir ~file) workspaces with | None -> - let lvl = Io.Level.error in - let message = "file not in workspace: " ^ file in - Io.Report.message ~io ~lvl ~message; + Io.Report.msg ~io ~lvl:Error "file not in workspace: %s" file; default | Some (_, Error err) -> - let lvl = Io.Level.error in - let message = "invalid workspace for: " ^ file ^ " " ^ err in - Io.Report.message ~io ~lvl ~message; + Io.Report.msg ~io ~lvl:Error "invalid workspace for: %s %s" file err; default | Some (_, Ok workspace) -> workspace @@ -34,13 +30,11 @@ let status_of_doc (doc : Doc.t) = match doc.completed with | Yes _ -> 0 | Stopped _ -> 2 - | Failed _ | FailedPermanent _ -> 1 + | Failed _ -> 1 let compile_file ~cc file : int = let { Cc.io; root_state; workspaces; default; token } = cc in - let lvl = Io.Level.info in - let message = Format.asprintf "compiling file %s" file in - Io.Report.message ~io ~lvl ~message; + Io.Report.msg ~io ~lvl:Info "compiling file %s" file; match Lang.LUri.(File.of_uri (of_string file)) with | Error _ -> 222 | Ok uri -> ( diff --git a/compiler/driver.ml b/compiler/driver.ml index 20814cc6..08bd8e18 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -22,10 +22,8 @@ let sanitize_paths message = let log_workspace ~io (dir, w) = let message, extra = Coq.Workspace.describe_guess w in - Fleche.Io.Log.trace "workspace" ("initialized " ^ dir) ~extra; - let lvl = Fleche.Io.Level.info in - let message = sanitize_paths message in - Fleche.Io.Report.message ~io ~lvl ~message + Fleche.Io.Log.trace "workspace" ~extra "initialized %s" dir; + Fleche.Io.Report.msg ~io ~lvl:Info "%s" (sanitize_paths message) let load_plugin plugin_name = Fl_dynload.load_packages [ plugin_name ] let plugin_init = List.iter load_plugin diff --git a/controller/cache.ml b/controller/cache.ml index d0c0b2d5..01eeb4ec 100644 --- a/controller/cache.ml +++ b/controller/cache.ml @@ -15,7 +15,7 @@ (* Written by: Emilio J. Gallego Arias *) (************************************************************************) -module LIO = Lsp.Io +module L = Fleche.Io.Log (* Cache stuff *) let memo_cache_file = ".coq-lsp.cache" @@ -23,9 +23,9 @@ let memo_cache_file = ".coq-lsp.cache" let memo_save_to_disk () = try (* Fleche.Memo.save_to_disk ~file:memo_cache_file; *) - LIO.trace "memo" "cache saved to disk" + L.trace "memo" "cache saved to disk" with exn -> - LIO.trace "memo" (Printexc.to_string exn); + L.trace "memo" "%s" (Printexc.to_string exn); Sys.remove memo_cache_file; () @@ -35,12 +35,12 @@ let save_to_disk () = if false then memo_save_to_disk () let memo_read_from_disk () = try if Sys.file_exists memo_cache_file then ( - LIO.trace "memo" "trying to load cache file"; + L.trace "memo" "trying to load cache file"; (* Fleche.Memo.load_from_disk ~file:memo_cache_file; *) - LIO.trace "memo" "cache file loaded") - else LIO.trace "memo" "cache file not present" + L.trace "memo" "cache file loaded") + else L.trace "memo" "cache file not present" with exn -> - LIO.trace "memo" ("loading cache failed: " ^ Printexc.to_string exn); + L.trace "memo" "loading cache failed: %s" (Printexc.to_string exn); Sys.remove memo_cache_file; () diff --git a/controller/coq_lsp.ml b/controller/coq_lsp.ml index 25caf87d..3d7746cb 100644 --- a/controller/coq_lsp.ml +++ b/controller/coq_lsp.ml @@ -19,27 +19,23 @@ based in OCaml threads. *) module U = Yojson.Safe.Util -module LIO = Lsp.Io -module LSP = Lsp.Base +module L = Fleche.Io.Log open Controller open Lsp_core (* Do cleanup here if necessary *) -let exit_message () = - let message = "server exiting" in - LIO.logMessage ~lvl:Error ~message - -let lsp_cleanup () = exit_message () +let exit_message ~io = Fleche.Io.Report.msg ~io ~lvl:Error "server exiting" +let lsp_cleanup ~io = exit_message ~io let rec process_queue ~delay ~io ~ofn ~state : unit = if Fleche.Debug.sched_wakeup then - LIO.trace "<- dequeue" (Format.asprintf "%.2f" (Unix.gettimeofday ())); + L.trace "<- dequeue" "%.2f" (Unix.gettimeofday ()); match dispatch_or_resume_check ~io ~ofn ~state with | None -> (* As of now, we exit the whole program here, we could try an experiment to invert the threads, so the I/O routine is a thread and process_queue is the main driver *) - lsp_cleanup (); + lsp_cleanup ~io; (* We can't use [Thread.exit] here as the main thread will be blocked on I/O *) exit 0 @@ -49,12 +45,9 @@ let rec process_queue ~delay ~io ~ofn ~state : unit = | Some (Cont state) -> process_queue ~delay ~io ~ofn ~state let concise_cb ofn = - let send_notification nt = - Lsp.Base.Message.(Notification nt |> to_yojson) |> ofn - in let diagnostics ~uri ~version diags = if List.length diags > 0 then - Lsp.JLang.mk_diagnostics ~uri ~version diags |> send_notification + Lsp.Core.mk_diagnostics ~uri ~version diags |> ofn in Fleche.Io.CallBack. { trace = (fun _hdr ?extra:_ _msg -> ()) @@ -67,35 +60,37 @@ let concise_cb ofn = } (* Main loop *) -let lsp_cb ofn = - let send_notification nt = - Lsp.Base.Message.(Notification nt |> to_yojson) |> ofn - in - let trace = LIO.trace in - let message ~lvl ~message = - let lvl = Fleche.Io.Level.to_int lvl in - LIO.logMessageInt ~lvl ~message - in +module CB (O : sig + val ofn : Lsp.Base.Notification.t -> unit +end) = +struct + let ofn = O.ofn + let trace _hdr ?extra message = Lsp.Io.logTrace ~message ~extra + let message ~lvl ~message = Lsp.Io.logMessage ~lvl ~message + let diagnostics ~uri ~version diags = - Lsp.JLang.mk_diagnostics ~uri ~version diags |> send_notification - in + Lsp.Core.mk_diagnostics ~uri ~version diags |> ofn + let fileProgress ~uri ~version progress = - Lsp.JFleche.mk_progress ~uri ~version progress |> send_notification - in + Lsp.JFleche.mk_progress ~uri ~version progress |> ofn + let perfData ~uri ~version perf = - Lsp.JFleche.mk_perf ~uri ~version perf |> send_notification - in - let serverVersion vi = Lsp.JFleche.mk_serverVersion vi |> send_notification in - let serverStatus st = Lsp.JFleche.mk_serverStatus st |> send_notification in - Fleche.Io.CallBack. - { trace - ; message - ; diagnostics - ; fileProgress - ; perfData - ; serverVersion - ; serverStatus - } + Lsp.JFleche.mk_perf ~uri ~version perf |> ofn + + let serverVersion vi = Lsp.JFleche.mk_serverVersion vi |> ofn + let serverStatus st = Lsp.JFleche.mk_serverStatus st |> ofn + + let cb = + Fleche.Io.CallBack. + { trace + ; message + ; diagnostics + ; fileProgress + ; perfData + ; serverVersion + ; serverStatus + } +end let coq_init ~debug = let load_module = Dynlink.loadfile in @@ -105,17 +100,17 @@ let coq_init ~debug = let exit_notification = Lsp.Base.Message.(Notification { method_ = "exit"; params = [] }) -let rec lsp_init_loop ~ifn ~ofn ~cmdline ~debug = +let rec lsp_init_loop ~io ~ifn ~ofn ~cmdline ~debug = match ifn () with | None -> raise Lsp_exit | Some (Ok msg) -> ( - match lsp_init_process ~ofn ~cmdline ~debug msg with + match lsp_init_process ~io ~ofn ~cmdline ~debug msg with | Init_effect.Exit -> raise Lsp_exit - | Init_effect.Loop -> lsp_init_loop ~ifn ~ofn ~cmdline ~debug + | Init_effect.Loop -> lsp_init_loop ~io ~ifn ~ofn ~cmdline ~debug | Init_effect.Success w -> w) | Some (Error err) -> - Lsp.Io.trace "read_request" ("error: " ^ err); - lsp_init_loop ~ifn ~ofn ~cmdline ~debug + L.trace "read_request" "error: %s" err; + lsp_init_loop ~io ~ifn ~ofn ~cmdline ~debug let lsp_main bt coqcorelib coqlib ocamlpath vo_load_path ml_include_path require_libraries delay int_backend = @@ -127,19 +122,18 @@ let lsp_main bt coqcorelib coqlib ocamlpath vo_load_path ml_include_path Stdlib.set_binary_mode_out stdout true; (* We output to stdout *) - let ifn () = LIO.read_message stdin in + let ifn () = Lsp.Io.read_message stdin in (* Set log channels *) - let json_fn = LIO.send_json Format.std_formatter in - - let ofn response = - let response = Lsp.Base.Message.to_yojson response in - LIO.send_json Format.std_formatter response - in + let ofn message = Lsp.Io.send_message Format.std_formatter message in + let ofn_ntn not = Lsp.Base.Message.notification not |> ofn in - LIO.set_log_fn json_fn; + Lsp.Io.set_log_fn ofn_ntn; - let io = lsp_cb json_fn in + let module CB = CB (struct + let ofn = ofn_ntn + end) in + let io = CB.cb in Fleche.Io.CallBack.set io; (* IMPORTANT: LSP spec forbids any message from server to client before @@ -169,20 +163,20 @@ let lsp_main bt coqcorelib coqlib ocamlpath vo_load_path ml_include_path enqueue_message msg; read_loop () | Some (Error err) -> - Lsp.Io.trace "read_request" ("error: " ^ err); + L.trace "read_request" "error: %s" err; read_loop () in (* Input/output will happen now *) try (* LSP Server server initialization *) - let workspaces = lsp_init_loop ~ifn ~ofn ~cmdline ~debug in + let workspaces = lsp_init_loop ~io ~ifn ~ofn ~cmdline ~debug in let io = if !Fleche.Config.v.verbosity < 2 then ( Fleche.Config.( v := { !v with send_diags = false; send_perf_data = false }); - LIO.set_log_fn (fun _obj -> ()); - let io = concise_cb json_fn in + Lsp.Io.set_log_fn (fun _obj -> ()); + let io = concise_cb ofn_ntn in Fleche.Io.CallBack.set io; io) else io @@ -200,19 +194,17 @@ let lsp_main bt coqcorelib coqlib ocamlpath vo_load_path ml_include_path read_loop () with - | Lsp_exit -> - let message = "[LSP shutdown] EOF\n" in - LIO.logMessage ~lvl:Error ~message + | Lsp_exit -> Fleche.Io.Report.msg ~io ~lvl:Error "[LSP shutdown] EOF\n" | exn -> let bt = Printexc.get_backtrace () in let exn, info = Exninfo.capture exn in let exn_msg = Printexc.to_string exn in - LIO.trace "fatal error" (exn_msg ^ bt); - LIO.trace "fatal_error [coq iprint]" - Pp.(string_of_ppcmds CErrors.(iprint (exn, info))); - LIO.trace "server crash" (exn_msg ^ bt); - let message = "[uncontrolled LSP shutdown] server crash\n" ^ exn_msg in - LIO.logMessage ~lvl:Error ~message + L.trace "fatal error" "%s\n%s" exn_msg bt; + L.trace "fatal_error [coq iprint]" "%a" Pp.pp_with + CErrors.(iprint (exn, info)); + L.trace "server crash" "%s\n%s" exn_msg bt; + Fleche.Io.Report.msg ~io ~lvl:Error + "[uncontrolled LSP shutdown] server crash:\n%s" exn_msg (* Arguments handling *) open Cmdliner diff --git a/controller/dune b/controller/dune index 5a9170ed..2a470ba3 100644 --- a/controller/dune +++ b/controller/dune @@ -1,7 +1,7 @@ (library (name controller) (modules :standard \ coq_lsp) - (libraries coq fleche lsp dune-build-info)) + (libraries coq fleche petanque petanque_json lsp dune-build-info)) (executable (name coq_lsp) diff --git a/controller/lsp_core.ml b/controller/lsp_core.ml index abc0c48c..62963a07 100644 --- a/controller/lsp_core.ml +++ b/controller/lsp_core.ml @@ -30,8 +30,8 @@ let string_field name dict = U.to_string (field name dict) let ofield name dict = List.(assoc_opt name dict) let ostring_field name dict = Option.map U.to_string (ofield name dict) -module LIO = Lsp.Io module LSP = Lsp.Base +module L = Fleche.Io.Log module Helpers = struct (* XXX helpers; fix to have better errors on wrong protocol code *) @@ -45,8 +45,11 @@ module Helpers = struct | Ok uri -> uri | Error err -> (* ppx_deriving_yojson error messages leave a lot to be desired *) + (* We use lsp.io here as we will push parsing to the outer loop, so no + need to reflect this on the type just to undo it later; as this + message morally doesn't belong here *) let message = Format.asprintf "json parsing failed: %s" err in - LIO.logMessage ~lvl:Error ~message; + Lsp.Io.logMessage ~lvl:Error ~message; (* XXX Fixme *) CErrors.user_err (Pp.str "failed to parse uri") in @@ -128,15 +131,15 @@ module State = struct let file_c = split_in_components file in CList.prefix_of String.equal dir_c file_c - let workspace_of_uri ~uri ~state = + let workspace_of_uri ~io ~uri ~state = let { root_state; workspaces; default_workspace; _ } = state in let file = Lang.LUri.File.to_string_file uri in match List.find_opt (fun (dir, _) -> is_in_dir ~dir ~file) workspaces with | None -> - LIO.logMessage ~lvl:Error ~message:("file not in workspace: " ^ file); + Fleche.Io.Report.msg ~io ~lvl:Error "file not in workspace: %s" file; (root_state, default_workspace) | Some (_, Error _) -> - LIO.logMessage ~lvl:Error ~message:("file in errored workspace: " ^ file); + Fleche.Io.Report.msg ~io ~lvl:Error "file in errored workspace: %s" file; (root_state, default_workspace) | Some (_, Ok workspace) -> (root_state, workspace) end @@ -191,8 +194,7 @@ end = struct let _rtable : (int, Request.Data.t) Hashtbl.t = Hashtbl.create 673 let postpone_ ~id (pr : Request.Data.t) = - if Fleche.Debug.request_delay then - LIO.trace "request" ("postponing rq : " ^ string_of_int id); + if Fleche.Debug.request_delay then L.trace "request" "postponing rq: %d" id; Hashtbl.add _rtable id pr (* Consumes a request, if alive, it answers mandatorily *) @@ -202,7 +204,7 @@ end = struct Hashtbl.remove _rtable id; f pr |> answer ~ofn_rq ~id | None -> - LIO.trace "can't consume cancelled request: " (string_of_int id); + L.trace "consuem" "can't consume cancelled request: %d" id; () let cancel ~ofn_rq ~code ~message id : unit = @@ -218,8 +220,7 @@ end = struct let debug_serve id pr = if Fleche.Debug.request_delay then - LIO.trace "serving" - (Format.asprintf "rq: %d | %a" id Request.Data.data pr) + L.trace "serving" "rq: %d | %a" id Request.Data.data pr let serve_postponed ~ofn_rq ~token ~doc id = let f pr = @@ -267,7 +268,7 @@ let do_open ~io ~token ~(state : State.t) params = |> Lsp.Doc.TextDocumentItem.of_yojson |> Result.get_ok in let Lsp.Doc.TextDocumentItem.{ uri; version; text; _ } = document in - let init, workspace = State.workspace_of_uri ~uri ~state in + let init, workspace = State.workspace_of_uri ~io ~uri ~state in let files = Coq.Files.make () in let env = Fleche.Doc.Env.make ~init ~workspace ~files in Fleche.Theory.create ~io ~token ~env ~uri ~raw:text ~version @@ -277,10 +278,10 @@ let do_change ~ofn_rq ~io ~token params = let changes = List.map U.to_assoc @@ list_field "contentChanges" params in match changes with | [] -> - LIO.trace "do_change" "no change in changes? ignoring"; + L.trace "do_change" "no change in changes? ignoring"; () | _ :: _ :: _ -> - LIO.trace "do_change" + L.trace "do_change" "more than one change unsupported due to sync method, ignoring"; () | change :: _ -> @@ -290,15 +291,15 @@ let do_change ~ofn_rq ~io ~token params = let message = "Request got old in server" in Int.Set.iter (Rq.cancel ~ofn_rq ~code ~message) invalid_rq -let do_close ~ofn:_ params = +let do_close params = let uri = Helpers.get_uri params in Fleche.Theory.close ~uri let do_trace params = let trace = string_field "value" params in - match LIO.TraceValue.of_string trace with - | Ok t -> LIO.set_trace_value t - | Error e -> LIO.trace "trace" ("invalid value: " ^ e) + match Lsp.Io.TraceValue.of_string trace with + | Ok t -> Lsp.Io.set_trace_value t + | Error e -> L.trace "$/setTrace" "invalid value: %s" e (***********************************************************************) (* Start of protocol handlers: document requests *) @@ -346,8 +347,7 @@ let get_pp_format_from_config () = | 0 -> Rq_goals.Str | 1 -> Rq_goals.Pp | v -> - LIO.trace "get_pp_format_from_config" - ("unknown output parameter: " ^ string_of_int v); + L.trace "get_pp_format_from_config" "unknown output parameter: %d" v; Rq_goals.Str let get_pp_format params = @@ -355,7 +355,7 @@ let get_pp_format params = | Some "Pp" -> Rq_goals.Pp | Some "Str" -> Rq_goals.Str | Some v -> - LIO.trace "get_pp_format" ("error in parameter: " ^ v); + L.trace "get_pp_format" "error in parameter: %s" v; get_pp_format_from_config () | None -> get_pp_format_from_config () @@ -371,7 +371,7 @@ let get_goals_mode params = | Some "Prev" -> Fleche.Info.Prev | Some "After" -> Fleche.Info.PrevIfEmpty | Some v -> - LIO.trace "get_goals_mode" ("error in parameter: " ^ v); + L.trace "get_goals_mode" "error in parameter: %s" v; get_goals_mode_from_config () | None -> get_goals_mode_from_config () @@ -409,35 +409,60 @@ let do_cancel ~ofn_rq ~params = let message = "Cancelled by client" in Rq.cancel ~ofn_rq ~code ~message id -let do_cache_trim () = Nt_cache_trim.notification () +let do_cache_trim ~io = Nt_cache_trim.notification ~io let do_viewRange params = match List.assoc "range" params |> Lsp.JLang.Diagnostic.Range.of_yojson with | Ok range -> let { Lsp.JLang.Diagnostic.Range.end_ = { line; character }; _ } = range in - let message = Format.asprintf "l: %d c:%d" line character in - LIO.trace "viewRange" message; + L.trace "viewRange" "l: %d c:%d" line character; let uri = Helpers.get_uri params in Fleche.Theory.Check.set_scheduler_hint ~uri ~point:(line, character); () - | Error err -> LIO.trace "viewRange" ("error in parsing notification: " ^ err) + | Error err -> L.trace "viewRange" "error in parsing notification: %s" err -let do_changeConfiguration params = - let message = "didChangeReceived" in - let () = LIO.(logMessage ~lvl:Lvl.Info ~message) in +let do_changeConfiguration ~io params = + Fleche.Io.Report.msg ~io ~lvl:Info "didChangeReceived"; let settings = field "settings" params |> U.to_assoc in Rq_init.do_settings settings; () +(* EJGA: Note that our current configuration allow petanque calls to be + interrupted, this can become an issue with LSP. For now, clients must choose + a trade-off (we could disable interruption on petanque call, but that brings + other downsides) + + The only real solution is to wait for OCaml 5.x support, so we can server + read-only queries without interrupting the main Coq thread. *) +let petanque_handle ~token = + let open Petanque_json in + function + | Interp.Action.Now handler -> Rq.Action.now (handler ~token) + | Interp.Action.Doc { uri; handler } -> + (* Request document execution if not ready *) + let postpone = true in + Rq.Action.(Data (DocRequest { uri; postpone; handler })) + +let do_petanque ~token method_ params = + let open Petanque_json in + let do_handle = petanque_handle in + let unhandled ~token:_ ~method_ = + (* JSON-RPC method not found *) + let code = -32601 in + let message = Format.asprintf "method %s not found" method_ in + Rq.Action.error (code, message) + in + Interp.handle_request ~do_handle ~unhandled ~token ~method_ ~params + (***********************************************************************) (** LSP Init routine *) exception Lsp_exit -let log_workspace (dir, w) = +let log_workspace ~io (dir, w) = let message, extra = Coq.Workspace.describe_guess w in - LIO.trace "workspace" ("initialized " ^ dir) ~extra; - LIO.logMessage ~lvl:Info ~message + L.trace "workspace" ~extra "initialized %s" dir; + Fleche.Io.Report.msg ~io ~lvl:Info "%s" message let version () = let dev_version = @@ -455,30 +480,26 @@ module Init_effect = struct | Exit end -let lsp_init_process ~ofn ~cmdline ~debug msg : Init_effect.t = +let serverInfo = + let coq = Coq_config.version in + let ocaml = Sys.ocaml_version in + let coq_lsp = Fleche.Version.server in + Fleche.ServerInfo.Version.{ coq; ocaml; coq_lsp } + +let lsp_init_process ~ofn ~io ~cmdline ~debug msg : Init_effect.t = let ofn_rq r = Lsp.Base.Message.response r |> ofn in + let ofn_nt r = Lsp.Base.Message.notification r |> ofn in match msg with | LSP.Message.Request { method_ = "initialize"; id; params } -> (* At this point logging is allowed per LSP spec *) - let message = - Format.asprintf "Initializing coq-lsp server %s" (version ()) - in - LIO.logMessage ~lvl:Info ~message; + Fleche.Io.Report.msg ~io ~lvl:Info "Initializing coq-lsp server %s" + (version ()); let token = Coq.Limits.Token.create () in - let result, dirs = Rq_init.do_initialize ~params in + let result, dirs = Rq_init.do_initialize ~io ~params in Rq.Action.now (Ok result) |> Rq.serve ~ofn_rq ~token ~id; - let vi = - let coq = Coq_config.version in - let ocaml = Sys.ocaml_version in - let coq_lsp = Fleche.Version.server in - Fleche.ServerInfo.Version.{ coq; ocaml; coq_lsp } - in - Lsp.JFleche.mk_serverVersion vi |> Lsp.Base.Message.notification |> ofn; - let message = - Format.asprintf "Server initializing (int_backend: %s)" - (Coq.Limits.name ()) - in - LIO.logMessage ~lvl:Info ~message; + Lsp.JFleche.mk_serverVersion serverInfo |> ofn_nt; + Fleche.Io.Report.msg ~io ~lvl:Info "Server initializing (int_backend: %s)" + (Coq.Limits.name ()); (* Workspace initialization *) let debug = debug || !Fleche.Config.v.debug in let workspaces = @@ -486,7 +507,7 @@ let lsp_init_process ~ofn ~cmdline ~debug msg : Init_effect.t = (fun dir -> (dir, Coq.Workspace.guess ~token ~cmdline ~debug ~dir)) dirs in - List.iter log_workspace workspaces; + List.iter (log_workspace ~io) workspaces; Success workspaces | LSP.Message.Request { id; _ } -> (* per spec *) @@ -509,21 +530,21 @@ let dispatch_notification ~io ~ofn ~token ~state ~method_ ~params : unit = | "exit" -> raise Lsp_exit (* setTrace and settings *) | "$/setTrace" -> do_trace params - | "workspace/didChangeConfiguration" -> do_changeConfiguration params + | "workspace/didChangeConfiguration" -> do_changeConfiguration ~io params (* Document lifetime *) | "textDocument/didOpen" -> do_open ~io ~token ~state params | "textDocument/didChange" -> do_change ~io ~ofn_rq ~token params - | "textDocument/didClose" -> do_close ~ofn params + | "textDocument/didClose" -> do_close params | "textDocument/didSave" -> Cache.save_to_disk () (* Specific to coq-lsp *) | "coq/viewRange" -> do_viewRange params - | "coq/trimCaches" -> do_cache_trim () + | "coq/trimCaches" -> do_cache_trim ~io (* Cancel Request *) | "$/cancelRequest" -> do_cancel ~ofn_rq ~params (* NOOPs *) | "initialized" -> () (* Generic handler *) - | msg -> LIO.trace "no_handler" msg + | msg -> L.trace "no_handler" "%s" msg let dispatch_state_notification ~io ~ofn ~token ~state ~method_ ~params : State.t = @@ -535,11 +556,11 @@ let dispatch_state_notification ~io ~ofn ~token ~state ~method_ ~params : dispatch_notification ~io ~ofn ~token ~state ~method_ ~params; state -let dispatch_request ~method_ ~params : Rq.Action.t = +let dispatch_request ~token ~method_ ~params : Rq.Action.t = match method_ with (* Lifecyle *) | "initialize" -> - LIO.trace "dispatch_request" "duplicate initialize request! Rejecting"; + L.trace "dispatch_request" "duplicate initialize request! Rejecting"; (* XXX what's the error code here *) Rq.Action.error (-32600, "Invalid Request: server already initialized") | "shutdown" -> do_shutdown @@ -556,27 +577,29 @@ let dispatch_request ~method_ ~params : Rq.Action.t = | "coq/saveVo" -> do_save_vo ~params (* Coq specific stuff *) | "coq/getDocument" -> do_document ~params + (* Petanque embedding *) + | msg when Coq.Compat.Ocaml_413.String.starts_with ~prefix:"petanque/" msg -> + do_petanque msg ~token params (* Generic handler *) | msg -> - LIO.trace "no_handler" msg; + L.trace "no_handler" "%s" msg; Rq.Action.error (-32601, "method not found") let dispatch_request ~ofn_rq ~token ~id ~method_ ~params = - dispatch_request ~method_ ~params |> Rq.serve ~ofn_rq ~token ~id + dispatch_request ~token ~method_ ~params |> Rq.serve ~ofn_rq ~token ~id let dispatch_message ~io ~ofn ~token ~state (com : LSP.Message.t) : State.t = let ofn_rq r = Lsp.Base.Message.response r |> ofn in match com with | Notification { method_; params } -> - LIO.trace "process_queue" ("Serving notification: " ^ method_); + L.trace "process_queue" "Serving notification: %s" method_; dispatch_state_notification ~io ~ofn ~token ~state ~method_ ~params | Request { id; method_; params } -> - LIO.trace "process_queue" ("Serving Request: " ^ method_); + L.trace "process_queue" "Serving Request: %s" method_; dispatch_request ~ofn_rq ~token ~id ~method_ ~params; state | Response r -> - LIO.trace "process_queue" - ("Serving response for: " ^ string_of_int (Lsp.Base.Response.id r)); + L.trace "process_queue" "Serving response for: %d" (Lsp.Base.Response.id r); state (* Queue handling *) @@ -659,7 +682,7 @@ let dispatch_or_resume_check ~io ~ofn ~state = let dispatch_or_resume_check ~io ~ofn ~state = try Some (dispatch_or_resume_check ~io ~ofn ~state) with | U.Type_error (msg, obj) -> - LIO.trace_object msg obj; + L.trace_object msg obj; Some (Yield state) | Lsp_exit -> (* EJGA: Maybe remove Lsp_exit and have dispatch_or_resume_check return an @@ -671,18 +694,18 @@ let dispatch_or_resume_check ~io ~ofn ~state = coq-lsp internal error and should be fixed *) let bt = Printexc.get_backtrace () in let iexn = Exninfo.capture exn in - LIO.trace "process_queue" + L.trace "process_queue" "%s" (if Printexc.backtrace_status () then "bt=true" else "bt=false"); (* let method_name = LSP.Message.method_ com in *) - (* LIO.trace "process_queue" ("exn in method: " ^ method_name); *) - LIO.trace "print_exn [OCaml]" (Printexc.to_string exn); - LIO.trace "print_exn [Coq ]" Pp.(string_of_ppcmds CErrors.(iprint iexn)); - LIO.trace "print_bt [OCaml]" bt; + (* L.trace "process_queue" "exn in method: %s" method_name; *) + L.trace "print_exn [OCaml]" "%s" (Printexc.to_string exn); + L.trace "print_exn [Coq ]" "%a" Pp.pp_with CErrors.(iprint iexn); + L.trace "print_bt [OCaml]" "%s" bt; Some (Yield state) let enqueue_message (com : LSP.Message.t) = if Fleche.Debug.sched_wakeup then - LIO.trace "-> enqueue" (Format.asprintf "%.2f" (Unix.gettimeofday ())); + L.trace "-> enqueue" "%.2f" (Unix.gettimeofday ()); (* TODO: this is the place to cancel pending requests that are invalid, and in general, to perform queue optimizations *) LspQueue.push_and_optimize com; diff --git a/controller/lsp_core.mli b/controller/lsp_core.mli index 8581e189..0b9368a3 100644 --- a/controller/lsp_core.mli +++ b/controller/lsp_core.mli @@ -42,6 +42,7 @@ end val lsp_init_process : ofn:(Lsp.Base.Message.t -> unit) + -> io:Fleche.Io.CallBack.t -> cmdline:Coq.Workspace.CmdLine.t -> debug:bool -> Lsp.Base.Message.t diff --git a/controller/nt_cache_trim.ml b/controller/nt_cache_trim.ml index e3954a52..b3444a16 100644 --- a/controller/nt_cache_trim.ml +++ b/controller/nt_cache_trim.ml @@ -37,7 +37,6 @@ module OCaml = struct end module M = Fleche.Memo -module LIO = Lsp.Io let caches () = [ ("interp", M.Interp.all_freqs ()) @@ -55,41 +54,38 @@ let pp_cache fmt (name, freqs) = Format.fprintf fmt "@[%s: %d | %a @[(%a)@]@]" name (List.length freqs) pp_zsum zsum pp_fsum fsum -let build_message () = +let build_message fmt () = let caches = caches () in - Format.asprintf "@[Cache trim requested:@\n @[%a@]@]" + Format.fprintf fmt "@[Cache trim requested:@\n @[%a@]@]" (Format.pp_print_list pp_cache) caches let cache_trim () = + let () = M.Intern.clear () in let () = M.Interp.clear () in let () = M.Admit.clear () in let () = M.Init.clear () in let () = M.Require.clear () in () -let gc_stats hd msg = - let message = - Format.asprintf "[%s] %s:@\n%a" hd msg OCaml.print_stat_simple () - in - LIO.logMessage ~lvl:Info ~message +let gc_stats ~io hd msg = + Fleche.Io.Report.msg ~io ~lvl:Info "[%s] %s:@\n%a" hd msg + OCaml.print_stat_simple () -let full_major hd = - gc_stats hd "before full major"; +let full_major ~io hd = + gc_stats ~io hd "before full major"; Gc.full_major (); - gc_stats hd "after full major"; + gc_stats ~io hd "after full major"; () -let do_trim () = - full_major "pre "; +let do_trim ~io = + full_major ~io "pre "; cache_trim (); - let message = Format.asprintf "%s@\n---------@\n" "trimming" in - LIO.logMessage ~lvl:Info ~message; - full_major "post"; + Fleche.Io.Report.msg ~io ~lvl:Info "%s@\n---------@\n" "trimming"; + full_major ~io "post"; () -let notification () = - let message = build_message () in - LIO.logMessage ~lvl:Info ~message; - do_trim (); +let notification ~io = + Fleche.Io.Report.msg ~io ~lvl:Info "%a" build_message (); + do_trim ~io; () diff --git a/controller/nt_cache_trim.mli b/controller/nt_cache_trim.mli index de9f4258..c09adb00 100644 --- a/controller/nt_cache_trim.mli +++ b/controller/nt_cache_trim.mli @@ -1 +1 @@ -val notification : unit -> unit +val notification : io:Fleche.Io.CallBack.t -> unit diff --git a/controller/rq_common.ml b/controller/rq_common.ml index 2a1627af..a607d6d9 100644 --- a/controller/rq_common.ml +++ b/controller/rq_common.ml @@ -28,19 +28,18 @@ let id_from_start s start = let end_ = if end_ > 1 && s.[end_ - 1] = '.' then end_ - 1 else end_ in if start < end_ then ( let id = String.sub s start (end_ - start) in - Lsp.Io.trace "find_id" ("found: " ^ id); + Fleche.Io.Log.trace "find_id" "found: %s" id; Some id) else None let find_id s c = let start = find_start s c in - Lsp.Io.trace "find_id" ("start: " ^ string_of_int start); + Fleche.Io.Log.trace "find_id" "start: %d" start; id_from_start s start let get_id_at_point ~contents ~point = let line, character = point in - Lsp.Io.trace "get_id_at_point" - ("l: " ^ string_of_int line ^ " c: " ^ string_of_int character); + Fleche.Io.Log.trace "get_id_at_point" "l: %d c: %d)" line character; let { Fleche.Contents.lines; _ } = contents in if line <= Array.length lines then let line = Array.get lines line in @@ -55,22 +54,44 @@ let validate_line ~(contents : Fleche.Contents.t) ~line = Some (Array.get contents.lines line) else None -let validate_column char line = +let validate_column ~get char line = let length = Lang.Utf.length_utf16 line in if char < length then let char = Lang.Utf.utf8_offset_of_utf16_offset ~line ~offset:char in - Some (String.get line char) + get line char else None (* This returns a byte-based char offset for the line *) -let validate_position ~contents ~point = +let validate_position ~get ~contents ~point = let line, char = point in - validate_line ~contents ~line |> fun l -> Option.bind l (validate_column char) + validate_line ~contents ~line |> fun l -> + Option.bind l (validate_column ~get char) -let get_char_at_point ~contents ~point = - let line, char = point in - if char >= 1 then - let point = (line, char - 1) in - validate_position ~contents ~point - else (* Can't get previous char *) - None +let get_char_at_point_gen ~prev ~get ~contents ~point = + if prev then + let line, char = point in + if char >= 1 then + let point = (line, char - 1) in + validate_position ~get ~contents ~point + else (* Can't get previous char *) + None + else validate_position ~get ~contents ~point + +let get_char_at_point ~prev ~contents ~point = + let get line utf8_offset = Some (String.get line utf8_offset) in + get_char_at_point_gen ~prev ~get ~contents ~point + +let get_uchar_at_point ~prev ~contents ~point = + let get line utf8_offset = + let decode = + Lang.Compat.OCaml4_14.String.get_utf_8_uchar line utf8_offset + in + if Lang.Compat.OCaml4_14.Uchar.utf_decode_is_valid decode then + let str = + String.sub line utf8_offset + (Lang.Compat.OCaml4_14.Uchar.utf_decode_length decode) + in + Some (Lang.Compat.OCaml4_14.Uchar.utf_decode_uchar decode, str) + else None + in + get_char_at_point_gen ~prev ~get ~contents ~point diff --git a/controller/rq_common.mli b/controller/rq_common.mli index a7f7bf68..75ac2447 100644 --- a/controller/rq_common.mli +++ b/controller/rq_common.mli @@ -12,4 +12,11 @@ val get_id_at_point : contents:Fleche.Contents.t -> point:int * int -> string option val get_char_at_point : - contents:Fleche.Contents.t -> point:int * int -> char option + prev:bool -> contents:Fleche.Contents.t -> point:int * int -> char option + +(* Get both the uchar and its utf-8 string representation *) +val get_uchar_at_point : + prev:bool + -> contents:Fleche.Contents.t + -> point:int * int + -> (Uchar.t * string) option diff --git a/controller/rq_completion.ml b/controller/rq_completion.ml index 62a8519e..81b2a601 100644 --- a/controller/rq_completion.ml +++ b/controller/rq_completion.ml @@ -60,13 +60,7 @@ let mk_unicode_completion_item point (label, newText) = mk_completion ~label ~labelDetails ~textEdit ~commitCharacters () let unicode_list point : Yojson.Safe.t list = - let ulist = - match !Fleche.Config.v.unicode_completion with - | Off -> [] - | Internal_small -> Unicode_bindings.small - | Normal -> Unicode_bindings.normal - | Extended -> Unicode_bindings.extended - in + let ulist = Unicode_bindings.from_config () in (* Coq's CList.map is tail-recursive *) CList.map (mk_unicode_completion_item point) ulist @@ -74,7 +68,7 @@ let completion ~token:_ ~(doc : Fleche.Doc.t) ~point = (* Instead of get_char_at_point we should have a CompletionContext.t, to be addressed in further completion PRs *) let contents = doc.contents in - (match Rq_common.get_char_at_point ~contents ~point with + (match Rq_common.get_char_at_point ~prev:true ~contents ~point with | None -> let incomplete = true in let items = [] in diff --git a/controller/rq_definition.ml b/controller/rq_definition.ml index fe7d28cc..a5e61ca8 100644 --- a/controller/rq_definition.ml +++ b/controller/rq_definition.ml @@ -5,17 +5,96 @@ (* Written by: Emilio J. Gallego Arias *) (************************************************************************) -let request ~token:_ ~(doc : Fleche.Doc.t) ~point = +let get_from_toc ~doc id_at_point = + let { Fleche.Doc.toc; _ } = doc in + Fleche.Io.Log.trace "rq_definition" "get_from_toc"; + match CString.Map.find_opt id_at_point toc with + | Some node -> + let uri = doc.uri in + let range = node.range in + Some Lsp.Core.Location.{ uri; range } + | None -> None + +let lp_to_string exn = CErrors.iprint exn |> Pp.string_of_ppcmds +let err_code = -32803 + +let locate_extended qid = + try Some (Nametab.locate_extended qid) with Not_found -> None + +let find_name_in dp name = + match Coq.Module.make dp with + | Error err -> Error (err_code, lp_to_string err) + | Ok mod_ -> ( + let uri = Coq.Module.uri mod_ in + match Coq.Module.find mod_ name with + | Error err -> Error (err_code, err) + | Ok range -> + Ok (Option.map (fun range -> Lsp.Core.Location.{ uri; range }) range)) + +let get_from_file id_at_point = + Fleche.Io.Log.trace "rq_definition" "get_from_file"; + let qid = Libnames.qualid_of_string id_at_point in + match locate_extended qid with + | Some (TrueGlobal (ConstRef cr)) -> + Fleche.Io.Log.trace "rq_definition" "TrueGlobal Found"; + let dp = Names.Constant.modpath cr |> Names.ModPath.dp in + let name = Names.Constant.to_string cr in + find_name_in dp name + | Some (TrueGlobal (IndRef (ind, _idx))) -> + let dp = Names.MutInd.modpath ind |> Names.ModPath.dp in + let name = Names.MutInd.to_string ind in + find_name_in dp name + | Some (Abbrev _abbrev) -> + (* Needs improved .glob parsing *) + Ok None + | _ -> + Fleche.Io.Log.trace "rq_definition" "No TrueGlobal Found"; + Ok None + +let get_from_import require_at_point = + match Loadpath.locate_qualified_library require_at_point with + | Ok (dp, _file) -> ( + match Coq.Module.make dp with + | Error _err -> None + | Ok mod_ -> + let uri = Coq.Module.uri mod_ in + let start = Lang.Point.{ line = 0; character = 0; offset = 0 } in + let range = Lang.Range.{ start; end_ = start } in + Some Lsp.Core.Location.{ uri; range }) + | Error _ -> None + +let get_from_file_or_import ~token ~st id_at_point = + let f id = + match get_from_file id with + | Error err -> Error err + | Ok (Some res) -> Ok (Some res) + | Ok None -> + let qualid = Libnames.qualid_of_string id_at_point in + Ok (get_from_import qualid) + in + Coq.State.in_state ~token ~st ~f id_at_point + +let request ~token ~(doc : Fleche.Doc.t) ~point = let { Fleche.Doc.contents; _ } = doc in + let ok s = Coq.Protect.E.ok (Result.Ok s) in + let idp = Rq_common.get_id_at_point ~contents ~point in Option.cata - (fun id_at_point -> - let { Fleche.Doc.toc; _ } = doc in - match CString.Map.find_opt id_at_point toc with - | Some node -> - let uri = doc.uri in - let range = node.range in - Lsp.Core.Location.({ uri; range } |> to_yojson) - | None -> `Null) - `Null - (Rq_common.get_id_at_point ~contents ~point) - |> Result.ok + (fun idp -> + match get_from_toc ~doc idp with + | Some loc -> ok (Some loc) + | None -> + let approx = Fleche.Info.PrevIfEmpty in + Fleche.Info.LC.node ~doc ~point approx + |> Option.cata + (fun node -> + let st = Fleche.Doc.Node.state node in + get_from_file_or_import ~token ~st idp) + (ok None)) + (ok None) idp + |> Coq.Protect.E.map + ~f:(Result.map (Option.cata Lsp.Core.Location.to_yojson `Null)) + +let request ~token ~doc ~point = + let name = "textDocument/definition" in + let f () = request ~token ~doc ~point in + Request.R.of_execution ~name ~f () diff --git a/controller/rq_document.ml b/controller/rq_document.ml index 7e94b817..a91587f1 100644 --- a/controller/rq_document.ml +++ b/controller/rq_document.ml @@ -13,7 +13,7 @@ let to_completed = function | Fleche.Doc.Completion.Yes range -> { Lsp.JFleche.CompletionStatus.status = `Yes; range } | Stopped range -> { status = `Stopped; range } - | Failed range | FailedPermanent range -> { status = `Failed; range } + | Failed range -> { status = `Failed; range } let request ~token:_ ~doc = let { Fleche.Doc.nodes; completed; _ } = doc in diff --git a/controller/rq_hover.ml b/controller/rq_hover.ml index b8cd63ed..6c42c6bd 100644 --- a/controller/rq_hover.ml +++ b/controller/rq_hover.ml @@ -12,7 +12,7 @@ let build_ind_type mip = Inductive.type_of_inductive mip type id_info = | Notation of Pp.t - | Def of Pp.t + | Def of (Pp.t * Names.Constant.t option * string option) let info_of_ind env sigma ((sp, i) : Names.Ind.t) = let mib = Environ.lookup_mind sp env in @@ -37,7 +37,7 @@ let info_of_ind env sigma ((sp, i) : Names.Ind.t) = (Impargs.implicits_of_global (Names.GlobRef.IndRef (sp, i))) in let impargs = List.map Impargs.binding_kind_of_status impargs in - Def (Printer.pr_ltype_env ~impargs env_params sigma arity) + Def (Printer.pr_ltype_env ~impargs env_params sigma arity, None, None) let type_of_constant cb = cb.Declarations.const_type @@ -53,7 +53,10 @@ let info_of_const env sigma cr = (Impargs.implicits_of_global (Names.GlobRef.ConstRef cr)) in let impargs = List.map Impargs.binding_kind_of_status impargs in - Def (Printer.pr_ltype_env env sigma ~impargs typ) + let typ = Printer.pr_ltype_env env sigma ~impargs typ in + let dp = Names.Constant.modpath cr |> Names.ModPath.dp in + let source = Coq.Module.(make dp |> Result.to_option |> Option.map source) in + Def (typ, Some cr, source) let info_of_var env vr = let vdef = Environ.lookup_named vr env in @@ -70,7 +73,7 @@ let info_of_constructor env cr = in ctype -let print_type env sigma x = Def (Printer.pr_ltype_env env sigma x) +let print_type env sigma x = Def (Printer.pr_ltype_env env sigma x, None, None) let info_of_id env sigma id = let qid = Libnames.qualid_of_string id in @@ -110,10 +113,22 @@ let info_of_id_at_point ~token ~node id = let st = node.Fleche.Doc.Node.state in Coq.State.in_state ~token ~st ~f:(info_of_id ~st) id +let pp_cr fmt = function + | None -> () + | Some cr -> + Format.fprintf fmt " - **full path**: `%a`@\n" Pp.pp_with + (Names.Constant.print cr) + +let pp_file fmt = function + | None -> () + | Some file -> Format.fprintf fmt " - **in file**: `%s`" file + let pp_typ id = function - | Def typ -> + | Def (typ, cr, file) -> let typ = Pp.string_of_ppcmds typ in - Format.(asprintf "```coq\n%s : %s\n```" id typ) + Format.( + asprintf "@[```coq\n%s : %s@\n```@\n@[%a@]@[%a@]@]" id typ pp_cr cr + pp_file file) | Notation nt -> let nt = Pp.string_of_ppcmds nt in Format.(asprintf "```coq\n%s\n```" nt) @@ -219,6 +234,56 @@ module Notation : HoverProvider = struct let h = Handler.WithNode info_notation end +module InputHelp : HoverProvider = struct + let mk_map map = + List.fold_left + (fun m (tex, uni) -> CString.Map.add uni tex m) + CString.Map.empty map + + (* A bit hackish, but OK *) + let unimap = + Lazy.from_fun (fun () -> mk_map (Unicode_bindings.from_config ())) + + let input_help ~token:_ ~contents ~point ~node:_ = + (* check if contents at point match *) + match Rq_common.get_uchar_at_point ~prev:false ~contents ~point with + | Some (uchar, uchar_str) + when Lang.Compat.OCaml4_14.Uchar.utf_8_byte_length uchar > 1 -> + Option.map + (fun tex -> Format.asprintf "Input %s with %s" uchar_str tex) + (CString.Map.find_opt uchar_str (Lazy.force unimap)) + | Some _ | None -> None + + let h = Handler.MaybeNode input_help +end + +module UniDiff = struct + let show_unidiff ~token ?diff ~st () = + let nuniv_prev, nconst_prev = + match diff with + | Some st -> ( + match Coq.State.info_universes ~token ~st with + | Coq.Protect.{ E.r = R.Completed (Ok (nuniv, nconst)); feedback = _ } + -> (nuniv, nconst) + | _ -> (0, 0)) + | None -> (0, 0) + in + match Coq.State.info_universes ~token ~st with + | Coq.Protect.{ E.r = R.Completed (Ok (nuniv, nconst)); feedback = _ } -> + Some + (Format.asprintf "@[univ data (%4d,%4d) {+%d, +%d}@\n@]" nuniv nconst + (nuniv - nuniv_prev) (nconst - nconst_prev)) + | _ -> None + + let h ~token ~contents:_ ~point:_ ~(node : Fleche.Doc.Node.t) = + if !Fleche.Config.v.show_universes_on_hover then + let diff = Option.map Fleche.Doc.Node.state node.prev in + show_unidiff ~token ?diff ~st:node.state () + else None + + let h = Handler.WithNode h +end + module Register = struct let handlers : Handler.t list ref = ref [] let add fn = handlers := fn :: !handlers @@ -236,7 +301,9 @@ module Register = struct end (* Register in-file hover plugins *) -let () = List.iter Register.add [ Loc_info.h; Stats.h; Type.h; Notation.h ] +let () = + List.iter Register.add + [ Loc_info.h; Stats.h; Type.h; Notation.h; InputHelp.h; UniDiff.h ] let hover ~token ~(doc : Fleche.Doc.t) ~point = let node = Info.LC.node ~doc ~point Exact in diff --git a/controller/rq_hover.mli b/controller/rq_hover.mli index d9786731..263003c8 100644 --- a/controller/rq_hover.mli +++ b/controller/rq_hover.mli @@ -41,3 +41,8 @@ end module Register : sig val add : Handler.t -> unit end + +(** Auxiliary functions *) +module UniDiff : sig + (** [info_universes ~node] returns [nunivs, nconstraints] *) +end diff --git a/controller/rq_init.ml b/controller/rq_init.ml index d99a4db6..3b008cd6 100644 --- a/controller/rq_init.ml +++ b/controller/rq_init.ml @@ -6,7 +6,7 @@ (************************************************************************) module U = Yojson.Safe.Util -module LIO = Lsp.Io +module L = Fleche.Io.Log (* Conditionals *) let option_default x d = @@ -25,36 +25,33 @@ let odict_field name dict = (* Request Handling: The client expects a reply *) let do_settings coq_lsp_options : unit = - LIO.trace "settings" "setting server options:"; - LIO.trace_object "settings" (`Assoc coq_lsp_options); + L.trace "settings" "setting server options:"; + L.trace_object "settings" (`Assoc coq_lsp_options); match Lsp.JFleche.Config.of_yojson (`Assoc coq_lsp_options) with | Ok v -> Fleche.Config.v := v - | Error msg -> LIO.trace "CoqLspOption.of_yojson error: " msg + | Error msg -> L.trace "CoqLspOption.of_yojson" "error: %s" msg -let check_client_version client_version : unit = +let check_client_version ~io client_version : unit = let server_version = Fleche.Version.server in - LIO.trace "client_version" client_version; + L.trace "client_version" "%s" client_version; if String.(equal client_version "any" || equal client_version server_version) then () (* Version OK *) else - let message = - Format.asprintf "Incorrect client version: %s , expected %s." - client_version server_version - in - LIO.(logMessage ~lvl:Lvl.Error ~message) + Fleche.Io.Report.msg ~io ~lvl:Error + "Incorrect client version: %s , expected %s." client_version + server_version (* Maybe this should be [cwd] ? *) let default_workspace_root = "." let parse_furi x = U.to_string x |> Lang.LUri.of_string |> Lang.LUri.File.of_uri -let parse_fpath x = +let parse_fpath ~io x = let path = U.to_string x in - (if Filename.is_relative path then - let message = - "rootPath is not absolute: " ^ path - ^ " . This is not robust, please use absolute paths or rootURI" - in - LIO.logMessage ~lvl:LIO.Lvl.Warning ~message); + if Filename.is_relative path then + Fleche.Io.Report.msg ~io ~lvl:Warning + "rootPath is not absolute: %s . This is not robust, please use absolute \ + paths or rootURI" + path; Lang.LUri.of_string ("file:///" ^ path) |> Lang.LUri.File.of_uri let parse_null_or f = function @@ -72,9 +69,9 @@ let rec result_map ls = let parse_furis l = List.map parse_furi l |> result_map let parse_wf l = List.map (field "uri") (U.to_list l) |> parse_furis -let determine_workspace_root ~params : string list = +let determine_workspace_root ~io ~params : string list = (* Careful: all paths fields can be present but have value `null` *) - let rootPath = ofield "rootPath" params |> parse_null_or parse_fpath in + let rootPath = ofield "rootPath" params |> parse_null_or (parse_fpath ~io) in let rootUri = ofield "rootUri" params |> parse_null_or parse_furi in let wsFolders = ofield "workspaceFolders" params |> parse_null_or parse_wf in match (rootPath, rootUri, wsFolders) with @@ -84,38 +81,38 @@ let determine_workspace_root ~params : string list = | Some (Ok dir_uri), None, (None | Some (Ok [])) -> [ Lang.LUri.File.to_string_file dir_uri ] | Some (Error msg), _, _ | _, Some (Error msg), _ | _, _, Some (Error msg) -> - LIO.trace "init" ("uri parsing failed: " ^ msg); + L.trace "init" "uri parsing failed: %s" msg; [ default_workspace_root ] | _, _, Some (Ok folders) -> List.map Lang.LUri.File.to_string_file folders -let determine_workspace_root ~params = - try determine_workspace_root ~params +let determine_workspace_root ~io ~params = + try determine_workspace_root ~io ~params with exn -> - LIO.trace "init" - ("problem determining workspace root: " ^ Printexc.to_string exn); + L.trace "init" "problem determining workspace root: %s" + (Printexc.to_string exn); [ default_workspace_root ] let get_trace ~params = match ostring_field "trace" params with - | None -> LIO.TraceValue.Off + | None -> Lsp.Io.TraceValue.Off | Some v -> ( - match LIO.TraceValue.of_string v with + match Lsp.Io.TraceValue.of_string v with | Ok t -> t | Error e -> - LIO.trace "trace" ("invalid value: " ^ e); - LIO.TraceValue.Off) + L.trace "trace" "invalid value: %s" e; + Lsp.Io.TraceValue.Off) -let do_initialize ~params = - let dir = determine_workspace_root ~params in +let do_initialize ~io ~params = + let dir = determine_workspace_root ~io ~params in let trace = get_trace ~params in - LIO.set_trace_value trace; + Lsp.Io.set_trace_value trace; let coq_lsp_settings = odict_field "initializationOptions" params in do_settings coq_lsp_settings; - check_client_version !Fleche.Config.v.client_version; + check_client_version ~io !Fleche.Config.v.client_version; let client_capabilities = odict_field "capabilities" params in if Fleche.Debug.lsp_init then ( - LIO.trace "init" "client capabilities:"; - LIO.trace_object "init" (`Assoc client_capabilities)); + L.trace "init" "client capabilities:"; + L.trace_object "init" (`Assoc client_capabilities)); let capabilities = [ ("textDocumentSync", `Int 1) ; ("documentSymbolProvider", `Bool true) @@ -127,7 +124,8 @@ let do_initialize ~params = ; ("resolveProvider", `Bool false) ] ) ; ("definitionProvider", `Bool true) - ; ("codeLensProvider", `Assoc []) + (* EJGA: Disable this as we have no use case for now *) + (* ; ("codeLensProvider", `Assoc []) *) ; ("selectionRangeProvider", `Bool true) ; ( "workspace" , `Assoc diff --git a/controller/rq_init.mli b/controller/rq_init.mli index c4a424c5..2123ca7c 100644 --- a/controller/rq_init.mli +++ b/controller/rq_init.mli @@ -10,4 +10,6 @@ val do_settings : (string * Yojson.Safe.t) list -> unit (** Returns answer request + workspace root directory *) val do_initialize : - params:(string * Yojson.Safe.t) list -> Yojson.Safe.t * string list + io:Fleche.Io.CallBack.t + -> params:(string * Yojson.Safe.t) list + -> Yojson.Safe.t * string list diff --git a/controller/unicode_bindings.ml b/controller/unicode_bindings.ml index 77ac63d8..569cb9ee 100644 --- a/controller/unicode_bindings.ml +++ b/controller/unicode_bindings.ml @@ -1697,3 +1697,10 @@ let extended = ; ("\\_v", "ᵥ") ; ("\\_x", "ₓ") ] + +let from_config () = + match !Fleche.Config.v.unicode_completion with + | Off -> [] + | Internal_small -> small + | Normal -> normal + | Extended -> extended diff --git a/controller/unicode_bindings.mli b/controller/unicode_bindings.mli index b14b2f49..67d604fc 100644 --- a/controller/unicode_bindings.mli +++ b/controller/unicode_bindings.mli @@ -9,3 +9,6 @@ val normal : (string * string) list (** All the supported bindings for unicode characters in a table. *) val extended : (string * string) list + +(** Return the list selected in config *) +val from_config : unit -> (string * string) list diff --git a/coq-lsp.opam b/coq-lsp.opam index d788e71e..917bdecb 100644 --- a/coq-lsp.opam +++ b/coq-lsp.opam @@ -37,7 +37,19 @@ depends: [ # Uncomment this for releases "coq" { >= "8.19" < "8.20" } - "coq-serapi" { >= "8.19" < "8.20" } + + # coq deps: remove this for releases + "ocamlfind" {>= "1.8.1"} + "zarith" {>= "1.11"} + + # serlib deps: see what we need to keep for release + "ppx_deriving" { >= "4.2.1" } + "ppx_deriving_yojson" { >= "3.4" } + "ppx_import" { >= "1.5-3" } + "sexplib" { >= "v0.13.0" & < "v0.18" } + "ppx_sexp_conv" { >= "v0.13.0" & < "v0.18" } + "ppx_compare" { >= "v0.13.0" & < "v0.18" } + "ppx_hash" { >= "v0.13.0" & < "v0.18" } ] depopts: ["lwt" "logs"] diff --git a/coq/args.ml b/coq/args.ml index d9d5a56a..0d7ddd99 100644 --- a/coq/args.ml +++ b/coq/args.ml @@ -84,14 +84,24 @@ let ri_from : (string option * string) list Term.t = & info [ "rifrom"; "require-import-from" ] ~docv:"FROM,LIBRARY" ~doc)) let int_backend = + let docv = "BACKEND" in + let backends = [ ("Coq", Limits.Coq); ("Mp", Limits.Mp) ] in + let backends_str = + "either 'Mp', for memprof-limits token-based interruption,\n\ + \ or 'Coq', for Coq's polling mode (unreliable). The 'Mp' backend is only \ + supported in OCaml 4.x series." + in let doc = - "Select Interruption Backend, if absent, the best available for your OCaml \ - version will be selected" + Printf.sprintf + "Select Interruption Backend, if absent, the best available for your \ + OCaml version will be selected. %s is %s" + docv backends_str in + let absent = "'Mp' for OCaml 4.x, 'Coq' for OCaml 5.x" in Arg.( value - & opt (enum [ ("Coq", Some Limits.Coq); ("Mp", Some Limits.Mp) ]) None - & info [ "int_backend" ] ~docv:"INT_BACKEND" ~doc) + & opt (some (enum backends)) None + & info [ "int_backend" ] ~docv ~doc ~absent) let roots : string list Term.t = let doc = "Workspace(s) root(s)" in @@ -99,7 +109,7 @@ let roots : string list Term.t = let coq_diags_level : int Term.t = let doc = - "Controsl whether Coq Info and Notice message appear in diagnostics.\n\ + "Controls whether Coq Info and Notice message appear in diagnostics.\n\ \ 0 = None; 1 = Notices, 2 = Notices and Info" in Arg.(value & opt int 0 & info [ "diags_level" ] ~docv:"DIAGS_LEVEL" ~doc) diff --git a/coq/ast.ml b/coq/ast.ml index fbf9a4ae..cc9c9569 100644 --- a/coq/ast.ml +++ b/coq/ast.ml @@ -77,6 +77,9 @@ module Meta = struct | Back of int | ResetName of Names.lident | ResetInitial + | AbortAll + (* Not supported, but actually easy if we want | VernacRestart | VernacUndo + _ | VernacUndoTo _ *) [@@deriving hash, compare] end @@ -104,6 +107,9 @@ module Meta = struct | { expr = VernacSynPure (VernacBack num); control; attrs } -> let command = Command.Back num in Some { command; loc; attrs; control } + | { expr = VernacSynPure VernacAbortAll; control; attrs } -> + let command = Command.AbortAll in + Some { command; loc; attrs; control } | _ -> None) end diff --git a/coq/ast.mli b/coq/ast.mli index 412d4721..f2562507 100644 --- a/coq/ast.mli +++ b/coq/ast.mli @@ -40,6 +40,7 @@ module Meta : sig | Back of int | ResetName of Names.lident | ResetInitial + | AbortAll end type t = diff --git a/coq/compat.ml b/coq/compat.ml index ea4561c3..3e3f2481 100644 --- a/coq/compat.ml +++ b/coq/compat.ml @@ -1,5 +1,21 @@ (* Compatibility file *) +module Ocaml_413 = struct + module String = struct + open String + + let starts_with ~prefix s = + let len_s = length s + and len_pre = length prefix in + let rec aux i = + if i = len_pre then true + else if unsafe_get s i <> unsafe_get prefix i then false + else aux (i + 1) + in + len_s >= len_pre && aux 0 + end +end + module Ocaml_414 = struct module In_channel = struct (* 4.14 can do this: In_channel.with_open_bin file In_channel.input_all, so @@ -120,3 +136,12 @@ let format_to_file ~file ~f x = Out_channel.with_open_bin file (fun oc -> let of_fmt = Format.formatter_of_out_channel oc in Format.fprintf of_fmt "@[%a@]%!" f x) + +module Option = struct + include Stdlib.Option + + module O = struct + let ( let+ ) r f = map f r + let ( let* ) r f = bind r f + end +end diff --git a/coq/compat.mli b/coq/compat.mli index fc56a00c..f5a44468 100644 --- a/coq/compat.mli +++ b/coq/compat.mli @@ -1,5 +1,11 @@ (* Compatiblity and general utils *) +module Ocaml_413 : sig + module String : sig + val starts_with : prefix:string -> string -> bool + end +end + (* We should at some point remove all of this file in favor of a standard library that suits our needs *) module Ocaml_414 : sig @@ -35,3 +41,12 @@ module Result : sig -> ('r, 'e) Result.t -> unit end + +module Option : sig + include module type of Stdlib.Option + + module O : sig + val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t + val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t + end +end diff --git a/coq/dune b/coq/dune index 7d954f4c..a6a55756 100644 --- a/coq/dune +++ b/coq/dune @@ -11,7 +11,7 @@ (!memprof-limits -> limits_mp_impl.fake.ml)) lang coq-core.vernac - coq-serapi.serlib + coq-lsp.serlib ; EJGA: This is due to Coq.Args, feel free to move to its own lib if ; needed cmdliner)) diff --git a/coq/glob.ml b/coq/glob.ml index 6c9eb714..054e72aa 100644 --- a/coq/glob.ml +++ b/coq/glob.ml @@ -184,7 +184,4 @@ let open_file file = Compat.Ocaml_414.In_channel.with_open_text file (Coq.read_glob (Some vfile)) else Error (Format.asprintf "Cannot open file: %s" file) -let get_info map name = - match DefMap.find_opt name map with - | Some info -> Ok info - | None -> Error (Format.asprintf "definition %s not found in glob table" name) +let get_info map name = DefMap.find_opt name map diff --git a/coq/glob.mli b/coq/glob.mli index 83376443..742a2564 100644 --- a/coq/glob.mli +++ b/coq/glob.mli @@ -18,6 +18,7 @@ (* Glob file that was read and parsed successfully *) type t +(* Input is a .glob file *) val open_file : string -> (t, string) Result.t module Info : sig @@ -27,4 +28,4 @@ module Info : sig } end -val get_info : t -> string -> (Info.t, string) Result.t +val get_info : t -> string -> Info.t option diff --git a/coq/goals.ml b/coq/goals.ml index e90ee9db..0bdc25d8 100644 --- a/coq/goals.ml +++ b/coq/goals.ml @@ -15,42 +15,50 @@ (* Written by: Emilio J. Gallego Arias *) (************************************************************************) -type 'a hyp = - { names : string list - ; def : 'a option - ; ty : 'a - } - -let map_hyp ~f { names; def; ty } = - let def = Option.map f def in - let ty = f ty in - { names; def; ty } - -type info = - { evar : Evar.t - ; name : Names.Id.t option - } - -type 'a reified_goal = - { info : info - ; hyps : 'a hyp list - ; ty : 'a - } - -let map_reified_goal ~f { info; ty; hyps } = - let ty = f ty in - let hyps = List.map (map_hyp ~f) hyps in - { info; ty; hyps } - -type ('a, 'pp) goals = - { goals : 'a list - ; stack : ('a list * 'a list) list +let equal_option = Option.equal + +module Reified_goal = struct + type 'a hyp = + { names : String.t List.t + ; def : 'a option + ; ty : 'a + } + [@@deriving equal] + + let map_hyp ~f { names; def; ty } = + let def = Option.map f def in + let ty = f ty in + { names; def; ty } + + type info = + { evar : Evar.t + ; name : Names.Id.t option + } + [@@deriving equal] + + type 'a t = + { info : info + ; hyps : 'a hyp List.t + ; ty : 'a + } + [@@deriving equal] + + let map ~f { info; ty; hyps } = + let ty = f ty in + let hyps = List.map (map_hyp ~f) hyps in + { info; ty; hyps } +end + +type ('a, 'pp) t = + { goals : 'a List.t + ; stack : ('a List.t * 'a List.t) List.t ; bullet : 'pp option - ; shelf : 'a list - ; given_up : 'a list + ; shelf : 'a List.t + ; given_up : 'a List.t } +[@@deriving equal] -let map_goals ~f ~g { goals; stack; bullet; shelf; given_up } = +let map ~f ~g { goals; stack; bullet; shelf; given_up } = let goals = List.map f goals in let stack = List.map (fun (s, r) -> (List.map f s, List.map f r)) stack in let bullet = Option.map g bullet in @@ -58,7 +66,7 @@ let map_goals ~f ~g { goals; stack; bullet; shelf; given_up } = let given_up = List.map f given_up in { goals; stack; bullet; shelf; given_up } -type 'pp reified_pp = ('pp reified_goal, 'pp) goals +type 'pp reified_pp = ('pp Reified_goal.t, 'pp) t (** XXX: Do we need to perform evar normalization? *) @@ -68,19 +76,19 @@ type cdcl = EConstr.compacted_declaration let binder_name n = Context.binder_name n |> Names.Id.to_string -let to_tuple ppx : cdcl -> 'pc hyp = +let to_tuple ppx : cdcl -> 'pc Reified_goal.hyp = let open CDC in function | LocalAssum (idl, tm) -> let names = List.map binder_name idl in - { names; def = None; ty = ppx tm } + { Reified_goal.names; def = None; ty = ppx tm } | LocalDef (idl, tdef, tm) -> let names = List.map binder_name idl in { names; def = Some (ppx tdef); ty = ppx tm } (** gets a hypothesis *) let get_hyp (ppx : EConstr.t -> 'pc) (_sigma : Evd.evar_map) (hdecl : cdcl) : - 'pc hyp = + 'pc Reified_goal.hyp = to_tuple ppx hdecl (** gets the constr associated to the type of the current goal *) @@ -94,10 +102,11 @@ let get_goal_type (ppx : EConstr.t -> 'pc) (env : Environ.env) in ppx concl -let build_info sigma g = { evar = g; name = Evd.evar_ident g sigma } +let build_info sigma g = + { Reified_goal.evar = g; name = Evd.evar_ident g sigma } (** Generic processor *) -let process_goal_gen ppx sigma g : 'a reified_goal = +let process_goal_gen ppx sigma g : 'a Reified_goal.t = (* XXX This looks cumbersome *) let env = Global.env () in let (EvarInfo evi) = Evd.find sigma g in @@ -126,3 +135,20 @@ let reify ~ppx lemmas = ; shelf = Evd.shelf sigma |> ppx ; given_up = Evd.given_up sigma |> Evar.Set.elements |> ppx } + +module Equality = struct + let eq_constr (_env1, evd1, c1) (_env2, evd2, c2) = + (* XXX Fixme, can be much faster using the advance compare functions *) + let c1 = EConstr.to_constr evd1 c1 in + let c2 = EConstr.to_constr evd2 c2 in + Constr.equal c1 c2 + + let eq_pp pp1 pp2 = pp1 = pp2 + let eq_rgoal = Reified_goal.equal eq_constr + + let equal_goals st1 st2 = + let ppx env evd c = (env, evd, c) in + let g1 = reify ~ppx st1 in + let g2 = reify ~ppx st2 in + equal eq_rgoal eq_pp g1 g2 +end diff --git a/coq/goals.mli b/coq/goals.mli index 5dc5e616..9112ce9d 100644 --- a/coq/goals.mli +++ b/coq/goals.mli @@ -15,26 +15,29 @@ (* Written by: Emilio J. Gallego Arias *) (************************************************************************) -type 'a hyp = - { names : string list (** This will become [Names.Id.t list] in 0.2.0 *) - ; def : 'a option - ; ty : 'a - } +module Reified_goal : sig + type 'a hyp = + { names : string list (** This will become [Names.Id.t list] in 0.2.0 *) + ; def : 'a option + ; ty : 'a + } -type info = - { evar : Evar.t - ; name : Names.Id.t option - } + type info = + { evar : Evar.t + ; name : Names.Id.t option + } -type 'a reified_goal = - { info : info - ; hyps : 'a hyp list - ; ty : 'a - } + type 'a t = + { info : info + ; hyps : 'a hyp list + ; ty : 'a + } -val map_reified_goal : f:('a -> 'b) -> 'a reified_goal -> 'b reified_goal + val map : f:('a -> 'b) -> 'a t -> 'b t + val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool +end -type ('a, 'pp) goals = +type ('a, 'pp) t = { goals : 'a list ; stack : ('a list * 'a list) list ; bullet : 'pp option @@ -42,13 +45,26 @@ type ('a, 'pp) goals = ; given_up : 'a list } -val map_goals : - f:('a -> 'b) -> g:('pp -> 'pp') -> ('a, 'pp) goals -> ('b, 'pp') goals +val equal : + ('a -> 'a -> bool) + -> ('pp -> 'pp -> bool) + -> ('a, 'pp) t + -> ('a, 'pp) t + -> bool -type 'pp reified_pp = ('pp reified_goal, 'pp) goals +val map : f:('a -> 'b) -> g:('pp -> 'pp') -> ('a, 'pp) t -> ('b, 'pp') t + +type 'pp reified_pp = ('pp Reified_goal.t, 'pp) t (** Stm-independent goal processor *) val reify : ppx:(Environ.env -> Evd.evar_map -> EConstr.t -> 'pp) -> State.Proof.t - -> ('pp reified_goal, Pp.t) goals + -> ('pp Reified_goal.t, Pp.t) t + +(* equality functions with heuristics *) +module Equality : sig + (** Goal-based eq heuristic, will return [true] when goals are "equal", in a + proof search sense *) + val equal_goals : State.Proof.t -> State.Proof.t -> bool +end diff --git a/coq/init.ml b/coq/init.ml index d4b34da3..95b3e357 100644 --- a/coq/init.ml +++ b/coq/init.ml @@ -85,19 +85,19 @@ let coq_init opts = (**************************************************************************) (* Inits the context for a document *) -let doc_init ~root_state ~workspace ~uri () = +let doc_init ~intern ~root_state ~workspace ~uri () = (* Lsp.Io.log_error "init" "starting"; *) Vernacstate.unfreeze_full_state (State.to_coq root_state); (* Set load paths from workspace info. *Important*, this has to happen before we declare the library below as [Declaremods/Library] will infer the module name by looking at the load path! *) - Workspace.apply ~uri workspace; + Workspace.apply ~intern ~uri workspace; (* We return the state at this point! *) Vernacstate.freeze_full_state () |> State.of_coq -let doc_init ~token:_ ~root_state ~workspace ~uri = +let doc_init ~token:_ ~intern ~root_state ~workspace ~uri = (* Don't interrupt document creation. *) let token = Limits.create_atomic () in - Protect.eval ~token ~f:(doc_init ~root_state ~workspace ~uri) () + Protect.eval ~token ~f:(doc_init ~intern ~root_state ~workspace ~uri) () diff --git a/coq/init.mli b/coq/init.mli index e547e3c6..84a5bd61 100644 --- a/coq/init.mli +++ b/coq/init.mli @@ -29,6 +29,7 @@ val coq_init : coq_opts -> State.t val doc_init : token:Limits.Token.t + -> intern:unit -> root_state:State.t -> workspace:Workspace.t -> uri:Lang.LUri.File.t diff --git a/coq/interp.ml b/coq/interp.ml index b259559f..42f1dd0a 100644 --- a/coq/interp.ml +++ b/coq/interp.ml @@ -15,17 +15,18 @@ (* Written by: Emilio J. Gallego Arias *) (************************************************************************) -let coq_interp ~st cmd = +let coq_interp ~intern:_ ~st cmd = let st = State.to_coq st in let cmd = Ast.to_coq cmd in Vernacinterp.interp ~st cmd |> State.of_coq -let interp ~token ~st cmd = Protect.eval ~token cmd ~f:(coq_interp ~st) +let interp ~token ~intern ~st cmd = + Protect.eval ~token cmd ~f:(coq_interp ~intern ~st) module Require = struct (* We could improve this Coq upstream by making the API a bit more orthogonal *) - let interp ~st _files + let interp ~intern:_ ~st _files { Ast.Require.from; export; mods; loc = _; attrs; control } = let () = Vernacstate.unfreeze_full_state (State.to_coq st) in let fn () = Vernacentries.vernac_require from export mods in @@ -40,6 +41,6 @@ module Require = struct let () = Utils.with_control ~fn ~control ~st in Vernacstate.freeze_full_state () |> State.of_coq - let interp ~token ~st files cmd = - Protect.eval ~token ~f:(interp ~st files) cmd + let interp ~token ~intern ~st files cmd = + Protect.eval ~token ~f:(interp ~intern ~st files) cmd end diff --git a/coq/interp.mli b/coq/interp.mli index 9b7e5118..0ce3bf13 100644 --- a/coq/interp.mli +++ b/coq/interp.mli @@ -19,7 +19,11 @@ assumed not to interact with the file-system, etc... Note these commands will be memoized. *) val interp : - token:Limits.Token.t -> st:State.t -> Ast.t -> (State.t, Loc.t) Protect.E.t + token:Limits.Token.t + -> intern:unit + -> st:State.t + -> Ast.t + -> (State.t, Loc.t) Protect.E.t (** Interpretation of "require". We wrap this function for two reasons: @@ -28,6 +32,7 @@ val interp : module Require : sig val interp : token:Limits.Token.t + -> intern:unit -> st:State.t -> Files.t -> Ast.Require.t diff --git a/coq/library_file.ml b/coq/library_file.ml index b5dd42f3..551a7ba8 100644 --- a/coq/library_file.ml +++ b/coq/library_file.ml @@ -98,12 +98,12 @@ let to_result ~f x = let iexn = Exninfo.capture exn in Error iexn -let try_locate_absolute_library dir = +let locate_absolute_library dir = let f = Loadpath.try_locate_absolute_library in to_result ~f dir let find_v_file dir = - match try_locate_absolute_library dir with + match locate_absolute_library dir with (* EJGA: we want to improve this as to pass the error to the client *) | Error _ -> "error when trying to locate the .v file" | Ok file -> file diff --git a/coq/library_file.mli b/coq/library_file.mli index a93fd482..9fd260db 100644 --- a/coq/library_file.mli +++ b/coq/library_file.mli @@ -36,3 +36,5 @@ val toc : (** Recovers the list of loaded libraries for state [st] *) val loaded : token:Limits.Token.t -> st:State.t -> (t list, Loc.t) Protect.E.t + +val locate_absolute_library : Names.DirPath.t -> (string, Exninfo.iexn) Result.t diff --git a/coq/loader.ml b/coq/loader.ml index 9dc1503e..75d7c8f2 100644 --- a/coq/loader.ml +++ b/coq/loader.ml @@ -1,18 +1,19 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* list_last in - let serlib_name = "coq-serapi.serlib." ^ plugin_name in + let serlib_name = "coq-lsp.serlib." ^ plugin_name in check_package_exists serlib_name else None diff --git a/coq/loader.mli b/coq/loader.mli index 0aed8eab..30ac8199 100644 --- a/coq/loader.mli +++ b/coq/loader.mli @@ -1,18 +1,19 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* + (* Fleche.Io.Log.trace "rq_definition" "File Found"; *) + let source = Filename.remove_extension vo ^ ".v" in + let source = Str.replace_first (Str.regexp "_build/default/") "" source in + let uri = Lang.LUri.of_string ("file://" ^ source) in + let uri = Lang.LUri.File.of_uri uri |> Result.get_ok in + Ok { dp; source; vo; uri } + | Error err -> + (* Fleche.Io.Log.trace "rq_definition" "File Not Found :("; *) + (* Debug? *) + Error err + +let offset_to_range source (bp, ep) = + let text = Compat.Ocaml_414.In_channel.(with_open_text source input_all) in + let rec count (lines, char) cur goal = + if cur >= goal then (lines, char) + else + match text.[cur] with + | '\n' -> count (lines + 1, 0) (cur + 1) goal + | _ -> count (lines, char + 1) (cur + 1) goal + in + (* XXX UTF-8 / 16 adjust *) + let bline, bchar = count (0, 0) 0 bp in + let eline, echar = count (bline, bchar) bp ep in + let start = Lang.Point.{ line = bline; character = bchar; offset = bp } in + let end_ = Lang.Point.{ line = eline; character = echar; offset = ep } in + Lang.Range.{ start; end_ } + +let find { vo; source; _ } name = + let glob = Filename.remove_extension vo ^ ".glob" in + match Glob.open_file glob with + | Error err -> + (* Fleche.Io.Log.trace "rq_definition:open_file" "Error: %s" err; *) + Error err + | Ok g -> ( + match Glob.get_info g name with + | Some { offset; _ } -> Ok (Some (offset_to_range source offset)) + | None -> + (* Fleche.Io.Log.trace "rq_definition:get_info" "Not found"; *) + Ok None) diff --git a/coq/module.mli b/coq/module.mli new file mode 100644 index 00000000..962e0b7d --- /dev/null +++ b/coq/module.mli @@ -0,0 +1,14 @@ +(************************************************************************) +(* Coq Language Server Protocol -- Common requests routines *) +(* Copyright 2019 MINES ParisTech -- Dual License LGPL 2.1 / GPL3+ *) +(* Copyright 2019-2024 Inria -- Dual License LGPL 2.1 / GPL3+ *) +(* Written by: Emilio J. Gallego Arias *) +(************************************************************************) + +type t + +(* Lookup module as needed *) +val make : Names.DirPath.t -> (t, Exninfo.iexn) Result.t +val uri : t -> Lang.LUri.File.t +val source : t -> string +val find : t -> string -> (Lang.Range.t option, string) Result.t diff --git a/coq/parsing.ml b/coq/parsing.ml index 58581066..8eba430a 100644 --- a/coq/parsing.ml +++ b/coq/parsing.ml @@ -2,11 +2,11 @@ module Parsable = Pcoq.Parsable let parse ~st ps = let mode = State.mode ~st in - let st = State.parsing ~st in + let pst = State.parsing ~st in (* Coq is missing this, so we add it here. Note that this MUST run inside coq_protect *) Control.check_for_interrupt (); - Vernacstate.Parser.parse st Pvernac.(main_entry mode) ps + Vernacstate.Parser.parse pst Pvernac.(main_entry mode) ps |> Option.map Ast.of_coq let parse ~token ~st ps = Protect.eval ~token ~f:(parse ~st) ps diff --git a/coq/state.ml b/coq/state.ml index 507d7537..e98c7737 100644 --- a/coq/state.ml +++ b/coq/state.ml @@ -45,22 +45,25 @@ let to_coq x = x (* let compare x y = compare x y *) let compare (x : t) (y : t) = let open Vernacstate in - let { synterp = { parsing = p1; system = ss1 } + let { synterp = ss1 ; interp = { system = is1; lemmas = l1; program = g1; opaques = o1 } } = x in - let { synterp = { parsing = p2; system = ss2 } + let { synterp = ss2 ; interp = { system = is2; lemmas = l2; program = g2; opaques = o2 } } = y in - if p1 == p2 && ss1 == ss2 && is1 == is2 && l1 == l2 && g1 == g2 && o1 == o2 - then 0 - else 1 + if ss1 == ss2 && is1 == is2 && l1 == l2 && g1 == g2 && o1 == o2 then 0 else 1 let equal x y = compare x y = 0 -let hash x = Hashtbl.hash x + +let hash x = + (* OCaml's defaults are 10, 100, but not so good for us, much improved + settings are below (best try so far) *) + let meaningful, total = (64, 256) in + Hashtbl.hash_param meaningful total x let mode ~st = Option.map @@ -82,7 +85,7 @@ let lemmas ~st = st.Vernacstate.interp.lemmas let program ~st = NeList.head st.Vernacstate.interp.program |> Declare.OblState.view -let drop_proofs ~st = +let drop_proof ~st = let open Vernacstate in let interp = { st.interp with @@ -94,6 +97,11 @@ let drop_proofs ~st = in { st with interp } +let drop_all_proofs ~st = + let open Vernacstate in + let interp = { st.interp with lemmas = None } in + { st with interp } + let in_state ~token ~st ~f a = let f a = Vernacstate.unfreeze_full_state st; @@ -130,3 +138,23 @@ let admit_goal ~st () = { st with interp = { st.interp with lemmas } } let admit_goal ~token ~st = Protect.eval ~token ~f:(admit_goal ~st) () + +let count_edges univ = + let univ = UGraph.repr univ in + Univ.Level.Map.fold + (fun _ node acc -> + acc + + + match node with + | UGraph.Alias _ -> 1 + | Node m -> Univ.Level.Map.cardinal m) + univ + (Univ.Level.Map.cardinal univ) + +let info_universes ~token ~st = + let open Protect.E.O in + let+ univ = in_state ~token ~st ~f:Global.universes () in + let univs = UGraph.domain univ in + let nuniv = Univ.Level.Set.cardinal univs in + let nconst = count_edges univ in + (nuniv, nconst) diff --git a/coq/state.mli b/coq/state.mli index 0a32c941..4741a0cc 100644 --- a/coq/state.mli +++ b/coq/state.mli @@ -29,8 +29,11 @@ val in_stateM : -> 'a -> ('b, Loc.t) Protect.E.t -(** Drop the proofs from the state *) -val drop_proofs : st:t -> t +(** Drop the top proof from the state *) +val drop_proof : st:t -> t + +(** Drop all proofs from the state *) +val drop_all_proofs : st:t -> t (** Fully admit an ongoing proof *) val admit : token:Limits.Token.t -> st:t -> (t, Loc.t) Protect.E.t @@ -38,6 +41,10 @@ val admit : token:Limits.Token.t -> st:t -> (t, Loc.t) Protect.E.t (** Admit the current sub-goal *) val admit_goal : token:Limits.Token.t -> st:t -> (t, Loc.t) Protect.E.t +(** Info about universes *) +val info_universes : + token:Limits.Token.t -> st:t -> (int * int, Loc.t) Protect.E.t + (** Extra / interanl *) val marshal_in : in_channel -> t diff --git a/coq/workspace.ml b/coq/workspace.ml index 649f8502..27fc1373 100644 --- a/coq/workspace.ml +++ b/coq/workspace.ml @@ -262,7 +262,7 @@ let describe_guess = function | Error msg -> (msg, "") (* Require a set of libraries *) -let load_objs libs = +let load_objs ~intern:_ libs = let rq_file { Require.library; from; flags } = let mp = Libnames.qualid_of_string library in let mfrom = Option.map Libnames.qualid_of_string from in @@ -295,7 +295,7 @@ let dirpath_of_uri ~uri = ldir (* NOTE: Use exhaustive match below to avoid bugs by skipping fields *) -let apply ~uri +let apply ~intern ~uri { coqlib = _ ; coqcorelib = _ ; ocamlpath @@ -314,7 +314,7 @@ let apply ~uri findlib_init ~ml_include_path ~ocamlpath; List.iter Loadpath.add_vo_path vo_load_path; Declaremods.start_library (dirpath_of_uri ~uri); - load_objs require_libs + load_objs ~intern require_libs (* This can raise, and will do in incorrect CoqProject files *) let dirpath_of_string_exn coq_path = Libnames.dirpath_of_string coq_path diff --git a/coq/workspace.mli b/coq/workspace.mli index 2cb76cad..a5ed7c2e 100644 --- a/coq/workspace.mli +++ b/coq/workspace.mli @@ -94,7 +94,7 @@ val guess : val default : debug:bool -> cmdline:CmdLine.t -> t (** [apply libname w] will prepare Coq for a new file [libname] on workspace [w] *) -val apply : uri:Lang.LUri.File.t -> t -> unit +val apply : intern:unit -> uri:Lang.LUri.File.t -> t -> unit (** *) val dirpath_of_uri : uri:Lang.LUri.File.t -> Names.DirPath.t diff --git a/dune b/dune index 94865487..b7137121 100644 --- a/dune +++ b/dune @@ -1 +1,3 @@ +(dirs :standard \ serlib) + (vendored_dirs vendor) diff --git a/dune-project b/dune-project index 1f3c77ef..b26b5f4b 100644 --- a/dune-project +++ b/dune-project @@ -6,4 +6,3 @@ (using menhir 2.1) (name coq-lsp) - diff --git a/editor/code/CHANGELOG.md b/editor/code/CHANGELOG.md index 1396f16b..e07b95b5 100644 --- a/editor/code/CHANGELOG.md +++ b/editor/code/CHANGELOG.md @@ -1,3 +1,11 @@ +# coq-lsp 0.1.10: Hasta el 40 de Mayo _en effect_... +---------------------------------------------------- + + - [code] Add `.v.tex` file extension to contributed language support + (@ejgallego, #740). + - [code] Don't show the panel on extension activation (@ejgallego, + #741, fix #737) + # coq-lsp 0.1.9: Hasta el 40 de Mayo... --------------------------------------- diff --git a/editor/code/lib/types.ts b/editor/code/lib/types.ts index 1e196f07..76c98ac7 100644 --- a/editor/code/lib/types.ts +++ b/editor/code/lib/types.ts @@ -208,3 +208,15 @@ export interface CoqStoppedStatus { } export type CoqServerStatus = CoqBusyStatus | CoqIdleStatus | CoqStoppedStatus; + +// Petanque types, canonical source agent.mli +export interface PetStartParams { + uri: string; + pre_commands: string | null; + thm: string; +} + +export interface PetRunParams { + st: number; + tac: string; +} diff --git a/editor/code/package-lock.json b/editor/code/package-lock.json index 3fb54af4..aae84a0d 100644 --- a/editor/code/package-lock.json +++ b/editor/code/package-lock.json @@ -1,12 +1,12 @@ { "name": "coq-lsp", - "version": "0.1.9", + "version": "0.2.0-dev", "lockfileVersion": 3, "requires": true, "packages": { "": { "name": "coq-lsp", - "version": "0.1.9", + "version": "0.2.0-dev", "dependencies": { "@vscode/webview-ui-toolkit": "^1.2.2", "jquery": "^3.7.1", @@ -172,10 +172,11 @@ } }, "node_modules/@azure/identity": { - "version": "4.1.0", - "resolved": "https://registry.npmjs.org/@azure/identity/-/identity-4.1.0.tgz", - "integrity": "sha512-BhYkF8Xr2gXjyDxocm0pc9RI5J5a1jw8iW0dw6Bx95OGdYbuMyFZrrwNw4eYSqQ2BB6FZOqpJP3vjsAqRcvDhw==", + "version": "4.2.1", + "resolved": "https://registry.npmjs.org/@azure/identity/-/identity-4.2.1.tgz", + "integrity": "sha512-U8hsyC9YPcEIzoaObJlRDvp7KiF0MGS7xcWbyJSVvXRkC/HXo1f0oYeBYmEvVgRfacw7GHf6D6yAoh9JHz6A5Q==", "dev": true, + "license": "MIT", "dependencies": { "@azure/abort-controller": "^1.0.0", "@azure/core-auth": "^1.5.0", @@ -185,7 +186,7 @@ "@azure/core-util": "^1.3.0", "@azure/logger": "^1.0.0", "@azure/msal-browser": "^3.11.1", - "@azure/msal-node": "^2.6.6", + "@azure/msal-node": "^2.9.2", "events": "^3.0.0", "jws": "^4.0.0", "open": "^8.0.0", @@ -230,12 +231,13 @@ } }, "node_modules/@azure/msal-node": { - "version": "2.7.0", - "resolved": "https://registry.npmjs.org/@azure/msal-node/-/msal-node-2.7.0.tgz", - "integrity": "sha512-wXD8LkUvHICeSWZydqg6o8Yvv+grlBEcmLGu+QEI4FcwFendbTEZrlSygnAXXSOCVaGAirWLchca35qrgpO6Jw==", + "version": "2.9.2", + "resolved": "https://registry.npmjs.org/@azure/msal-node/-/msal-node-2.9.2.tgz", + "integrity": "sha512-8tvi6Cos3m+0KmRbPjgkySXi+UQU/QiuVRFnrxIwt5xZlEEFa69O04RTaNESGgImyBBlYbo2mfE8/U8Bbdk1WQ==", "dev": true, + "license": "MIT", "dependencies": { - "@azure/msal-common": "14.9.0", + "@azure/msal-common": "14.12.0", "jsonwebtoken": "^9.0.0", "uuid": "^8.3.0" }, @@ -243,6 +245,16 @@ "node": ">=16" } }, + "node_modules/@azure/msal-node/node_modules/@azure/msal-common": { + "version": "14.12.0", + "resolved": "https://registry.npmjs.org/@azure/msal-common/-/msal-common-14.12.0.tgz", + "integrity": "sha512-IDDXmzfdwmDkv4SSmMEyAniJf6fDu3FJ7ncOjlxkDuT85uSnLEhZi3fGZpoR7T4XZpOMx9teM9GXBgrfJgyeBw==", + "dev": true, + "license": "MIT", + "engines": { + "node": ">=0.8.0" + } + }, "node_modules/@esbuild/android-arm": { "version": "0.16.17", "resolved": "https://registry.npmjs.org/@esbuild/android-arm/-/android-arm-0.16.17.tgz", diff --git a/editor/code/package.json b/editor/code/package.json index 20f5dae1..a5278d66 100644 --- a/editor/code/package.json +++ b/editor/code/package.json @@ -62,7 +62,8 @@ "LaTeX" ], "extensions": [ - ".lv" + ".lv", + "v.tex" ] } ], @@ -131,6 +132,14 @@ { "command": "coq-lsp.heatmap.toggle", "title": "Coq LSP: Toggle heatmap" + }, + { + "command": "coq-lsp.petanque.start", + "title": "Coq LSP: Start a petanque session for theorem (Coq developer-only command)" + }, + { + "command": "coq-lsp.petanque.run", + "title": "Coq LSP: Run a tactic over a petanque session (Coq developer-only command)" } ], "keybindings": [ @@ -216,6 +225,11 @@ "type": "boolean", "default": false, "description": "Show parsing information for a sentence on hover." + }, + "coq-lsp.show_universes_on_hover": { + "type": "boolean", + "default": false, + "description": "Show universe information and diff for a sentence on hover." } } }, diff --git a/editor/code/src/client.ts b/editor/code/src/client.ts index c600a556..d8dbf352 100644 --- a/editor/code/src/client.ts +++ b/editor/code/src/client.ts @@ -15,6 +15,7 @@ import { languages, Uri, TextEditorVisibleRangesChangeEvent, + InputBoxOptions, } from "vscode"; import * as vscode from "vscode"; @@ -54,6 +55,7 @@ import { FileProgressManager } from "./progress"; import { coqPerfData, PerfDataView } from "./perf"; import { sentenceNext, sentencePrevious } from "./edit"; import { HeatMap, HeatMapConfig } from "./heatmap"; +import { petanqueStart, petanqueRun, petSetClient } from "./petanque"; import { debounce, throttle } from "throttle-debounce"; // Convert perf data to VSCode format @@ -154,6 +156,7 @@ export function activateCoqLSP( ); context.subscriptions.push(disposable); } + function checkForVSCoq() { let vscoq = extensions.getExtension("maximedenes.vscoq") || @@ -216,6 +219,7 @@ export function activateCoqLSP( let cP = new Promise((resolve) => { client = clientFactory(context, clientOptions, wsConfig); + petSetClient(client); fileProgress = new FileProgressManager(client); perfDataHook = client.onNotification(coqPerfData, (data) => { perfDataView.update(data); @@ -460,7 +464,7 @@ export function activateCoqLSP( 0 ); lspStatusItem.command = "coq-lsp.toggle"; - lspStatusItem.text = "coq-lsp (activating)"; + lspStatusItem.text = "coq-lsp (not active)"; lspStatusItem.show(); context.subscriptions.push(lspStatusItem); }; @@ -519,9 +523,28 @@ export function activateCoqLSP( coqEditorCommand("heatmap.toggle", heatMapToggle); + coqEditorCommand("petanque.start", petanqueStart); + coqEditorCommand("petanque.run", petanqueRun); + createEnableButton(); - start(); + // Fix for bug #750 + const active_editors_for_us = (editors: readonly TextEditor[]) => + editors.some( + (editor) => languages.match(CoqSelector.all, editor.document) > 0 + ); + + // We track when new buffers appear, and start the client if so. We + // dispose of the hook too. + if (active_editors_for_us(window.visibleTextEditors)) { + start(); + } else { + window.onDidChangeVisibleTextEditors((editors) => { + if (!client || !client.isRunning()) { + if (active_editors_for_us(editors)) start(); + } + }, context.subscriptions); + } return { goalsRequest: (params) => { diff --git a/editor/code/src/config.ts b/editor/code/src/config.ts index 21f4821f..a55320fc 100644 --- a/editor/code/src/config.ts +++ b/editor/code/src/config.ts @@ -13,6 +13,7 @@ export interface CoqLspServerConfig { pp_type: 0 | 1 | 2; show_stats_on_hover: boolean; show_loc_info_on_hover: boolean; + show_universes_on_hover: boolean; check_only_on_request: boolean; send_perf_data: boolean; } @@ -35,6 +36,7 @@ export namespace CoqLspServerConfig { pp_type: wsConfig.pp_type, show_stats_on_hover: wsConfig.show_stats_on_hover, show_loc_info_on_hover: wsConfig.show_loc_info_on_hover, + show_universes_on_hover: wsConfig.show_universes_on_hover, check_only_on_request: wsConfig.check_only_on_request, send_perf_data: wsConfig.send_perf_data, }; diff --git a/editor/code/src/goals.ts b/editor/code/src/goals.ts index 7a085b1b..87aec4db 100644 --- a/editor/code/src/goals.ts +++ b/editor/code/src/goals.ts @@ -38,7 +38,12 @@ export class InfoPanel { constructor(extensionUri: Uri) { this.extensionUri = extensionUri; - this.panelFactory(); + + // We don't create the panel until we actually try to show + // something on it; this will fix the panel appearing when the + // extension is actived but actually chooses not to handle a file, cc #737 + + // this.panelFactory(); } dispose() { @@ -99,7 +104,11 @@ export class InfoPanel { this.panelFactory(); } else { if (!this.panel.visible) { - this.panel.reveal(2, true); + // Otherwise we create a race with the active editor! + // Careful about this. + if (window.activeTextEditor?.viewColumn !== 2) { + this.panel.reveal(2, true); + } } } } diff --git a/editor/code/src/petanque.ts b/editor/code/src/petanque.ts new file mode 100644 index 00000000..87d5b1a1 --- /dev/null +++ b/editor/code/src/petanque.ts @@ -0,0 +1,60 @@ +import { window, InputBoxOptions, TextEditor } from "vscode"; +import { BaseLanguageClient, RequestType } from "vscode-languageclient"; +import { PetRunParams, PetStartParams } from "../lib/types"; + +const petStartReq = new RequestType( + "petanque/start" +); +let client: BaseLanguageClient; + +export function petSetClient(newClient: BaseLanguageClient) { + client = newClient; +} + +export const petanqueStart = (editor: TextEditor) => { + let uri = editor.document.uri.toString(); + let pre_commands = null; + + // Imput theorem name + let inputOptions: InputBoxOptions = { + title: "Petanque Start", + prompt: "Name of the theorem to start a session ", + }; + window + .showInputBox(inputOptions) + .then((thm_user) => { + let thm = thm_user ?? "petanque_debug"; + let params: PetStartParams = { uri, pre_commands, thm }; + return Promise.resolve(params); + }) + .then((params: PetStartParams) => { + client + .sendRequest(petStartReq, params) + .then((id) => + window.setStatusBarMessage(`petanque/start succeed ${id}`, 5000) + ) + .catch((error) => { + let err_message = error.toString(); + console.log(`error in save: ${err_message}`); + window.showErrorMessage(err_message); + }); + }); +}; + +const petRunReq = new RequestType("petanque/run"); + +export const petanqueRun = (editor: TextEditor) => { + // XXX Read from user + let params: PetRunParams = { st: 1, tac: "idtac." }; + client + .sendRequest(petRunReq, params) + .then((answer: any) => { + let res = JSON.stringify(answer); + window.setStatusBarMessage(`petanque/run succeed ${res}`, 5000); + }) + .catch((error) => { + let err_message = error.toString(); + console.log(`error in save: ${err_message}`); + window.showErrorMessage(err_message); + }); +}; diff --git a/etc/doc/PROTOCOL.md b/etc/doc/PROTOCOL.md index 8da3b04c..e802371d 100644 --- a/etc/doc/PROTOCOL.md +++ b/etc/doc/PROTOCOL.md @@ -19,41 +19,41 @@ https://github.com/microsoft/language-server-protocol/issues/1414 If a feature doesn't appear here it usually means it is not planned in the short term: -| Method | Support | Notes | -|---------------------------------------|---------|------------------------------------------------------------| -| `initialize` | Partial | We don't obey the advertised client capabilities | -| `client/registerCapability` | No | Not planned ATM | -| `$/setTrace` | Yes | | -| `$/logTrace` | Yes | | -| `window/logMessage` | Yes | | -|---------------------------------------|---------|------------------------------------------------------------| -| `textDocument/didOpen` | Yes | We can't reuse Memo tables yet | -| `textDocument/didChange` | Yes | We only support `TextDocumentSyncKind.Full` for now | -| `textDocument/didClose` | Partial | We'd likely want to save a `.vo` file on close if possible | -| `textDocument/didSave` | Partial | Undergoing behavior refinement | -|---------------------------------------|---------|------------------------------------------------------------| -| `notebookDocument/didOpen` | No | Planned | -|---------------------------------------|---------|------------------------------------------------------------| -| `textDocument/declaration` | No | Planned, blocked on upstream issues | -| `textDocument/definition` | Partial | Working only locally on files for now | -| `textDocument/references` | No | Planned, blocked on upstream issues | -| `textDocument/hover` | Yes | Shows stats and type info of identifiers at point | -| `textDocument/codeLens` | No | | -| `textDocument/foldingRange` | No | | -| `textDocument/documentSymbol` | Yes | Sections and modules missing (#322) | -| `textDocument/semanticTokens` | No | Planned | -| `textDocument/inlineValue` | No | Planned | -| `textDocument/inlayHint` | No | Planned | -| `textDocument/completion` | Partial | Needs more work locally and upstream (#50) | -| `textDocument/publishDiagnostics` | Yes | | -| `textDocument/diagnostic` | No | Planned, issue #49 | -| `textDocument/codeAction` | No | Planned | -| `textDocument/selectionRange` | Partial | Selection for a point is its span; no parents | -|---------------------------------------|---------|------------------------------------------------------------| -| `workspace/workspaceFolders` | Yes | Each folder should have a `_CoqProject` file at the root. | -| `workspace/didChangeWorkspaceFolders` | Yes | | -| `workspace/didChangeConfiguration` | Yes (*) | We still do a client -> server push, instead of pull | -|---------------------------------------|---------|------------------------------------------------------------| +| Method | Support | Notes | +|---------------------------------------|---------|---------------------------------------------------------------| +| `initialize` | Partial | We don't obey the advertised client capabilities | +| `client/registerCapability` | No | Not planned ATM | +| `$/setTrace` | Yes | | +| `$/logTrace` | Yes | | +| `window/logMessage` | Yes | | +|---------------------------------------|---------|---------------------------------------------------------------| +| `textDocument/didOpen` | Yes | We can't reuse Memo tables yet | +| `textDocument/didChange` | Yes | We only support `TextDocumentSyncKind.Full` for now | +| `textDocument/didClose` | Partial | We'd likely want to save a `.vo` file on close if possible | +| `textDocument/didSave` | Partial | Undergoing behavior refinement | +|---------------------------------------|---------|---------------------------------------------------------------| +| `notebookDocument/didOpen` | No | Planned | +|---------------------------------------|---------|---------------------------------------------------------------| +| `textDocument/declaration` | No | Planned, blocked on upstream issues | +| `textDocument/definition` | Yes (*) | Uses .glob information which is often incomplete | +| `textDocument/references` | No | Planned, blocked on upstream issues | +| `textDocument/hover` | Yes | Shows stats and type info of identifiers at point, extensible | +| `textDocument/codeLens` | No | | +| `textDocument/foldingRange` | No | | +| `textDocument/documentSymbol` | Yes | Sections and modules missing (#322) | +| `textDocument/semanticTokens` | No | Planned | +| `textDocument/inlineValue` | No | Planned | +| `textDocument/inlayHint` | No | Planned | +| `textDocument/completion` | Partial | Needs more work locally and upstream (#50) | +| `textDocument/publishDiagnostics` | Yes | | +| `textDocument/diagnostic` | No | Planned, issue #49 | +| `textDocument/codeAction` | No | Planned | +| `textDocument/selectionRange` | Partial | Selection for a point is its span; no parents | +|---------------------------------------|---------|---------------------------------------------------------------| +| `workspace/workspaceFolders` | Yes | Each folder should have a `_CoqProject` file at the root. | +| `workspace/didChangeWorkspaceFolders` | Yes | | +| `workspace/didChangeConfiguration` | Yes (*) | We still do a client -> server push, instead of pull | +|---------------------------------------|---------|---------------------------------------------------------------| ### URIs accepted by coq-lsp diff --git a/examples/MetaCommands.v b/examples/MetaCommands.v index 8b54b52d..a352ed8c 100644 --- a/examples/MetaCommands.v +++ b/examples/MetaCommands.v @@ -34,5 +34,13 @@ About muu. About foo. About bar. +Lemma foo : True. + Lemma bar : False. + Abort All. + +Lemma foo : True. now auto. Qed. + +Print foo. + diff --git a/examples/Pff.v b/examples/Pff.v index e058003b..252b89f3 100644 --- a/examples/Pff.v +++ b/examples/Pff.v @@ -11,6 +11,8 @@ Require Export List. Require Export PeanoNat. Require Import Psatz. +Set Warnings "-deprecated". + (* Compatibility workaround, remove once requiring Coq >= 8.16 *) Module Import Compat. diff --git a/examples/petanque.v b/examples/petanque.v new file mode 100644 index 00000000..8616a823 --- /dev/null +++ b/examples/petanque.v @@ -0,0 +1,2 @@ +Theorem petanque_debug : True. +Proof. now auto. Qed. diff --git a/flake.lock b/flake.lock index b34b4eb6..4d6681c3 100644 --- a/flake.lock +++ b/flake.lock @@ -1,22 +1,5 @@ { "nodes": { - "coq-serapi": { - "flake": false, - "locked": { - "lastModified": 1711058787, - "narHash": "sha256-Gpl3HFyMRNLThJIARbjN9FgCcgMwMOVGj2IKDKtWGWg=", - "owner": "ejgallego", - "repo": "coq-serapi", - "rev": "bc3450a8dfdd86136ce5d9aac427548ba828d30f", - "type": "github" - }, - "original": { - "owner": "ejgallego", - "ref": "v8.18", - "repo": "coq-serapi", - "type": "github" - } - }, "flake-compat": { "flake": false, "locked": { @@ -155,7 +138,6 @@ }, "root": { "inputs": { - "coq-serapi": "coq-serapi", "flake-compat": "flake-compat", "flake-parts": "flake-parts", "napalm": "napalm", diff --git a/flake.nix b/flake.nix index 056ac7f4..6783a2d6 100644 --- a/flake.nix +++ b/flake.nix @@ -11,11 +11,6 @@ url = "github:edolstra/flake-compat"; flake = false; }; - - coq-serapi = { - url = "github:ejgallego/coq-serapi/v8.18"; - flake = false; - }; }; outputs = inputs @ { @@ -54,20 +49,26 @@ inherit (ocamlPackages) menhir; }; - propagatedBuildInputs = let - serapi = - (coqPackages.lib.overrideCoqDerivation { - defaultVersion = "8.18.0+0.18.0"; - } - coqPackages.serapi) - .overrideAttrs (_: { - src = inputs.coq-serapi; - }); - in - l.attrValues { - inherit serapi; - inherit (ocamlPackages) yojson cmdliner uri dune-build-info ppx_inline_test; - }; + propagatedBuildInputs = l.attrValues { + inherit + (ocamlPackages) + cmdliner + findlib + ppx_deriving + ppx_deriving_yojson + ppx_import + ppx_sexp_conv + ppx_hash + sexplib + yojson + zarith + uri + dune-build-info + ppx_inline_test + logs + lwt + ; + }; }; treefmt.config = { diff --git a/fleche/config.ml b/fleche/config.ml index 2ad0b302..27dc9090 100644 --- a/fleche/config.ml +++ b/fleche/config.ml @@ -39,6 +39,8 @@ type t = ; show_stats_on_hover : bool [@default false] (** Show stats on hover *) ; show_loc_info_on_hover : bool [@default false] (** Show loc info on hover *) + ; show_universes_on_hover : bool [@default false] + (** Show universe data on hover *) ; pp_json : bool [@default false] (** Whether to pretty print the protocol JSON on the wire *) ; send_perf_data : bool [@default true] @@ -71,6 +73,7 @@ let default = ; pp_type = 0 ; show_stats_on_hover = false ; show_loc_info_on_hover = false + ; show_universes_on_hover = false ; verbosity = 2 ; pp_json = false ; send_perf_data = true diff --git a/fleche/contents.ml b/fleche/contents.ml index bbd73b59..1f8c8492 100644 --- a/fleche/contents.ml +++ b/fleche/contents.ml @@ -113,10 +113,8 @@ module WaterProof = struct List.fold_left coq_block_to_span ("", start_point) code_blocks in (if waterproof_debug then - let msg = - "pos:\n" ^ String.concat "\n" code_pos ^ "\nContents:\n" ^ contents - in - Io.Log.trace "waterproof" msg); + let code_pos = String.concat "\n" code_pos in + Io.Log.trace "waterproof" "pos:\n%s\nContents:\n%s" code_pos contents); R.Ok contents let from_json json = diff --git a/fleche/doc.ml b/fleche/doc.ml index 8744f260..76d9c836 100644 --- a/fleche/doc.ml +++ b/fleche/doc.ml @@ -29,10 +29,10 @@ module Util = struct let print_stats () = (if !Config.v.mem_stats then let size = Memo.all_size () in - Io.Log.trace "stats" (string_of_int size)); + Io.Log.trace "stats" "%d" size); let stats = Stats.Global.dump () in - Io.Log.trace "cache" (Stats.Global.to_string stats); - Io.Log.trace "cache" (Memo.GlobalCacheStats.stats ()); + Io.Log.trace "cache" "%s" (Stats.Global.to_string stats); + Io.Log.trace "cache" "%s" (Memo.GlobalCacheStats.stats ()); (* this requires patches to Coq *) (* Io.Log.error "coq parsing" (CoqParsingStats.dump ()); *) (* CoqParsingStats.reset (); *) @@ -42,8 +42,7 @@ module Util = struct let safe_sub s pos len = if pos < 0 || len < 0 || pos > String.length s - len then ( let s = String.sub s 0 (Stdlib.min 20 String.(length s - 1)) in - Io.Log.trace "string_sub" - (Format.asprintf "error for pos: %d len: %d str: %s" pos len s); + Io.Log.trace "string_sub" "error for pos: %d len: %d str: %s" pos len s; None) else Some (String.sub s pos len) end @@ -51,15 +50,13 @@ end module DDebug = struct let parsed_sentence ~ast = let loc = Coq.Ast.loc ast |> Option.get in - let line = "[l: " ^ string_of_int (loc.Loc.line_nb - 1) ^ "] " in - Io.Log.trace "coq" - ("parsed sentence: " ^ line ^ Pp.string_of_ppcmds (Coq.Ast.print ast)) + let line = loc.Loc.line_nb - 1 in + Io.Log.trace "coq" "parsed sentence: [l: %d] | %a" line Pp.pp_with + (Coq.Ast.print ast) let resume (last_tok : Lang.Range.t) version = - Io.Log.trace "check" - Format.( - asprintf "resuming [v: %d], from: %d l: %d" version last_tok.end_.offset - last_tok.end_.line) + Io.Log.trace "check" "resuming [v: %d], from: %d l: %d" version + last_tok.end_.offset last_tok.end_.line end (* [node list] is a very crude form of a meta-data map "loc -> data" , where for @@ -156,10 +153,11 @@ module Diags : sig (** Build advanced diagnostic with AST analysis *) val error : - lines:string array - -> range:Lang.Range.t + err_range:Lang.Range.t -> msg:Pp.t - -> ast:Node.Ast.t + -> stm_range:Lang.Range.t (* range for the sentence *) + -> ?ast:Node.Ast.t + -> unit -> Lang.Diagnostic.t (** [of_messages drange msgs] process feedback messages, and convert some to @@ -176,11 +174,11 @@ end = struct Lang.Diagnostic.{ range; severity; message; data } (* ast-dependent error diagnostic generation *) - let extra_diagnostics_of_ast ~lines ast = - let stm_range = ast.Node.Ast.v |> Coq.Ast.loc |> Option.get in - let stm_range = Coq.Utils.to_range ~lines stm_range in + let extra_diagnostics_of_ast stm_range ast = let stm_range = Lang.Diagnostic.Data.SentenceRange stm_range in - match Coq.Ast.Require.extract ast.Node.Ast.v with + match + Option.bind ast (fun (ast : Node.Ast.t) -> Coq.Ast.Require.extract ast.v) + with | Some { Coq.Ast.Require.from; mods; _ } -> let refs = List.map fst mods in Some @@ -189,13 +187,14 @@ end = struct ] | _ -> Some [ stm_range ] - let extra_diagnostics_of_ast ~lines ast = - if !Config.v.send_diags_extra_data then extra_diagnostics_of_ast ~lines ast + let extra_diagnostics_of_ast stm_range ast = + if !Config.v.send_diags_extra_data then + extra_diagnostics_of_ast stm_range ast else None - let error ~lines ~range ~msg ~ast = - let data = extra_diagnostics_of_ast ~lines ast in - make ?data range Lang.Diagnostic.Severity.error msg + let error ~err_range ~msg ~stm_range ?ast () = + let data = extra_diagnostics_of_ast stm_range ast in + make ?data err_range Lang.Diagnostic.Severity.error msg let of_feed ~drange (range, severity, message) = let range = Option.default drange range in @@ -237,20 +236,17 @@ module Completion = struct | Yes of Lang.Range.t (** Location of the last token in the document *) | Stopped of Lang.Range.t (** Location of the last valid token *) | Failed of Lang.Range.t (** Critical failure, like an anomaly *) - | FailedPermanent of Lang.Range.t - (** Temporal Coq hack, avoids any computation *) let range = function - | Yes range | Stopped range | Failed range | FailedPermanent range -> range + | Yes range | Stopped range | Failed range -> range let to_string = function | Yes _ -> "fully checked" | Stopped _ -> "stopped" | Failed _ -> "failed" - | FailedPermanent _ -> "refused to create due to Coq parsing bug" let is_completed = function - | Yes _ | Failed _ | FailedPermanent _ -> true + | Yes _ | Failed _ -> true | _ -> false end @@ -292,7 +288,7 @@ type t = (* Flatten the list of document asts *) let asts doc = List.filter_map Node.ast doc.nodes -let diags doc = List.concat_map (fun node -> node.Node.diags) doc.nodes +let diags doc = List.concat_map Node.diags doc.nodes (* TOC handling *) let rec add_toc_info node toc { Lang.Ast.Info.name; children; _ } = @@ -353,13 +349,14 @@ let empty_doc ~uri ~contents ~version ~env ~root ~nodes ~completed = let completed = completed init_range in { uri; contents; toc; version; env; root; nodes; diags_dirty; completed } -let error_doc ~loc ~message ~uri ~contents ~version ~env ~completed = +let error_doc ~loc ~message ~uri ~contents ~version ~env = let feedback = [ (loc, Diags.err, Pp.str message) ] in let root = env.Env.init in let nodes = [] in + let completed range = Completion.Failed range in (empty_doc ~uri ~version ~contents ~env ~root ~nodes ~completed, feedback) -let conv_error_doc ~raw ~uri ~version ~env ~root ~completed err = +let conv_error_doc ~raw ~uri ~version ~env ~root err = let contents = Contents.make_raw ~raw in let lines = contents.lines in let err = @@ -369,6 +366,7 @@ let conv_error_doc ~raw ~uri ~version ~env ~root ~completed err = let stats = None in let global_stats = Stats.Global.dump () in let nodes = process_init_feedback ~lines ~stats ~global_stats root [ err ] in + let completed range = Completion.Failed range in empty_doc ~uri ~version ~env ~root ~nodes ~completed ~contents let create ~token ~env ~uri ~version ~contents = @@ -380,28 +378,10 @@ let create ~token ~env ~uri ~version ~contents = empty_doc ~uri ~contents ~version ~env ~root ~nodes ~completed) , stats ) -(** Create a permanently failed doc, to be removed when we drop 8.16 support *) -let handle_failed_permanent ~env ~uri ~version ~contents = - let completed range = Completion.FailedPermanent range in - let loc, message = (None, "Document Failed Permanently due to Coq bugs") in - let doc, feedback = - error_doc ~loc ~message ~uri ~contents ~version ~env ~completed - in - let stats = None in - let global_stats = Stats.Global.dump () in - let nodes = - let lines = contents.Contents.lines in - process_init_feedback ~lines ~stats ~global_stats env.Env.init feedback - @ doc.nodes - in - let diags_dirty = not (CList.is_empty nodes) in - { doc with nodes; diags_dirty } - (** Try to create a doc, if Coq execution fails, create a failed doc with the corresponding errors; for now we refine the contents step as to better setup the initial document. *) let handle_doc_creation_exec ~token ~env ~uri ~version ~contents = - let completed range = Completion.Failed range in let { Coq.Protect.E.r; feedback }, stats = create ~token ~env ~uri ~version ~contents in @@ -410,13 +390,13 @@ let handle_doc_creation_exec ~token ~env ~uri ~version ~contents = | Interrupted -> let message = "Document Creation Interrupted!" in let loc = None in - error_doc ~loc ~message ~uri ~version ~contents ~env ~completed + error_doc ~loc ~message ~uri ~version ~contents ~env | Completed (Error (User (loc, err_msg))) | Completed (Error (Anomaly (loc, err_msg))) -> let message = Format.asprintf "Doc.create, internal error: @[%a@]" Pp.pp_with err_msg in - error_doc ~loc ~message ~uri ~version ~contents ~env ~completed + error_doc ~loc ~message ~uri ~version ~contents ~env | Completed (Ok doc) -> (doc, []) in let state = doc.root in @@ -431,16 +411,15 @@ let handle_doc_creation_exec ~token ~env ~uri ~version ~contents = let diags_dirty = not (CList.is_empty nodes) in { doc with nodes; diags_dirty } -let handle_contents_creation ~env ~uri ~version ~raw ~completed f = +let handle_contents_creation ~env ~uri ~version ~raw f = match Contents.make ~uri ~raw with | Contents.R.Error err -> let root = env.Env.init in - conv_error_doc ~raw ~uri ~version ~env ~root ~completed err + conv_error_doc ~raw ~uri ~version ~env ~root err | Contents.R.Ok contents -> f ~env ~uri ~version ~contents let create ~token ~env ~uri ~version ~raw = - let completed range = Completion.Failed range in - handle_contents_creation ~env ~uri ~version ~raw ~completed + handle_contents_creation ~env ~uri ~version ~raw (handle_doc_creation_exec ~token) (* Used in bump, we should consolidate with create *) @@ -448,21 +427,14 @@ let recreate ~token ~doc ~version ~contents = let env, uri = (doc.env, doc.uri) in handle_doc_creation_exec ~token ~env ~uri ~version ~contents -let create_failed_permanent ~env ~uri ~version ~raw = - let completed range = Completion.FailedPermanent range in - handle_contents_creation ~env ~uri ~version ~raw ~completed - handle_failed_permanent - let recover_up_to_offset ~init_range doc offset = - Io.Log.trace "prefix" - (Format.asprintf "common prefix offset found at %d" offset); + Io.Log.trace "prefix" "common prefix offset found at %d" offset; let rec find acc_nodes acc_range nodes = match nodes with | [] -> (List.rev acc_nodes, acc_range) | n :: ns -> if Debug.scan then - Io.Log.trace "scan" - (Format.asprintf "consider node at %a" Lang.Range.pp n.Node.range); + Io.Log.trace "scan" "consider node at %a" Lang.Range.pp n.Node.range; if n.range.end_.offset >= offset then (List.rev acc_nodes, acc_range) else find (n :: acc_nodes) n.range ns in @@ -481,7 +453,7 @@ let compute_common_prefix ~init_range ~contents (prev : t) = let common_idx = match_or_stop 0 in let nodes, range = recover_up_to_offset ~init_range prev common_idx in let toc = rebuild_toc nodes in - Io.Log.trace "prefix" ("resuming from " ^ Lang.Range.to_string range); + Io.Log.trace "prefix" "resuming from %a" Lang.Range.pp range; let completed = Completion.Stopped range in (nodes, completed, toc) @@ -509,7 +481,6 @@ let bump_version ~token ~version ~(contents : Contents.t) doc = match doc.completed with (* We can do better, but we need to handle the case where the anomaly is when restoring / executing the first sentence *) - | FailedPermanent _ -> doc | Failed _ -> (* re-create the document on failed, as the env may have changed *) recreate ~token ~doc ~version ~contents @@ -519,8 +490,7 @@ let bump_version ~token ~version ~raw doc = let uri = doc.uri in match Contents.make ~uri ~raw with | Contents.R.Error e -> - let completed range = Completion.Failed range in - conv_error_doc ~raw ~uri ~version ~env:doc.env ~root:doc.root ~completed e + conv_error_doc ~raw ~uri ~version ~env:doc.env ~root:doc.root e | Contents.R.Ok contents -> bump_version ~token ~version ~contents doc let add_node ~node doc = @@ -616,8 +586,8 @@ end = struct let log_qed_recovery v = Coq.Protect.E.map ~f:(fun (st, range) -> let loc_msg = Option.cata Lang.Range.to_string "no loc" range in - Io.Log.trace "recovery" - ("success" ^ loc_msg ^ " " ^ Memo.Interp.input_info (st, v)); + Io.Log.trace "recovery" "success %s %s" loc_msg + (Memo.Interp.input_info (st, v)); st) (* Contents-based recovery heuristic, special 'Qed.' case when `Qed.` is part @@ -639,7 +609,7 @@ end = struct | Some ("Qed" as txt), _, _ | _, Some ("Defined" as txt), _ | _, _, Some ("Admitted" as txt) -> - Io.Log.trace "lex recovery" (txt ^ " detected"); + Io.Log.trace "lex recovery" "%s detected" txt; recovery_for_failed_qed ~token ~default:st nodes |> Coq.Protect.E.map ~f:fst | _, _, _ -> Coq.Protect.E.ok st @@ -656,7 +626,10 @@ end = struct -> Io.Log.trace "recovery" "bullet"; Coq.State.admit_goal ~token ~st - |> Coq.Protect.E.bind ~f:(fun st -> Coq.Interp.interp ~token ~st v) + |> Coq.Protect.E.bind ~f:(fun st -> + (* We skip the cache here, but likely we don't want to do that. *) + let intern = () in + Coq.Interp.interp ~token ~intern ~st v) | _ -> (* Fallback to qed special lex case *) lex_recovery_heuristic ~token last_tok contents nodes st @@ -681,7 +654,7 @@ let interp_and_info ~token ~st ~files ast = | Some ast -> Memo.Require.evalS ~token (st, files, ast) (* Support for meta-commands, a bit messy, but cool in itself *) -let search_node ~command ~doc = +let search_node ~command ~doc ~st = let nstats (node : Node.t option) = Option.cata (fun (node : Node.t) -> Option.default Memo.Stats.zero node.info.stats) @@ -710,6 +683,9 @@ let search_node ~command ~doc = let node = Option.default node node.prev in (Coq.Protect.E.ok node.state, nstats (Some node))) | ResetInitial -> (Coq.Protect.E.ok doc.root, nstats None) + | AbortAll -> + let st = Coq.State.drop_all_proofs ~st in + (Coq.Protect.E.ok st, nstats None) let interp_and_info ~token ~st ~files ~doc ast = match Coq.Ast.Meta.extract ast with @@ -719,7 +695,7 @@ let interp_and_info ~token ~st ~files ~doc ast = spending on error recovery and meta stuff, we should record that time actually at some point too. In this case, maybe we could recover the cache hit from the original node? *) - search_node ~command ~doc + search_node ~command ~doc ~st let interp_and_info ~token ~parsing_time ~st ~files ~doc ast = let res, stats = interp_and_info ~token ~st ~files ~doc ast in @@ -759,15 +735,19 @@ let parse_action ~token ~lines ~st last_tok doc_handle = (* We don't have a better alternative :(, usually missing error loc here means an anomaly, so we stop *) let err_range = last_tok in - let parse_diags = [ Diags.make err_range Diags.err msg ] in + let parse_diags = + [ Diags.error ~err_range ~msg ~stm_range:err_range () ] + in (EOF (Failed last_tok), parse_diags, feedback, time) | Error (User (Some err_range, msg)) -> - let parse_diags = [ Diags.make err_range Diags.err msg ] in Coq.Parsing.discard_to_dot doc_handle; let last_tok = Coq.Parsing.Parsable.loc doc_handle in let last_tok_range = Coq.Utils.to_range ~lines last_tok in let span_loc = Util.build_span start_loc last_tok in let span_range = Coq.Utils.to_range ~lines span_loc in + let parse_diags = + [ Diags.error ~err_range ~msg ~stm_range:span_range () ] + in (Skip (span_range, last_tok_range), parse_diags, feedback, time)) (* Result of node-building action *) @@ -809,7 +789,7 @@ let strategy_of_coq_err ~node ~state ~last_tok = function | Coq.Protect.Error.Anomaly _ -> Stop (Failed last_tok, node) | User _ -> Continue { state; last_tok; node } -let node_of_coq_result ~lines ~token ~doc ~range ~prev ~ast ~st ~parsing_diags +let node_of_coq_result ~token ~doc ~range ~prev ~ast ~st ~parsing_diags ~parsing_feedback ~feedback ~info last_tok res = match res with | Ok state -> @@ -821,7 +801,7 @@ let node_of_coq_result ~lines ~token ~doc ~range ~prev ~ast ~st ~parsing_diags | Error (Coq.Protect.Error.Anomaly (err_range, msg) as coq_err) | Error (User (err_range, msg) as coq_err) -> let err_range = Option.default range err_range in - let err_diags = [ Diags.error ~lines ~range:err_range ~msg ~ast ] in + let err_diags = [ Diags.error ~err_range ~msg ~stm_range:range ~ast () ] in let contents, nodes = (doc.contents, doc.nodes) in let context = Recovery_context.make ~contents ~last_tok ~nodes ~ast:ast.v () @@ -878,7 +858,7 @@ let document_action ~token ~st ~parsing_diags ~parsing_feedback ~parsing_time this point then, hence the new last valid token last_tok_new *) let last_tok_new = Coq.Parsing.Parsable.loc doc_handle in let last_tok_new = Coq.Utils.to_range ~lines last_tok_new in - node_of_coq_result ~lines ~token ~doc ~range:ast_range ~prev ~ast ~st + node_of_coq_result ~token ~doc ~range:ast_range ~prev ~ast ~st ~parsing_diags ~parsing_feedback ~feedback ~info last_tok_new res) module Target = struct @@ -897,14 +877,14 @@ let beyond_target (range : Lang.Range.t) target = | Target.End -> false | Position (cut_line, cut_col) -> Target.reached ~range (cut_line, cut_col) -let pr_target = function - | Target.End -> "end" - | Target.Position (l, c) -> Format.asprintf "{cutpoint l: %02d | c: %02d" l c +let pp_target fmt = function + | Target.End -> Format.fprintf fmt "end" + | Target.Position (l, c) -> + Format.fprintf fmt "{cutpoint l: %02d | c: %02d" l c let log_beyond_target last_tok target = - Io.Log.trace "beyond_target" - ("target reached " ^ Lang.Range.to_string last_tok); - Io.Log.trace "beyond_target" ("target is " ^ pr_target target) + Io.Log.trace "beyond_target" "target reached %a" Lang.Range.pp last_tok; + Io.Log.trace "beyond_target" "target is %a" pp_target target let max_errors_node ~state ~range ~prev = let msg = Pp.str "Maximum number of errors reached" in @@ -983,8 +963,7 @@ let process_and_parse ~io ~token ~target ~uri ~version doc last_tok doc_handle = (* Note that nodes and diags are in reversed order here *) (match doc.nodes with | [] -> () - | n :: _ -> - Io.Log.trace "resume" ("last node :" ^ Lang.Range.to_string n.range)); + | n :: _ -> Io.Log.trace "resume" "last node: %a" Lang.Range.pp n.range); let last_node = Util.hd_opt doc.nodes in let st, stats = Option.cata @@ -1003,17 +982,15 @@ let log_doc_completion (completed : Completion.t) = let timestamp = Unix.gettimeofday () in let range = Completion.range completed in let status = Completion.to_string completed in - Format.asprintf "done [%.2f]: document %s with pos %a" timestamp status + Io.Log.trace "check" "done [%.2f]: document %s with pos %a" timestamp status Lang.Range.pp range - |> Io.Log.trace "check" (* Rebuild a Coq loc from a range, this used to be done using [CLexer.after] but due to Fleche now being 100% based on unicode locations we implement our own *) let debug_loc_after line (r : Lang.Range.t) = if Debug.unicode then - Io.Log.trace "loc_after" - (Format.asprintf "str: '%s' | char: %d" line r.end_.character) + Io.Log.trace "loc_after" "str: '%s' | char: %d" line r.end_.character let loc_after ~lines ~uri (r : Lang.Range.t) = let line_nb_last = r.end_.line + 1 in @@ -1058,7 +1035,7 @@ let check ~io ~token ~target ~doc () = | Yes _ -> Io.Log.trace "check" "resuming, completed=yes, nothing to do"; doc - | FailedPermanent _ | Failed _ -> + | Failed _ -> Io.Log.trace "check" "can't resume, failed=yes, nothing to do"; doc | Stopped last_tok -> diff --git a/fleche/doc.mli b/fleche/doc.mli index 2d1d206c..f309d9bc 100644 --- a/fleche/doc.mli +++ b/fleche/doc.mli @@ -50,8 +50,6 @@ module Completion : sig | Yes of Lang.Range.t (** Location of the last token in the document *) | Stopped of Lang.Range.t (** Location of the last valid token *) | Failed of Lang.Range.t (** Critical failure, like an anomaly *) - | FailedPermanent of Lang.Range.t - (** Temporal Coq hack, avoids any computation *) val is_completed : t -> bool end @@ -139,7 +137,3 @@ val check : (** [save ~doc] will save [doc] .vo file. It will fail if proofs are open, or if the document completion status is not [Yes] *) val save : token:Coq.Limits.Token.t -> doc:t -> (unit, Loc.t) Coq.Protect.E.t - -(** This is internal, to workaround the Coq multiple-docs problem *) -val create_failed_permanent : - env:Env.t -> uri:Lang.LUri.File.t -> version:int -> raw:string -> t diff --git a/fleche/info.ml b/fleche/info.ml index 1cdd1253..f214bb63 100644 --- a/fleche/info.ml +++ b/fleche/info.ml @@ -37,8 +37,7 @@ module LineCol : Point with type t = int * int = struct | None -> String.length text - offset let rec to_offset cur lc (l, c) text = - Io.Log.trace "to_offset" - (Format.asprintf "cur: %d | lc: %d | l: %d c: %d" cur lc l c); + Io.Log.trace "to_offset" "cur: %d | lc: %d | l: %d c: %d" cur lc l c; if lc = l then cur + c else let ll = line_length cur text + 1 in @@ -50,9 +49,8 @@ module LineCol : Point with type t = int * int = struct let debug_in_range hdr line col line1 col1 line2 col2 = if debug_in_range then - Io.Log.trace hdr - (Format.asprintf "(%d, %d) in (%d,%d)-(%d,%d)" line col line1 col1 line2 - col2) + Io.Log.trace hdr "(%d, %d) in (%d,%d)-(%d,%d)" line col line1 col1 line2 + col2 let in_range ?range (line, col) = (* Coq starts at 1, lsp at 0 *) @@ -149,6 +147,14 @@ module O = Make (Offset) (* Related to goal request *) module Goals = struct + let get_goals_unit ~st = + let ppx _env _sigma _x = () in + Coq.State.lemmas ~st |> Option.map (Coq.Goals.reify ~ppx) + + let get_goals ~st = + let ppx env sigma x = (env, sigma, x) in + Coq.State.lemmas ~st |> Option.map (Coq.Goals.reify ~ppx) + let pr_goal ~token st = let ppx env sigma x = let { Coq.Protect.E.r; feedback } = diff --git a/fleche/info.mli b/fleche/info.mli index 53c55feb..b4998d97 100644 --- a/fleche/info.mli +++ b/fleche/info.mli @@ -52,6 +52,16 @@ module O : S with module P := Offset (** We move towards a more modular design here, for preprocessing *) module Goals : sig + val get_goals_unit : + st:Coq.State.t -> (unit Coq.Goals.Reified_goal.t, Pp.t) Coq.Goals.t option + + val get_goals : + st:Coq.State.t + -> ( (Environ.env * Evd.evar_map * EConstr.t) Coq.Goals.Reified_goal.t + , Pp.t ) + Coq.Goals.t + option + val goals : token:Coq.Limits.Token.t -> st:Coq.State.t diff --git a/fleche/io.ml b/fleche/io.ml index 1f376f2b..6b6a0fa0 100644 --- a/fleche/io.ml +++ b/fleche/io.ml @@ -1,13 +1,10 @@ module Level = struct - type t = int - - (* We follow LSP spec *) - let error = 1 - let warning = 2 - let info = 3 - let log = 4 - let debug = 5 - let to_int x = x + type t = + | Error + | Warning + | Info + | Log + | Debug end module CallBack = struct @@ -38,7 +35,12 @@ module CallBack = struct end module Log = struct - let trace d ?extra m = !CallBack.cb.trace d ?extra m + let trace_ d ?extra m = !CallBack.cb.trace d ?extra m + let trace d ?extra = Format.kasprintf (fun m -> trace_ d ?extra m) + + let trace_object hdr obj = + (* Fixme, use the extra parameter *) + trace hdr "[%s]: @[%a@]" hdr Yojson.Safe.(pretty_print ~std:false) obj let feedback feedback = if not (CList.is_empty feedback) then @@ -49,7 +51,8 @@ module Log = struct end module Report = struct - let message ~io ~lvl ~message = io.CallBack.message ~lvl ~message + let message_ ~io ~lvl ~message = io.CallBack.message ~lvl ~message + let msg ~io ~lvl = Format.kasprintf (fun m -> message_ ~io ~lvl ~message:m) let diagnostics ~io ~uri ~version d = io.CallBack.diagnostics ~uri ~version d let fileProgress ~io ~uri ~version d = diff --git a/fleche/io.mli b/fleche/io.mli index 822c3710..e5a9e1f2 100644 --- a/fleche/io.mli +++ b/fleche/io.mli @@ -1,14 +1,10 @@ module Level : sig - type t - - val error : t - val warning : t - val info : t - val log : t - val debug : t - - (** Convert to LSP numeric code *) - val to_int : t -> int + type t = + | Error + | Warning + | Info + | Log + | Debug end module CallBack : sig @@ -32,7 +28,14 @@ end module Log : sig (** Debug trace *) - val trace : string -> ?extra:string -> string -> unit + val trace : + string -> ?extra:string -> ('a, Format.formatter, unit) format -> 'a + + (** Raw LSP method *) + val trace_ : string -> ?extra:string -> string -> unit + + (** Log JSON object to server info log *) + val trace_object : string -> Yojson.Safe.t -> unit (** For unexpected feedback, remove eventually or just assert false? *) val feedback : Loc.t Coq.Message.t list -> unit @@ -40,7 +43,11 @@ end module Report : sig (** User-visible message *) - val message : io:CallBack.t -> lvl:Level.t -> message:string -> unit + val msg : + io:CallBack.t -> lvl:Level.t -> ('a, Format.formatter, unit) format -> 'a + + (** Raw LSP method *) + val message_ : io:CallBack.t -> lvl:Level.t -> message:string -> unit val diagnostics : io:CallBack.t diff --git a/fleche/memo.ml b/fleche/memo.ml index a288f8aa..92e18f1d 100644 --- a/fleche/memo.ml +++ b/fleche/memo.ml @@ -1,5 +1,35 @@ module CS = Stats +(* XXX: We are missing good error handling here! Fix submitted upstream. *) +module Intern = struct + let hc : (Names.DirPath.t, _) Hashtbl.t = Hashtbl.create 1000 + let _use_cache = true + + exception LocateError of (Names.DirPath.t * Loadpath.locate_error) + [@@warning "-38"] + + let reason = function + | Loadpath.LibUnmappedDir -> + "Logical path was not found (missing _CoqProject settings)" + | LibNotFound -> "Library wasn't found (no .vo in place?)" + + let () = + CErrors.register_handler (function + | LocateError (dp, error) -> + Some + Pp.( + str "Couldn't find .vo file for " + ++ Names.DirPath.print dp ++ str " : " + ++ str (reason error)) + | _ -> None) + + let intern = () + let clear () = Hashtbl.clear hc +end + +let intern = Intern.intern + +(* Regular memo tables *) module Stats = struct type t = { stats : Stats.t @@ -69,6 +99,8 @@ module MemoTable = struct (** sorted *) val all_freqs : unit -> int list + + val stats : 'a t -> Hashtbl.statistics end module Make (H : Hashtbl.HashedType) : S with type key = H.t = struct @@ -182,6 +214,9 @@ module type S = sig (** [freqs ()]: (sorted) histogram *) val all_freqs : unit -> int list + (** [stats ()]: hashtbl stats *) + val stats : unit -> Hashtbl.statistics + (** debug data for input *) val input_info : input -> string @@ -200,6 +235,7 @@ module SEval (E : EvalType) : let size () = Obj.reachable_words (Obj.magic cache) let input_info i = E.input_info i let all_freqs = HC.all_freqs + let stats () = HC.stats cache let clear () = HC.clear cache let in_cache i = @@ -245,6 +281,7 @@ module CEval (E : LocEvalType) = struct let size () = Obj.reachable_words (Obj.magic cache) let all_freqs = HC.all_freqs let input_info = E.input_info + let stats () = HC.stats cache let clear () = HC.clear cache let in_cache i = @@ -287,7 +324,7 @@ module VernacEval = struct type output = Coq.State.t - let eval ~token (st, stm) = Coq.Interp.interp ~token ~st stm + let eval ~token (st, stm) = Coq.Interp.interp ~token ~intern ~st stm end module Interp = CEval (VernacEval) @@ -316,7 +353,7 @@ module RequireEval = struct type output = Coq.State.t let eval ~token (st, files, stm) = - Coq.Interp.Require.interp ~token ~st files stm + Coq.Interp.Require.interp ~token ~intern ~st files stm end module Require = CEval (RequireEval) @@ -347,7 +384,7 @@ module InitEval = struct type output = Coq.State.t let eval ~token (root_state, workspace, uri) = - Coq.Init.doc_init ~token ~root_state ~workspace ~uri + Coq.Init.doc_init ~token ~intern ~root_state ~workspace ~uri let input_info (st, ws, file) = Format.asprintf "st %d | ws %d | file %s" (Hashtbl.hash st) diff --git a/fleche/memo.mli b/fleche/memo.mli index 205385c5..7c1a6960 100644 --- a/fleche/memo.mli +++ b/fleche/memo.mli @@ -9,6 +9,10 @@ module Stats : sig val zero : t end +module Intern : sig + val clear : unit -> unit +end + (** Flèche memo / cache tables, with some advanced features *) module type S = sig type input @@ -32,6 +36,9 @@ module type S = sig (** [freqs ()]: (sorted) histogram *) val all_freqs : unit -> int list + (** [stats ()]: hashtbl stats *) + val stats : unit -> Hashtbl.statistics + (** debug data for input *) val input_info : input -> string diff --git a/fleche/perf_analysis.ml b/fleche/perf_analysis.ml index bc82cfda..f9d8cc44 100644 --- a/fleche/perf_analysis.ml +++ b/fleche/perf_analysis.ml @@ -35,6 +35,7 @@ let node_time_compare (n1 : Doc.Node.t) (n2 : Doc.Node.t) = (* Old mode of sending only the 10 hotspots *) let hotspot = false +let debug_hashtbl = false let make (doc : Doc.t) = let n_stm = List.length doc.nodes in @@ -43,8 +44,15 @@ let make (doc : Doc.t) = if display_cache_size then Memo.all_size () |> float_of_int else 0.0 in let summary = - Format.asprintf "{ num sentences: %d@\n; stats: %s; cache: %a@\n}" n_stm - stats Stats.pp_words cache_size + Format.asprintf "{ num sentences: %d@\n; stats: %s; cache: %a@}" n_stm stats + Stats.pp_words cache_size + in + let summary = + if debug_hashtbl then + summary + ^ Format.asprintf "{memo max bucket: %d}" + (Memo.Interp.stats ()).max_bucket_length + else summary in let timings = if hotspot then List.stable_sort node_time_compare doc.nodes |> list_take 10 diff --git a/fleche/theory.ml b/fleche/theory.ml index 1c79e714..d4234974 100644 --- a/fleche/theory.ml +++ b/fleche/theory.ml @@ -40,15 +40,21 @@ module Handle = struct (match Hashtbl.find_opt doc_table uri with | None -> () | Some _ -> - Io.Log.trace "do_open" - ("file " - ^ Lang.LUri.File.to_string_uri uri - ^ " not properly closed by client")); + Io.Log.trace "do_open" "file %a not properly closed by client" + Lang.LUri.File.pp uri); Hashtbl.add doc_table uri { doc; cp_requests = Int.Set.empty; pt_requests = [] } let close ~uri = Hashtbl.remove doc_table uri - let find_opt ~uri = Hashtbl.find_opt doc_table uri + + let with_doc ~kind ~f ~uri ~default = + match Hashtbl.find_opt doc_table uri with + | None -> + Io.Log.trace kind "document %a not available" Lang.LUri.File.pp uri; + default () + | Some handle -> f handle handle.doc + + let _find_opt ~uri = Hashtbl.find_opt doc_table uri let _update_doc ~handle ~(doc : Doc.t) = Hashtbl.replace doc_table doc.uri { handle with doc } @@ -124,7 +130,7 @@ module Handle = struct in let handle = { handle with pt_requests = delayed } in (handle, pt_ids fullfilled) - | Failed _ | FailedPermanent _ -> (handle, Int.Set.empty) + | Failed _ -> (handle, Int.Set.empty) (* trigger pending incremental requests *) let update_doc_info ~handle ~(doc : Doc.t) = @@ -133,8 +139,6 @@ module Handle = struct requests end -let diags_of_doc doc = List.concat_map Doc.Node.diags doc.Doc.nodes - (* This is temporary for 0.1.9 and our ER project, we need to reify this to a general structure *) module Register : sig @@ -168,12 +172,16 @@ end = struct let callback : t list ref = ref [] let add fn = callback := fn :: !callback - let fire ~io ~token ~doc = List.iter (fun f -> f ~io ~token ~doc) !callback + + let fire ~io ~token ~doc = + (* TODO: Add a field to IO representing plugin context *) + let io = io in + List.iter (fun f -> f ~io ~token ~doc) !callback end end let send_diags ~io ~token:_ ~doc = - let diags = diags_of_doc doc in + let diags = Doc.diags doc in if List.length diags > 0 || !Config.v.send_diags then let uri, version = (doc.uri, doc.version) in Io.Report.diagnostics ~io ~uri ~version diags @@ -216,25 +224,53 @@ end = struct | None -> pend_try f tt | Some r -> Some r) - let hint : (int * int) option ref = ref None + let hint : (Lang.LUri.File.t * (int * int)) option ref = ref None - let get_check_target pt_requests = + let get_check_target ~(doc : Doc.t) pt_requests = let target_of_pt_handle (_, (l, c)) = Doc.Target.Position (l, c) in match Option.map target_of_pt_handle (List.nth_opt pt_requests 0) with | None -> - Option.map - (fun (l, c) -> - hint := None; - Doc.Target.Position (l, c)) - !hint + Option.bind !hint (fun (uri, (l, c)) -> + if Lang.LUri.File.equal uri doc.uri then + match doc.completed with + | Yes _ | Failed _ -> None + | Stopped range when Doc.Target.reached ~range (l, c) -> None + | Stopped _ -> Some (Doc.Target.Position (l, c)) + else None) | Some t -> Some t + let report_start ~io doc = + let uri = doc.Doc.uri in + let uri_short = Lang.LUri.File.to_string_file uri |> Filename.basename in + Io.Report.serverStatus ~io (ServerInfo.Status.Running uri_short) + + let report_idle ~io = + let mem = + Format.asprintf "%a" Stats.pp_words + (Gc.((quick_stat ()).heap_words) |> Float.of_int) + in + Io.Report.serverStatus ~io (ServerInfo.Status.Idle mem) + + let do_check ~io ~token ~handle ~doc target = + let () = report_start ~io doc in + let doc = Doc.check ~io ~token ~target ~doc () in + let () = report_idle ~io in + let requests = Handle.update_doc_info ~handle ~doc in + if Doc.Completion.is_completed doc.completed then ( + Register.Completed.fire ~io ~token ~doc; + pending := pend_pop !pending); + (requests, doc) + (* Notification handling; reply is optional / asynchronous *) let check ~io ~token ~uri = Io.Log.trace "process_queue" "resuming document checking"; - match Handle.find_opt ~uri with - | Some handle -> ( - let target = get_check_target handle.pt_requests in + let kind = "Check.check" in + let default () = + pending := pend_pop !pending; + None + in + let f (handle : Handle.t) doc = + let target = get_check_target ~doc handle.pt_requests in match target with (* If we are in lazy mode and we don't have any full document requests pending, we just deschedule *) @@ -244,29 +280,10 @@ end = struct pending := pend_pop !pending; None | (None | Some _) as tgt -> - let uri_short = - Lang.LUri.File.to_string_file uri |> Filename.basename - in let target = Option.default Doc.Target.End tgt in - Io.Report.serverStatus ~io (ServerInfo.Status.Running uri_short); - let doc = Doc.check ~io ~token ~target ~doc:handle.doc () in - let mem = - Format.asprintf "%a" Stats.pp_words - (Gc.((quick_stat ()).heap_words) |> Float.of_int) - in - Io.Report.serverStatus ~io (ServerInfo.Status.Idle mem); - let requests = Handle.update_doc_info ~handle ~doc in - if Doc.Completion.is_completed doc.completed then - Register.Completed.fire ~io ~token ~doc; - (* Remove from the queue *) - if Doc.Completion.is_completed doc.completed then - pending := pend_pop !pending; - Some (requests, doc)) - | None -> - pending := pend_pop !pending; - Io.Log.trace "Check.check" - ("file " ^ Lang.LUri.File.to_string_uri uri ^ " not available"); - None + Some (do_check ~io ~token ~handle ~doc target) + in + Handle.with_doc ~kind ~uri ~default ~f let maybe_check ~io ~token = pend_try (fun uri -> check ~io ~token ~uri) !pending @@ -278,9 +295,9 @@ end = struct let set_scheduler_hint ~uri ~point = if CList.is_empty !pending then - let () = hint := Some point in + let () = hint := Some (uri, point) in schedule ~uri (* if the hint is set we wanna override it *) - else if not (Option.is_empty !hint) then hint := Some point + else if not (Option.is_empty !hint) then hint := Some (uri, point) end let create ~io ~token ~env ~uri ~raw ~version = @@ -290,68 +307,31 @@ let create ~io ~token ~env ~uri ~raw ~version = Handle.create ~uri ~doc; Check.schedule ~uri -(* Set this to false for < 8.17, we could parse the version but not worth it. *) -let sane_coq_base_version = true - -let sane_coq_branch = - CString.string_contains ~where:Coq_config.version ~what:"+lsp" - -(* for testing in master, set this to true *) -let force_single_mode = false - -let sane_coq_version = - (sane_coq_base_version || sane_coq_branch) && not force_single_mode - -(* Can't wait for the day this goes away *) -let tainted = ref false - -let create ~io ~token ~env ~uri ~raw ~version = - if !tainted && not sane_coq_version then ( - (* Error due to Coq bug *) - let message = - "You have opened two or more Coq files simultaneously in the server\n\ - Unfortunately Coq's < 8.17 doesn't properly support that setup yet\n\ - You'll need to close all files but one, and restart the server.\n\n\ - Check coq-lsp webpage (Working with multiple files section) for\n\ - instructions on how to install a fixed branch for earlier Coq versions." - in - let lvl = Io.Level.error in - Io.Report.message ~io ~lvl ~message; - let doc = Doc.create_failed_permanent ~env ~uri ~raw ~version in - Handle.create ~uri ~doc; - Check.schedule ~uri) - else ( - tainted := true; - create ~io ~token ~env ~uri ~raw ~version) - let change ~io:_ ~token ~(doc : Doc.t) ~version ~raw = let uri = doc.uri in - Io.Log.trace "bump file" - (Lang.LUri.File.to_string_uri uri ^ " / version: " ^ string_of_int version); + Io.Log.trace "bump file" "%a / version: %d" Lang.LUri.File.pp uri version; let tb = Unix.gettimeofday () in - (* The discrepancy here will be solved once we remove the [Protect.*.t] types - from `doc.mli` *) let doc = Doc.bump_version ~token ~version ~raw doc in let diff = Unix.gettimeofday () -. tb in - Io.Log.trace "bump file took" (Format.asprintf "%f" diff); + Io.Log.trace "bump file" "took %f seconds" diff; (* Just in case for the future, we update the document before requesting it to be checked *) let invalid = Handle.update_doc_version ~doc in Check.schedule ~uri; invalid -let change ~io ~token ~uri ~version ~raw = - match Handle.find_opt ~uri with - | None -> - Io.Log.trace "DocHandle.find" - ("file " ^ Lang.LUri.File.to_string_uri uri ^ " not available"); +let change ~io ~token ~(doc : Doc.t) ~version ~raw = + if version > doc.version then change ~io ~token ~doc ~version ~raw + else + (* That's a weird case, get got changes without a version bump? Do nothing + for now *) Int.Set.empty - | Some { doc; _ } -> - if version > doc.version then change ~io ~token ~doc ~version ~raw - else - (* That's a weird case, get got changes without a version bump? Do nothing - for now *) - Int.Set.empty + +let change ~io ~token ~uri ~version ~raw = + let kind = "Theory.change" in + let default () = Int.Set.empty in + let f _ doc = change ~io ~token ~doc ~version ~raw in + Handle.with_doc ~kind ~f ~uri ~default let close ~uri = (* XXX: Our handling of the "queue" is not good, handle should take care of @@ -379,21 +359,11 @@ module Request = struct | Postpone | Cancel - let with_doc ~f ~uri = - match Handle.find_opt ~uri with - | None -> - Io.Log.trace "Request.add" - ("document " ^ Lang.LUri.File.to_string_uri uri ^ " not available"); - (* XXX Should be cancelled *) - Cancel - | Some { doc; _ } -> f doc - let request_in_range ~(doc : Doc.t) ~version (line, col) = let in_range = match doc.completed with | Yes _ -> true - | Failed range | FailedPermanent range | Stopped range -> - Doc.Target.reached ~range (line, col) + | Failed range | Stopped range -> Doc.Target.reached ~range (line, col) in let in_range = match version with @@ -405,9 +375,12 @@ module Request = struct (** Add a request to be served; returns [true] if request is added to the queue , [false] if the request can be already answered. *) let add { id; uri; postpone; request } = + let kind = "Request.add" in + let default () = Cancel in + (* should be Cancelled? *) match request with | FullDoc -> - with_doc ~uri ~f:(fun doc -> + Handle.with_doc ~kind ~default ~uri ~f:(fun _ doc -> match (Doc.Completion.is_completed doc.completed, postpone) with | true, _ -> Now doc | false, false -> Cancel @@ -416,7 +389,7 @@ module Request = struct Check.schedule ~uri; Postpone) | PosInDoc { point; version } -> - with_doc ~uri ~f:(fun doc -> + Handle.with_doc ~kind ~default ~uri ~f:(fun _ doc -> let in_range = request_in_range ~doc ~version point in match (in_range, postpone) with | true, _ -> Now doc diff --git a/lang/compat.ml b/lang/compat.ml new file mode 100644 index 00000000..8590464f --- /dev/null +++ b/lang/compat.ml @@ -0,0 +1,176 @@ +(* OCaml compat *) + +(* The following is copied from Ocaml's standard library Bytes and Uchar + modules. We use the public safe variant of various functions, so it should be + slower. + + TODO: when our minimum supported Ocaml version is >= 4.14 we shoud switch to + the standard library. *) +module Uchar_ = Uchar + +module OCaml4_14 = struct + module Uchar = struct + type utf_decode = int + + (* From Uchar.ml *) + let rep = 0xFFFD + let valid_bit = 27 + let decode_bits = 24 + let[@inline] utf_decode_is_valid d = d lsr valid_bit = 1 + let[@inline] utf_decode_length d = (d lsr decode_bits) land 0b111 + let[@inline] utf_decode_uchar d = Uchar.unsafe_of_int (d land 0xFFFFFF) + let[@inline] utf_decode n u = ((8 lor n) lsl decode_bits) lor Uchar.to_int u + let[@inline] utf_decode_invalid n = (n lsl decode_bits) lor rep + + let utf_8_byte_length u = + match Uchar.to_int u with + | u when u < 0 -> assert false + | u when u <= 0x007F -> 1 + | u when u <= 0x07FF -> 2 + | u when u <= 0xFFFF -> 3 + | u when u <= 0x10FFFF -> 4 + | _ -> assert false + + let utf_16_byte_length u = + match Uchar.to_int u with + | u when u < 0 -> assert false + | u when u <= 0xFFFF -> 2 + | u when u <= 0x10FFFF -> 4 + | _ -> assert false + end + + module String = struct + let[@inline] not_in_x80_to_xBF b = b lsr 6 <> 0b10 + let[@inline] not_in_xA0_to_xBF b = b lsr 5 <> 0b101 + let[@inline] not_in_x80_to_x9F b = b lsr 5 <> 0b100 + let[@inline] not_in_x90_to_xBF b = b < 0x90 || 0xBF < b + let[@inline] not_in_x80_to_x8F b = b lsr 4 <> 0x8 + let[@inline] utf_8_uchar_2 b0 b1 = ((b0 land 0x1F) lsl 6) lor (b1 land 0x3F) + + let[@inline] utf_8_uchar_3 b0 b1 b2 = + ((b0 land 0x0F) lsl 12) lor ((b1 land 0x3F) lsl 6) lor (b2 land 0x3F) + + let[@inline] utf_8_uchar_4 b0 b1 b2 b3 = + ((b0 land 0x07) lsl 18) + lor ((b1 land 0x3F) lsl 12) + lor ((b2 land 0x3F) lsl 6) + lor (b3 land 0x3F) + + let[@inline] dec_ret n u = Uchar.utf_decode n (Uchar_.unsafe_of_int u) + let dec_invalid = Uchar.utf_decode_invalid + + let get_utf_8_uchar s i = + let b = Bytes.unsafe_of_string s in + let b0 = Bytes.get_uint8 b i in + (* raises if [i] is not a valid index. *) + let get = Bytes.get_uint8 in + let max = Bytes.length b - 1 in + match Char.unsafe_chr b0 with + (* See The Unicode Standard, Table 3.7 *) + | '\x00' .. '\x7F' -> dec_ret 1 b0 + | '\xC2' .. '\xDF' -> + let i = i + 1 in + if i > max then dec_invalid 1 + else + let b1 = get b i in + if not_in_x80_to_xBF b1 then dec_invalid 1 + else dec_ret 2 (utf_8_uchar_2 b0 b1) + | '\xE0' -> + let i = i + 1 in + if i > max then dec_invalid 1 + else + let b1 = get b i in + if not_in_xA0_to_xBF b1 then dec_invalid 1 + else + let i = i + 1 in + if i > max then dec_invalid 2 + else + let b2 = get b i in + if not_in_x80_to_xBF b2 then dec_invalid 2 + else dec_ret 3 (utf_8_uchar_3 b0 b1 b2) + | '\xE1' .. '\xEC' | '\xEE' .. '\xEF' -> + let i = i + 1 in + if i > max then dec_invalid 1 + else + let b1 = get b i in + if not_in_x80_to_xBF b1 then dec_invalid 1 + else + let i = i + 1 in + if i > max then dec_invalid 2 + else + let b2 = get b i in + if not_in_x80_to_xBF b2 then dec_invalid 2 + else dec_ret 3 (utf_8_uchar_3 b0 b1 b2) + | '\xED' -> + let i = i + 1 in + if i > max then dec_invalid 1 + else + let b1 = get b i in + if not_in_x80_to_x9F b1 then dec_invalid 1 + else + let i = i + 1 in + if i > max then dec_invalid 2 + else + let b2 = get b i in + if not_in_x80_to_xBF b2 then dec_invalid 2 + else dec_ret 3 (utf_8_uchar_3 b0 b1 b2) + | '\xF0' -> + let i = i + 1 in + if i > max then dec_invalid 1 + else + let b1 = get b i in + if not_in_x90_to_xBF b1 then dec_invalid 1 + else + let i = i + 1 in + if i > max then dec_invalid 2 + else + let b2 = get b i in + if not_in_x80_to_xBF b2 then dec_invalid 2 + else + let i = i + 1 in + if i > max then dec_invalid 3 + else + let b3 = get b i in + if not_in_x80_to_xBF b3 then dec_invalid 3 + else dec_ret 4 (utf_8_uchar_4 b0 b1 b2 b3) + | '\xF1' .. '\xF3' -> + let i = i + 1 in + if i > max then dec_invalid 1 + else + let b1 = get b i in + if not_in_x80_to_xBF b1 then dec_invalid 1 + else + let i = i + 1 in + if i > max then dec_invalid 2 + else + let b2 = get b i in + if not_in_x80_to_xBF b2 then dec_invalid 2 + else + let i = i + 1 in + if i > max then dec_invalid 3 + else + let b3 = get b i in + if not_in_x80_to_xBF b3 then dec_invalid 3 + else dec_ret 4 (utf_8_uchar_4 b0 b1 b2 b3) + | '\xF4' -> + let i = i + 1 in + if i > max then dec_invalid 1 + else + let b1 = get b i in + if not_in_x80_to_x8F b1 then dec_invalid 1 + else + let i = i + 1 in + if i > max then dec_invalid 2 + else + let b2 = get b i in + if not_in_x80_to_xBF b2 then dec_invalid 2 + else + let i = i + 1 in + if i > max then dec_invalid 3 + else + let b3 = get b i in + if not_in_x80_to_xBF b3 then dec_invalid 3 + else dec_ret 4 (utf_8_uchar_4 b0 b1 b2 b3) + | _ -> dec_invalid 1 + end +end diff --git a/lang/compat.mli b/lang/compat.mli new file mode 100644 index 00000000..fe4f24a2 --- /dev/null +++ b/lang/compat.mli @@ -0,0 +1,16 @@ +module OCaml4_14 : sig + module Uchar : sig + type utf_decode + + val utf_decode_is_valid : utf_decode -> bool + val utf_decode_uchar : utf_decode -> Uchar.t + val utf_decode_length : utf_decode -> int + val utf_decode : int -> Uchar.t -> int + val utf_8_byte_length : Uchar.t -> int + val utf_16_byte_length : Uchar.t -> int + end + + module String : sig + val get_utf_8_uchar : string -> int -> Uchar.utf_decode + end +end diff --git a/lang/lUri.ml b/lang/lUri.ml index 7b83a12c..10355a79 100644 --- a/lang/lUri.ml +++ b/lang/lUri.ml @@ -24,4 +24,5 @@ module File = struct let hash = Hashtbl.hash let compare = Stdlib.compare let equal = Stdlib.( = ) + let pp fmt uri = Format.fprintf fmt "%a" Uri.pp uri.uri end diff --git a/lang/lUri.mli b/lang/lUri.mli index 710137dc..2b772921 100644 --- a/lang/lUri.mli +++ b/lang/lUri.mli @@ -36,4 +36,7 @@ module File : sig (** hash *) val hash : t -> int + + (** print *) + val pp : Format.formatter -> t -> unit end diff --git a/lang/utf.ml b/lang/utf.ml index a4e78049..a4f0ae61 100644 --- a/lang/utf.ml +++ b/lang/utf.ml @@ -112,121 +112,17 @@ let nth s n = nth_aux s 0 n (* end of camomille *) -(* We disabled auto-formatting in copied code *) -[@@@ocamlformat "disable=true"] - -(* The following is copied from Ocaml's standard library Bytes and Uchar - modules. We use the public safe variant of various functions, so it should be - slower. - - TODO: when our minimum supported Ocaml version is >= 4.14 we shoud switch to - the standard library. *) - -(* From Uchar.ml *) -let rep = 0xFFFD -let decode_bits = 24 -let[@inline] utf_decode n u = ((8 lor n) lsl decode_bits) lor (Uchar.to_int u) -let[@inline] utf_decode_invalid n = (n lsl decode_bits) lor rep -let[@inline] uchar_utf_decode_uchar d = Uchar.unsafe_of_int (d land 0xFFFFFF) - -let uchar_utf_16_byte_length u = match Uchar.to_int u with -| u when u < 0 -> assert false -| u when u <= 0xFFFF -> 2 -| u when u <= 0x10FFFF -> 4 -| _ -> assert false - -(* From bytes.ml *) -let[@inline] not_in_x80_to_xBF b = b lsr 6 <> 0b10 -let[@inline] not_in_xA0_to_xBF b = b lsr 5 <> 0b101 -let[@inline] not_in_x80_to_x9F b = b lsr 5 <> 0b100 -let[@inline] not_in_x90_to_xBF b = b < 0x90 || 0xBF < b -let[@inline] not_in_x80_to_x8F b = b lsr 4 <> 0x8 - -let[@inline] utf_8_uchar_2 b0 b1 = - ((b0 land 0x1F) lsl 6) lor - ((b1 land 0x3F)) - -let[@inline] utf_8_uchar_3 b0 b1 b2 = - ((b0 land 0x0F) lsl 12) lor - ((b1 land 0x3F) lsl 6) lor - ((b2 land 0x3F)) - -let[@inline] utf_8_uchar_4 b0 b1 b2 b3 = - ((b0 land 0x07) lsl 18) lor - ((b1 land 0x3F) lsl 12) lor - ((b2 land 0x3F) lsl 6) lor - ((b3 land 0x3F)) - -let[@inline] dec_ret n u = utf_decode n (Uchar.unsafe_of_int u) -let dec_invalid = utf_decode_invalid - -let string_get_utf_8_uchar s i = - let b = Bytes.unsafe_of_string s in - let b0 = Bytes.get_uint8 b i in (* raises if [i] is not a valid index. *) - let get = Bytes.get_uint8 in - let max = Bytes.length b - 1 in - match Char.unsafe_chr b0 with (* See The Unicode Standard, Table 3.7 *) - | '\x00' .. '\x7F' -> dec_ret 1 b0 - | '\xC2' .. '\xDF' -> - let i = i + 1 in if i > max then dec_invalid 1 else - let b1 = get b i in if not_in_x80_to_xBF b1 then dec_invalid 1 else - dec_ret 2 (utf_8_uchar_2 b0 b1) - | '\xE0' -> - let i = i + 1 in if i > max then dec_invalid 1 else - let b1 = get b i in if not_in_xA0_to_xBF b1 then dec_invalid 1 else - let i = i + 1 in if i > max then dec_invalid 2 else - let b2 = get b i in if not_in_x80_to_xBF b2 then dec_invalid 2 else - dec_ret 3 (utf_8_uchar_3 b0 b1 b2) - | '\xE1' .. '\xEC' | '\xEE' .. '\xEF' -> - let i = i + 1 in if i > max then dec_invalid 1 else - let b1 = get b i in if not_in_x80_to_xBF b1 then dec_invalid 1 else - let i = i + 1 in if i > max then dec_invalid 2 else - let b2 = get b i in if not_in_x80_to_xBF b2 then dec_invalid 2 else - dec_ret 3 (utf_8_uchar_3 b0 b1 b2) - | '\xED' -> - let i = i + 1 in if i > max then dec_invalid 1 else - let b1 = get b i in if not_in_x80_to_x9F b1 then dec_invalid 1 else - let i = i + 1 in if i > max then dec_invalid 2 else - let b2 = get b i in if not_in_x80_to_xBF b2 then dec_invalid 2 else - dec_ret 3 (utf_8_uchar_3 b0 b1 b2) - | '\xF0' -> - let i = i + 1 in if i > max then dec_invalid 1 else - let b1 = get b i in if not_in_x90_to_xBF b1 then dec_invalid 1 else - let i = i + 1 in if i > max then dec_invalid 2 else - let b2 = get b i in if not_in_x80_to_xBF b2 then dec_invalid 2 else - let i = i + 1 in if i > max then dec_invalid 3 else - let b3 = get b i in if not_in_x80_to_xBF b3 then dec_invalid 3 else - dec_ret 4 (utf_8_uchar_4 b0 b1 b2 b3) - | '\xF1' .. '\xF3' -> - let i = i + 1 in if i > max then dec_invalid 1 else - let b1 = get b i in if not_in_x80_to_xBF b1 then dec_invalid 1 else - let i = i + 1 in if i > max then dec_invalid 2 else - let b2 = get b i in if not_in_x80_to_xBF b2 then dec_invalid 2 else - let i = i + 1 in if i > max then dec_invalid 3 else - let b3 = get b i in if not_in_x80_to_xBF b3 then dec_invalid 3 else - dec_ret 4 (utf_8_uchar_4 b0 b1 b2 b3) - | '\xF4' -> - let i = i + 1 in if i > max then dec_invalid 1 else - let b1 = get b i in if not_in_x80_to_x8F b1 then dec_invalid 1 else - let i = i + 1 in if i > max then dec_invalid 2 else - let b2 = get b i in if not_in_x80_to_xBF b2 then dec_invalid 2 else - let i = i + 1 in if i > max then dec_invalid 3 else - let b3 = get b i in if not_in_x80_to_xBF b3 then dec_invalid 3 else - dec_ret 4 (utf_8_uchar_4 b0 b1 b2 b3) - | _ -> dec_invalid 1 - -(* End of copy from Stdlib *) -[@@@ocamlformat "disable=false"] - let length_utf16 line = let byte_idx = ref 0 in let utf16_len = ref 0 in let len = String.length line in while !byte_idx < len do - let ch = string_get_utf_8_uchar line !byte_idx in + let ch = Compat.OCaml4_14.String.get_utf_8_uchar line !byte_idx in let next_idx = next line !byte_idx in byte_idx := next_idx; - let l = uchar_utf_16_byte_length (uchar_utf_decode_uchar ch) / 2 in + let l = + Compat.OCaml4_14.Uchar.(utf_16_byte_length (utf_decode_uchar ch)) / 2 + in utf16_len := !utf16_len + l done; !utf16_len @@ -239,11 +135,11 @@ let utf8_offset_of_utf16_offset ~line ~(offset : utf16_index) = let len = String.length line in (try while !utf16_char_count < offset do - let ch = string_get_utf_8_uchar line !byte_idx in + let ch = Compat.OCaml4_14.String.get_utf_8_uchar line !byte_idx in let next_idx = next line !byte_idx in if next_idx >= len then raise Not_found else byte_idx := next_idx; let code_unit_count = - uchar_utf_16_byte_length (uchar_utf_decode_uchar ch) / 2 + Compat.OCaml4_14.Uchar.(utf_16_byte_length (utf_decode_uchar ch)) / 2 in utf16_char_count := !utf16_char_count + code_unit_count; () @@ -257,11 +153,11 @@ let utf16_offset_of_utf8_offset ~line ~(offset : utf8_index) = let len = String.length line in (try while !byte_idx < offset do - let ch = string_get_utf_8_uchar line !byte_idx in + let ch = Compat.OCaml4_14.String.get_utf_8_uchar line !byte_idx in let next_idx = next line !byte_idx in if next_idx > len then raise Not_found else byte_idx := next_idx; let code_unit_count = - uchar_utf_16_byte_length (uchar_utf_decode_uchar ch) / 2 + Compat.OCaml4_14.Uchar.(utf_16_byte_length (utf_decode_uchar ch)) / 2 in utf16_char_count := !utf16_char_count + code_unit_count; () @@ -281,11 +177,11 @@ let char_of_utf16_offset ~line ~(offset : utf16_index) = let len = String.length line in (try while !utf16_char_count < offset do - let ch = string_get_utf_8_uchar line !byte_idx in + let ch = Compat.OCaml4_14.String.get_utf_8_uchar line !byte_idx in let next_idx = next line !byte_idx in if next_idx >= len then raise Not_found else byte_idx := next_idx; let code_unit_count = - uchar_utf_16_byte_length (uchar_utf_decode_uchar ch) / 2 + Compat.OCaml4_14.Uchar.(utf_16_byte_length (utf_decode_uchar ch)) / 2 in utf16_char_count := !utf16_char_count + code_unit_count; count := !count + 1; @@ -298,8 +194,10 @@ let utf16_offset_of_char ~line ~(char : char) = let offset16 = ref 0 in let idx = ref 0 in for _ = 0 to char - 1 do - let ch = string_get_utf_8_uchar line !idx in - let byte_len = uchar_utf_16_byte_length (uchar_utf_decode_uchar ch) in + let ch = Compat.OCaml4_14.String.get_utf_8_uchar line !idx in + let byte_len = + Compat.OCaml4_14.Uchar.(utf_16_byte_length (utf_decode_uchar ch)) + in offset16 := !offset16 + (byte_len / 2); idx := next line !idx done; diff --git a/lang/utf.mli b/lang/utf.mli index 1bdce61a..48ac98ff 100644 --- a/lang/utf.mli +++ b/lang/utf.mli @@ -57,7 +57,7 @@ val length_utf16 : utf8_string -> utf16_index (******************************************************) (** Number of characters in the utf-8-encoded utf8_string. *) -val length : utf8_string -> char +(* val length : utf8_string -> char *) (** Converstion from char to UTF-8/16 *) diff --git a/lsp/core.ml b/lsp/core.ml index 8d8b6164..7284656c 100644 --- a/lsp/core.ml +++ b/lsp/core.ml @@ -124,6 +124,23 @@ module SelectionRange = struct [@@deriving yojson] end +(** Publish Diagnostics params *) +module PublishDiagnosticsParams = struct + type t = + { uri : JLang.LUri.File.t + ; version : int + ; diagnostics : JLang.Diagnostic.t list + } + [@@deriving to_yojson] +end + +let mk_diagnostics ~uri ~version diagnostics : Base.Notification.t = + let params = + PublishDiagnosticsParams.( + { uri; version; diagnostics } |> to_yojson |> Yojson.Safe.Util.to_assoc) + in + Base.Notification.make ~method_:"textDocument/publishDiagnostics" ~params () + (** Pull Diagnostics *) module DocumentDiagnosticParams = struct type t = diff --git a/lsp/core.mli b/lsp/core.mli index 7a6cdd8b..ae706ef8 100644 --- a/lsp/core.mli +++ b/lsp/core.mli @@ -123,6 +123,23 @@ module SelectionRange : sig [@@deriving yojson] end +(** Publish Diagnostics params *) +module PublishDiagnosticsParams : sig + type t = + { uri : JLang.LUri.File.t + ; version : int + ; diagnostics : JLang.Diagnostic.t list + } + [@@deriving to_yojson] +end + +(* create textDocument/publishDiagnostics notification *) +val mk_diagnostics : + uri:Lang.LUri.File.t + -> version:int + -> Lang.Diagnostic.t list + -> Base.Notification.t + (** Pull Diagnostics *) module DocumentDiagnosticParams : sig type t = diff --git a/lsp/io.ml b/lsp/io.ml index 020de655..5697ca03 100644 --- a/lsp/io.ml +++ b/lsp/io.ml @@ -54,6 +54,8 @@ let read_raw_message ic = | Invalid_argument msg -> Some (Error msg) let mut = Mutex.create () + +(* This needs a fix as to log protocol stuff not using the protocol *) let log = ref (fun _ _ -> ()) let send_json fmt obj = @@ -68,6 +70,8 @@ let send_json fmt obj = F.fprintf fmt "Content-Length: %d\r\n\r\n%s%!" size msg; Mutex.unlock mut +let send_message fmt message = send_json fmt (Base.Message.to_yojson message) + (** Logging *) module TraceValue = struct @@ -93,7 +97,7 @@ let set_trace_value value = trace_value := value module Lvl = struct (* 1-5 *) - type t = + type t = Fleche.Io.Level.t = | Error | Warning | Info @@ -108,49 +112,63 @@ module Lvl = struct | Debug -> 5 end -let logMessage ~lvl ~message = - let method_ = "window/logMessage" in - let lvl = Lvl.to_int lvl in - (* Replace with the json serializer in petanque protocol *) - let params = [ ("type", `Int lvl); ("message", `String message) ] in - let msg = Base.Notification.(make ~method_ ~params () |> to_yojson) in - !fn msg - -let logMessageInt ~lvl ~message = - let method_ = "window/logMessage" in - (* Replace with the json serializer in petanque protocol *) - let params = [ ("type", `Int lvl); ("message", `String message) ] in - let msg = Base.Notification.(make ~method_ ~params () |> to_yojson) in - !fn msg - -let logTrace ~message ~extra = - let method_ = "$/logTrace" in +module MessageParams = struct + let method_ = "window/logMessage" + + type t = + { type_ : int [@key "type"] + ; message : string + } + [@@deriving yojson] +end + +let mk_logMessage ~type_ ~message = + let module M = MessageParams in + let method_ = M.method_ in let params = - match (!trace_value, extra) with - | Verbose, Some extra -> - [ ("message", `String message); ("verbose", `String extra) ] - | _, _ -> [ ("message", `String message) ] + M.({ type_; message } |> to_yojson |> Yojson.Safe.Util.to_assoc) in - Base.Notification.(make ~method_ ~params () |> to_yojson) |> !fn + Base.Notification.make ~method_ ~params () -let trace hdr ?extra msg = - let message = Format.asprintf "[%s]: @[%s@]" hdr msg in - logTrace ~message ~extra +let logMessage ~lvl ~message = + let type_ = Lvl.to_int lvl in + mk_logMessage ~type_ ~message |> !fn -let trace_object hdr obj = - let message = - Format.asprintf "[%s]: @[%a@]" hdr Yojson.Safe.(pretty_print ~std:false) obj +let logMessageInt ~lvl ~message = mk_logMessage ~type_:lvl ~message |> !fn + +module TraceParams = struct + let method_ = "$/logTrace" + + type t = + { message : string + ; verbose : string option [@default None] + } + [@@deriving yojson] +end + +let mk_logTrace ~message ~extra = + let module M = TraceParams in + let method_ = M.method_ in + let verbose = + match (!trace_value, extra) with + | Verbose, Some extra -> Some extra + | _ -> None + in + let params = + M.({ message; verbose } |> to_yojson |> Yojson.Safe.Util.to_assoc) in - (* Fixme, use the extra parameter *) - trace hdr message + Base.Notification.make ~method_ ~params () + +let logTrace ~message ~extra = mk_logTrace ~message ~extra |> !fn -let () = log := trace_object +(* Disabled for now, see comment above *) +(* let () = log := trace_object *) (** Misc helpers *) let read_message ic = match read_raw_message ic with | None -> None (* EOF *) | Some (Ok com) -> - if Fleche.Debug.read then trace_object "read" com; + if Fleche.Debug.read then !log "read" com; Some (Base.Message.of_yojson com) | Some (Error err) -> Some (Error err) diff --git a/lsp/io.mli b/lsp/io.mli index 5d8d8856..e6f717de 100644 --- a/lsp/io.mli +++ b/lsp/io.mli @@ -17,17 +17,14 @@ (** JSON-RPC input/output *) -(** Set the log function *) -val set_log_fn : (Yojson.Safe.t -> unit) -> unit +(** Set the log output function *) +val set_log_fn : (Base.Notification.t -> unit) -> unit -(** Read a JSON-RPC message from channel *) -val read_raw_message : in_channel -> (Yojson.Safe.t, string) Result.t option - -(** [None] signals [EOF] *) +(** Read a JSON-RPC message from channel; [None] signals [EOF] *) val read_message : in_channel -> (Base.Message.t, string) Result.t option -(** Send a JSON-RPC request to channel *) -val send_json : Format.formatter -> Yojson.Safe.t -> unit +(** Send a JSON-RPC message to channel *) +val send_message : Format.formatter -> Base.Message.t -> unit (** Logging *) @@ -47,26 +44,47 @@ val set_trace_value : TraceValue.t -> unit module Lvl : sig (* 1-5 *) - type t = + type t = Fleche.Io.Level.t = | Error | Warning | Info | Log | Debug + + val to_int : t -> int +end + +module MessageParams : sig + val method_ : string + + type t = + { type_ : int [@key "type"] + ; message : string + } + [@@deriving yojson] end +(** Create a logMessage notification *) +val mk_logMessage : type_:int -> message:string -> Base.Notification.t + (** Send a [window/logMessage] notification to the client *) val logMessage : lvl:Lvl.t -> message:string -> unit (** Send a [window/logMessage] notification to the client *) val logMessageInt : lvl:int -> message:string -> unit -(** Send a [$/logTrace] notification to the client *) -val logTrace : message:string -> extra:string option -> unit +module TraceParams : sig + val method_ : string -(** [log hdr ?extra message] Log [message] to server info log with header [hdr]. - [extra] will be used when [trace_value] is set to [Verbose] *) -val trace : string -> ?extra:string -> string -> unit + type t = + { message : string + ; verbose : string option [@default None] + } + [@@deriving yojson] +end -(** Log JSON object to server info log *) -val trace_object : string -> Yojson.Safe.t -> unit +(** Create a logTrace notification *) +val mk_logTrace : message:string -> extra:string option -> Base.Notification.t + +(** Send a [$/logTrace] notification to the client *) +val logTrace : message:string -> extra:string option -> unit diff --git a/lsp/jCoq.ml b/lsp/jCoq.ml index 41fcf8e7..3497091a 100644 --- a/lsp/jCoq.ml +++ b/lsp/jCoq.ml @@ -32,11 +32,11 @@ module Pp = struct end module Goals = struct - type 'a hyp = [%import: 'a Coq.Goals.hyp] [@@deriving yojson] - type info = [%import: Coq.Goals.info] [@@deriving yojson] - - type 'a reified_goal = [%import: 'a Coq.Goals.reified_goal] - [@@deriving yojson] + module Reified_goal = struct + type 'a hyp = [%import: 'a Coq.Goals.Reified_goal.hyp] [@@deriving yojson] + type info = [%import: Coq.Goals.Reified_goal.info] [@@deriving yojson] + type 'a t = [%import: 'a Coq.Goals.Reified_goal.t] [@@deriving yojson] + end module Goals_ = struct type ('a, 'pp) t = @@ -55,15 +55,15 @@ module Goals = struct { Coq.Goals.goals; stack; bullet; shelf; given_up } end - type ('a, 'pp) goals = ('a, 'pp) Coq.Goals.goals + type ('a, 'pp) t = ('a, 'pp) Coq.Goals.t - let goals_to_yojson f pp g = Goals_.to_ g |> Goals_.to_yojson f pp + let to_yojson f pp g = Goals_.to_ g |> Goals_.to_yojson f pp - let goals_of_yojson f pp j = + let of_yojson f pp j = let open Ppx_deriving_yojson_runtime in Goals_.of_yojson f pp j >|= Goals_.of_ - type 'pp reified_pp = ('pp reified_goal, 'pp) goals [@@deriving yojson] + type 'pp reified_pp = ('pp Reified_goal.t, 'pp) t [@@deriving yojson] end module Ast = struct diff --git a/lsp/jLang.ml b/lsp/jLang.ml index 304b8c66..7df98eb9 100644 --- a/lsp/jLang.ml +++ b/lsp/jLang.ml @@ -88,14 +88,3 @@ module Diagnostic = struct let message = Pp.to_string message in _t_to_yojson { range; severity; message; data } end - -let mk_diagnostics ~uri ~version ld : Base.Notification.t = - let diags = List.map Diagnostic.to_yojson ld in - let uri = Lang.LUri.File.to_string_uri uri in - let params = - [ ("uri", `String uri) - ; ("version", `Int version) - ; ("diagnostics", `List diags) - ] - in - Base.Notification.make ~method_:"textDocument/publishDiagnostics" ~params () diff --git a/lsp/jLang.mli b/lsp/jLang.mli index 9772fea7..3aba7f17 100644 --- a/lsp/jLang.mli +++ b/lsp/jLang.mli @@ -38,9 +38,3 @@ module Diagnostic : sig [@@deriving yojson] end end - -val mk_diagnostics : - uri:Lang.LUri.File.t - -> version:int - -> Lang.Diagnostic.t list - -> Base.Notification.t diff --git a/petanque/README.md b/petanque/README.md index a7a85a6c..cdb47056 100644 --- a/petanque/README.md +++ b/petanque/README.md @@ -23,27 +23,50 @@ an OCaml API (`agent.mli`) which is then exposed via some form of RPC. ## Install instructions -Please see the regular `coq-lsp` install instructions. In general you -have three options: +Please see the regular `coq-lsp` install instructions for more details. -- use a released version from Opam -- use a development version directly from the tree -- install a development version using Opam +In general, you want to install `coq-lsp` first, the `pytanque`, the +Python companion. You have three options to install `coq-lsp`, in +order of easiness: -See the contributing guide for instructions on how to perform the last -two. +- use a released version from Opam: + +``` +$ opam install coq-lsp +``` + +- install a development version using Opam: + +``` +$ git clone ... coq-lsp && cd coq-lsp +$ opam install vendor/coq/coq{-core,-stdlib,ide-server,}.opam +$ opam install . +$ opam install coq-mathcomp-ssreflect # etc... +``` + +- use a development version directly from the tree (expert-mode) + +See the contributing guide for instructions on how to do the last. ## Running `petanque` JSON shell -You can use `petanque` in 2 different ways: +You can use `petanque` in 3 different ways: +- call the API using JSON-RPC directly in `coq-lsp`, over the LSP + protocol +- use the provided `pet` and `pet-server` JSON-RPC shells, usually + with a library such as Pytanque - call the API directly from your OCaml program -- use the provided `pet` JSON-RPC shell -to execute the `pet` JSON-RPC shell do: +See `agent.mli` for an overview of the API. The +`petanque/setWorkspace` method is only available in the `pet` and +`pet-server` shells; when `petanque` is used from LSP, the workspace +needs to be set using LSP in the usual way. + +To execute the `pet` JSON-RPC shell do: ``` make -dune exec -- rlwrap %{bin:pet} +dune exec -- rlwrap %{bin:pet} --http_headers=no ``` `rlwrap` is just a convenience, if your dune version is too old and @@ -61,25 +84,23 @@ NOTE: If you use this option, you should not call `Init`! ### A first example: -Please use one line per json input. json input examples are: +`pet` speaks JSON-RPC, and is usable interactively (tho not designed for it): ```json -["Init",{"debug": false,"root":"file:///home/egallego/research/coq-lsp/examples/"}] -["Init",["Ok",1]] - -["Start",{"env":1,"uri": "file:///home/egallego/research/coq-lsp/examples/ex0.v","thm":"addnC"}] -["Start",["Ok",1]] +{ method: "petanque/setWorkspace", id: 1, params: { debug: false, root: "file:///home/egallego/research/coq-lsp/examples" } } + > {"jsonrpc":"2.0","id":1,"result":null} -["Run_tac", {"st": 1, "tac": "induction n."}] -["Run_tac", ["Ok", 2]] +{ method: "petanque/start", id: 2, params: { uri: "file:///home/egallego/research/coq-lsp/examples/ex0.v", thm: "addnC" } } + > {"jsonrpc":"2.0","method":"$/logTrace","params":{"message":"[check] resuming [v: 0], from: 0 l: 0"}} + > ... + > {"jsonrpc":"2.0","id":2,"result":1} -["Run_tac", {"st": 2, "tac": "simpl."}] -["Run_tac", 3] +{ method: "petanque/run", id: 3, params: { "st": 1, "tac": "induction n."} } + > {"jsonrpc":"2.0","id":3,"result":["Current_state",2]} -["Run_tac", {"st": 3, "tac": "auto."}] -["Run_tac",4] +{ method: "petanque/goals", id: 4, params: { "st": 2 } } + > {"jsonrpc":"2.0","id":4,"result":{"goals":[{"info":{"evar":["Ser_Evar",51],"name":null},"hyps":[{"names":["m"],"def":null,"ty":"nat"}],"ty":"0 + m = m + 0"},{"info":{"evar":["Ser_Evar",55],"name":null},"hyps":[{"names":["n","m"],"def":null,"ty":"nat"},{"names":["IHn"],"def":null,"ty":"n + m = m + n"}],"ty":"S n + m = m + S n"}],"stack":[],"bullet":null,"shelf":[],"given_up":[]}} -["Premises", {"st": 2}] -["Premises", ...] +... ``` Seems to work! (TM) (Famous last words) diff --git a/petanque/agent.ml b/petanque/agent.ml index dcb846a8..25a11edd 100644 --- a/petanque/agent.ml +++ b/petanque/agent.ml @@ -11,11 +11,25 @@ module State = struct type t = Coq.State.t let hash = Coq.State.hash - let equal = Coq.State.equal -end - -module Env = struct - type t = Fleche.Doc.Env.t + let name = "state" + + module Inspect = struct + type t = + | Physical (** Flèche-based "almost physical" state eq *) + | Goals + (** Full goal equality; must faster than calling goals as it won't + unelaborate them. Note that this may not fully capture proof state + equality (it is possible to have similar goals but different + evar_maps, but should be enough for all practical users. *) + end + + let equal ?(kind = Inspect.Physical) = + match kind with + | Physical -> Coq.State.equal + | Goals -> + fun st1 st2 -> + let st1, st2 = (Coq.State.lemmas ~st:st1, Coq.State.lemmas ~st:st2) in + Option.equal Coq.Goals.Equality.equal_goals st1 st2 end (** Petanque errors *) @@ -25,6 +39,7 @@ module Error = struct | Parsing of string | Coq of string | Anomaly of string + | System of string | Theorem_not_found of string let to_string = function @@ -32,6 +47,7 @@ module Error = struct | Parsing msg -> Format.asprintf "Parsing: %s" msg | Coq msg -> Format.asprintf "Coq: %s" msg | Anomaly msg -> Format.asprintf "Anomaly: %s" msg + | System msg -> Format.asprintf "System: %s" msg | Theorem_not_found msg -> Format.asprintf "Theorem_not_found: %s" msg (* JSON-RPC server reserved codes *) @@ -40,66 +56,32 @@ module Error = struct | Parsing _ -> -32002 | Coq _ -> -32003 | Anomaly _ -> -32004 - | Theorem_not_found _ -> -32005 + | System _ -> -32005 + | Theorem_not_found _ -> -32006 + + let coq e = Coq e + let system e = System e end module R = struct type 'a t = ('a, Error.t) Result.t end +module Run_opts = struct + type t = + { memo : bool [@default true] + ; hash : bool [@default true] + } +end + module Run_result = struct type 'a t = - | Proof_finished of 'a - | Current_state of 'a + { st : 'a + ; hash : int option [@default None] + ; proof_finished : bool + } end -let init_coq ~debug = - let load_module = Dynlink.loadfile in - let load_plugin = Coq.Loader.plugin_handler None in - Coq.Init.(coq_init { debug; load_module; load_plugin }) - -let cmdline : Coq.Workspace.CmdLine.t = - { coqlib = Coq_config.coqlib - ; coqcorelib = Filename.concat Coq_config.coqlib "../coq-core" - ; ocamlpath = None - ; vo_load_path = [] - ; ml_include_path = [] - ; args = [] - ; require_libraries = [] - } - -let trace_stderr hdr ?extra:_ msg = - Format.eprintf "@[[trace] %s | %s @]@\n%!" hdr msg - -let trace_ref = ref trace_stderr - -let message_stderr ~lvl:_ ~message = - Format.eprintf "@[[message] %s @]@\n%!" message - -let message_ref = ref message_stderr - -let io = - let trace hdr ?extra msg = !trace_ref hdr ?extra msg in - let message ~lvl ~message = !message_ref ~lvl ~message in - let diagnostics ~uri:_ ~version:_ _diags = () in - let fileProgress ~uri:_ ~version:_ _pinfo = () in - let perfData ~uri:_ ~version:_ _perf = () in - let serverVersion _ = () in - let serverStatus _ = () in - { Fleche.Io.CallBack.trace - ; message - ; diagnostics - ; fileProgress - ; perfData - ; serverVersion - ; serverStatus - } - -let read_raw ~uri = - let file = Lang.LUri.File.to_string_file uri in - try Ok Coq.Compat.Ocaml_414.In_channel.(with_open_text file input_all) - with Sys_error err -> Error err - let find_thm ~(doc : Fleche.Doc.t) ~thm = let { Fleche.Doc.toc; _ } = doc in match CString.Map.find_opt thm toc with @@ -109,59 +91,34 @@ let find_thm ~(doc : Fleche.Doc.t) ~thm = | Some node -> if pet_debug then Format.eprintf "@[[find_thm] Theorem found!@\n@]%!"; (* let point = (range.start.line, range.start.character) in *) - Ok (Fleche.Doc.Node.state node) - -let pp_diag fmt { Lang.Diagnostic.message; _ } = - Format.fprintf fmt "%a" Pp.pp_with message - -let print_diags (doc : Fleche.Doc.t) = - let d = Fleche.Doc.diags doc in - Format.(eprintf "@[%a@]" (pp_print_list pp_diag) d) - -let init ~token ~debug ~root = - let init = init_coq ~debug in - Fleche.Io.CallBack.set io; - let dir = Lang.LUri.File.to_string_file root in - (let open Coq.Compat.Result.O in - let+ workspace = Coq.Workspace.guess ~token ~debug ~cmdline ~dir in - let files = Coq.Files.make () in - Fleche.Doc.Env.make ~init ~workspace ~files) - |> Result.map_error (fun msg -> Error.Coq msg) - -let start ~token ~env ~uri ~thm = - match read_raw ~uri with - | Ok raw -> - (* Format.eprintf "raw: @[%s@]%!" raw; *) - let doc = Fleche.Doc.create ~token ~env ~uri ~version:0 ~raw in - print_diags doc; - let target = Fleche.Doc.Target.End in - let doc = Fleche.Doc.check ~io ~token ~target ~doc () in - find_thm ~doc ~thm - | Error err -> - let msg = Format.asprintf "@[[read_raw] File not found %s@]" err in - Error (Error.Theorem_not_found msg) + Ok node let parse ~loc tac st = let str = Gramlib.Stream.of_string tac in let str = Coq.Parsing.Parsable.make ?loc str in Coq.Parsing.parse ~st str -let proof_finished { Coq.Goals.goals; stack; shelf; given_up; _ } = - List.for_all CList.is_empty [ goals; shelf; given_up ] && CList.is_empty stack +(* Adaptor, should be supported in memo directly *) +let eval_no_memo ~token (st, cmd) = Coq.Interp.interp ~token ~intern:() ~st cmd -let parse_and_execute_in ~token ~loc tac st = +let parse_and_execute_in ~token ~loc ~memo tac st = + (* To improve in memo *) + let eval = if memo then Fleche.Memo.Interp.eval else eval_no_memo in let open Coq.Protect.E.O in let* ast = parse ~token ~loc tac st in match ast with - | Some ast -> ( + | Some ast -> eval ~token (st, ast) + | None -> Coq.Protect.E.ok st + +let execute_precommands ~token ~memo ~pre_commands ~(node : Fleche.Doc.Node.t) = + match (pre_commands, node.prev, node.ast) with + | Some pre_commands, Some prev, Some ast -> + let st = prev.state in let open Coq.Protect.E.O in - let* st = Fleche.Memo.Interp.eval ~token (st, ast) in - let+ goals = Fleche.Info.Goals.goals ~token ~st in - match goals with - | None -> Run_result.Proof_finished st - | Some goals when proof_finished goals -> Run_result.Proof_finished st - | _ -> Run_result.Current_state st) - | None -> Coq.Protect.E.ok (Run_result.Current_state st) + let* st = parse_and_execute_in ~token ~memo ~loc:None pre_commands st in + (* We re-interpret the lemma statement *) + Fleche.Memo.Interp.eval ~token (st, ast.v) + | _, _, _ -> Coq.Protect.E.ok node.state let protect_to_result (r : _ Coq.Protect.E.t) : (_, _) Result.t = match r with @@ -172,30 +129,75 @@ let protect_to_result (r : _ Coq.Protect.E.t) : (_, _) Result.t = Error (Error.Anomaly (Pp.string_of_ppcmds msg)) | { r = Completed (Ok r); feedback = _ } -> Ok r -let run_tac ~token ~st ~tac : (_ Run_result.t, Error.t) Result.t = +let proof_finished { Coq.Goals.goals; stack; shelf; given_up; _ } = + List.for_all CList.is_empty [ goals; shelf; given_up ] && CList.is_empty stack + +let analyze_after_run ~hash st = + let proof_finished = + let goals = Fleche.Info.Goals.get_goals_unit ~st in + match goals with + | None -> true + | Some goals when proof_finished goals -> true + | _ -> false + in + let hash = if hash then Some (State.hash st) else None in + Run_result.{ st; hash; proof_finished } + +(* Would be nice to keep this in sync with the type annotations. *) +let default_opts = function + | None -> { Run_opts.memo = true; hash = true } + | Some opts -> opts + +(* XXX: EJGA, we should not need the [Coq.State.in_stateM] here and in run *) +let start ~token ~doc ?opts ?pre_commands ~thm () = + let open Coq.Compat.Result.O in + let* node = find_thm ~doc ~thm in + (* Usually single shot, so we don't memoize *) + let f () = + let opts = default_opts opts in + let memo, hash = (opts.memo, opts.hash) in + let open Coq.Protect.E.O in + let+ st = execute_precommands ~token ~memo ~pre_commands ~node in + analyze_after_run ~hash st + in + let st = node.state in + Coq.State.in_stateM ~token ~st ~f () |> protect_to_result + +let run ~token ?opts ~st ~tac () : (_ Run_result.t, Error.t) Result.t = + let opts = default_opts opts in (* Improve with thm? *) let loc = None in - Coq.State.in_stateM ~token ~st ~f:(parse_and_execute_in ~token ~loc tac) st - |> protect_to_result + let memo, hash = (opts.memo, opts.hash) in + let f st = + let open Coq.Protect.E.O in + let+ st = parse_and_execute_in ~token ~memo ~loc tac st in + analyze_after_run ~hash st + in + Coq.State.in_stateM ~token ~st ~f st |> protect_to_result let goals ~token ~st = let f goals = - let f = Coq.Goals.map_reified_goal ~f:Pp.string_of_ppcmds in + let f = Coq.Goals.Reified_goal.map ~f:Pp.string_of_ppcmds in let g = Pp.string_of_ppcmds in - Option.map (Coq.Goals.map_goals ~f ~g) goals + Option.map (Coq.Goals.map ~f ~g) goals in Coq.Protect.E.map ~f (Fleche.Info.Goals.goals ~token ~st) |> protect_to_result module Premise = struct + module Info = struct + type t = + { kind : string (* type of object *) + ; range : Lang.Range.t option (* a range *) + ; offset : int * int (* a offset in the file *) + ; raw_text : (string, string) Result.t (* raw text of the premise *) + } + end + type t = { full_name : string (* should be a Coq DirPath, but let's go step by step *) ; file : string (* file (in FS format) where the premise is found *) - ; kind : (string, string) Result.t (* type of object *) - ; range : (Lang.Range.t, string) Result.t (* a range if known *) - ; offset : (int * int, string) Result.t - (* a offset in the file if known (from .glob files) *) - ; raw_text : (string, string) Result.t (* raw text of the premise *) + ; info : (Info.t, string) Result.t (* Info about the object, if available *) } end @@ -237,26 +239,32 @@ end let info_of ~glob ~name = let open Coq.Compat.Result.O in let* g = Memo.open_file glob in - let+ { Coq.Glob.Info.kind; offset } = Coq.Glob.get_info g name in - (kind, offset) + Ok + (Option.map + (fun { Coq.Glob.Info.kind; offset } -> (kind, offset)) + (Coq.Glob.get_info g name)) let raw_of ~file ~offset = - match offset with - | Ok (bp, ep) -> - let open Coq.Compat.Result.O in - let* c = Memo.input_source file in - if String.length c < ep then Error "offset out of bounds" - else Ok (String.sub c bp (ep - bp + 1)) - | Error err -> Error ("offset information is not available: " ^ err) + let bp, ep = offset in + let open Coq.Compat.Result.O in + let* c = Memo.input_source file in + if String.length c < ep then Error "offset out of bounds" + else Ok (String.sub c bp (ep - bp + 1)) let to_premise (p : Coq.Library_file.Entry.t) : Premise.t = let { Coq.Library_file.Entry.name; typ = _; file } = p in let file = Filename.(remove_extension file ^ ".v") in let glob = Filename.(remove_extension file ^ ".glob") in - let range = Error "not implemented yet" in - let kind, offset = info_of ~glob ~name |> Coq.Compat.Result.split in - let raw_text = raw_of ~file ~offset in - { full_name = name; file; kind; range; offset; raw_text } + let info = + match info_of ~glob ~name with + | Ok None -> Error "not in glob table" + | Error err -> Error err + | Ok (Some (kind, offset)) -> + let range = None in + let raw_text = raw_of ~file ~offset in + Ok { Premise.Info.kind; range; offset; raw_text } + in + { Premise.full_name = name; file; info } let premises ~token ~st = (let open Coq.Protect.E.O in diff --git a/petanque/agent.mli b/petanque/agent.mli index 18a3152d..06395f46 100644 --- a/petanque/agent.mli +++ b/petanque/agent.mli @@ -10,13 +10,24 @@ module State : sig type t + val name : string + + (** Fleche-based Coq state hash; it has been designed for interactive use, so + please report back *) val hash : t -> int - val equal : t -> t -> bool -end -module Env : sig - (** Coq Workspaces / project enviroments *) - type t + module Inspect : sig + type t = + | Physical (** Flèche-based "almost physical" state eq *) + | Goals + (** Full goal equality; must faster than calling goals as it won't + unelaborate them. Note that this may not fully capture proof state + equality (it is possible to have similar goals but different + evar_maps, but should be enough for all practical users. *) + end + + (** [equal ?kind st1 st2] [kind] defaults to [Inspect.Physical] *) + val equal : ?kind:Inspect.t -> t -> t -> bool end (** Petanque errors *) @@ -26,10 +37,13 @@ module Error : sig | Parsing of string | Coq of string | Anomaly of string + | System of string | Theorem_not_found of string val to_string : t -> string val to_code : t -> int + val coq : string -> t + val system : string -> t end (** Petanque results *) @@ -37,39 +51,64 @@ module R : sig type 'a t = ('a, Error.t) Result.t end +module Run_opts : sig + type t = + { memo : bool [@default true] + ; hash : bool [@default true] + } +end + module Run_result : sig type 'a t = - | Proof_finished of 'a - | Current_state of 'a + { st : 'a + ; hash : int option [@default None] + ; proof_finished : bool + } end -(** I/O handling, by default, print to stderr *) +(** Protocol notes: + + The idea is that the types of the functions here have a direct translation + to the JSON-RPC (or any other) protocol. + + Thus, types here correspond to types in the wire, except for cases where the + protocol layer performs an implicit mapping on types. -(** [trace header extra message] *) -val trace_ref : (string -> ?extra:string -> string -> unit) ref + So far, the mappings are: -(** [message level message] *) -val message_ref : (lvl:Fleche.Io.Level.t -> message:string -> unit) ref + - [uri] <-> [Doc.t] + - [int] <-> [State.t] -(** [init ~debug ~root] Initializes Coq, with project and workspace settings - from [root]. [root] needs to be in URI format. This function needs to be - called _once_ before all others. *) -val init : - token:Coq.Limits.Token.t -> debug:bool -> root:Lang.LUri.File.t -> Env.t R.t + The [State.t] mapping is easy to do at the protocol level with a simple + mapping, however [uri -> Doc.t] may need to yield to the document manager to + build the corresponding [doc]. This is very convenient for users, but + introduces a little bit more machinery. -(** [start uri thm] start a new proof for theorem [thm] in file [uri]. *) + We could imagine a future where [State.t] need to be managed asynchronously, + then the same approach that we use for [Doc.t] could happen. *) + +(** [start ~token ~doc ~pre_commands ~thm] start a new proof for theorem [thm] + in file [uri] under [fn]. [token] can be used to interrupt the computation. + Returns the proof state or error otherwise. [pre_commands] is a string of + dot-separated Coq commands that will be executed before the proof starts. *) val start : token:Coq.Limits.Token.t - -> env:Env.t - -> uri:Lang.LUri.File.t + -> doc:Fleche.Doc.t + -> ?opts:Run_opts.t + -> ?pre_commands:string -> thm:string - -> State.t R.t + -> unit + -> State.t Run_result.t R.t -(** [run_tac ~token ~st ~tac] tries to run [tac] over state [st] *) -val run_tac : +(** [run ~token ?memo ~st ~tac] tries to run [tac] over state [st]. [memo] (by + default true) controls whether the command execution will be memoized in + Flèche incremental engine. *) +val run : token:Coq.Limits.Token.t + -> ?opts:Run_opts.t -> st:State.t -> tac:string + -> unit -> State.t Run_result.t R.t (** [goals ~token ~st] return the list of goals for a given [st] *) @@ -79,15 +118,21 @@ val goals : -> string Coq.Goals.reified_pp option R.t module Premise : sig + module Info : sig + (* (from .glob files) *) + type t = + { kind : string (* type of object *) + ; range : Lang.Range.t option (* a range *) + ; offset : int * int (* a offset in the file *) + ; raw_text : (string, string) Result.t (* raw text of the premise *) + } + end + type t = { full_name : string (* should be a Coq DirPath, but let's go step by step *) ; file : string (* file (in FS format) where the premise is found *) - ; kind : (string, string) Result.t (* type of object *) - ; range : (Lang.Range.t, string) Result.t (* a range if known *) - ; offset : (int * int, string) Result.t - (* a offset in the file if known (from .glob files) *) - ; raw_text : (string, string) Result.t (* raw text of the premise *) + ; info : (Info.t, string) Result.t (* Info about the object, if available *) } end diff --git a/petanque/json/dune b/petanque/json/dune new file mode 100644 index 00000000..540024e0 --- /dev/null +++ b/petanque/json/dune @@ -0,0 +1,6 @@ +(library + (name petanque_json) + (public_name coq-lsp.petanque.json) + (preprocess + (staged_pps ppx_import ppx_deriving_yojson)) + (libraries lsp petanque)) diff --git a/petanque/json/interp.ml b/petanque/json/interp.ml new file mode 100644 index 00000000..8570cd03 --- /dev/null +++ b/petanque/json/interp.ml @@ -0,0 +1,68 @@ +(************************************************************************) +(* Coq Petanque *) +(* Copyright 2019 MINES ParisTech -- Dual License LGPL 2.1 / GPL3+ *) +(* Copyright 2019-2024 Inria -- Dual License LGPL 2.1 / GPL3+ *) +(************************************************************************) + +open Protocol +module A = Petanque.Agent + +(* These types ares basically duplicated with controller/request.ml; move to a + common lib (lsp?) *) +type 'a r = ('a, int * string) Result.t + +module Action = struct + type t = + | Now of (token:Coq.Limits.Token.t -> Yojson.Safe.t r) + | Doc of + { uri : Lang.LUri.File.t + ; handler : + token:Coq.Limits.Token.t -> doc:Fleche.Doc.t -> Yojson.Safe.t r + } +end +(* End of controller/request.ml *) + +let of_pet_err res = + Result.map_error + (fun err -> + let message = Petanque.Agent.Error.to_string err in + let code = Petanque.Agent.Error.to_code err in + (code, message)) + res + +(* Basically a functor from R.Handler.t to Action.t, but closing over params *) +let do_request (module R : Protocol.Request.S) ~params = + let of_pet res = Result.map R.Handler.Response.to_yojson res |> of_pet_err in + let handler params = + match R.Handler.handler with + | Immediate handler -> + Action.Now (fun ~token -> handler ~token params |> of_pet) + | FullDoc { uri_fn; handler } -> + let uri = uri_fn params in + let handler ~token ~doc = handler ~token ~doc params |> of_pet in + Action.Doc { uri; handler } + in + match R.Handler.Params.of_yojson (`Assoc params) with + | Ok params -> handler params + | Error message -> + (* JSON-RPC Parse error *) + let code = -32700 in + Action.Now (fun ~token:_ -> Error (code, message)) + +type 'a handle = token:Coq.Limits.Token.t -> Action.t -> 'a + +let handle_request ~(do_handle : 'a handle) ~unhandled ~token ~method_ ~params = + match method_ with + | s when String.equal Start.method_ s -> + do_handle ~token (do_request (module Start) ~params) + | s when String.equal RunTac.method_ s -> + do_handle ~token (do_request (module RunTac) ~params) + | s when String.equal Goals.method_ s -> + do_handle ~token (do_request (module Goals) ~params) + | s when String.equal Premises.method_ s -> + do_handle ~token (do_request (module Premises) ~params) + | s when String.equal StateEqual.method_ s -> + do_handle ~token (do_request (module StateEqual) ~params) + | s when String.equal StateHash.method_ s -> + do_handle ~token (do_request (module StateHash) ~params) + | _ -> unhandled ~token ~method_ diff --git a/petanque/json/interp.mli b/petanque/json/interp.mli new file mode 100644 index 00000000..6137cf8d --- /dev/null +++ b/petanque/json/interp.mli @@ -0,0 +1,39 @@ +(************************************************************************) +(* Coq Petanque *) +(* Copyright 2019 MINES ParisTech -- Dual License LGPL 2.1 / GPL3+ *) +(* Copyright 2019-2024 Inria -- Dual License LGPL 2.1 / GPL3+ *) +(************************************************************************) + +(* API for embedding petanque into a different protocol, needs to be moved to a + core request library *) +type 'a r = ('a, int * string) Result.t + +module Action : sig + type t = + | Now of (token:Coq.Limits.Token.t -> Yojson.Safe.t r) + | Doc of + { uri : Lang.LUri.File.t + ; handler : + token:Coq.Limits.Token.t -> doc:Fleche.Doc.t -> Yojson.Safe.t r + } +end + +type 'a handle = token:Coq.Limits.Token.t -> Action.t -> 'a + +val handle_request : + do_handle:'a handle + -> unhandled:(token:Coq.Limits.Token.t -> method_:string -> 'a) + -> token:Coq.Limits.Token.t + -> method_:string + -> params:(string * Yojson.Safe.t) list + -> 'a + +(* aux function *) +val of_pet_err : + ('a, Petanque.Agent.Error.t) result -> ('a, int * string) Result.t + +(* Mostly Internal for pet-shell extensions; not for public consumption *) +val do_request : + (module Protocol.Request.S) + -> params:(string * Yojson.Safe.t) list + -> Action.t diff --git a/petanque/json_shell/jAgent.ml b/petanque/json/jAgent.ml similarity index 56% rename from petanque/json_shell/jAgent.ml rename to petanque/json/jAgent.ml index d69ecb82..9eb99c41 100644 --- a/petanque/json_shell/jAgent.ml +++ b/petanque/json/jAgent.ml @@ -2,10 +2,15 @@ (* Implement State.t and Env.t serialization methods *) module State = Obj_map.Make (Petanque.Agent.State) -module Env = Obj_map.Make (Petanque.Agent.Env) + +module Inspect = struct + type t = [%import: Petanque.Agent.State.Inspect.t] [@@deriving yojson] +end (* The typical protocol dance *) +(* What a mess result stuff is, we need this in case result is installed, as + then the types below will be referenced as plain result ... *) module Stdlib = struct module Result = struct include Stdlib.Result @@ -14,20 +19,31 @@ module Stdlib = struct end end -(* What a mess result stuff is, we need this in case result is installed, as - then the types below will be referenced as plain result ... *) module Result = Stdlib.Result +(* ppx_import < 1.10 hack, for some reason it gets confused with the aliases. *) +module Result_ = Stdlib.Result + module Error = struct type t = [%import: Petanque.Agent.Error.t] [@@deriving yojson] end +module Run_opts = struct + type t = [%import: Petanque.Agent.Run_opts.t] [@@deriving yojson] +end + module Run_result = struct type 'a t = [%import: 'a Petanque.Agent.Run_result.t] [@@deriving yojson] end module R = struct - type 'a t = [%import: 'a Petanque.Agent.R.t] [@@deriving yojson] + type 'a t = + [%import: + ('a Petanque.Agent.R.t + [@with + Stdlib.Result.t := Result_.t; + Result.t := Result_.t])] + [@@deriving yojson] end module Goals = struct @@ -41,5 +57,15 @@ module Lang = struct end module Premise = struct - type t = [%import: Petanque.Agent.Premise.t] [@@deriving yojson] + module Info = struct + type t = [%import: Petanque.Agent.Premise.Info.t] [@@deriving yojson] + end + + type t = + [%import: + (Petanque.Agent.Premise.t + [@with + Stdlib.Result.t := Result_.t; + Result.t := Result_.t])] + [@@deriving yojson] end diff --git a/petanque/json_shell/obj_map.ml b/petanque/json/obj_map.ml similarity index 70% rename from petanque/json_shell/obj_map.ml rename to petanque/json/obj_map.ml index 70f1707b..9680b72d 100644 --- a/petanque/json_shell/obj_map.ml +++ b/petanque/json/obj_map.ml @@ -1,4 +1,6 @@ module type Obj = sig + val name : string + type t (* Not yet *) (* val equal : t -> t -> bool *) @@ -32,12 +34,13 @@ module Make (O : Obj) : S with type t = O.t = struct let () = Memo.add memo id s in id - let to_obj (id : int) : O.t = - try Memo.find memo id - with Not_found -> - dump_memo (); - raise Not_found + let to_obj (id : int) : (O.t, _) Result.t = + match Memo.find_opt memo id with + | Some v -> Ok v + | None -> + if false then dump_memo (); + Error (Format.asprintf "key %d for object %s not found" id O.name) - let of_yojson json = _t_of_yojson json |> Result.map to_obj + let of_yojson json = _t_of_yojson json |> fun r -> Result.bind r to_obj let to_yojson st : Yojson.Safe.t = of_obj st |> _t_to_yojson end diff --git a/petanque/json_shell/protocol.ml b/petanque/json/protocol.ml similarity index 53% rename from petanque/json_shell/protocol.ml rename to petanque/json/protocol.ml index a3c0defb..0cd45c7c 100644 --- a/petanque/json_shell/protocol.ml +++ b/petanque/json/protocol.ml @@ -1,3 +1,4 @@ +open Lang open Petanque (* Serialization for agent types *) @@ -5,6 +6,15 @@ open JAgent (* RPC-side server mappings, internal; we could split this in a different module eventually as to make this clearer. *) +module HType = struct + type ('p, 'r) t = + | Immediate of (token:Coq.Limits.Token.t -> 'p -> 'r R.t) + | FullDoc of + { uri_fn : 'p -> LUri.File.t + ; handler : token:Coq.Limits.Token.t -> doc:Fleche.Doc.t -> 'p -> 'r R.t + } +end + module type Handler = sig (* Server-side RPC specification *) module Params : sig @@ -16,7 +26,7 @@ module type Handler = sig type t [@@deriving to_yojson] end - val handler : token:Coq.Limits.Token.t -> Params.t -> Response.t R.t + val handler : (Params.t, Response.t) HType.t end (* Note that here we follow JSON-RPC / LSP capitalization conventions *) @@ -38,66 +48,46 @@ module Request = struct end end -(* init RPC *) -module Init = struct - let method_ = "petanque/init" - - module Params = struct - type t = - { debug : bool - ; root : Lsp.JLang.LUri.File.t - } - [@@deriving yojson] - end - - module Response = struct - type t = int [@@deriving yojson] - end - - module Handler = struct - module Params = Params - - module Response = struct - type t = Env.t [@@deriving yojson] - end - - let handler ~token { Params.debug; root } = Agent.init ~token ~debug ~root - end -end - (* start RPC *) module Start = struct let method_ = "petanque/start" module Params = struct type t = - { env : int - ; uri : Lsp.JLang.LUri.File.t + { uri : Lsp.JLang.LUri.File.t + ; opts : Run_opts.t option [@default None] + ; pre_commands : string option [@default None] ; thm : string } [@@deriving yojson] end module Response = struct - type t = int [@@deriving yojson] + type t = int Run_result.t [@@deriving yojson] end module Handler = struct module Params = struct type t = - { env : Env.t - ; uri : Lsp.JLang.LUri.File.t + { uri : Lsp.JLang.LUri.File.t + ; opts : Run_opts.t option [@default None] + ; pre_commands : string option [@default None] ; thm : string } [@@deriving yojson] end module Response = struct - type t = State.t [@@deriving yojson] + type t = State.t Run_result.t [@@deriving yojson] end - let handler ~token { Params.env; uri; thm } = - Agent.start ~token ~env ~uri ~thm + let handler = + HType.FullDoc + { uri_fn = (fun { Params.uri; _ } -> uri) + ; handler = + (fun ~token ~doc { Params.uri = _; opts; pre_commands; thm } -> + Agent.start ~token ~doc ?opts ?pre_commands ~thm ()) + } end end @@ -107,7 +97,8 @@ module RunTac = struct module Params = struct type t = - { st : int + { opts : Run_opts.t option [@default None] + ; st : int ; tac : string } [@@deriving yojson] @@ -120,7 +111,9 @@ module RunTac = struct module Handler = struct module Params = struct type t = - { st : State.t + { opts : Run_opts.t option + [@default None] (* Whether to memoize the execution *) + ; st : State.t ; tac : string } [@@deriving yojson] @@ -130,7 +123,10 @@ module RunTac = struct type t = State.t Run_result.t [@@deriving yojson] end - let handler ~token { Params.st; tac } = Agent.run_tac ~token ~st ~tac + let handler = + HType.Immediate + (fun ~token { Params.opts; st; tac } -> + Agent.run ~token ?opts ~st ~tac ()) end end @@ -153,7 +149,8 @@ module Goals = struct module Response = Response - let handler ~token { Params.st } = Agent.goals ~token ~st + let handler = + HType.Immediate (fun ~token { Params.st } -> Agent.goals ~token ~st) end end @@ -176,45 +173,66 @@ module Premises = struct module Response = Response - let handler ~token { Params.st } = Agent.premises ~token ~st + let handler = + HType.Immediate (fun ~token { Params.st } -> Agent.premises ~token ~st) end end -(* Notifications don't get a reply *) -module Notification = struct - module type S = sig - val method_ : string - - module Params : sig - type t [@@deriving yojson] - end - end -end - -(* These two are identical from LSP *) - -(* Trace notification *) -module Trace = struct - let method_ = "$/logTrace" +(* StateEqual *) +module StateEqual = struct + let method_ = "petanque/state/eq" module Params = struct type t = - { message : string - ; verbose : string option [@default None] + { kind : Inspect.t option [@default None] + ; st1 : int + ; st2 : int } [@@deriving yojson] end + + module Response = struct + type t = bool [@@deriving yojson] + end + + module Handler = struct + module Params = struct + type t = + { kind : Inspect.t option + ; st1 : State.t + ; st2 : State.t + } + [@@deriving yojson] + end + + module Response = Response + + let handler = + HType.Immediate + (fun ~token:_ { Params.kind; st1; st2 } -> + Ok (Agent.State.equal ?kind st1 st2)) + end end -(* Message notification *) -module Message = struct - let method_ = "window/logMessage" +module StateHash = struct + let method_ = "petanque/state/hash" module Params = struct - type t = - { type_ : int [@key "type"] - ; message : string - } - [@@deriving yojson] + type t = { st : int } [@@deriving yojson] + end + + module Response = struct + type t = int [@@deriving yojson] + end + + module Handler = struct + module Params = struct + type t = { st : State.t } [@@deriving yojson] + end + + module Response = Response + + let handler = + HType.Immediate (fun ~token:_ { Params.st } -> Ok (Agent.State.hash st)) end end diff --git a/petanque/json_shell/client.ml b/petanque/json_shell/client.ml index 4535775d..7efd6394 100644 --- a/petanque/json_shell/client.ml +++ b/petanque/json_shell/client.ml @@ -1,3 +1,5 @@ +open Petanque_json + (* Client wrap *) module type Chans = sig val ic : in_channel @@ -13,12 +15,12 @@ let maybe_display_request method_ = if display_requests then Format.eprintf "received request: %s@\n%!" method_ let do_trace ~trace params = - match Protocol.Trace.Params.of_yojson (`Assoc params) with + match Lsp.Io.TraceParams.of_yojson (`Assoc params) with | Ok { message; verbose } -> trace ?verbose message | Error _ -> () let do_message ~message params = - match Protocol.Message.Params.of_yojson (`Assoc params) with + match Lsp.Io.MessageParams.of_yojson (`Assoc params) with | Ok { type_; message = msg } -> message ~lvl:type_ ~message:msg | Error _ -> () @@ -27,11 +29,11 @@ let rec read_response ~trace ~message ic = match Lsp.Io.read_message ic with | Some (Ok (Lsp.Base.Message.Response r)) -> Ok r | Some (Ok (Notification { method_; params })) - when String.equal method_ Protocol.Trace.method_ -> + when String.equal method_ Lsp.Io.TraceParams.method_ -> do_trace ~trace params; read_response ~trace ~message ic | Some (Ok (Notification { method_; params })) - when String.equal method_ Protocol.Message.method_ -> + when String.equal method_ Lsp.Io.MessageParams.method_ -> do_message ~message params; read_response ~trace ~message ic | Some (Ok (Request { method_; _ })) | Some (Ok (Notification { method_; _ })) @@ -57,10 +59,8 @@ end = struct let id = get_id () in let method_ = R.method_ in let params = Yojson.Safe.Util.to_assoc (R.Params.to_yojson params) in - let request = - Lsp.Base.Request.(make ~id ~method_ ~params () |> to_yojson) - in - let () = Lsp.Io.send_json C.oc request in + let request = Lsp.Base.Request.make ~id ~method_ ~params () in + let () = Lsp.Io.send_message C.oc (Lsp.Base.Message.Request request) in read_response ~trace ~message C.ic |> fun r -> Result.bind r (function | Ok { id = _; result } -> R.Response.of_yojson result @@ -68,23 +68,34 @@ end = struct end module S (C : Chans) = struct - let init = - let module M = Wrap (Protocol.Init) (C) in + open Protocol + open Protocol_shell + + let set_workspace = + let module M = Wrap (SetWorkspace) (C) in M.call let start = - let module M = Wrap (Protocol.Start) (C) in + let module M = Wrap (Start) (C) in M.call - let run_tac = - let module M = Wrap (Protocol.RunTac) (C) in + let run = + let module M = Wrap (RunTac) (C) in M.call let goals = - let module M = Wrap (Protocol.Goals) (C) in + let module M = Wrap (Goals) (C) in M.call let premises = - let module M = Wrap (Protocol.Premises) (C) in + let module M = Wrap (Premises) (C) in + M.call + + let state_equal = + let module M = Wrap (StateEqual) (C) in + M.call + + let state_hash = + let module M = Wrap (StateHash) (C) in M.call end diff --git a/petanque/json_shell/client.mli b/petanque/json_shell/client.mli index 83dcbefa..f3501a2d 100644 --- a/petanque/json_shell/client.mli +++ b/petanque/json_shell/client.mli @@ -1,3 +1,5 @@ +open Petanque_json + module type Chans = sig val ic : in_channel val oc : Format.formatter @@ -6,11 +8,19 @@ module type Chans = sig end open Protocol +open Protocol_shell module S (C : Chans) : sig - val init : Init.Params.t -> (Init.Response.t, string) result + val set_workspace : + SetWorkspace.Params.t -> (SetWorkspace.Response.t, string) result + val start : Start.Params.t -> (Start.Response.t, string) result - val run_tac : RunTac.Params.t -> (RunTac.Response.t, string) result + val run : RunTac.Params.t -> (RunTac.Response.t, string) result val goals : Goals.Params.t -> (Goals.Response.t, string) result val premises : Premises.Params.t -> (Premises.Response.t, string) result + + val state_equal : + StateEqual.Params.t -> (StateEqual.Response.t, string) result + + val state_hash : StateHash.Params.t -> (StateHash.Response.t, string) result end diff --git a/petanque/json_shell/dune b/petanque/json_shell/dune index bd19ff96..b0390ea9 100644 --- a/petanque/json_shell/dune +++ b/petanque/json_shell/dune @@ -1,20 +1,20 @@ (library - (name petanque_json) - (public_name coq-lsp.petanque.json) + (name petanque_shell) + (public_name coq-lsp.petanque.json_shell) (modules :standard \ pet server) (preprocess (staged_pps ppx_import ppx_deriving_yojson)) - (libraries cmdliner lsp petanque)) + (libraries lsp petanque petanque_json)) (executable (name pet) (public_name pet) (modules pet) - (libraries petanque_json)) + (libraries petanque_shell)) (executable (name server) (public_name pet-server) (modules server) (optional) - (libraries logs.lwt lwt.unix petanque_json)) + (libraries logs.lwt lwt.unix petanque_shell)) diff --git a/petanque/json_shell/interp.ml b/petanque/json_shell/interp.ml deleted file mode 100644 index 38735748..00000000 --- a/petanque/json_shell/interp.ml +++ /dev/null @@ -1,47 +0,0 @@ -open Protocol -module A = Petanque.Agent - -let do_request ~token (module R : Request.S) ~id ~params = - match R.Handler.Params.of_yojson (`Assoc params) with - | Ok params -> ( - match R.Handler.handler ~token params with - | Ok result -> - let result = R.Handler.Response.to_yojson result in - Lsp.Base.Response.mk_ok ~id ~result - | Error err -> - let message = A.Error.to_string err in - let code = A.Error.to_code err in - Lsp.Base.Response.mk_error ~id ~code ~message) - | Error message -> - (* JSON-RPC Parse error *) - let code = -32700 in - Lsp.Base.Response.mk_error ~id ~code ~message - -let handle_request ~token ~id ~method_ ~params = - match method_ with - | s when String.equal Init.method_ s -> - do_request ~token (module Init) ~id ~params - | s when String.equal Start.method_ s -> - do_request ~token (module Start) ~id ~params - | s when String.equal RunTac.method_ s -> - do_request ~token (module RunTac) ~id ~params - | s when String.equal Goals.method_ s -> - do_request ~token (module Goals) ~id ~params - | s when String.equal Premises.method_ s -> - do_request ~token (module Premises) ~id ~params - | _ -> - (* JSON-RPC method not found *) - let code = -32601 in - let message = "method not found" in - Lsp.Base.Response.mk_error ~id ~code ~message - -let interp ~token (r : Lsp.Base.Message.t) : Yojson.Safe.t option = - match r with - | Request { id; method_; params } -> - let response = handle_request ~token ~id ~method_ ~params in - let response = Lsp.Base.Response.to_yojson response in - Some response - | Notification { method_ = _; params = _ } -> None - | Response _ -> - (* XXX: to implement *) - None diff --git a/petanque/json_shell/interp_shell.ml b/petanque/json_shell/interp_shell.ml new file mode 100644 index 00000000..a50b5ce0 --- /dev/null +++ b/petanque/json_shell/interp_shell.ml @@ -0,0 +1,51 @@ +(************************************************************************) +(* Coq Petanque *) +(* Copyright 2019 MINES ParisTech -- Dual License LGPL 2.1 / GPL3+ *) +(* Copyright 2019-2024 Inria -- Dual License LGPL 2.1 / GPL3+ *) +(************************************************************************) + +open Petanque_json.Interp +open Protocol_shell + +let do_handle ~fn ~token action = + match action with + | Action.Now handler -> handler ~token + | Action.Doc { uri; handler } -> + let open Coq.Compat.Result.O in + let* doc = fn ~token ~uri |> of_pet_err in + handler ~token ~doc + +let request ~fn ~token ~id ~method_ ~params = + let unhandled ~token ~method_ = + match method_ with + | s when String.equal SetWorkspace.method_ s -> + do_handle ~fn ~token (do_request (module SetWorkspace) ~params) + | _ -> + (* JSON-RPC method not found *) + let code = -32601 in + let message = Format.asprintf "method %s not found" method_ in + Error (code, message) + in + let do_handle = do_handle ~fn in + match handle_request ~do_handle ~unhandled ~token ~method_ ~params with + | Ok result -> Lsp.Base.Response.mk_ok ~id ~result + | Error (code, message) -> Lsp.Base.Response.mk_error ~id ~code ~message + +type doc_handler = + token:Coq.Limits.Token.t + -> uri:Lang.LUri.File.t + -> (Fleche.Doc.t, Petanque.Agent.Error.t) Result.t + +let interp ~fn ~token (r : Lsp.Base.Message.t) : Lsp.Base.Message.t option = + match r with + | Request { id; method_; params } -> + let response = request ~fn ~token ~id ~method_ ~params in + Some (Lsp.Base.Message.response response) + | Notification { method_; params = _ } -> + let message = "unhandled notification: " ^ method_ in + let log = Lsp.Io.mk_logTrace ~message ~extra:None in + Some (Lsp.Base.Message.Notification log) + | Response (Ok { id; _ }) | Response (Error { id; _ }) -> + let message = "unhandled response: " ^ string_of_int id in + let log = Lsp.Io.mk_logTrace ~message ~extra:None in + Some (Lsp.Base.Message.Notification log) diff --git a/petanque/json_shell/interp_shell.mli b/petanque/json_shell/interp_shell.mli new file mode 100644 index 00000000..7439e308 --- /dev/null +++ b/petanque/json_shell/interp_shell.mli @@ -0,0 +1,17 @@ +(************************************************************************) +(* Coq Petanque *) +(* Copyright 2019 MINES ParisTech -- Dual License LGPL 2.1 / GPL3+ *) +(* Copyright 2019-2024 Inria -- Dual License LGPL 2.1 / GPL3+ *) +(************************************************************************) + +(* API for regular pet-server style shells *) +type doc_handler = + token:Coq.Limits.Token.t + -> uri:Lang.LUri.File.t + -> (Fleche.Doc.t, Petanque.Agent.Error.t) Result.t + +val interp : + fn:doc_handler + -> token:Coq.Limits.Token.t + -> Lsp.Base.Message.t + -> Lsp.Base.Message.t option diff --git a/petanque/json_shell/pet.ml b/petanque/json_shell/pet.ml index 2b390fe4..9d09a6b2 100644 --- a/petanque/json_shell/pet.ml +++ b/petanque/json_shell/pet.ml @@ -1,15 +1,42 @@ (* json rpc server *) -open Petanque_json +open Petanque_shell + +let use_http_headers = ref true + +let read_json inc = + match Yojson.Safe.from_channel inc with + | json -> Ok json + | exception Yojson.Json_error err -> Error err + +let read_message inc = + if !use_http_headers then Lsp.Io.read_message inc + else + try + match read_json inc with + | Error err -> Some (Error err) + | Ok json -> Some (Lsp.Base.Message.of_yojson json) + with End_of_file -> None + +let send_message msg = + if !use_http_headers then ( + Lsp.Io.send_message Format.std_formatter msg; + Format.pp_print_flush Format.std_formatter ()) + else + let msg = Lsp.Base.Message.to_yojson msg in + Format.fprintf Format.std_formatter "@[%s@]@\n%!" + (Yojson.Safe.to_string ?std:None msg) +(* Format.fprintf Format.std_formatter "@[%a@]@\n%!" Yojson.Safe.pretty_print + msg *) + +let fn = Shell.build_doc let interp ~token request = - match Interp.interp ~token request with + match Interp_shell.interp ~fn ~token request with | None -> () - | Some response -> - Lsp.Io.send_json Format.std_formatter response; - Format.pp_print_flush Format.std_formatter () + | Some message -> send_message message let rec loop ~token : unit = - match Lsp.Io.read_message stdin with + match read_message stdin with | None -> () (* EOF *) | Some (Ok request) -> interp ~token request; @@ -19,41 +46,43 @@ let rec loop ~token : unit = loop ~token let trace_notification hdr ?extra msg = - let module M = Protocol.Trace in - let method_ = M.method_ in let message = Format.asprintf "[%s] %s" hdr msg in - let params = { M.Params.message; verbose = extra } in - let params = M.Params.to_yojson params |> Yojson.Safe.Util.to_assoc in - let notification = - Lsp.Base.Notification.(make ~method_ ~params () |> to_yojson) - in - Lsp.Io.send_json Format.std_formatter notification + let notification = Lsp.Io.mk_logTrace ~message ~extra in + send_message (Lsp.Base.Message.Notification notification) let message_notification ~lvl ~message = - let module M = Protocol.Message in - let method_ = M.method_ in - let type_ = Fleche.Io.Level.to_int lvl in - let params = M.Params.({ type_; message } |> to_yojson) in - let params = Yojson.Safe.Util.to_assoc params in - let notification = - Lsp.Base.Notification.(make ~method_ ~params () |> to_yojson) - in - Lsp.Io.send_json Format.std_formatter notification + let type_ = Lsp.Io.Lvl.to_int lvl in + let notification = Lsp.Io.mk_logMessage ~type_ ~message in + send_message (Lsp.Base.Message.Notification notification) let trace_enabled = true -let pet_main debug roots = +let log_error err = + let message = Petanque.Agent.Error.to_string err in + message_notification ~lvl:Lsp.Io.Lvl.Error ~message + +let pet_main debug roots http_headers = Coq.Limits.start (); - (* Don't trace for now *) if trace_enabled then ( - Petanque.Agent.trace_ref := trace_notification; - Petanque.Agent.message_ref := message_notification); + Shell.trace_ref := trace_notification; + Shell.message_ref := message_notification); let token = Coq.Limits.Token.create () in - let () = Utils.set_roots ~token ~debug ~roots in + Result.iter_error log_error (Shell.init_agent ~token ~debug ~roots); + use_http_headers := http_headers; loop ~token open Cmdliner +let http_headers : bool Term.t = + let docv = "{yes|no}" in + let opts = [ ("yes", true); ("no", false) ] in + let absent = "yes" in + let doc = + "whether http-headers CONTENT-LENGHT are used in the JSON-RPC encoding" + in + Arg.( + value & opt (enum opts) true & info [ "http_headers" ] ~docv ~doc ~absent) + let pet_cmd : unit Cmd.t = let doc = "Petanque Coq Environment" in let man = @@ -65,7 +94,7 @@ let pet_cmd : unit Cmd.t = in let version = Fleche.Version.server in let pet_term = - Term.(const pet_main $ Coq.Args.debug $ Coq.Args.roots) + Term.(const pet_main $ Coq.Args.debug $ Coq.Args.roots $ http_headers) (* const pet_main $ roots $ display $ debug $ plugins $ file $ coqlib *) (* $ coqcorelib $ ocamlpath $ rload_path $ load_path $ rifrom) *) in diff --git a/petanque/json_shell/protocol_shell.ml b/petanque/json_shell/protocol_shell.ml new file mode 100644 index 00000000..442c0817 --- /dev/null +++ b/petanque/json_shell/protocol_shell.ml @@ -0,0 +1,31 @@ +open Petanque_json + +(* set_workspace RPC *) +module SetWorkspace = struct + let method_ = "petanque/setWorkspace" + + module Params = struct + type t = + { debug : bool + ; root : Lsp.JLang.LUri.File.t + } + [@@deriving yojson] + end + + module Response = struct + type t = unit [@@deriving yojson] + end + + module Handler = struct + module Params = Params + + module Response = struct + type t = unit [@@deriving yojson] + end + + let handler = + Protocol.HType.Immediate + (fun ~token { Params.debug; root } -> + Shell.set_workspace ~token ~debug ~root) + end +end diff --git a/petanque/json_shell/server.ml b/petanque/json_shell/server.ml index 1e536945..e59172fb 100644 --- a/petanque/json_shell/server.ml +++ b/petanque/json_shell/server.ml @@ -1,6 +1,6 @@ open Lwt open Lwt.Syntax -open Petanque_json +open Petanque_shell let rq_info (r : Lsp.Base.Message.t) = match r with @@ -9,6 +9,8 @@ let rq_info (r : Lsp.Base.Message.t) = | Response (Ok { id; _ } | Error { id; _ }) -> Format.asprintf "response for: %d" id +let fn = Shell.build_doc + let rec handle_connection ~token ic oc () = try let* request = Lwt_io.read_line ic in @@ -23,11 +25,14 @@ let rec handle_connection ~token ic oc () = let* () = Logs_lwt.info (fun m -> m "Received: %s" (rq_info request)) in (* request could be a notification, so maybe we don't have to do a reply! *) - match Interp.interp ~token request with + match Interp_shell.interp ~fn ~token request with | None -> handle_connection ~token ic oc () | Some reply -> let* () = Logs_lwt.info (fun m -> m "Sent reply") in - let* () = Lwt_io.fprintl oc (Yojson.Safe.to_string reply) in + let* () = + Lwt_io.fprintl oc + (Yojson.Safe.to_string (Lsp.Base.Message.to_yojson reply)) + in handle_connection ~token ic oc ()) with End_of_file -> return () @@ -56,6 +61,11 @@ let create_server ~token sock = in serve +let log_error err = + let message = Petanque.Agent.Error.to_string err in + Format.eprintf "Error in --root option: %s@\n%!" message +(* Logs_lwt.info (fun m -> m "%s" message) *) + let pet_main debug roots address port backlog = Coq.Limits.start (); let token = Coq.Limits.Token.create () in @@ -63,7 +73,10 @@ let pet_main debug roots address port backlog = let () = Logs.set_level (Some Logs.Info) in let sock = create_socket ~address ~port ~backlog in let serve = create_server ~token sock in - let () = Utils.set_roots ~token ~debug ~roots in + (* EJGA: pet-server should handle this at some point *) + (* Petanque.Shell.trace_ref := trace_notification; *) + (* Petanque.Shell.message_ref := message_notification); *) + Result.iter_error log_error (Shell.init_agent ~token ~debug ~roots); Lwt_main.run @@ serve () open Cmdliner diff --git a/petanque/json_shell/shell.ml b/petanque/json_shell/shell.ml new file mode 100644 index 00000000..ab69f5cf --- /dev/null +++ b/petanque/json_shell/shell.ml @@ -0,0 +1,104 @@ +let init_coq ~debug = + let load_module = Dynlink.loadfile in + let load_plugin = Coq.Loader.plugin_handler None in + Coq.Init.(coq_init { debug; load_module; load_plugin }) + +let cmdline : Coq.Workspace.CmdLine.t = + { coqlib = Coq_config.coqlib + ; coqcorelib = Filename.concat Coq_config.coqlib "../coq-core" + ; ocamlpath = None + ; vo_load_path = [] + ; ml_include_path = [] + ; args = [] + ; require_libraries = [] + } + +let setup_workspace ~token ~init ~debug ~root = + let dir = Lang.LUri.File.to_string_file root in + (let open Coq.Compat.Result.O in + let+ workspace = Coq.Workspace.guess ~token ~debug ~cmdline ~dir in + let files = Coq.Files.make () in + Fleche.Doc.Env.make ~init ~workspace ~files) + |> Result.map_error Petanque.Agent.Error.coq + +let trace_stderr hdr ?extra:_ msg = + Format.eprintf "@[[trace] %s | %s @]@\n%!" hdr msg + +let trace_ref = ref trace_stderr + +let message_stderr ~lvl:_ ~message = + Format.eprintf "@[[message] %s @]@\n%!" message + +let message_ref = ref message_stderr + +let io = + let trace hdr ?extra msg = !trace_ref hdr ?extra msg in + let message ~lvl ~message = !message_ref ~lvl ~message in + let diagnostics ~uri:_ ~version:_ _diags = () in + let fileProgress ~uri:_ ~version:_ _pinfo = () in + let perfData ~uri:_ ~version:_ _perf = () in + let serverVersion _ = () in + let serverStatus _ = () in + { Fleche.Io.CallBack.trace + ; message + ; diagnostics + ; fileProgress + ; perfData + ; serverVersion + ; serverStatus + } + +let init_st = ref None +let env = ref None + +let set_workspace ~token ~debug ~root = + let init = Option.get !init_st in + let open Coq.Compat.Result.O in + let+ env_ = setup_workspace ~token ~init ~debug ~root in + env := Some env_ + +(* likely duplicated somewhere else *) +let pp_diag fmt { Lang.Diagnostic.message; _ } = + Format.fprintf fmt "%a" Pp.pp_with message + +let print_diags (doc : Fleche.Doc.t) = + let d = Fleche.Doc.diags doc in + Format.(eprintf "@[%a@]" (pp_print_list pp_diag) d) + +let read_raw ~uri = + let file = Lang.LUri.File.to_string_file uri in + try Ok Coq.Compat.Ocaml_414.In_channel.(with_open_text file input_all) + with Sys_error err -> Error (Petanque.Agent.Error.system err) + +let setup_doc ~token env uri = + match read_raw ~uri with + | Ok raw -> + let doc = Fleche.Doc.create ~token ~env ~uri ~version:0 ~raw in + print_diags doc; + let target = Fleche.Doc.Target.End in + Ok (Fleche.Doc.check ~io ~token ~target ~doc ()) + | Error err -> Error err + +let build_doc ~token ~uri = setup_doc ~token (Option.get !env) uri + +(* Flèche LSP backend handles the conversion at the protocol level *) +let to_uri uri = + Lang.LUri.of_string uri |> Lang.LUri.File.of_uri + |> Result.map_error Petanque.Agent.Error.system + +let uri_of_path path = Format.asprintf "file:///%s" path |> to_uri + +let set_roots ~token ~debug ~roots = + let root = + match roots with + | [] -> Sys.getcwd () + | root :: _ -> root + in + let open Coq.Compat.Result.O in + let* root = uri_of_path root in + set_workspace ~token ~debug ~root + +let init_agent ~token ~debug ~roots = + init_st := Some (init_coq ~debug); + Fleche.Io.CallBack.set io; + set_roots ~token ~debug ~roots diff --git a/petanque/json_shell/shell.mli b/petanque/json_shell/shell.mli new file mode 100644 index 00000000..149fe514 --- /dev/null +++ b/petanque/json_shell/shell.mli @@ -0,0 +1,27 @@ +open Petanque + +(** I/O handling, by default, print to stderr *) + +(** [trace header extra message] *) +val trace_ref : (string -> ?extra:string -> string -> unit) ref + +(** [message level message] *) +val message_ref : (lvl:Fleche.Io.Level.t -> message:string -> unit) ref + +(** Start the shell, must be called only once. *) +val init_agent : + token:Coq.Limits.Token.t -> debug:bool -> roots:string list -> unit Agent.R.t + +(** [set_workspace ~root] Sets project and workspace settings from [root]. + [root] needs to be in URI format. If called repeteadly, overrides the + previous call. *) +val set_workspace : + token:Coq.Limits.Token.t + -> debug:bool + -> root:Lang.LUri.File.t + -> unit Agent.R.t + +val build_doc : + token:Coq.Limits.Token.t + -> uri:Lang.LUri.File.t + -> (Fleche.Doc.t, Agent.Error.t) Result.t diff --git a/petanque/json_shell/utils.ml b/petanque/json_shell/utils.ml deleted file mode 100644 index 84ebf089..00000000 --- a/petanque/json_shell/utils.ml +++ /dev/null @@ -1,17 +0,0 @@ -(* XXX: Flèche LSP backend already handles the conversion at the protocol - level *) -let uri_of_string_exn uri = - Lang.LUri.of_string uri |> Lang.LUri.File.of_uri |> Result.get_ok - -let set_roots ~token ~debug ~roots = - match roots with - | [] -> () - | [ root ] | root :: _ -> ( - let root = uri_of_string_exn root in - match Petanque.Agent.init ~token ~debug ~root with - | Ok env -> - (* hack until we fix the stuff *) - let _ : Yojson.Safe.t = JAgent.Env.to_yojson env in - () - | Error err -> - Format.eprintf "Error: %s@\n%!" (Petanque.Agent.Error.to_string err)) diff --git a/petanque/test/basic_api.ml b/petanque/test/basic_api.ml index 19219ada..a54eb6f2 100644 --- a/petanque/test/basic_api.ml +++ b/petanque/test/basic_api.ml @@ -1,4 +1,5 @@ open Petanque +open Petanque_shell let prepare_paths () = let to_uri file = @@ -18,30 +19,40 @@ let dump_msgs () = List.iter (Format.eprintf "%s@\n") (List.rev !msgs) let start ~token = let debug = false in - Petanque.Agent.trace_ref := trace; - Petanque.Agent.message_ref := message; + Shell.trace_ref := trace; + Shell.message_ref := message; (* Will this work on Windows? *) let open Coq.Compat.Result.O in + let _ : _ Result.t = Shell.init_agent ~token ~debug ~roots:[] in + (* Twice to test for #766 *) let root, uri = prepare_paths () in - let* env = Agent.init ~token ~debug ~root in - Agent.start ~token ~env ~uri ~thm:"rev_snoc_cons" + let* () = Shell.set_workspace ~token ~debug ~root in + let* () = Shell.set_workspace ~token ~debug ~root in + (* Careful to call [build_doc] before we have set an environment! [pet] and + [pet-server] are careful to always set a default one *) + let* doc = Shell.build_doc ~token ~uri in + Agent.start ~token ~doc ~thm:"rev_snoc_cons" () -let extract_st (st : _ Agent.Run_result.t) = - match st with - | Proof_finished st | Current_state st -> st +let extract_st { Agent.Run_result.st; _ } = st let main () = let open Coq.Compat.Result.O in let token = Coq.Limits.create_atomic () in let r ~st ~tac = let st = extract_st st in - Agent.run_tac ~token ~st ~tac + Agent.run ~token ~st ~tac () in - let* st = start ~token in + let* { st; _ } = start ~token in let* _premises = Agent.premises ~token ~st in - let* st = Agent.run_tac ~token ~st ~tac:"induction l." in + let* st = Agent.run ~token ~st ~tac:"induction l." () in + let h1 = Agent.State.hash st.st in + let* st = r ~st ~tac:"idtac." in + let h2 = Agent.State.hash st.st in + assert (Int.equal h1 h2); let* st = r ~st ~tac:"-" in let* st = r ~st ~tac:"reflexivity." in + let h3 = Agent.State.hash st.st in + assert (not (Int.equal h1 h3)); let* st = r ~st ~tac:"-" in let* st = r ~st ~tac:"now simpl; rewrite IHl." in let* st = r ~st ~tac:"Qed." in diff --git a/petanque/test/dune b/petanque/test/dune index fe4c7a8e..42a9d095 100644 --- a/petanque/test/dune +++ b/petanque/test/dune @@ -2,7 +2,7 @@ (name basic_api) (modules basic_api) (deps test.v) - (libraries petanque)) + (libraries petanque_shell)) (test (name json_api) @@ -10,7 +10,7 @@ (deps test.v %{bin:pet}) (enabled_if (<> %{os_type} "Win32")) - (libraries petanque petanque_json lsp)) + (libraries petanque petanque_shell lsp)) (test (name json_api_failure) @@ -18,4 +18,4 @@ (deps test.v %{bin:pet}) (enabled_if (<> %{os_type} "Win32")) - (libraries petanque petanque_json lsp)) + (libraries petanque petanque_shell lsp)) diff --git a/petanque/test/json_api.ml b/petanque/test/json_api.ml index a77c67cb..91052b71 100644 --- a/petanque/test/json_api.ml +++ b/petanque/test/json_api.ml @@ -1,4 +1,5 @@ open Petanque_json +open Petanque_shell let prepare_paths () = let to_uri file = @@ -12,30 +13,24 @@ let msgs = ref [] let trace ?verbose:_ msg = msgs := Format.asprintf "[trace] %s" msg :: !msgs let message ~lvl:_ ~message = msgs := message :: !msgs let dump_msgs () = List.iter (Format.eprintf "%s@\n") (List.rev !msgs) - -let extract_st (st : Protocol.RunTac.Response.t) = - match st with - | Proof_finished st | Current_state st -> st - +let extract_st { JAgent.Run_result.st; _ } = st let pp_offset fmt (bp, ep) = Format.fprintf fmt "(%d,%d)" bp ep let pp_res_str = Coq.Compat.Result.pp Format.pp_print_string Format.pp_print_string -let pp_premise fmt - { Petanque.Agent.Premise.full_name - ; kind - ; file - ; range = _ - ; offset - ; raw_text - } = +let pp_info fmt info = + let { Petanque.Agent.Premise.Info.kind; range = _; offset; raw_text } = + info + in + Format.fprintf fmt "kind = %s;@ offset = %a;@ raw_text = %a" kind pp_offset + offset pp_res_str raw_text + +let pp_premise fmt { Petanque.Agent.Premise.full_name; file; info } = Format.( - fprintf fmt - "@[{ name = %s;@ file = %s;@ kind = %a;@ offset = %a;@ raw_text = %a}@]@\n" - full_name file pp_res_str kind - (Coq.Compat.Result.pp pp_offset pp_print_string) - offset pp_res_str raw_text) + fprintf fmt "@[{ name = %s;@ file = %s;@ %a}@]@\n" full_name file + (Coq.Compat.Result.pp pp_info pp_print_string) + info) let print_premises = false @@ -49,19 +44,28 @@ let run (ic, oc) = let message = message end) in let r ~st ~tac = + let opts = None in let st = extract_st st in - S.run_tac { st; tac } + S.run { opts; st; tac } in (* Will this work on Windows? *) let root, uri = prepare_paths () in - let* env = S.init { debug; root } in - let* st = S.start { env; uri; thm = "rev_snoc_cons" } in + let* () = S.set_workspace { debug; root } in + let* { st; _ } = + S.start { uri; opts = None; pre_commands = None; thm = "rev_snoc_cons" } + in let* premises = S.premises { st } in (if print_premises then Format.(eprintf "@[%a@]@\n%!" (pp_print_list pp_premise) premises)); - let* st = S.run_tac { st; tac = "induction l." } in + let* st = S.run { opts = None; st; tac = "induction l." } in + let* h1 = S.state_hash { st = st.st } in + let* st = r ~st ~tac:"idtac." in + let* h2 = S.state_hash { st = st.st } in + assert (Int.equal h1 h2); let* st = r ~st ~tac:"-" in let* st = r ~st ~tac:"reflexivity." in + let* h3 = S.state_hash { st = st.st } in + assert (not (Int.equal h1 h3)); let* st = r ~st ~tac:"-" in let* st = r ~st ~tac:"now simpl; rewrite IHl." in let* st = r ~st ~tac:"Qed." in diff --git a/petanque/test/json_api_failure.ml b/petanque/test/json_api_failure.ml index 71bce482..2f165324 100644 --- a/petanque/test/json_api_failure.ml +++ b/petanque/test/json_api_failure.ml @@ -1,4 +1,5 @@ open Petanque_json +open Petanque_shell let prepare_paths () = let to_uri file = @@ -12,10 +13,7 @@ let msgs = ref [] let trace ?verbose:_ msg = msgs := Format.asprintf "[trace] %s" msg :: !msgs let message ~lvl:_ ~message = msgs := message :: !msgs let dump_msgs () = List.iter (Format.eprintf "%s@\n") (List.rev !msgs) - -let extract_st (st : Protocol.RunTac.Response.t) = - match st with - | Proof_finished st | Current_state st -> st +let extract_st { JAgent.Run_result.st; _ } = st let run (ic, oc) = let open Coq.Compat.Result.O in @@ -27,15 +25,19 @@ let run (ic, oc) = let message = message end) in let r ~st ~tac = + let opts = None in let st = extract_st st in - S.run_tac { st; tac } + S.run { opts; st; tac } in (* Will this work on Windows? *) let root, uri = prepare_paths () in - let* env = S.init { debug; root } in - let* st = S.start { env; uri; thm = "rev_snoc_cons" } in + let opts = None in + let* _env = S.set_workspace { debug; root } in + let* { st; _ } = + S.start { uri; opts; pre_commands = None; thm = "rev_snoc_cons" } + in let* _premises = S.premises { st } in - let* st = S.run_tac { st; tac = "induction l." } in + let* st = S.run { opts; st; tac = "induction l." } in let* st = r ~st ~tac:"-" in (* Introduce an error *) (* let* st = r ~st ~tac:"reflexivity." in *) diff --git a/plugins/astdump/main.ml b/plugins/astdump/main.ml index 8b7b1dfe..ae7ffe84 100644 --- a/plugins/astdump/main.ml +++ b/plugins/astdump/main.ml @@ -1,39 +1,32 @@ open Fleche let pp_json fmt (ast : Doc.Node.Ast.t) = - let jast = Lsp.JCoq.Ast.to_yojson ast.v in - Yojson.Safe.pretty_print fmt jast + Lsp.JCoq.Ast.to_yojson ast.v |> Yojson.Safe.pretty_print fmt let pp_sexp fmt (ast : Doc.Node.Ast.t) = - let sast = - Serlib.Ser_vernacexpr.sexp_of_vernac_control (Coq.Ast.to_coq ast.v) - in - Sexplib.Sexp.pp_hum fmt sast + Serlib.Ser_vernacexpr.sexp_of_vernac_control (Coq.Ast.to_coq ast.v) + |> Sexplib.Sexp.pp_hum fmt let pw pp fmt ast = Format.fprintf fmt "@[%a@]" pp ast let dump_asts ~out_file pp asts = - let out = Stdlib.open_out out_file in - let fmt = Format.formatter_of_out_channel out in - List.iter (pw pp fmt) asts; - Format.pp_print_flush fmt (); - Stdlib.close_out out + let f fmt asts = List.iter (pw pp fmt) asts in + Coq.Compat.format_to_file ~file:out_file ~f asts let dump_ast ~io ~token:_ ~(doc : Doc.t) = let uri = doc.uri in let uri_str = Lang.LUri.File.to_string_uri uri in - let out_file_j = Lang.LUri.File.to_string_file uri ^ ".json.astdump" in - let out_file_s = Lang.LUri.File.to_string_file uri ^ ".sexp.astdump" in - let lvl = Io.Level.info in - let message = Format.asprintf "[ast plugin] dumping ast for %s ..." uri_str in - Io.Report.message ~io ~lvl ~message; + let lvl = Io.Level.Info in + Io.Report.msg ~io ~lvl "[ast plugin] dumping ast for %s ..." uri_str; let asts = Doc.asts doc in + (* Output json *) + let out_file_j = Lang.LUri.File.to_string_file uri ^ ".json.astdump" in let () = dump_asts ~out_file:out_file_j pp_json asts in + (* Output sexp *) + let out_file_s = Lang.LUri.File.to_string_file uri ^ ".sexp.astdump" in let () = dump_asts ~out_file:out_file_s pp_sexp asts in - let message = - Format.asprintf "[ast plugin] dumping ast for %s was completed!" uri_str - in - Io.Report.message ~io ~lvl ~message; + Io.Report.msg ~io ~lvl "[ast plugin] dumping ast for %s was completed!" + uri_str; () let main () = Theory.Register.Completed.add dump_ast diff --git a/plugins/goaldump/main.ml b/plugins/goaldump/main.ml index 980e969e..4f753945 100644 --- a/plugins/goaldump/main.ml +++ b/plugins/goaldump/main.ml @@ -8,10 +8,9 @@ let of_execution ~io ~what (v : (_, _) Coq.Protect.E.t) = | Coq.Protect.R.Completed (Ok goals) -> goals | Coq.Protect.R.Completed (Error (Anomaly err)) | Coq.Protect.R.Completed (Error (User err)) -> - let message = - Format.asprintf "error when retrieving %s: %a" what Pp.pp_with (snd err) - in - Io.Report.message ~io ~lvl:Io.Level.error ~message; + let lvl = Io.Level.Error in + Io.Report.msg ~io ~lvl "error when retrieving %s: %a" what Pp.pp_with + (snd err); None | Coq.Protect.R.Interrupted -> None) @@ -40,47 +39,41 @@ module AstGoals = struct end let pp_json pp fmt (astgoal : _ AstGoals.t) = - let g_json = AstGoals.to_yojson pp astgoal in - Yojson.Safe.pretty_print fmt g_json + AstGoals.to_yojson pp astgoal |> Yojson.Safe.pretty_print fmt (* For now we have not added sexp serialization, but we can easily do so *) (* let pp_sexp fmt (astgoal : AstGoals.t) = *) -(* let g_sexp = AstGoals.sexp_of astgoal in *) -(* Sexplib.Sexp.pp_hum fmt sast *) +(* AstGoals.sexp_of astgoal *) +(* |> Sexplib.Sexp.pp_hum fmt *) let pw pp fmt v = Format.fprintf fmt "@[%a@]@\n" pp v let pp_ast_goals ~io ~token ~contents pp fmt node = - let res = AstGoals.of_node ~io ~token ~contents node in - pw pp fmt res + AstGoals.of_node ~io ~token ~contents node |> pw pp fmt let dump_goals ~io ~token ~out_file ~(doc : Doc.t) pp = - let out = Stdlib.open_out out_file in - let fmt = Format.formatter_of_out_channel out in let contents = doc.contents in - List.iter (pp_ast_goals ~io ~token ~contents pp fmt) doc.nodes; - Format.pp_print_flush fmt (); - Stdlib.close_out out + let f fmt nodes = + List.iter (pp_ast_goals ~io ~token ~contents pp fmt) nodes + in + Coq.Compat.format_to_file ~file:out_file ~f doc.nodes + +let pp d = + (* Set to true to output Pp-formatted goals *) + let output_pp = false in + if output_pp then Lsp.JCoq.Pp.to_yojson d else `String (Pp.string_of_ppcmds d) let dump_ast ~io ~token ~(doc : Doc.t) = let uri = doc.uri in let uri_str = Lang.LUri.File.to_string_uri uri in - let message = - Format.asprintf "[goaldump plugin] dumping goals for %s ..." uri_str - in - let lvl = Io.Level.info in - Io.Report.message ~io ~lvl ~message; + let lvl = Io.Level.Info in + Io.Report.msg ~io ~lvl "[goaldump plugin] dumping goals for %s ..." uri_str; let out_file_j = Lang.LUri.File.to_string_file uri ^ ".json.goaldump" in - let pp d = `String (Pp.string_of_ppcmds d) in - (* Uncomment to output Pp-formatted goals *) - (* let pp d = Lsp.JCoq.Pp.to_yojson d in *) let () = dump_goals ~io ~token ~out_file:out_file_j ~doc (pp_json pp) in (* let out_file_s = Lang.LUri.File.to_string_file uri ^ ".sexp.goaldump" in *) (* let () = dump_goals ~out_file:out_file_s ~doc pp_sexp in *) - let message = - Format.asprintf "[ast plugin] dumping ast for %s was completed!" uri_str - in - Io.Report.message ~io ~lvl ~message; + Io.Report.msg ~io ~lvl "[goaldump plugin] dumping ast for %s was completed!" + uri_str; () let main () = Theory.Register.Completed.add dump_ast diff --git a/plugins/simple/main.ml b/plugins/simple/main.ml index b965c171..78849ac7 100644 --- a/plugins/simple/main.ml +++ b/plugins/simple/main.ml @@ -1,12 +1,10 @@ open Fleche -let simple_action ~io ~token:_ ~doc = - let uri = Lang.LUri.File.to_string_uri doc.Doc.uri in - let lvl = Io.Level.info in - let message = - Format.asprintf "[example plugin] file checking for %s was completed" uri - in - Io.Report.message ~io ~lvl ~message +let msg_info ~io = Io.(Report.msg ~io ~lvl:Info) + +let simple_action ~io ~token:_ ~(doc : Doc.t) = + msg_info ~io "[example plugin] file checking for %a was completed" + Lang.LUri.File.pp doc.uri let main () = Theory.Register.Completed.add simple_action let () = main () diff --git a/plugins/univdiff/dune b/plugins/univdiff/dune new file mode 100644 index 00000000..9b3f4746 --- /dev/null +++ b/plugins/univdiff/dune @@ -0,0 +1,4 @@ +(library + (name Unidiff_plugin) + (public_name coq-lsp.plugin.univdiff) + (libraries coq-lsp.fleche)) diff --git a/plugins/univdiff/main.ml b/plugins/univdiff/main.ml new file mode 100644 index 00000000..648da8a1 --- /dev/null +++ b/plugins/univdiff/main.ml @@ -0,0 +1,53 @@ +open Fleche + +let rec dump_univs ~token ~contents fmt (nuniv_prev, nconst_prev) + (qed_total, qed_yes) (nodes : Doc.Node.t list) = + match nodes with + | [] -> Format.fprintf fmt "qed_total: %d / qed_yes: %d" qed_total qed_yes + | next :: nodes -> ( + let st = next.state in + let raw = Fleche.Contents.extract_raw ~contents ~range:next.range in + let qed_total = qed_total + if String.equal "Qed." raw then 1 else 0 in + match Coq.State.info_universes ~token ~st with + | Coq.Protect.{ E.r = R.Completed (Ok (nuniv, nconst)); feedback = _ } -> + let qed_yes = + qed_yes + + + if nuniv_prev <> nuniv || nconst_prev <> nconst then ( + let raw = raw in + (* maybe trim above ? *) + Format.fprintf fmt "@[univs for \"%s\":@\n (%4d,%4d) {+%d, +%d}@\n@]" + raw nuniv nconst (nuniv - nuniv_prev) (nconst - nconst_prev); + if String.equal "Qed." raw then 1 else 0) + else 0 + in + dump_univs ~token ~contents fmt (nuniv, nconst) (qed_total, qed_yes) nodes + | _ -> + Format.fprintf fmt "Error!! Terminating!! X_X O_O@\n%!"; + ()) + +let dump_univs ~token ~out_file (doc : Doc.t) = + let f fmt nodes = + match Coq.State.info_universes ~token ~st:doc.root with + | Coq.Protect.{ E.r = R.Completed (Ok root); feedback = _ } -> + dump_univs ~token ~contents:doc.contents fmt root (0, 0) nodes + | _ -> () + in + Coq.Compat.format_to_file ~file:out_file ~f doc.nodes + +let dump_univdiff ~io ~token ~(doc : Doc.t) = + let uri = doc.uri in + let uri_str = Lang.LUri.File.to_string_uri uri in + let out_file = Lang.LUri.File.to_string_file uri ^ ".unidiff" in + let lvl = Io.Level.Info in + let ndiags = Doc.diags doc |> List.length in + Io.Report.msg ~io ~lvl "[univdiff plugin] %d diags present for file..." ndiags; + Io.Report.msg ~io ~lvl "[univdiff plugin] dumping universe diff for %s ..." + uri_str; + dump_univs ~token ~out_file doc; + Io.Report.msg ~io ~lvl + "[univdiff plugin] dumping universe diff for %s was completed!" uri_str; + () + +let main () = Theory.Register.Completed.add dump_univdiff +let () = main () diff --git a/.gitmodules b/plugins/univdiff/main.mli similarity index 100% rename from .gitmodules rename to plugins/univdiff/main.mli diff --git a/serlib/.ocamlformat b/serlib/.ocamlformat new file mode 100644 index 00000000..593b6a1f --- /dev/null +++ b/serlib/.ocamlformat @@ -0,0 +1 @@ +disable diff --git a/serlib/README.md b/serlib/README.md new file mode 100644 index 00000000..383b971b --- /dev/null +++ b/serlib/README.md @@ -0,0 +1,142 @@ +## Serlib README + +Welcome to `coq-serlib` README. + +`coq-serlib` is a library that declares missing serialization +functions (from/to JSON, sexp), comparison, and hash functions for +most Coq datatypes, allowing users to serialize full ASTs faithfully +for example, and many other interesting use cases. + +`coq-serlib` also includes support for [Coq's extensible syntax]() and +plugins. + +### Builtins and Configuration + +`serlib` provides some builtins and configuration values in the +`Serlib_base` and `Serlib_init` modules. + +### Serializing regular Coq types + +The standard recipe is to use a combination of `ppx_import` and +several ppx-based "derivers" to make `serlib` generate the +corresponding serializers. + +The pattern for a Coq module `Foo` exporting the datatype `bar` and +their constructors is: + +1. create a new OCaml module named `ser_foo.ml` +2. get the corresponding serializers for existing types in scope, this is unusually done in two steps: + - serializers for OCaml Stdlib: +```ocaml +open Ppx_hash_lib.Std.Hash.Builtin +open Ppx_compare_lib.Builtin +open Sexplib.Std +``` + - serializers for types that `Foo.bar` depends on, for example: +```ocaml +module Names = Ser_names +module EConstr = Ser_eConstr +... +``` +3. implement the serializers for your type. Add to `ser_foo.ml`: +```ocaml +type bar = + [%import: Foo.bar] + [@@deriving sexp,yojson,hash,compare] +``` + +Additionally, you can add an `.mli` file, with the same contents as +above, but in this case, `[@@deriving ...]` will generate the right +interface declarations. + +If `Foo.bar` has no public constructors, `Obj.magic` will be +needed. `serlib` provides helpers for this, see below. + +### Serializing opaque and private types + +`serlib` uses `ppx_import` to retrieve the original type definitions +from Coq; when these are not available, we provide some helpers in the +`SerType` module. Current helpers are: + +- `Biject`: use when it is convenient to provide an isomorphic type to + the one that is "opaque". +- `Pierce`: use when it is not possible to access the type, you really + want to use a copy + `Obj.magic` +- `Opaque`: when you want to declare the type as non-serializable + +**note**: use of `Obj.magic` is now prohibited, all the type piercings +need to use the `Pierce` functor. + +### Serializing GADTS + +Unfortunately, it is not possible to easily serialize GADTS. For now, +we use a very ugly workaround: we basically copy the original Coq +datatype, in non-GADT version, then we pierce the type as their +representation is isomorphic. + +We will use an example from https://github.com/coq/coq/pull/17667#issuecomment-1714473449 : + +```ocaml +type _ gen_pattern = GPat : Genarg.glob_generic_argument -> [ `uninstantiated ] gen_pattern +``` + +In this case, we could indeed derive a serialization function (try +`[@@deriving of_sexp]` for example), however full serialization is +harder, so we may need to provide an alternative data-type: + +```ocaml +module GenPatternRep : SerType.Pierceable1 = struct + + type 'a t = 'a Pattern.gen_pattern + + type _ _t = GPat of Genarg.glob_generic_argument + [@@deriving sexp,yojson,hash,compare] +end + +module GenPatternSer = SerType.Pierce1(GenPatternRep) +type 'a gen_pattern = GenPatternSer.t [@@deriving sexp,yojson,hash,compare] +``` + +and here you go! The main problem with this approach is that it +requires a manual check for each use of `Pierce` and each Coq +version. Fortunately the numbers of `Pierce`'s so far have been very +low. + +### Pre-release checks + +Due to the above, when updating SerAPI for a new release to OPAM, we +must check that the definitions we are piercing are up to date. + +I perform this check with Emacs + Merlin for OCaml: + +- I do `vc-git-grep` for `Pierce(` and `Pierce1(` +- For each use, I use merlin to jump to the original type +- I compare update these types + +That's painful, but takes like 10 minutes, so for now it is doable a +couple of times a year. To illustrate, these are the current +occurrences to check: + +``` +serlib/plugins/ltac2/ser_tac2expr.ml:module T2E = Serlib.SerType.Pierce(T2ESpec) +serlib/plugins/ltac2/ser_tac2expr.ml:module GT2E = Serlib.SerType.Pierce(GT2ESpec) +serlib/ser_cooking.ml:module B_ = SerType.Pierce(CIP) +serlib/ser_environ.ml: include SerType.Pierce(PierceSpec) +serlib/ser_float64.ml:include SerType.Pierce(PierceSpec) +serlib/ser_impargs.ml:module B_ = SerType.Pierce(ISCPierceSpec) +serlib/ser_names.ml:include SerType.Pierce(MBIdBij) +serlib/ser_names.ml: include SerType.Pierce(PierceSpec) +serlib/ser_names.ml: include SerType.Pierce(PierceSpec) +serlib/ser_numTok.ml: include SerType.Pierce(PierceSpec) +serlib/ser_opaqueproof.ml:module B_ = SerType.Pierce(OP) +serlib/ser_opaqueproof.ml:module C_ = SerType.Pierce(OTSpec) +serlib/ser_rtree.ml:include SerType.Pierce1(RTreePierce) +serlib/ser_sList.ml:include SerType.Pierce1(SL) +serlib/ser_safe_typing.ml:module B_ = SerType.Pierce(PC) +serlib/ser_sorts.ml:include SerType.Pierce(PierceSpec) +serlib/ser_stateid.ml:include SerType.Pierce(SId) +serlib/ser_univ.ml: module PierceImp = SerType.Pierce(PierceSpec) +serlib/ser_univ.ml: include SerType.Pierce(PierceSpec) +serlib/ser_univ.ml: include SerType.Pierce(ACPierceDef) +serlib/ser_vmemitcodes.ml:module B = SerType.Pierce(PierceToPatch) +``` diff --git a/serlib/dune b/serlib/dune new file mode 100644 index 00000000..1b863e4e --- /dev/null +++ b/serlib/dune @@ -0,0 +1,12 @@ +(library + (name serlib) + (public_name coq-lsp.serlib) + (synopsis "AST utility Library for Coq") + (preprocess + (staged_pps + ppx_import + ppx_sexp_conv + ppx_hash + ppx_compare + ppx_deriving_yojson)) + (libraries coq-core.vernac sexplib)) diff --git a/serlib/plugins/btauto/dune b/serlib/plugins/btauto/dune new file mode 100644 index 00000000..f29b7d50 --- /dev/null +++ b/serlib/plugins/btauto/dune @@ -0,0 +1,12 @@ +(library + (name serlib_btauto) + (public_name coq-lsp.serlib.btauto) + (synopsis "Serialization Library for Coq BTauto Plugin") + (preprocess + (staged_pps + ppx_import + ppx_sexp_conv + ppx_deriving_yojson + ppx_hash + ppx_compare)) + (libraries coq-core.plugins.btauto serlib sexplib)) diff --git a/serlib/plugins/cc/dune b/serlib/plugins/cc/dune new file mode 100644 index 00000000..28ca0e2d --- /dev/null +++ b/serlib/plugins/cc/dune @@ -0,0 +1,12 @@ +(library + (name serlib_cc) + (public_name coq-lsp.serlib.cc) + (synopsis "Serialization Library for Coq Congruence Plugin") + (preprocess + (staged_pps + ppx_import + ppx_sexp_conv + ppx_deriving_yojson + ppx_hash + ppx_compare)) + (libraries coq-core.plugins.cc serlib sexplib)) diff --git a/serlib/plugins/extraction/dune b/serlib/plugins/extraction/dune new file mode 100644 index 00000000..2c19356c --- /dev/null +++ b/serlib/plugins/extraction/dune @@ -0,0 +1,12 @@ +(library + (name serlib_extraction) + (public_name coq-lsp.serlib.extraction) + (synopsis "Serialization Library for Coq Fundind Plugin") + (preprocess + (staged_pps + ppx_import + ppx_sexp_conv + ppx_deriving_yojson + ppx_hash + ppx_compare)) + (libraries coq-core.plugins.extraction serlib)) diff --git a/serlib/plugins/extraction/ser_g_extraction.ml b/serlib/plugins/extraction/ser_g_extraction.ml new file mode 100644 index 00000000..69cad774 --- /dev/null +++ b/serlib/plugins/extraction/ser_g_extraction.ml @@ -0,0 +1,56 @@ +(************************************************************************) +(* SerAPI: Coq interaction protocol with bidirectional serialization *) +(************************************************************************) +(* Copyright 2016-2019 MINES ParisTech -- License LGPL 2.1+ *) +(* Copyright 2019-2023 Inria -- License LGPL 2.1+ *) +(* Written by: Emilio J. Gallego Arias and others *) +(************************************************************************) + +open Serlib + +open Sexplib.Conv +open Ppx_compare_lib.Builtin +open Ppx_hash_lib.Std.Hash.Builtin + +module Names = Ser_names + +module Extraction_plugin = struct + module G_extraction = Extraction_plugin.G_extraction + module Table = struct + type int_or_id = + [%import: Extraction_plugin.Table.int_or_id] + [@@deriving sexp,yojson,hash,compare] + type lang = + [%import: Extraction_plugin.Table.lang] + [@@deriving sexp,yojson,hash,compare] + end +end + +module WitII = struct + type t = Extraction_plugin.Table.int_or_id + [@@deriving sexp,yojson,hash,compare] +end + +let ser_wit_int_or_id = let module M = Ser_genarg.GSV(WitII) in M.genser + +module WitL = struct + type t = Extraction_plugin.Table.lang + [@@deriving sexp,yojson,hash,compare] +end + +let ser_wit_language = let module M = Ser_genarg.GSV(WitL) in M.genser + +module WitMN = struct + type t = string + [@@deriving sexp,yojson,hash,compare] +end + +let ser_wit_mlname = let module M = Ser_genarg.GSV(WitMN) in M.genser + +let register () = + Ser_genarg.register_genser Extraction_plugin.G_extraction.wit_int_or_id ser_wit_int_or_id; + Ser_genarg.register_genser Extraction_plugin.G_extraction.wit_language ser_wit_language; + Ser_genarg.register_genser Extraction_plugin.G_extraction.wit_mlname ser_wit_mlname; + () + +let _ = register () diff --git a/serlib/plugins/firstorder/dune b/serlib/plugins/firstorder/dune new file mode 100644 index 00000000..ee351fc9 --- /dev/null +++ b/serlib/plugins/firstorder/dune @@ -0,0 +1,7 @@ +(library + (name serlib_firstorder) + (public_name coq-lsp.serlib.firstorder) + (synopsis "Serialization Library for Coq Firstorder Plugin") + (preprocess + (staged_pps ppx_import ppx_sexp_conv ppx_hash ppx_compare)) + (libraries coq-core.plugins.firstorder serlib sexplib)) diff --git a/serlib/plugins/firstorder/ser_g_ground.ml b/serlib/plugins/firstorder/ser_g_ground.ml new file mode 100644 index 00000000..06d54743 --- /dev/null +++ b/serlib/plugins/firstorder/ser_g_ground.ml @@ -0,0 +1,55 @@ +(************************************************************************) +(* SerAPI: Coq interaction protocol with bidirectional serialization *) +(************************************************************************) +(* Copyright 2016-2019 MINES ParisTech -- License LGPL 2.1+ *) +(* Copyright 2019-2023 Inria -- License LGPL 2.1+ *) +(* Written by: Emilio J. Gallego Arias and others *) +(************************************************************************) + +open Serlib + +open Sexplib.Conv +open Ppx_compare_lib.Builtin +open Ppx_hash_lib.Std.Hash.Builtin + +module Loc = Ser_loc +module Names = Ser_names +module Libnames = Ser_libnames +module Locus = Ser_locus +(* module Globnames = Ser_globnames *) + +type h1 = Libnames.qualid list + [@@deriving sexp, hash, compare] + +type h2 = Names.GlobRef.t Loc.located Locus.or_var list +[@@deriving sexp, hash, compare] + +type h3 = Names.GlobRef.t list +[@@deriving sexp,hash,compare] + +let ser_wit_firstorder_using : + (Libnames.qualid list, + Names.GlobRef.t Loc.located Locus.or_var list, + Names.GlobRef.t list) Ser_genarg.gen_ser = + Ser_genarg.{ + raw_ser = sexp_of_h1 + ; raw_des = h1_of_sexp + ; raw_hash = hash_fold_h1 + ; raw_compare = compare_h1 + + ; glb_ser = sexp_of_h2 + ; glb_des = h2_of_sexp + ; glb_hash = hash_fold_h2 + ; glb_compare = compare_h2 + + ; top_ser = sexp_of_h3 + ; top_des = h3_of_sexp + ; top_hash = hash_fold_h3 + ; top_compare = compare_h3 + } + +let register () = + Ser_genarg.register_genser Firstorder_plugin.G_ground.wit_firstorder_using ser_wit_firstorder_using; + () + +let _ = register () diff --git a/serlib/plugins/funind/dune b/serlib/plugins/funind/dune new file mode 100644 index 00000000..591c0571 --- /dev/null +++ b/serlib/plugins/funind/dune @@ -0,0 +1,7 @@ +(library + (name serlib_funind) + (public_name coq-lsp.serlib.funind) + (synopsis "Serialization Library for Coq Fundind Plugin") + (preprocess + (staged_pps ppx_import ppx_sexp_conv ppx_hash ppx_compare)) + (libraries coq-core.plugins.funind serlib serlib_ltac sexplib)) diff --git a/serlib/plugins/funind/ser_g_indfun.ml b/serlib/plugins/funind/ser_g_indfun.ml new file mode 100644 index 00000000..c8dffca9 --- /dev/null +++ b/serlib/plugins/funind/ser_g_indfun.ml @@ -0,0 +1,104 @@ +(************************************************************************) +(* SerAPI: Coq interaction protocol with bidirectional serialization *) +(************************************************************************) +(* Copyright 2016-2019 MINES ParisTech -- License LGPL 2.1+ *) +(* Copyright 2019-2023 Inria -- License LGPL 2.1+ *) +(* Written by: Emilio J. Gallego Arias and others *) +(************************************************************************) + +open Serlib + +open Ppx_compare_lib.Builtin +open Ppx_hash_lib.Std.Hash.Builtin +open Sexplib.Conv + +module CAst = Ser_cAst +module Names = Ser_names +module Sorts = Ser_sorts +module Libnames = Ser_libnames +module Constrexpr = Ser_constrexpr +module Tactypes = Ser_tactypes +module Genintern = Ser_genintern +module EConstr = Ser_eConstr +module Tacexpr = Serlib_ltac.Ser_tacexpr + +module A1 = struct + +type h1 = Constrexpr.constr_expr Tactypes.intro_pattern_expr CAst.t option +[@@deriving sexp,hash,compare] +type h2 = Genintern.glob_constr_and_expr Tactypes.intro_pattern_expr CAst.t option +[@@deriving sexp,hash,compare] +type h3 = Tacexpr.intro_pattern option +[@@deriving sexp,hash,compare] + +end + +let ser_wit_with_names = + let open A1 in + Ser_genarg.{ + raw_ser = sexp_of_h1 + ; raw_des = h1_of_sexp + ; raw_hash = hash_fold_h1 + ; raw_compare = compare_h1 + + ; glb_ser = sexp_of_h2 + ; glb_des = h2_of_sexp + ; glb_hash = hash_fold_h2 + ; glb_compare = compare_h2 + + ; top_ser = sexp_of_h3 + ; top_des = h3_of_sexp + ; top_hash = hash_fold_h3 + ; top_compare = compare_h3 + } + +module WitFI = struct + type raw = Constrexpr.constr_expr Tactypes.with_bindings option + [@@deriving sexp,hash,compare] + type glb = Genintern.glob_constr_and_expr Tactypes.with_bindings option + [@@deriving sexp,hash,compare] + type top = EConstr.t Tactypes.with_bindings Ser_tactypes.delayed_open option + [@@deriving sexp,hash,compare] +end + +let ser_wit_fun_ind_using = let module M = Ser_genarg.GS(WitFI) in M.genser + +module WitFS = struct + type t = Names.variable * Libnames.qualid * Sorts.family + [@@deriving sexp,hash,compare] +end + +let ser_wit_fun_scheme_arg = let module M = Ser_genarg.GSV(WitFS) in M.genser + +module Loc = Ser_loc +module Vernacexpr = Ser_vernacexpr + +module WFFD = struct + type t = Vernacexpr.fixpoint_expr Loc.located + [@@deriving sexp,hash,compare] +end + +let ser_wit_function_fix_definition = + let module M = Ser_genarg.GS0(WFFD) in M.genser + +module WAU = struct + type raw = Constrexpr.constr_expr list + [@@deriving sexp,hash,compare] + type glb = Genintern.glob_constr_and_expr list + [@@deriving sexp,hash,compare] + type top = EConstr.constr list + [@@deriving sexp,hash,compare] +end + +let ser_wit_auto_using' = let module M = Ser_genarg.GS(WAU) in M.genser + +let register () = + Ser_genarg.register_genser Funind_plugin.G_indfun.wit_auto_using' ser_wit_auto_using'; + Ser_genarg.register_genser Funind_plugin.G_indfun.wit_constr_comma_sequence' ser_wit_auto_using'; + Ser_genarg.register_genser Funind_plugin.G_indfun.wit_with_names ser_wit_with_names; + Ser_genarg.register_genser Funind_plugin.G_indfun.wit_fun_ind_using ser_wit_fun_ind_using; + Ser_genarg.register_genser Funind_plugin.G_indfun.wit_fun_scheme_arg ser_wit_fun_scheme_arg; + Ser_genarg.register_genser Funind_plugin.G_indfun.wit_function_fix_definition ser_wit_function_fix_definition; + () + +let _ = register () diff --git a/serlib/plugins/ltac/dune b/serlib/plugins/ltac/dune new file mode 100644 index 00000000..b2668504 --- /dev/null +++ b/serlib/plugins/ltac/dune @@ -0,0 +1,12 @@ +(library + (name serlib_ltac) + (public_name coq-lsp.serlib.ltac) + (synopsis "Serialization Library for Coq [LTAC plugin]") + (preprocess + (staged_pps + ppx_import + ppx_sexp_conv + ppx_deriving_yojson + ppx_hash + ppx_compare)) + (libraries coq-core.plugins.ltac serlib sexplib)) diff --git a/serlib/plugins/ltac/ser_rewrite.ml b/serlib/plugins/ltac/ser_rewrite.ml new file mode 100644 index 00000000..299b88b6 --- /dev/null +++ b/serlib/plugins/ltac/ser_rewrite.ml @@ -0,0 +1,43 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ITac.TacIntroPattern(a,b) + | Ltac_plugin.Tacexpr.TacApply (a,b,c,d) -> ITac.TacApply (a,b,c,d) + | Ltac_plugin.Tacexpr.TacElim (a,b,c) -> ITac.TacElim (a,b,c) + | Ltac_plugin.Tacexpr.TacCase (a,b) -> ITac.TacCase (a,b) + | Ltac_plugin.Tacexpr.TacMutualFix (a,b,c) -> ITac.TacMutualFix (a,b,c) + | Ltac_plugin.Tacexpr.TacMutualCofix (a,b) -> ITac.TacMutualCofix (a,b) + | Ltac_plugin.Tacexpr.TacAssert (a,b,c,d,e) -> ITac.TacAssert (a,b,c,d,e) + | Ltac_plugin.Tacexpr.TacGeneralize a -> ITac.TacGeneralize a + | Ltac_plugin.Tacexpr.TacLetTac (a,b,c,d,e,f) -> ITac.TacLetTac (a,b,c,d,e,f) + | Ltac_plugin.Tacexpr.TacInductionDestruct (a,b,c) -> ITac.TacInductionDestruct (a,b,c) + | Ltac_plugin.Tacexpr.TacReduce (a,b) -> ITac.TacReduce (a,b) + | Ltac_plugin.Tacexpr.TacChange (a,b,c,d) -> ITac.TacChange (a,b,c,d) + | Ltac_plugin.Tacexpr.TacRewrite (a,b,c,d) -> ITac.TacRewrite (a,b,c,d) + | Ltac_plugin.Tacexpr.TacInversion (a,b) -> ITac.TacInversion (a,b) +and _gen_tactic_arg_put (t : 'a Ltac_plugin.Tacexpr.gen_tactic_arg) : + ('t, 'dtrm, 'p, 'rp, 'c, 'r, 'n, 'occvar, 'tacexpr, 'l) ITac.gen_tactic_arg = match t with + | Ltac_plugin.Tacexpr.TacGeneric (a,b) -> ITac.TacGeneric (a,b) + | Ltac_plugin.Tacexpr.ConstrMayEval a -> ITac.ConstrMayEval a + | Ltac_plugin.Tacexpr.Reference a -> ITac.Reference a + | Ltac_plugin.Tacexpr.TacCall l -> ITac.TacCall C.(map (fun (b,c) -> (b, List.map _gen_tactic_arg_put c)) l) + | Ltac_plugin.Tacexpr.TacFreshId a -> ITac.TacFreshId a + | Ltac_plugin.Tacexpr.Tacexp a -> ITac.Tacexp a + | Ltac_plugin.Tacexpr.TacPretype a -> ITac.TacPretype a + | Ltac_plugin.Tacexpr.TacNumgoals -> ITac.TacNumgoals +and _gen_tactic_expr_r_put (t : 'a Ltac_plugin.Tacexpr.gen_tactic_expr_r) : + ('t, 'dtrm, 'p, 'rp, 'c, 'r, 'n, 'occvar, 'tacexpr, 'l) ITac.gen_tactic_expr_r = + let u x = _gen_tactic_expr_put x in + let uu x = List.map u x in + let ua x = Array.map u x in + match t with + | Ltac_plugin.Tacexpr.TacAtom l -> ITac.TacAtom (_gen_atomic_tactic_expr_put l) + | Ltac_plugin.Tacexpr.TacThen (a,b) -> ITac.TacThen (u a, u b) + | Ltac_plugin.Tacexpr.TacDispatch a -> ITac.TacDispatch (uu a) + | Ltac_plugin.Tacexpr.TacExtendTac (a,b,c) -> ITac.TacExtendTac (ua a, u b, ua c) + | Ltac_plugin.Tacexpr.TacThens (a,b) -> ITac.TacThens (u a, uu b) + | Ltac_plugin.Tacexpr.TacThens3parts (a,b,c,d) -> ITac.TacThens3parts (u a, ua b, u c, ua d) + | Ltac_plugin.Tacexpr.TacFirst a -> ITac.TacFirst (uu a) + | Ltac_plugin.Tacexpr.TacSolve a -> ITac.TacSolve (uu a) + | Ltac_plugin.Tacexpr.TacTry a -> ITac.TacTry (u a) + | Ltac_plugin.Tacexpr.TacOr (a,b) -> ITac.TacOr (u a, u b) + | Ltac_plugin.Tacexpr.TacOnce a -> ITac.TacOnce (u a) + | Ltac_plugin.Tacexpr.TacExactlyOnce a -> ITac.TacExactlyOnce (u a) + | Ltac_plugin.Tacexpr.TacIfThenCatch (a,b,c) -> ITac.TacIfThenCatch (u a,u b,u c) + | Ltac_plugin.Tacexpr.TacOrelse (a,b) -> ITac.TacOrelse (u a,u b) + | Ltac_plugin.Tacexpr.TacDo (a,b) -> ITac.TacDo (a,u b) + | Ltac_plugin.Tacexpr.TacTimeout (a,b) -> ITac.TacTimeout (a,u b) + | Ltac_plugin.Tacexpr.TacTime (a,b) -> ITac.TacTime (a,u b) + | Ltac_plugin.Tacexpr.TacRepeat a -> ITac.TacRepeat (u a) + | Ltac_plugin.Tacexpr.TacProgress a -> ITac.TacProgress (u a) + (* | Ltac_plugin.Tacexpr.TacShowHyps a -> ITac.TacShowHyps (u a) *) + | Ltac_plugin.Tacexpr.TacAbstract (a,b) -> ITac.TacAbstract (u a,b) + | Ltac_plugin.Tacexpr.TacId a -> ITac.TacId a + | Ltac_plugin.Tacexpr.TacFail (a,b,c) -> ITac.TacFail (a,b,c) + (* | Ltac_plugin.Tacexpr.TacInfo a -> ITac.TacInfo (u a) *) + (* | TacLetIn of rec_flag * *) + (* (Names.Id.t located * 'a gen_tactic_arg) list * *) + (* 'a gen_tactic_expr *) + | Ltac_plugin.Tacexpr.TacLetIn (a, l, t) -> + let _pt = List.map (fun (a,t) -> (a,_gen_tactic_arg_put t)) in + ITac.TacLetIn (a, _pt l, _gen_tactic_expr_put t) + (* | TacMatch of lazy_flag * *) + (* 'a gen_tactic_expr * *) + (* ('p,'a gen_tactic_expr) match_rule list *) + (* type ('a,'t) match_rule = *) + (* | Pat of 'a match_context_hyps list * 'a match_pattern * 't *) + (* | All of 't *) + | Ltac_plugin.Tacexpr.TacMatch (a, e, mr) -> + let _pmr = List.map (function + | Ltac_plugin.Tacexpr.Pat (a,b,t) -> Ltac_plugin.Tacexpr.Pat (a,b,_gen_tactic_expr_put t) + | Ltac_plugin.Tacexpr.All e -> Ltac_plugin.Tacexpr.All (_gen_tactic_expr_put e) + ) in + ITac.TacMatch(a, _gen_tactic_expr_put e, _pmr mr) + | Ltac_plugin.Tacexpr.TacMatchGoal (e, d, t) -> + let _pmr = List.map (function + | Ltac_plugin.Tacexpr.Pat (a,b,t) -> Ltac_plugin.Tacexpr.Pat (a,b,_gen_tactic_expr_put t) + | Ltac_plugin.Tacexpr.All e -> Ltac_plugin.Tacexpr.All (_gen_tactic_expr_put e) + ) in + ITac.TacMatchGoal(e, d, _pmr t) + | Ltac_plugin.Tacexpr.TacFun a -> ITac.TacFun (_gen_tactic_fun_ast_put a) + | Ltac_plugin.Tacexpr.TacArg l -> ITac.TacArg (_gen_tactic_arg_put l) + | Ltac_plugin.Tacexpr.TacSelect(gs,te) -> ITac.TacSelect(gs, _gen_tactic_expr_put te) + | Ltac_plugin.Tacexpr.TacML (l,m) -> ITac.TacML (l, List.map _gen_tactic_arg_put m) + | Ltac_plugin.Tacexpr.TacAlias (l,m) -> ITac.TacAlias (l, List.map _gen_tactic_arg_put m) +and _gen_tactic_expr_put (t : _ Ltac_plugin.Tacexpr.gen_tactic_expr) = + C.map _gen_tactic_expr_r_put t + +and _gen_tactic_fun_ast_put (t : 'a Ltac_plugin.Tacexpr.gen_tactic_fun_ast) : + ('t, 'dtrm, 'p, 'rp, 'c, 'r, 'n, 'occvar, 'tacexpr, 'l) ITac.gen_tactic_fun_ast = + match t with + | (a,b) -> (a, _gen_tactic_expr_put b) + +let rec _gen_atom_tactic_expr_get (t : ('t, 'dtrm, 'p, 'rp, 'c, 'r, 'n, 'occvar, 'tacexpr, 'l) ITac.gen_atomic_tactic_expr) : + 'a Ltac_plugin.Tacexpr.gen_atomic_tactic_expr = match t with + | ITac.TacIntroPattern(a,b) -> Ltac_plugin.Tacexpr.TacIntroPattern(a,b) + | ITac.TacApply (a,b,c,d) -> Ltac_plugin.Tacexpr.TacApply (a,b,c,d) + | ITac.TacElim (a,b,c) -> Ltac_plugin.Tacexpr.TacElim (a,b,c) + | ITac.TacCase (a,b) -> Ltac_plugin.Tacexpr.TacCase (a,b) + | ITac.TacMutualFix (a,b,c) -> Ltac_plugin.Tacexpr.TacMutualFix (a,b,c) + | ITac.TacMutualCofix (a,b) -> Ltac_plugin.Tacexpr.TacMutualCofix (a,b) + | ITac.TacAssert (a,b,c,d,e) -> Ltac_plugin.Tacexpr.TacAssert (a,b,c,d,e) + | ITac.TacGeneralize a -> Ltac_plugin.Tacexpr.TacGeneralize a + | ITac.TacLetTac (a,b,c,d,e,f) -> Ltac_plugin.Tacexpr.TacLetTac (a,b,c,d,e,f) + | ITac.TacInductionDestruct (a,b,c) -> Ltac_plugin.Tacexpr.TacInductionDestruct (a,b,c) + | ITac.TacReduce (a,b) -> Ltac_plugin.Tacexpr.TacReduce (a,b) + | ITac.TacChange (a,b,c,d) -> Ltac_plugin.Tacexpr.TacChange (a,b,c,d) + | ITac.TacRewrite (a,b,c,d) -> Ltac_plugin.Tacexpr.TacRewrite (a,b,c,d) + | ITac.TacInversion (a,b) -> Ltac_plugin.Tacexpr.TacInversion (a,b) +and _gen_tactic_arg_get (t : ('t, 'dtrm, 'p, 'rp, 'c, 'r, 'n, 'occvar, 'tacexpr, 'l) ITac.gen_tactic_arg) : + 'a Ltac_plugin.Tacexpr.gen_tactic_arg = match t with + | ITac.TacGeneric(a,b) -> Ltac_plugin.Tacexpr.TacGeneric (a,b) + | ITac.ConstrMayEval a -> Ltac_plugin.Tacexpr.ConstrMayEval a + | ITac.Reference a -> Ltac_plugin.Tacexpr.Reference a + | ITac.TacCall l -> Ltac_plugin.Tacexpr.TacCall C.(map (fun (b,c) -> (b, List.map _gen_tactic_arg_get c)) l) + | ITac.TacFreshId a -> Ltac_plugin.Tacexpr.TacFreshId a + | ITac.Tacexp a -> Ltac_plugin.Tacexpr.Tacexp a + | ITac.TacPretype a -> Ltac_plugin.Tacexpr.TacPretype a + | ITac.TacNumgoals -> Ltac_plugin.Tacexpr.TacNumgoals +and _gen_tactic_expr_r_get (t : ('t, 'dtrm, 'p, 'rp, 'c, 'r, 'n, 'occvar, 'tacexpr, 'l) ITac.gen_tactic_expr_r) : + 'a Ltac_plugin.Tacexpr.gen_tactic_expr_r = + let u x = _gen_tactic_expr_get x in + let uu x = List.map u x in + let ua x = Array.map u x in + match t with + | ITac.TacAtom l -> Ltac_plugin.Tacexpr.TacAtom (_gen_atom_tactic_expr_get l) + | ITac.TacThen (a,b) -> Ltac_plugin.Tacexpr.TacThen (u a, u b) + | ITac.TacDispatch a -> Ltac_plugin.Tacexpr.TacDispatch (uu a) + | ITac.TacExtendTac (a,b,c) -> Ltac_plugin.Tacexpr.TacExtendTac (ua a, u b, ua c) + | ITac.TacThens (a,b) -> Ltac_plugin.Tacexpr.TacThens (u a, uu b) + | ITac.TacThens3parts (a,b,c,d) -> Ltac_plugin.Tacexpr.TacThens3parts (u a, ua b, u c, ua d) + | ITac.TacFirst a -> Ltac_plugin.Tacexpr.TacFirst (uu a) + | ITac.TacSolve a -> Ltac_plugin.Tacexpr.TacSolve (uu a) + | ITac.TacTry a -> Ltac_plugin.Tacexpr.TacTry (u a) + | ITac.TacOr (a,b) -> Ltac_plugin.Tacexpr.TacOr (u a, u b) + | ITac.TacOnce a -> Ltac_plugin.Tacexpr.TacOnce (u a) + | ITac.TacExactlyOnce a -> Ltac_plugin.Tacexpr.TacExactlyOnce (u a) + | ITac.TacIfThenCatch (a,b,c) -> Ltac_plugin.Tacexpr.TacIfThenCatch (u a,u b,u c) + | ITac.TacOrelse (a,b) -> Ltac_plugin.Tacexpr.TacOrelse (u a,u b) + | ITac.TacDo (a,b) -> Ltac_plugin.Tacexpr.TacDo (a,u b) + | ITac.TacTimeout (a,b) -> Ltac_plugin.Tacexpr.TacTimeout (a,u b) + | ITac.TacTime (a,b) -> Ltac_plugin.Tacexpr.TacTime (a,u b) + | ITac.TacRepeat a -> Ltac_plugin.Tacexpr.TacRepeat (u a) + | ITac.TacProgress a -> Ltac_plugin.Tacexpr.TacProgress (u a) + (* | ITac.TacShowHyps a -> Ltac_plugin.Tacexpr.TacShowHyps (u a) *) + | ITac.TacAbstract (a,b) -> Ltac_plugin.Tacexpr.TacAbstract (u a,b) + | ITac.TacId a -> Ltac_plugin.Tacexpr.TacId a + | ITac.TacFail (a,b,c) -> Ltac_plugin.Tacexpr.TacFail (a,b,c) + (* | ITac.TacInfo a -> Ltac_plugin.Tacexpr.TacInfo (u a) *) + | ITac.TacLetIn (a, l, t) -> + let _pt = List.map (fun (a,t) -> (a,_gen_tactic_arg_get t)) in + Ltac_plugin.Tacexpr.TacLetIn (a, _pt l, _gen_tactic_expr_get t) + | ITac.TacMatch (a,e,mr) -> + let _gmr = List.map (function + | Ltac_plugin.Tacexpr.Pat (a,b,t) -> Ltac_plugin.Tacexpr.Pat (a,b,_gen_tactic_expr_get t) + | Ltac_plugin.Tacexpr.All e -> Ltac_plugin.Tacexpr.All (_gen_tactic_expr_get e) + ) in + Ltac_plugin.Tacexpr.TacMatch(a, _gen_tactic_expr_get e, _gmr mr) + | ITac.TacMatchGoal (a,d,t) -> + let _gmr = List.map (function + | Ltac_plugin.Tacexpr.Pat (a,b,t) -> Ltac_plugin.Tacexpr.Pat (a,b,_gen_tactic_expr_get t) + | Ltac_plugin.Tacexpr.All e -> Ltac_plugin.Tacexpr.All (_gen_tactic_expr_get e) + ) in + Ltac_plugin.Tacexpr.TacMatchGoal(a,d, _gmr t) + | ITac.TacFun a -> Ltac_plugin.Tacexpr.TacFun (_gen_tactic_fun_ast_get a) + | ITac.TacArg l -> Ltac_plugin.Tacexpr.TacArg (_gen_tactic_arg_get l) + | ITac.TacSelect(gs,te) -> Ltac_plugin.Tacexpr.TacSelect(gs, _gen_tactic_expr_get te) + | ITac.TacML (l,m) -> Ltac_plugin.Tacexpr.TacML (l, List.map _gen_tactic_arg_get m) + | ITac.TacAlias (l,m) -> Ltac_plugin.Tacexpr.TacAlias (l, List.map _gen_tactic_arg_get m) + +and _gen_tactic_expr_get (t : ('t, 'dtrm, 'p, 'rp, 'c, 'r, 'n, 'occvar, 'tacexpr, 'l) ITac.gen_tactic_expr) : + 'a Ltac_plugin.Tacexpr.gen_tactic_expr = + C.map _gen_tactic_expr_r_get t + +and _gen_tactic_fun_ast_get (t : ('t, 'dtrm, 'p, 'rp, 'c, 'r, 'n, 'occvar, 'tacexpr, 'l) ITac.gen_tactic_fun_ast) : + 'a Ltac_plugin.Tacexpr.gen_tactic_fun_ast = + match t with + | (a,b) -> (a, _gen_tactic_expr_get b) + +type 'd gen_atomic_tactic_expr = 'd Ltac_plugin.Tacexpr.gen_atomic_tactic_expr + +(* Sexp part for generic functions *) + +let sexp_of_gen_atomic_tactic_expr + t d p rp c r n ov te l (tac : 'a Ltac_plugin.Tacexpr.gen_atomic_tactic_expr) : Sexp.t = + ITac.sexp_of_gen_atomic_tactic_expr t d p rp c r n ov te l (_gen_atomic_tactic_expr_put tac) + +let sexp_of_gen_tactic_expr + t d p rp c r n ov te l (tac : 'a Ltac_plugin.Tacexpr.gen_tactic_expr) : Sexp.t = + ITac.sexp_of_gen_tactic_expr t d p rp c r n ov te l (_gen_tactic_expr_put tac) + +let sexp_of_gen_tactic_arg + t d p rp c r n ov te l (tac : 'a Ltac_plugin.Tacexpr.gen_tactic_arg) : Sexp.t = + ITac.sexp_of_gen_tactic_arg t d p rp c r n ov te l (_gen_tactic_arg_put tac) + +let sexp_of_gen_fun_ast + t d p rp c r n ov te l (tac : 'a Ltac_plugin.Tacexpr.gen_tactic_fun_ast) : Sexp.t = + ITac.sexp_of_gen_tactic_fun_ast t d p rp c r n ov te l (_gen_tactic_fun_ast_put tac) + +let gen_atomic_tactic_expr_of_sexp (tac : Sexp.t) + t d p rp c r n ov te l : 'a Ltac_plugin.Tacexpr.gen_atomic_tactic_expr = + _gen_atom_tactic_expr_get (ITac.gen_atomic_tactic_expr_of_sexp t d p rp c r n ov te l tac) + +let gen_tactic_expr_of_sexp (tac : Sexp.t) + t d p rp c r n ov te l : 'a Ltac_plugin.Tacexpr.gen_tactic_expr = + _gen_tactic_expr_get (ITac.gen_tactic_expr_of_sexp t d p rp c r n ov te l tac) + +let gen_tactic_arg_of_sexp (tac : Sexp.t) + t d p rp c r n ov te l : 'a Ltac_plugin.Tacexpr.gen_tactic_arg = + _gen_tactic_arg_get (ITac.gen_tactic_arg_of_sexp t d p rp c r n ov te l tac) + +let gen_fun_ast_of_sexp (tac : Sexp.t) + t d p rp c r n ov te l : 'a Ltac_plugin.Tacexpr.gen_tactic_fun_ast = + _gen_tactic_fun_ast_get (ITac.gen_tactic_fun_ast_of_sexp t d p rp c r n ov te l tac) + +(* Yojson part for generic functions *) + +let gen_atomic_tactic_expr_to_yojson + t d p rp c r n ov te l (tac : 'a Ltac_plugin.Tacexpr.gen_atomic_tactic_expr) : _ = + ITac.gen_atomic_tactic_expr_to_yojson t d p rp c r n ov te l (_gen_atomic_tactic_expr_put tac) + +let gen_tactic_expr_to_yojson + t d p rp c r n ov te l (tac : 'a Ltac_plugin.Tacexpr.gen_tactic_expr) : Yojson.Safe.t = + ITac.gen_tactic_expr_to_yojson t d p rp c r n ov te l (_gen_tactic_expr_put tac) + +let gen_tactic_expr_of_yojson tac + t d p rp c r n ov te l : ('a Ltac_plugin.Tacexpr.gen_tactic_expr, _) result = + Result.map _gen_tactic_expr_get (ITac.gen_tactic_expr_of_yojson t d p rp c r n ov te l tac) + +let gen_atomic_tactic_expr_of_yojson tac + t d p rp c r n ov te l : ('a Ltac_plugin.Tacexpr.gen_atomic_tactic_expr, _) result = + Result.map _gen_atom_tactic_expr_get (ITac.gen_atomic_tactic_expr_of_yojson t d p rp c r n ov te l tac) + +(* Hash part for generic functions *) + +let hash_fold_gen_tactic_expr t d p rp c r n ov te l st tac = + ITac.hash_fold_gen_tactic_expr t d p rp c r n ov te l st (_gen_tactic_expr_put tac) + +let hash_fold_gen_atomic_tactic_expr t d p rp c r n ov te l st tac = + ITac.hash_fold_gen_atomic_tactic_expr t d p rp c r n ov te l st (_gen_atomic_tactic_expr_put tac) + +(* Compare part for generic functions *) + +let compare_gen_tactic_expr t d p rp c r n ov te l t1 t2 : int = + ITac.compare_gen_tactic_expr t d p rp c r n ov te l (_gen_tactic_expr_put t1) (_gen_tactic_expr_put t2) + +let compare_gen_atomic_tactic_expr t d p rp c r n ov te l t1 t2 = + ITac.compare_gen_atomic_tactic_expr t d p rp c r n ov te l (_gen_atomic_tactic_expr_put t1) (_gen_atomic_tactic_expr_put t2) + +(************************************************************************) +(* Main tactics types, we follow tacexpr and provide glob,raw, and *) +(* atomic *) +(************************************************************************) + +(* Glob *) +type glob_tactic_expr = Ltac_plugin.Tacexpr.glob_tactic_expr +type glob_atomic_tactic_expr = Ltac_plugin.Tacexpr.glob_atomic_tactic_expr + +let rec glob_tactic_expr_of_sexp tac = + gen_tactic_expr_of_sexp + tac + Genintern.glob_constr_and_expr_of_sexp + Genintern.glob_constr_and_expr_of_sexp + Genintern.glob_constr_pattern_and_expr_of_sexp + Genintern.glob_constr_and_expr_of_sexp + (Locus.or_var_of_sexp (Genredexpr.and_short_name_of_sexp Evaluable.t_of_sexp)) + (Locus.or_var_of_sexp (Loc.located_of_sexp ltac_constant_of_sexp)) + Names.lident_of_sexp + (Locus.or_var_of_sexp int_of_sexp) + glob_tactic_expr_of_sexp + Genarg.glevel_of_sexp +and glob_atomic_tactic_expr_of_sexp tac = + gen_atomic_tactic_expr_of_sexp + tac + Genintern.glob_constr_and_expr_of_sexp + Genintern.glob_constr_and_expr_of_sexp + Genintern.glob_constr_pattern_and_expr_of_sexp + Genintern.glob_constr_and_expr_of_sexp + (Locus.or_var_of_sexp (Genredexpr.and_short_name_of_sexp Evaluable.t_of_sexp)) + (Locus.or_var_of_sexp (Loc.located_of_sexp ltac_constant_of_sexp)) + Names.lident_of_sexp + (Locus.or_var_of_sexp int_of_sexp) + glob_tactic_expr_of_sexp + Genarg.glevel_of_sexp + +let rec sexp_of_glob_tactic_expr (tac : glob_tactic_expr) = + sexp_of_gen_tactic_expr + Genintern.sexp_of_glob_constr_and_expr + Genintern.sexp_of_glob_constr_and_expr + Genintern.sexp_of_glob_constr_pattern_and_expr + Genintern.sexp_of_glob_constr_and_expr + (Locus.sexp_of_or_var (Genredexpr.sexp_of_and_short_name Evaluable.sexp_of_t)) + (Locus.sexp_of_or_var (Loc.sexp_of_located sexp_of_ltac_constant)) + Names.sexp_of_lident + (Locus.sexp_of_or_var sexp_of_int) + sexp_of_glob_tactic_expr + Genarg.sexp_of_glevel + tac +and sexp_of_glob_atomic_tactic_expr (tac : glob_atomic_tactic_expr) = + sexp_of_gen_atomic_tactic_expr + Genintern.sexp_of_glob_constr_and_expr + Genintern.sexp_of_glob_constr_and_expr + Genintern.sexp_of_glob_constr_pattern_and_expr + Genintern.sexp_of_glob_constr_and_expr + (Locus.sexp_of_or_var (Genredexpr.sexp_of_and_short_name Evaluable.sexp_of_t)) + (Locus.sexp_of_or_var (Loc.sexp_of_located sexp_of_ltac_constant)) + Names.sexp_of_lident + (Locus.sexp_of_or_var sexp_of_int) + sexp_of_glob_tactic_expr + Genarg.sexp_of_glevel + tac + +let rec glob_tactic_expr_of_yojson tac = + gen_tactic_expr_of_yojson + tac + Genintern.glob_constr_and_expr_of_yojson + Genintern.glob_constr_and_expr_of_yojson + Genintern.glob_constr_pattern_and_expr_of_yojson + Genintern.glob_constr_and_expr_of_yojson + (Locus.or_var_of_yojson (Genredexpr.and_short_name_of_yojson Evaluable.of_yojson)) + (Locus.or_var_of_yojson (Loc.located_of_yojson ltac_constant_of_yojson)) + Names.lident_of_yojson + (Locus.or_var_of_yojson Ser_int.of_yojson) + glob_tactic_expr_of_yojson + Genarg.glevel_of_yojson +and glob_atomic_tactic_expr_of_yojson tac = + gen_atomic_tactic_expr_of_yojson + tac + Genintern.glob_constr_and_expr_of_yojson + Genintern.glob_constr_and_expr_of_yojson + Genintern.glob_constr_pattern_and_expr_of_yojson + Genintern.glob_constr_and_expr_of_yojson + (Locus.or_var_of_yojson (Genredexpr.and_short_name_of_yojson Evaluable.of_yojson)) + (Locus.or_var_of_yojson (Loc.located_of_yojson ltac_constant_of_yojson)) + Names.lident_of_yojson + (Locus.or_var_of_yojson Ser_int.of_yojson) + glob_tactic_expr_of_yojson + Genarg.glevel_of_yojson + +let rec glob_tactic_expr_to_yojson tac = + gen_tactic_expr_to_yojson + Genintern.glob_constr_and_expr_to_yojson + Genintern.glob_constr_and_expr_to_yojson + Genintern.glob_constr_pattern_and_expr_to_yojson + Genintern.glob_constr_and_expr_to_yojson + (Locus.or_var_to_yojson (Genredexpr.and_short_name_to_yojson Evaluable.to_yojson)) + (Locus.or_var_to_yojson (Loc.located_to_yojson ltac_constant_to_yojson)) + Names.lident_to_yojson + (Locus.or_var_to_yojson Ser_int.to_yojson) + glob_tactic_expr_to_yojson + Genarg.glevel_to_yojson + tac +and glob_atomic_tactic_expr_to_yojson tac = + gen_atomic_tactic_expr_to_yojson + Genintern.glob_constr_and_expr_to_yojson + Genintern.glob_constr_and_expr_to_yojson + Genintern.glob_constr_pattern_and_expr_to_yojson + Genintern.glob_constr_and_expr_to_yojson + (Locus.or_var_to_yojson (Genredexpr.and_short_name_to_yojson Evaluable.to_yojson)) + (Locus.or_var_to_yojson (Loc.located_to_yojson ltac_constant_to_yojson)) + Names.lident_to_yojson + (Locus.or_var_to_yojson Ser_int.to_yojson) + glob_tactic_expr_to_yojson + Genarg.glevel_to_yojson + tac + +let rec hash_fold_glob_tactic_expr st tac = + hash_fold_gen_tactic_expr + Genintern.hash_fold_glob_constr_and_expr + Genintern.hash_fold_glob_constr_and_expr + Genintern.hash_fold_glob_constr_pattern_and_expr + Genintern.hash_fold_glob_constr_and_expr + (Locus.hash_fold_or_var (Genredexpr.hash_fold_and_short_name Evaluable.hash_fold_t)) + (Locus.hash_fold_or_var (Loc.hash_fold_located hash_fold_ltac_constant)) + Names.hash_fold_lident + (Locus.hash_fold_or_var Ser_int.hash_fold_t) + hash_fold_glob_tactic_expr + Genarg.hash_fold_glevel + st tac +and hash_fold_glob_atomic_tactic_expr st tac = + hash_fold_gen_atomic_tactic_expr + Genintern.hash_fold_glob_constr_and_expr + Genintern.hash_fold_glob_constr_and_expr + Genintern.hash_fold_glob_constr_pattern_and_expr + Genintern.hash_fold_glob_constr_and_expr + (Locus.hash_fold_or_var (Genredexpr.hash_fold_and_short_name Evaluable.hash_fold_t)) + (Locus.hash_fold_or_var (Loc.hash_fold_located hash_fold_ltac_constant)) + Names.hash_fold_lident + (Locus.hash_fold_or_var Ser_int.hash_fold_t) + hash_fold_glob_tactic_expr + Genarg.hash_fold_glevel + st tac + +let hash_glob_tactic_expr = Ppx_hash_lib.Std.Hash.of_fold hash_fold_glob_tactic_expr +let hash_glob_atomic_tactic_expr = Ppx_hash_lib.Std.Hash.of_fold hash_fold_glob_atomic_tactic_expr + +let rec compare_glob_tactic_expr tac = + compare_gen_tactic_expr + Genintern.compare_glob_constr_and_expr + Genintern.compare_glob_constr_and_expr + Genintern.compare_glob_constr_pattern_and_expr + Genintern.compare_glob_constr_and_expr + (Locus.compare_or_var (Genredexpr.compare_and_short_name Evaluable.compare)) + (Locus.compare_or_var (Loc.compare_located compare_ltac_constant)) + Names.compare_lident + (Locus.compare_or_var Ser_int.compare) + compare_glob_tactic_expr + Genarg.compare_glevel + tac +and compare_glob_atomic_tactic_expr tac = + compare_gen_atomic_tactic_expr + Genintern.compare_glob_constr_and_expr + Genintern.compare_glob_constr_and_expr + Genintern.compare_glob_constr_pattern_and_expr + Genintern.compare_glob_constr_and_expr + (Locus.compare_or_var (Genredexpr.compare_and_short_name Evaluable.compare)) + (Locus.compare_or_var (Loc.compare_located compare_ltac_constant)) + Names.compare_lident + (Locus.compare_or_var Ser_int.compare) + compare_glob_tactic_expr + Genarg.compare_glevel + tac + +(* Raw *) +type raw_tactic_expr = Ltac_plugin.Tacexpr.raw_tactic_expr +type raw_atomic_tactic_expr = Ltac_plugin.Tacexpr.raw_atomic_tactic_expr + +let rec raw_tactic_expr_of_sexp tac = + gen_tactic_expr_of_sexp + tac + Constrexpr.constr_expr_of_sexp + Constrexpr.constr_expr_of_sexp + Constrexpr.constr_pattern_expr_of_sexp + Constrexpr.constr_expr_of_sexp + (Constrexpr.or_by_notation_of_sexp Libnames.qualid_of_sexp) + Libnames.qualid_of_sexp + Names.lident_of_sexp + (Locus.or_var_of_sexp Ser_int.t_of_sexp) + raw_tactic_expr_of_sexp + Genarg.rlevel_of_sexp +and raw_atomic_tactic_expr_of_sexp tac = + gen_atomic_tactic_expr_of_sexp + tac + Constrexpr.constr_expr_of_sexp + Constrexpr.constr_expr_of_sexp + Constrexpr.constr_pattern_expr_of_sexp + Constrexpr.constr_expr_of_sexp + (Constrexpr.or_by_notation_of_sexp Libnames.qualid_of_sexp) + Libnames.qualid_of_sexp + Names.lident_of_sexp + (Locus.or_var_of_sexp Ser_int.t_of_sexp) + raw_tactic_expr_of_sexp + Genarg.rlevel_of_sexp + +let rec sexp_of_raw_tactic_expr (tac : raw_tactic_expr) = + sexp_of_gen_tactic_expr + Constrexpr.sexp_of_constr_expr + Constrexpr.sexp_of_constr_expr + Constrexpr.sexp_of_constr_pattern_expr + Constrexpr.sexp_of_constr_expr + (Constrexpr.sexp_of_or_by_notation Libnames.sexp_of_qualid) + Libnames.sexp_of_qualid + Names.sexp_of_lident + (Locus.sexp_of_or_var Ser_int.sexp_of_t) + sexp_of_raw_tactic_expr + Genarg.sexp_of_rlevel + tac +and sexp_of_raw_atomic_tactic_expr tac = + sexp_of_gen_atomic_tactic_expr + Constrexpr.sexp_of_constr_expr + Constrexpr.sexp_of_constr_expr + Constrexpr.sexp_of_constr_pattern_expr + Constrexpr.sexp_of_constr_expr + (Constrexpr.sexp_of_or_by_notation Libnames.sexp_of_qualid) + Libnames.sexp_of_qualid + Names.sexp_of_lident + (Locus.sexp_of_or_var Ser_int.sexp_of_t) + sexp_of_raw_tactic_expr + Genarg.sexp_of_rlevel + tac + +(* Yojson *) +let rec raw_tactic_expr_of_yojson tac = + gen_tactic_expr_of_yojson + tac + Constrexpr.constr_expr_of_yojson + Constrexpr.constr_expr_of_yojson + Constrexpr.constr_pattern_expr_of_yojson + Constrexpr.constr_expr_of_yojson + (Constrexpr.or_by_notation_of_yojson Libnames.qualid_of_yojson) + Libnames.qualid_of_yojson + Names.lident_of_yojson + (Locus.or_var_of_yojson Ser_int.of_yojson) + raw_tactic_expr_of_yojson + Genarg.rlevel_of_yojson +and raw_atomic_tactic_expr_of_yojson tac = + gen_atomic_tactic_expr_of_yojson + tac + Constrexpr.constr_expr_of_yojson + Constrexpr.constr_expr_of_yojson + Constrexpr.constr_pattern_expr_of_yojson + Constrexpr.constr_expr_of_yojson + (Constrexpr.or_by_notation_of_yojson Libnames.qualid_of_yojson) + Libnames.qualid_of_yojson + Names.lident_of_yojson + (Locus.or_var_of_yojson Ser_int.of_yojson) + raw_tactic_expr_of_yojson + Genarg.rlevel_of_yojson + +let rec raw_tactic_expr_to_yojson (tac : raw_tactic_expr) = + gen_tactic_expr_to_yojson + Constrexpr.constr_expr_to_yojson + Constrexpr.constr_expr_to_yojson + Constrexpr.constr_pattern_expr_to_yojson + Constrexpr.constr_expr_to_yojson + (Constrexpr.or_by_notation_to_yojson Libnames.qualid_to_yojson) + Libnames.qualid_to_yojson + Names.lident_to_yojson + (Locus.or_var_to_yojson Ser_int.to_yojson) + raw_tactic_expr_to_yojson + Genarg.rlevel_to_yojson + tac +and raw_atomic_tactic_expr_to_yojson tac = + gen_atomic_tactic_expr_to_yojson + Constrexpr.constr_expr_to_yojson + Constrexpr.constr_expr_to_yojson + Constrexpr.constr_pattern_expr_to_yojson + Constrexpr.constr_expr_to_yojson + (Constrexpr.or_by_notation_to_yojson Libnames.qualid_to_yojson) + Libnames.qualid_to_yojson + Names.lident_to_yojson + (Locus.or_var_to_yojson Ser_int.to_yojson) + raw_tactic_expr_to_yojson + Genarg.rlevel_to_yojson + tac + +let rec hash_fold_raw_tactic_expr st tac = + hash_fold_gen_tactic_expr + Constrexpr.hash_fold_constr_expr + Constrexpr.hash_fold_constr_expr + Constrexpr.hash_fold_constr_pattern_expr + Constrexpr.hash_fold_constr_expr + (Constrexpr.hash_fold_or_by_notation Libnames.hash_fold_qualid) + Libnames.hash_fold_qualid + Names.hash_fold_lident + (Locus.hash_fold_or_var Ser_int.hash_fold_t) + hash_fold_raw_tactic_expr + Genarg.hash_fold_rlevel + st tac +and hash_fold_raw_atomic_tactic_expr st tac = + hash_fold_gen_atomic_tactic_expr + Constrexpr.hash_fold_constr_expr + Constrexpr.hash_fold_constr_expr + Constrexpr.hash_fold_constr_pattern_expr + Constrexpr.hash_fold_constr_expr + (Constrexpr.hash_fold_or_by_notation Libnames.hash_fold_qualid) + Libnames.hash_fold_qualid + Names.hash_fold_lident + (Locus.hash_fold_or_var Ser_int.hash_fold_t) + hash_fold_raw_tactic_expr + Genarg.hash_fold_rlevel + st tac + +let hash_raw_tactic_expr = Ppx_hash_lib.Std.Hash.of_fold hash_fold_raw_tactic_expr +let hash_raw_atomic_tactic_expr = Ppx_hash_lib.Std.Hash.of_fold hash_fold_raw_atomic_tactic_expr + +let rec compare_raw_tactic_expr tac = + compare_gen_tactic_expr + Constrexpr.compare_constr_expr + Constrexpr.compare_constr_expr + Constrexpr.compare_constr_pattern_expr + Constrexpr.compare_constr_expr + (Constrexpr.compare_or_by_notation Libnames.compare_qualid) + Libnames.compare_qualid + Names.compare_lident + (Locus.compare_or_var Ser_int.compare) + compare_raw_tactic_expr + Genarg.compare_rlevel + tac +and compare_raw_atomic_tactic_expr tac = + compare_gen_atomic_tactic_expr + Constrexpr.compare_constr_expr + Constrexpr.compare_constr_expr + Constrexpr.compare_constr_pattern_expr + Constrexpr.compare_constr_expr + (Constrexpr.compare_or_by_notation Libnames.compare_qualid) + Libnames.compare_qualid + Names.compare_lident + (Locus.compare_or_var Ser_int.compare) + compare_raw_tactic_expr + Genarg.compare_rlevel + tac + +(* Atomic *) +type atomic_tactic_expr = Ltac_plugin.Tacexpr.atomic_tactic_expr + +let atomic_tactic_expr_of_sexp tac = + gen_atomic_tactic_expr_of_sexp tac + EConstr.t_of_sexp + Genintern.glob_constr_and_expr_of_sexp + Pattern.constr_pattern_of_sexp + Pattern.constr_pattern_of_sexp + Evaluable.t_of_sexp + (Loc.located_of_sexp ltac_constant_of_sexp) + Names.Id.t_of_sexp + Ser_int.t_of_sexp + unit_of_sexp + Genarg.tlevel_of_sexp + +let sexp_of_atomic_tactic_expr tac = + sexp_of_gen_atomic_tactic_expr + EConstr.sexp_of_t + Genintern.sexp_of_glob_constr_and_expr + Pattern.sexp_of_constr_pattern + Pattern.sexp_of_constr_pattern + Evaluable.sexp_of_t + (Loc.sexp_of_located sexp_of_ltac_constant) + Names.Id.sexp_of_t + Ser_int.sexp_of_t + sexp_of_unit + Genarg.sexp_of_tlevel + tac + +(* Helpers for raw_red_expr *) +type tacdef_body = + [%import: Ltac_plugin.Tacexpr.tacdef_body] + [@@deriving sexp,yojson,hash,compare] + +(* Unsupported serializers *) +type intro_pattern = + [%import: Ltac_plugin.Tacexpr.intro_pattern] + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib/plugins/ltac/ser_tacexpr.mli b/serlib/plugins/ltac/ser_tacexpr.mli new file mode 100644 index 00000000..1ec73a81 --- /dev/null +++ b/serlib/plugins/ltac/ser_tacexpr.mli @@ -0,0 +1,288 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* direction_flag +val sexp_of_direction_flag : direction_flag -> Sexp.t + +type lazy_flag = Tacexpr.lazy_flag = General | Select | Once +val lazy_flag_of_sexp : Sexp.t -> lazy_flag +val sexp_of_lazy_flag : lazy_flag -> Sexp.t + +type global_flag = Tacexpr.global_flag = TacGlobal | TacLocal +val global_flag_of_sexp : Sexp.t -> global_flag +val sexp_of_global_flag : global_flag -> Sexp.t + +type evars_flag = bool +val evars_flag_of_sexp : Sexp.t -> evars_flag +val sexp_of_evars_flag : evars_flag -> Sexp.t + +type rec_flag = bool +val rec_flag_of_sexp : Sexp.t -> rec_flag +val sexp_of_rec_flag : rec_flag -> Sexp.t + +type advanced_flag = bool +val advanced_flag_of_sexp : Sexp.t -> advanced_flag +val sexp_of_advanced_flag : advanced_flag -> Sexp.t + +type letin_flag = bool +val letin_flag_of_sexp : Sexp.t -> letin_flag +val sexp_of_letin_flag : letin_flag -> Sexp.t + +type clear_flag = bool option +val clear_flag_of_sexp : Sexp.t -> clear_flag +val sexp_of_clear_flag : clear_flag -> Sexp.t + +(* type debug = Tacexpr.debug = Debug | Info | Off *) +(* val debug_of_sexp : Sexp.t -> debug *) +(* val sexp_of_debug : debug -> Sexp.t *) + +(* type goal_selector = Tacexpr.goal_selector *) +(* val goal_selector_of_sexp : Sexp.t -> goal_selector *) +(* val sexp_of_goal_selector : goal_selector -> Sexp.t *) + +type ('c, 'd, 'id) inversion_strength = ('c, 'd, 'id) Tacexpr.inversion_strength + +val inversion_strength_of_sexp : + (Sexp.t -> 'c) -> + (Sexp.t -> 'd) -> + (Sexp.t -> 'id) -> + Sexp.t -> ('c, 'd, 'id) inversion_strength + +val sexp_of_inversion_strength : + ('c -> Sexp.t) -> + ('d -> Sexp.t) -> + ('id -> Sexp.t) -> + ('c, 'd, 'id) inversion_strength -> Sexp.t + +type 'id message_token = 'id Tacexpr.message_token + +val message_token_of_sexp : + (Sexp.t -> 'id) -> Sexp.t -> 'id message_token + +val sexp_of_message_token : + ('id -> Sexp.t) -> 'id message_token -> Sexp.t + +type ('dconstr, 'id) induction_clause = ('dconstr, 'id) Tacexpr.induction_clause + +val induction_clause_of_sexp : + (Sexp.t -> 'dconstr) -> + (Sexp.t -> 'id) -> + Sexp.t -> ('dconstr, 'id) induction_clause + +val sexp_of_induction_clause : + ('dconstr -> Sexp.t) -> + ('id -> Sexp.t) -> + ('dconstr, 'id) induction_clause -> Sexp.t + + +type ('constr, 'dconstr, 'id) induction_clause_list = + ('constr, 'dconstr, 'id) Tacexpr.induction_clause_list + +val induction_clause_list_of_sexp : + (Sexp.t -> 'constr) -> + (Sexp.t -> 'dconstr) -> + (Sexp.t -> 'id) -> + Sexp.t -> ('constr, 'dconstr, 'id) induction_clause_list + +val sexp_of_induction_clause_list : + ('constr -> Sexp.t) -> + ('dconstr -> Sexp.t) -> + ('id -> Sexp.t) -> + ('constr, 'dconstr, 'id) induction_clause_list -> Sexp.t + +type 'a with_bindings_arg = 'a Tacexpr.with_bindings_arg + +val with_bindings_arg_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a with_bindings_arg +val sexp_of_with_bindings_arg : ('a -> Sexp.t) -> 'a with_bindings_arg -> Sexp.t + +(* type multi = Tacexpr.multi *) +(* val multi_of_sexp : Sexp.t -> multi *) +(* val sexp_of_multi : multi -> Sexp.t *) + +type 'a match_pattern = 'a Tacexpr.match_pattern + +val match_pattern_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a match_pattern +val sexp_of_match_pattern : ('a -> Sexp.t) -> 'a match_pattern -> Sexp.t + +type 'a match_context_hyps = 'a Tacexpr.match_context_hyps + +val match_context_hyps_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a match_context_hyps +val sexp_of_match_context_hyps : ('a -> Sexp.t) -> 'a match_context_hyps -> Sexp.t + +type ('a, 't) match_rule = ('a, 't) Tacexpr.match_rule + +val match_rule_of_sexp : + (Sexp.t -> 'a) -> + (Sexp.t -> 't) -> Sexp.t -> ('a, 't) match_rule +val sexp_of_match_rule : + ('a -> Sexp.t) -> + ('t -> Sexp.t) -> ('a, 't) match_rule -> Sexp.t + +type ml_tactic_name = Tacexpr.ml_tactic_name + +val ml_tactic_name_of_sexp : Sexp.t -> ml_tactic_name +val sexp_of_ml_tactic_name : ml_tactic_name -> Sexp.t + +type 'd gen_atomic_tactic_expr = 'd Tacexpr.gen_atomic_tactic_expr + +val sexp_of_gen_atomic_tactic_expr : + ('a -> Sexplib.Sexp.t) -> + ('c -> Sexplib.Sexp.t) -> + ('d -> Sexplib.Sexp.t) -> + ('rp -> Sexplib.Sexp.t) -> + ('e -> Sexplib.Sexp.t) -> + ('f -> Sexplib.Sexp.t) -> + ('g -> Sexplib.Sexp.t) -> + ('occvar -> Sexplib.Sexp.t) -> + ('h -> Sexplib.Sexp.t) -> + ('i -> Sexplib.Sexp.t) -> + < occvar : 'occvar; red_pattern : 'rp; constant : 'e; dterm : 'c; level : 'i; name : 'g; pattern : 'd; + reference : 'f; tacexpr : 'h; term : 'a; > + Tacexpr.gen_atomic_tactic_expr -> Sexplib.Sexp.t +val sexp_of_gen_tactic_expr : + ('a -> Sexplib.Sexp.t) -> + ('c -> Sexplib.Sexp.t) -> + ('d -> Sexplib.Sexp.t) -> + ('rp -> Sexplib.Sexp.t) -> + ('e -> Sexplib.Sexp.t) -> + ('f -> Sexplib.Sexp.t) -> + ('g -> Sexplib.Sexp.t) -> + ('occvar -> Sexplib.Sexp.t) -> + ('h -> Sexplib.Sexp.t) -> + ('i -> Sexplib.Sexp.t) -> + < occvar : 'occvar; red_pattern : 'rp; constant : 'e; dterm : 'c; level : 'i; name : 'g; pattern : 'd; + reference : 'f; tacexpr : 'h; term : 'a; > + Tacexpr.gen_tactic_expr -> Sexplib.Sexp.t +val sexp_of_gen_tactic_arg : + ('a -> Sexplib.Sexp.t) -> + ('c -> Sexplib.Sexp.t) -> + ('d -> Sexplib.Sexp.t) -> + ('rp -> Sexplib.Sexp.t) -> + ('e -> Sexplib.Sexp.t) -> + ('f -> Sexplib.Sexp.t) -> + ('g -> Sexplib.Sexp.t) -> + ('occvar -> Sexplib.Sexp.t) -> + ('h -> Sexplib.Sexp.t) -> + ('i -> Sexplib.Sexp.t) -> + < occvar : 'occvar; red_pattern : 'rp; constant : 'e; dterm : 'c; level : 'i; name : 'g; pattern : 'd; + reference : 'f; tacexpr : 'h; term : 'a; > + Tacexpr.gen_tactic_arg -> Sexplib.Sexp.t +val sexp_of_gen_fun_ast : + ('a -> Sexplib.Sexp.t) -> + ('c -> Sexplib.Sexp.t) -> + ('d -> Sexplib.Sexp.t) -> + ('rp -> Sexplib.Sexp.t) -> + ('e -> Sexplib.Sexp.t) -> + ('f -> Sexplib.Sexp.t) -> + ('g -> Sexplib.Sexp.t) -> + ('occvar -> Sexplib.Sexp.t) -> + ('h -> Sexplib.Sexp.t) -> + ('i -> Sexplib.Sexp.t) -> + < occvar : 'occvar; red_pattern : 'rp; constant : 'e; dterm : 'c; level : 'i; name : 'g; pattern : 'd; + reference : 'f; tacexpr : 'h; term : 'a; > + Tacexpr.gen_tactic_fun_ast -> Sexplib.Sexp.t + +val gen_atomic_tactic_expr_of_sexp : + Sexplib.Sexp.t -> + (Sexplib.Sexp.t -> 'a) -> + (Sexplib.Sexp.t -> 'c) -> + (Sexplib.Sexp.t -> 'd) -> + (Sexplib.Sexp.t -> 'rp) -> + (Sexplib.Sexp.t -> 'e) -> + (Sexplib.Sexp.t -> 'f) -> + (Sexplib.Sexp.t -> 'g) -> + (Sexplib.Sexp.t -> 'occvar) -> + (Sexplib.Sexp.t -> 'h) -> + (Sexplib.Sexp.t -> 'i) -> + < occvar : 'occvar; red_pattern : 'rp; constant : 'e; dterm : 'c; level : 'i; name : 'g; pattern : 'd; + reference : 'f; tacexpr : 'h; term : 'a; > + Tacexpr.gen_atomic_tactic_expr + +val gen_tactic_expr_of_sexp : + Sexplib.Sexp.t -> + (Sexplib.Sexp.t -> 'a) -> + (Sexplib.Sexp.t -> 'c) -> + (Sexplib.Sexp.t -> 'd) -> + (Sexplib.Sexp.t -> 'rp) -> + (Sexplib.Sexp.t -> 'e) -> + (Sexplib.Sexp.t -> 'f) -> + (Sexplib.Sexp.t -> 'g) -> + (Sexplib.Sexp.t -> 'occvar) -> + (Sexplib.Sexp.t -> 'h) -> + (Sexplib.Sexp.t -> 'i) -> + < occvar : 'occvar; red_pattern : 'rp; constant : 'e; dterm : 'c; level : 'i; name : 'g; pattern : 'd; + reference : 'f; tacexpr : 'h; term : 'a; > + Tacexpr.gen_tactic_expr + +val gen_tactic_arg_of_sexp : + Sexplib.Sexp.t -> + (Sexplib.Sexp.t -> 'a) -> + (Sexplib.Sexp.t -> 'c) -> + (Sexplib.Sexp.t -> 'd) -> + (Sexplib.Sexp.t -> 'rp) -> + (Sexplib.Sexp.t -> 'e) -> + (Sexplib.Sexp.t -> 'f) -> + (Sexplib.Sexp.t -> 'g) -> + (Sexplib.Sexp.t -> 'occvar) -> + (Sexplib.Sexp.t -> 'h) -> + (Sexplib.Sexp.t -> 'i) -> + < occvar : 'occvar; red_pattern : 'rp; constant : 'e; dterm : 'c; level : 'i; name : 'g; pattern : 'd; + reference : 'f; tacexpr : 'h; term : 'a; > + Tacexpr.gen_tactic_arg + +val gen_fun_ast_of_sexp : + Sexplib.Sexp.t -> + (Sexplib.Sexp.t -> 'a) -> + (Sexplib.Sexp.t -> 'c) -> + (Sexplib.Sexp.t -> 'd) -> + (Sexplib.Sexp.t -> 'rp) -> + (Sexplib.Sexp.t -> 'e) -> + (Sexplib.Sexp.t -> 'f) -> + (Sexplib.Sexp.t -> 'g) -> + (Sexplib.Sexp.t -> 'occvar) -> + (Sexplib.Sexp.t -> 'h) -> + (Sexplib.Sexp.t -> 'i) -> + < occvar : 'occvar; red_pattern : 'rp; constant : 'e; dterm : 'c; level : 'i; name : 'g; pattern : 'd; + reference : 'f; tacexpr : 'h; term : 'a; > + Tacexpr.gen_tactic_fun_ast + +type glob_tactic_expr = Tacexpr.glob_tactic_expr + [@@deriving sexp,yojson,hash,compare] + +type glob_atomic_tactic_expr = Tacexpr.glob_atomic_tactic_expr + [@@deriving sexp,yojson,hash,compare] + +type raw_tactic_expr = Tacexpr.raw_tactic_expr + [@@deriving sexp,yojson,hash,compare] + +type raw_atomic_tactic_expr = Tacexpr.raw_atomic_tactic_expr + [@@deriving sexp,yojson,hash,compare] + +type atomic_tactic_expr = Tacexpr.atomic_tactic_expr +val atomic_tactic_expr_of_sexp : Sexp.t -> atomic_tactic_expr +val sexp_of_atomic_tactic_expr : atomic_tactic_expr -> Sexp.t + +type tacdef_body = Tacexpr.tacdef_body + [@@deriving sexp,hash,compare] + +type intro_pattern = Tacexpr.intro_pattern + [@@deriving sexp,hash,compare] diff --git a/serlib/plugins/ltac2/dune b/serlib/plugins/ltac2/dune new file mode 100644 index 00000000..fe468ad6 --- /dev/null +++ b/serlib/plugins/ltac2/dune @@ -0,0 +1,12 @@ +(library + (name serlib_ltac2) + (public_name coq-lsp.serlib.ltac2) + (synopsis "Serialization Library for Coq [LTAC2 plugin]") + (preprocess + (staged_pps + ppx_import + ppx_sexp_conv + ppx_deriving_yojson + ppx_hash + ppx_compare)) + (libraries coq-core.plugins.ltac2 serlib sexplib)) diff --git a/serlib/plugins/ltac2/ser_g_ltac2.ml b/serlib/plugins/ltac2/ser_g_ltac2.ml new file mode 100644 index 00000000..5498267d --- /dev/null +++ b/serlib/plugins/ltac2/ser_g_ltac2.ml @@ -0,0 +1,35 @@ +(************************************************************************) +(* SerAPI: Coq interaction protocol with bidirectional serialization *) +(************************************************************************) +(* Copyright 2016-2019 MINES ParisTech -- License LGPL 2.1+ *) +(* Copyright 2019-2023 Inria -- License LGPL 2.1+ *) +(* Written by: Emilio J. Gallego Arias and others *) +(************************************************************************) + +open Serlib +open Ltac2_plugin + +module Tac2expr = Ser_tac2expr + +(* val Ltac2_plugin.G_ltac2.wit_ltac2_entry: + (Ltac2_plugin.Tac2expr.strexpr, unit, unit) Genarg.genarg_type *) +module L2Entry = struct + type t = Tac2expr.strexpr + [@@deriving sexp,hash,compare] +end + +let ser_wit_ltac2_entry = let module M = Ser_genarg.GSV(L2Entry) in M.genser + +module L2Expr = struct + type t = Tac2expr.raw_tacexpr + [@@deriving sexp,hash,compare] +end + +let ser_wit_ltac2_expr = let module M = Ser_genarg.GSV(L2Expr) in M.genser + +let register () = + Ser_genarg.register_genser G_ltac2.wit_ltac2_entry ser_wit_ltac2_entry; + Ser_genarg.register_genser G_ltac2.wit_ltac2_expr ser_wit_ltac2_expr; + () + +let () = register () diff --git a/serlib/plugins/ltac2/ser_tac2env.ml b/serlib/plugins/ltac2/ser_tac2env.ml new file mode 100644 index 00000000..c5d5dd0c --- /dev/null +++ b/serlib/plugins/ltac2/ser_tac2env.ml @@ -0,0 +1,89 @@ +(************************************************************************) +(* SerAPI: Coq interaction protocol with bidirectional serialization *) +(************************************************************************) +(* Copyright 2016-2019 MINES ParisTech -- License LGPL 2.1+ *) +(* Copyright 2019-2023 Inria -- License LGPL 2.1+ *) +(* Written by: Emilio J. Gallego Arias and others *) +(************************************************************************) + +open Serlib +open Ltac2_plugin + +open Sexplib.Std +open Ppx_hash_lib.Std.Hash.Builtin +open Ppx_compare_lib.Builtin + +module Util = Ser_util +module Loc = Ser_loc +module CAst = Ser_cAst +module Names = Ser_names +module Tac2expr = Ser_tac2expr + +module WL2in1 = struct + type raw = Tac2expr.uid CAst.t list * Tac2expr.raw_tacexpr + [@@deriving sexp,hash,compare] + type glb = Tac2expr.uid list * Tac2expr.glb_tacexpr + [@@deriving sexp,hash,compare] + type top = Util.Empty.t + [@@deriving sexp,hash,compare] +end + +let ser_wit_ltac2in1 = let module M = Ser_genarg.GS(WL2in1) in M.genser + +module WL2in1V = struct + type raw = Tac2expr.uid CAst.t list * Tac2expr.raw_tacexpr + [@@deriving sexp,hash,compare] + type glb = Tac2expr.glb_tacexpr + [@@deriving sexp,hash,compare] + type top = Util.Empty.t + [@@deriving sexp,hash,compare] +end + +let ser_wit_ltac2in1_val = let module M = Ser_genarg.GS(WL2in1V) in M.genser + +module WLC2 = struct + type raw = Tac2expr.raw_tacexpr + [@@deriving sexp,hash,compare] + type glb = Names.Id.Set.t * Tac2expr.glb_tacexpr + [@@deriving sexp,hash,compare] + type top = Util.Empty.t + [@@deriving sexp,hash,compare] +end + +let ser_wit_ltac2_constr = let module M = Ser_genarg.GS(WLC2) in M.genser + +type var_quotation_kind = + [%import: Ltac2_plugin.Tac2env.var_quotation_kind] + [@@deriving sexp,yojson,hash,compare] + +module WLQ2 = struct + type raw = Names.lident option * Names.lident + [@@deriving sexp,hash,compare] + type glb = var_quotation_kind * Names.Id.t + [@@deriving sexp,hash,compare] + type top = Util.Empty.t + [@@deriving sexp,hash,compare] +end + +let ser_wit_ltac2_var_quotation = let module M = Ser_genarg.GS(WLQ2) in M.genser + +module WLV2 = struct + type raw = Util.Empty.t + [@@deriving sexp,hash,compare] + type glb = unit + [@@deriving sexp,hash,compare] + type top = Util.Empty.t + [@@deriving sexp,hash,compare] +end + +let ser_wit_ltac2_val = let module M = Ser_genarg.GS(WLV2) in M.genser + +let register () = + Ser_genarg.register_genser Tac2env.wit_ltac2in1 ser_wit_ltac2in1; + Ser_genarg.register_genser Tac2env.wit_ltac2in1_val ser_wit_ltac2in1_val; + Ser_genarg.register_genser Tac2env.wit_ltac2_constr ser_wit_ltac2_constr; + Ser_genarg.register_genser Tac2env.wit_ltac2_var_quotation ser_wit_ltac2_var_quotation; + Ser_genarg.register_genser Tac2env.wit_ltac2_val ser_wit_ltac2_val; + () + +let () = register () diff --git a/serlib/plugins/ltac2/ser_tac2expr.ml b/serlib/plugins/ltac2/ser_tac2expr.ml new file mode 100644 index 00000000..65eb5a41 --- /dev/null +++ b/serlib/plugins/ltac2/ser_tac2expr.ml @@ -0,0 +1,202 @@ +(************************************************************************) +(* SerAPI: Coq interaction protocol with bidirectional serialization *) +(************************************************************************) +(* Copyright 2016-2019 MINES ParisTech -- License LGPL 2.1+ *) +(* Copyright 2019-2023 Inria -- License LGPL 2.1+ *) +(* Written by: Emilio J. Gallego Arias and others *) +(************************************************************************) + +open Serlib + +module Loc = Ser_loc +module CAst = Ser_cAst +module Names = Ser_names +module Libnames = Ser_libnames + +open Sexplib.Std +open Ppx_hash_lib.Std.Hash.Builtin +open Ppx_compare_lib.Builtin + +let hash_fold_array = hash_fold_array_frozen + +type mutable_flag = + [%import: Ltac2_plugin.Tac2expr.mutable_flag] + [@@deriving sexp,yojson,hash,compare] + +type uid = + [%import: Ltac2_plugin.Tac2expr.uid] + [@@deriving sexp,yojson,hash,compare] + +type lid = + [%import: Ltac2_plugin.Tac2expr.lid] + [@@deriving sexp,yojson,hash,compare] + +type rec_flag = + [%import: Ltac2_plugin.Tac2expr.rec_flag] + [@@deriving sexp,yojson,hash,compare] + +type redef_flag = + [%import: Ltac2_plugin.Tac2expr.redef_flag] + [@@deriving sexp,yojson,hash,compare] + +type 'a or_relid = + [%import: 'a Ltac2_plugin.Tac2expr.or_relid] + [@@deriving sexp,yojson,hash,compare] + +type 'a or_tuple = + [%import: 'a Ltac2_plugin.Tac2expr.or_tuple] + [@@deriving sexp,yojson,hash,compare] + +type type_constant = + [%import: Ltac2_plugin.Tac2expr.type_constant] + [@@deriving sexp,yojson,hash,compare] + +type raw_typexpr_r = + [%import: Ltac2_plugin.Tac2expr.raw_typexpr_r] + [@@deriving sexp,yojson,hash,compare] +and raw_typexpr = + [%import: Ltac2_plugin.Tac2expr.raw_typexpr] + [@@deriving sexp,yojson,hash,compare] + +type raw_typedef = + [%import: Ltac2_plugin.Tac2expr.raw_typedef] + [@@deriving sexp,yojson,hash,compare] + +type raw_quant_typedef = + [%import: Ltac2_plugin.Tac2expr.raw_quant_typedef] + [@@deriving sexp,yojson,hash,compare] + +type 'a glb_typexpr = + [%import: 'a Ltac2_plugin.Tac2expr.glb_typexpr] + [@@deriving sexp,yojson,hash,compare] + +type atom = + [%import: Ltac2_plugin.Tac2expr.atom] + [@@deriving sexp,yojson,hash,compare] + +type ltac_constant = + [%import: Ltac2_plugin.Tac2expr.ltac_constant] + [@@deriving sexp,yojson,hash,compare] + +type ltac_alias = + [%import: Ltac2_plugin.Tac2expr.ltac_alias] + [@@deriving sexp,yojson,hash,compare] + +type ltac_constructor = + [%import: Ltac2_plugin.Tac2expr.ltac_constructor] + [@@deriving sexp,yojson,hash,compare] + +type ltac_projection = + [%import: Ltac2_plugin.Tac2expr.ltac_projection] + [@@deriving sexp,yojson,hash,compare] + +type raw_patexpr = + [%import: Ltac2_plugin.Tac2expr.raw_patexpr] + [@@deriving sexp,yojson,hash,compare] +and raw_patexpr_r = + [%import: Ltac2_plugin.Tac2expr.raw_patexpr_r] + [@@deriving sexp,yojson,hash,compare] + +type tacref = + [%import: Ltac2_plugin.Tac2expr.tacref] + [@@deriving sexp,yojson,hash,compare] + +type ml_tactic_name = + [%import: Ltac2_plugin.Tac2expr.ml_tactic_name] + [@@deriving sexp,yojson,hash,compare] + +type sexpr = + [%import: Ltac2_plugin.Tac2expr.sexpr] + [@@deriving sexp,yojson,hash,compare] + +type ctor_indx = + [%import: Ltac2_plugin.Tac2expr.ctor_indx] + [@@deriving sexp,yojson,hash,compare] + +type ctor_data_for_patterns = + [%import: Ltac2_plugin.Tac2expr.ctor_data_for_patterns] + [@@deriving sexp,yojson,hash,compare] + +type glb_pat = + [%import: Ltac2_plugin.Tac2expr.glb_pat] + [@@deriving sexp,yojson,hash,compare] + +type case_info = + [%import: Ltac2_plugin.Tac2expr.case_info] + [@@deriving sexp,yojson,hash,compare] + +type 'a open_match = + [%import: 'a Ltac2_plugin.Tac2expr.open_match] + [@@deriving sexp,yojson,hash,compare] + +module ObjS = struct type t = Obj.t let name = "Obj.t" end +module Obj = SerType.Opaque(ObjS) + +module GT2ESpec = struct + type t = Ltac2_plugin.Tac2expr.glb_tacexpr + open Ltac2_plugin.Tac2expr + type _t = + | GTacAtm of atom + | GTacVar of Names.Id.t + | GTacRef of ltac_constant + | GTacFun of Names.Name.t list * _t + | GTacApp of _t * _t list + | GTacLet of rec_flag * (Names.Name.t * _t) list * _t + | GTacCst of case_info * int * _t list + | GTacCse of _t * case_info * _t array * (Names.Name.t array * _t) array + | GTacPrj of type_constant * _t * int + | GTacSet of type_constant * _t * int * _t + | GTacOpn of ltac_constructor * _t list + | GTacWth of _t open_match + | GTacFullMatch of _t * (glb_pat * _t) list + | GTacExt of int * Obj.t + | GTacPrm of ml_tactic_name + [@@deriving sexp,yojson,hash,compare] + +end + +module GT2E = Serlib.SerType.Pierce(GT2ESpec) +type glb_tacexpr = GT2E.t + [@@deriving sexp,yojson,hash,compare] + +module T2ESpec = struct + type t = Ltac2_plugin.Tac2expr.raw_tacexpr_r + open Ltac2_plugin.Tac2expr + type _t = + | CTacAtm of atom + | CTacRef of tacref or_relid + | CTacCst of ltac_constructor or_tuple or_relid + | CTacFun of raw_patexpr list * raw_tacexpr + | CTacApp of raw_tacexpr * raw_tacexpr list + | CTacSyn of (Names.lname * raw_tacexpr) list * Names.KerName.t + | CTacLet of rec_flag * (raw_patexpr * raw_tacexpr) list * Names.KerName.t + | CTacCnv of raw_tacexpr * raw_typexpr + | CTacSeq of raw_tacexpr * raw_tacexpr + | CTacIft of raw_tacexpr * raw_tacexpr * raw_tacexpr + | CTacCse of raw_tacexpr * raw_taccase list + | CTacRec of raw_tacexpr option * raw_recexpr + | CTacPrj of raw_tacexpr * ltac_projection or_relid + | CTacSet of raw_tacexpr * ltac_projection or_relid * raw_tacexpr + | CTacExt of int * Obj.t + | CTacGlb of int * (Names.lname * raw_tacexpr * int glb_typexpr option) list * glb_tacexpr * int glb_typexpr + + and raw_tacexpr = _t CAst.t + and raw_taccase = + [%import: Ltac2_plugin.Tac2expr.raw_taccase] + and raw_recexpr = + [%import: Ltac2_plugin.Tac2expr.raw_recexpr] + [@@deriving sexp,yojson,hash,compare] + +end + +module T2E = Serlib.SerType.Pierce(T2ESpec) +type raw_tacexpr_r = T2E.t + [@@deriving sexp,yojson,hash,compare] + +type raw_tacexpr = + [%import: Ltac2_plugin.Tac2expr.raw_tacexpr] + [@@deriving sexp,yojson,hash,compare] + +type strexpr = + [%import: Ltac2_plugin.Tac2expr.strexpr] + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib/plugins/ltac2/ser_tac2quote.ml b/serlib/plugins/ltac2/ser_tac2quote.ml new file mode 100644 index 00000000..39008770 --- /dev/null +++ b/serlib/plugins/ltac2/ser_tac2quote.ml @@ -0,0 +1,27 @@ +(************************************************************************) +(* SerAPI: Coq interaction protocol with bidirectional serialization *) +(************************************************************************) +(* Copyright 2016-2019 MINES ParisTech -- License LGPL 2.1+ *) +(* Copyright 2019-2023 Inria -- License LGPL 2.1+ *) +(* Written by: Emilio J. Gallego Arias and others *) +(************************************************************************) + +(* open Sexplib.Std *) +(* open Ppx_hash_lib.Std.Hash.Builtin *) +(* open Ppx_compare_lib.Builtin *) + +(* let b x = Obj.magic x *) + +(* These are all special ltac2 extensible objects, brrrr... *) +let register () = + (* Ser_genarg.register_genser Tac2quote.wit_constr (b()); *) + (* Ser_genarg.register_genser Tac2quote.wit_ident (b()); *) + (* Ser_genarg.register_genser Tac2quote.wit_ltac1 (b()); *) + (* Ser_genarg.register_genser Tac2quote.wit_ltac1val (b()); *) + (* Ser_genarg.register_genser Tac2quote.wit_open_constr (b()); *) + (* Ser_genarg.register_genser Tac2quote.wit_pattern (b()); *) + (* Ser_genarg.register_genser Tac2quote.wit_preterm (b()); *) + (* Ser_genarg.register_genser Tac2quote.wit_reference (b()); *) + () + +let () = register () diff --git a/serlib/plugins/micromega/dune b/serlib/plugins/micromega/dune new file mode 100644 index 00000000..9f0296e9 --- /dev/null +++ b/serlib/plugins/micromega/dune @@ -0,0 +1,12 @@ +(library + (name serlib_micromega) + (public_name coq-lsp.serlib.micromega) + (synopsis "Serialization Library for Coq Congruence Plugin") + (preprocess + (staged_pps + ppx_import + ppx_sexp_conv + ppx_deriving_yojson + ppx_hash + ppx_compare)) + (libraries coq-core.plugins.micromega serlib sexplib)) diff --git a/serlib/plugins/micromega_core/dune b/serlib/plugins/micromega_core/dune new file mode 100644 index 00000000..ff4e2658 --- /dev/null +++ b/serlib/plugins/micromega_core/dune @@ -0,0 +1,12 @@ +(library + (name serlib_micromega_core) + (public_name coq-lsp.serlib.micromega_core) + (synopsis "Serialization Library for Coq Micromega_core Plugin") + (preprocess + (staged_pps + ppx_import + ppx_sexp_conv + ppx_deriving_yojson + ppx_hash + ppx_compare)) + (libraries coq-core.plugins.micromega_core serlib sexplib)) diff --git a/serlib/plugins/ring/dune b/serlib/plugins/ring/dune new file mode 100644 index 00000000..6b7b8e47 --- /dev/null +++ b/serlib/plugins/ring/dune @@ -0,0 +1,7 @@ +(library + (name serlib_ring) + (public_name coq-lsp.serlib.ring) + (synopsis "Serialization Library for Coq Setoid Newring Plugin") + (preprocess + (staged_pps ppx_import ppx_sexp_conv ppx_hash ppx_compare)) + (libraries coq-core.plugins.ring serlib serlib_ltac sexplib)) diff --git a/serlib/plugins/ring/ser_g_ring.ml b/serlib/plugins/ring/ser_g_ring.ml new file mode 100644 index 00000000..28f18c29 --- /dev/null +++ b/serlib/plugins/ring/ser_g_ring.ml @@ -0,0 +1,77 @@ +(************************************************************************) +(* SerAPI: Coq interaction protocol with bidirectional serialization *) +(************************************************************************) +(* Copyright 2016-2019 MINES ParisTech -- License LGPL 2.1+ *) +(* Copyright 2019-2023 Inria -- License LGPL 2.1+ *) +(* Written by: Emilio J. Gallego Arias and others *) +(************************************************************************) + +open Sexplib.Conv +open Ppx_hash_lib.Std.Hash.Builtin +open Ppx_compare_lib.Builtin +open Serlib + +module CAst = Ser_cAst +module Libnames = Ser_libnames +module Constrexpr = Ser_constrexpr +module Tactypes = Ser_tactypes +module Genintern = Ser_genintern +module EConstr = Ser_eConstr +module Tacexpr = Serlib_ltac.Ser_tacexpr + +module Ltac_plugin = struct + module Tacexpr = Serlib_ltac.Ser_tacexpr +end + +type 'constr coeff_spec = + [%import: 'constr Ring_plugin.Ring_ast.coeff_spec] + [@@deriving sexp,hash,compare] + +type cst_tac_spec = + [%import: Ring_plugin.Ring_ast.cst_tac_spec] + [@@deriving sexp,hash,compare] + +type 'constr ring_mod = + [%import: 'constr Ring_plugin.Ring_ast.ring_mod] + [@@deriving sexp,hash,compare] + +type 'a field_mod = + [%import: 'a Ring_plugin.Ring_ast.field_mod] + [@@deriving sexp,hash,compare] + +module A0 = struct + type t = Constrexpr.constr_expr field_mod + [@@deriving sexp,hash,compare] +end + +let ser_wit_field_mod = let module M = Ser_genarg.GSV(A0) in M.genser + +module A1 = struct + type t = Constrexpr.constr_expr field_mod list + [@@deriving sexp,hash,compare] +end + +let ser_wit_field_mods = let module M = Ser_genarg.GSV(A1) in M.genser + +module A2 = struct + type t = Constrexpr.constr_expr ring_mod + [@@deriving sexp,hash,compare] +end + +let ser_wit_ring_mod = let module M = Ser_genarg.GSV(A2) in M.genser + +module A3 = struct + type t = Constrexpr.constr_expr ring_mod list + [@@deriving sexp,hash,compare] +end + +let ser_wit_ring_mods = let module M = Ser_genarg.GSV(A3) in M.genser + +let register () = + Ser_genarg.register_genser Ring_plugin.G_ring.wit_field_mod ser_wit_field_mod; + Ser_genarg.register_genser Ring_plugin.G_ring.wit_field_mods ser_wit_field_mods; + Ser_genarg.register_genser Ring_plugin.G_ring.wit_ring_mod ser_wit_ring_mod; + Ser_genarg.register_genser Ring_plugin.G_ring.wit_ring_mods ser_wit_ring_mods; + () + +let _ = register () diff --git a/serlib/plugins/ssr/dune b/serlib/plugins/ssr/dune new file mode 100644 index 00000000..277917c8 --- /dev/null +++ b/serlib/plugins/ssr/dune @@ -0,0 +1,17 @@ +(library + (name serlib_ssr) + (public_name coq-lsp.serlib.ssreflect) + (synopsis "Serialization Library for Coq [SSR plugin]") + (preprocess + (staged_pps + ppx_import + ppx_sexp_conv + ppx_deriving_yojson + ppx_hash + ppx_compare)) + (libraries + coq-core.plugins.ssreflect + serlib + serlib_ltac + serlib_ssrmatching + sexplib)) diff --git a/serlib/plugins/ssr/ser_ssrast.ml b/serlib/plugins/ssr/ser_ssrast.ml new file mode 100644 index 00000000..794c354b --- /dev/null +++ b/serlib/plugins/ssr/ser_ssrast.ml @@ -0,0 +1,221 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* t + val of_t : t -> _t + +end + +module Biject(M : Bijectable) : SJHC with type t = M.t = struct + + type t = M.t + + let sexp_of_t x = M.sexp_of__t (M.of_t x) + let t_of_sexp s = M.to_t (M._t_of_sexp s) + + let to_yojson p = M._t_to_yojson (M.of_t p) + let of_yojson p = M._t_of_yojson p |> Result.map M.to_t + + let hash x = M.hash__t (M.of_t x) + let hash_fold_t st x = M.hash_fold__t st (M.of_t x) + + let compare x1 x2 = M.compare__t (M.of_t x1) (M.of_t x2) +end + +(* Bijection with serializable types *) +module type Bijectable1 = sig + + (* Base Type *) + type 'a t + + (* Representation type *) + type 'a _t [@@deriving sexp,yojson,hash,compare] + + (* Need to be bijetive *) + val to_t : 'a _t -> 'a t + val of_t : 'a t -> 'a _t + +end + +module Biject1(M : Bijectable1) : SJHC1 with type 'a t = 'a M.t = struct + + type 'a t = 'a M.t + + let sexp_of_t f x = M.sexp_of__t f (M.of_t x) + let t_of_sexp f s = M.to_t (M._t_of_sexp f s) + + let to_yojson f p = M._t_to_yojson f (M.of_t p) + let of_yojson f p = M._t_of_yojson f p |> Result.map M.to_t + + let hash_fold_t f st x = M.hash_fold__t f st (M.of_t x) + + let compare f x1 x2 = M.compare__t f (M.of_t x1) (M.of_t x2) +end + +(* We do our own alias as to have better control *) +let _sercast = Obj.magic + +(* Obj.magic piercing *) +module type Pierceable = sig + + (* Type to pierce *) + type t + + (* Representation type *) + type _t [@@deriving sexp,yojson,hash,compare] +end + +module type Pierceable1 = sig + + (* Type to pierce *) + type 'a t + + (* Representation type *) + type 'a _t [@@deriving sexp,yojson,hash,compare] +end + +module Pierce(M : Pierceable) : SJHC with type t = M.t = struct + + type t = M.t + + let sexp_of_t x = M.sexp_of__t (_sercast x) + let t_of_sexp s = _sercast (M._t_of_sexp s) + + let to_yojson p = M._t_to_yojson (_sercast p) + let of_yojson p = M._t_of_yojson p |> Result.map _sercast + + let hash x = M.hash__t (_sercast x) + let hash_fold_t st x = M.hash_fold__t st (_sercast x) + + let compare x1 x2 = M.compare__t (_sercast x1) (_sercast x2) + +end + +module Pierce1(M : Pierceable1) : SJHC1 with type 'a t = 'a M.t = struct + + type 'a t = 'a M.t + + let sexp_of_t f x = M.sexp_of__t f (_sercast x) + let t_of_sexp f s = _sercast (M._t_of_sexp f s) + + let to_yojson f p = M._t_to_yojson f (_sercast p) + let of_yojson f p = M._t_of_yojson f p |> Result.map _sercast + + (* let hash x = M.hash__t (_sercast x) *) + let hash_fold_t f st x = M.hash_fold__t f st (_sercast x) + + let compare f x1 x2 = M.compare__t f (_sercast x1) (_sercast x2) + +end + +(* Unfortunately this doesn't really work for types that are named as + the functions would have to be sexp_of_name etc... Maybe fixme in + the future *) +module PierceAlt(M : Pierceable) : SJHC with type t := M.t = struct + + let sexp_of_t x = M.sexp_of__t (_sercast x) + let t_of_sexp s = _sercast (M._t_of_sexp s) + + let to_yojson p = M._t_to_yojson (_sercast p) + let of_yojson p = M._t_of_yojson p |> Result.map _sercast + + let hash x = M.hash__t (_sercast x) + let hash_fold_t st x = M.hash_fold__t st (_sercast x) + + let compare x1 x2 = M.compare__t (_sercast x1) (_sercast x2) + +end + +module type OpaqueDesc = sig type t val name : string end + +module Opaque(M : OpaqueDesc) : SJHC with type t = M.t = struct + + type t = M.t + let typ = M.name + + let sexp_of_t x = Serlib_base.sexp_of_opaque ~typ x + let t_of_sexp s = Serlib_base.opaque_of_sexp ~typ s + + let to_yojson p = Serlib_base.opaque_to_yojson ~typ p + let of_yojson p = Serlib_base.opaque_of_yojson ~typ p + + let hash x = Serlib_base.hash_opaque ~typ x + let hash_fold_t st x = Serlib_base.hash_fold_opaque ~typ st x + + let compare x1 x2 = Serlib_base.compare_opaque ~typ x1 x2 + +end + +module type OpaqueDesc1 = sig type 'a t val name : string end + +module Opaque1(M : OpaqueDesc1) : SJHC1 with type 'a t = 'a M.t = struct + + type 'a t = 'a M.t + let typ = M.name + + let sexp_of_t _ x = Serlib_base.sexp_of_opaque ~typ x + let t_of_sexp _ s = Serlib_base.opaque_of_sexp ~typ s + + let to_yojson _ p = Serlib_base.opaque_to_yojson ~typ p + let of_yojson _ p = Serlib_base.opaque_of_yojson ~typ p + + let hash_fold_t _ st x = Serlib_base.hash_fold_opaque ~typ st x + + let compare _ x1 x2 = Serlib_base.compare_opaque ~typ x1 x2 + +end diff --git a/serlib/serType.mli b/serlib/serType.mli new file mode 100644 index 00000000..5adb4980 --- /dev/null +++ b/serlib/serType.mli @@ -0,0 +1,91 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* t + val of_t : t -> _t + +end + +module Biject(M : Bijectable) : SJHC with type t = M.t + +(* Bijection with serializable types *) +module type Bijectable1 = sig + + (* Base Type *) + type 'a t + + (* Representation type *) + type 'a _t [@@deriving sexp,yojson,hash,compare] + + (* Need to be bijetive *) + val to_t : 'a _t -> 'a t + val of_t : 'a t -> 'a _t + +end + +module Biject1(M : Bijectable1) : SJHC1 with type 'a t = 'a M.t + +module type Pierceable = sig + + (** Type to pierce *) + type t + + (** Representation type *) + type _t [@@deriving sexp,yojson,hash,compare] + +end + +module type Pierceable1 = sig + + (** Type to pierce *) + type 'a t + + (** Representation type *) + type 'a _t [@@deriving sexp,yojson,hash,compare] +end + +module Pierce(M : Pierceable) : SJHC with type t = M.t +module Pierce1(M : Pierceable1) : SJHC1 with type 'a t = 'a M.t + +module type OpaqueDesc = sig type t val name : string end +module Opaque(M : OpaqueDesc) : SJHC with type t = M.t + +module type OpaqueDesc1 = sig type 'a t val name : string end +module Opaque1(M : OpaqueDesc1) : SJHC1 with type 'a t = 'a M.t diff --git a/serlib/ser_attributes.ml b/serlib/ser_attributes.ml new file mode 100644 index 00000000..538f19de --- /dev/null +++ b/serlib/ser_attributes.ml @@ -0,0 +1,35 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* |= fun { L.v; loc } -> CAst.make ?loc:loc v) +let to_yojson f { CAst.v ; loc } = L.to_yojson f { L.v ; loc } + +let hash_fold_t f st { CAst.v; loc } = L.hash_fold_t f st { L.v; loc } + +let compare f { CAst.v = v1; loc = l1 } { CAst.v = v2; loc = l2 } = L.compare f { L.v = v1; loc = l1 } { L.v = v2; loc = l2 } + +let omit_att = ref false + +let sexp_of_t f x = + if !omit_att then f x.CAst.v else sexp_of_t f x + +(* let to_yojson f x = + if !omit_att then ... *) + diff --git a/serlib/ser_cAst.mli b/serlib/ser_cAst.mli new file mode 100644 index 00000000..60ea445a --- /dev/null +++ b/serlib/ser_cAst.mli @@ -0,0 +1,24 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* M.add k s e) M.empty l + let of_t = M.bindings + end + + include SerType.Biject1(BijectSpec) + +end diff --git a/serlib/ser_cMap.mli b/serlib/ser_cMap.mli new file mode 100644 index 00000000..7f7bd948 --- /dev/null +++ b/serlib/ser_cMap.mli @@ -0,0 +1,32 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* NoInvert + | CaseInvert { indices } -> + CaseInvert { indices = Array.map f indices } + +type ('constr, 'r) pcase_branch = + [%import: ('constr, 'r) Constr.pcase_branch] + [@@deriving sexp,yojson,hash,compare] + +let map_pcase_branch f (bi, c) = (bi, f c) + +type ('types, 'r) pcase_return = + [%import: ('types, 'r) Constr.pcase_return] + [@@deriving sexp,yojson,hash,compare] + +let map_pcase_return f (bi, c) = (bi, f c) + +type _constr = + | Rel of int + | Var of Names.Id.t + | Meta of int + | Evar of _constr pexistential + | Sort of Sorts.t + | Cast of _constr * cast_kind * _constr + | Prod of (Names.Name.t, Sorts.relevance) Context.pbinder_annot * _constr * _constr + | Lambda of (Names.Name.t, Sorts.relevance) Context.pbinder_annot * _constr * _constr + | LetIn of (Names.Name.t, Sorts.relevance) Context.pbinder_annot * _constr * _constr * _constr + | App of _constr * _constr array + | Const of pconstant + | Ind of pinductive + | Construct of pconstructor + | Case of case_info * UVars.Instance.t * _constr array * (_constr, Sorts.relevance) pcase_return * _constr pcase_invert * _constr * (_constr, Sorts.relevance) pcase_branch array + | Fix of (_constr, _constr, Sorts.relevance) pfixpoint + | CoFix of (_constr, _constr, Sorts.relevance) pcofixpoint + | Proj of Names.Projection.t * Sorts.relevance * _constr + | Int of Uint63.t + | Float of Float64.t + | String of Pstring.t + | Array of UVars.Instance.t * _constr array * _constr * _constr +[@@deriving sexp,yojson,hash,compare] + +let rec _constr_put (c : Constr.t) : _constr = + let cr = _constr_put in + let crl = SList.map _constr_put in + let cra = Array.map _constr_put in + let crci = map_pcase_invert _constr_put in + let crcb = map_pcase_branch _constr_put in + let crcr = map_pcase_return _constr_put in + let module C = Constr in + match C.kind c with + | C.Rel i -> Rel(i) + | C.Var v -> Var(v) + | C.Meta(mv) -> Meta mv + | C.Evar(ek, csa) -> Evar (ek, crl csa) + | C.Sort(st) -> Sort (st) + | C.Cast(cs,k,ty) -> Cast(cr cs, k, cr ty) + | C.Prod(n,tya,tyr) -> Prod(n, cr tya, cr tyr) + | C.Lambda(n,ab,bd) -> Lambda(n, cr ab, cr bd) + | C.LetIn(n,u,ab,bd) -> LetIn(n, cr u, cr ab, cr bd) + | C.App(hd, al) -> App(cr hd, cra al) + | C.Const p -> Const p + | C.Ind(p,q) -> Ind (p,q) + | C.Construct(p) -> Construct (p) + | C.Case(ci, u, ca, (pr,r), pi, c, pb) -> + Case(ci, u, cra ca, (crcr pr,r), crci pi, cr c, Array.map crcb pb) + (* (int array * int) * (Name.t array * 'types array * 'constr array)) *) + | C.Fix(p,(na,u1,u2)) -> Fix(p, (na, cra u1, cra u2)) + | C.CoFix(p,(na,u1,u2)) -> CoFix(p, (na, cra u1, cra u2)) + | C.Proj(p,r,c) -> Proj(p, r, cr c) + | C.Int i -> Int i + | C.Float i -> Float i + | C.String s -> String s + | C.Array (u,a,e,t) -> Array(u, cra a, cr e, cr t) + +let rec _constr_get (c : _constr) : Constr.t = + let cr = _constr_get in + let crl = SList.map _constr_get in + let cra = Array.map _constr_get in + let crci = map_pcase_invert _constr_get in + let crcb = map_pcase_branch _constr_get in + let crcr = map_pcase_return _constr_get in + let module C = Constr in + match c with + | Rel i -> C.mkRel i + | Var v -> C.mkVar v + | Meta(mv) -> C.mkMeta mv + | Evar(ek, csa) -> C.mkEvar (ek, crl csa) + | Sort(st) -> C.mkSort (st) + | Cast(cs,k,ty) -> C.mkCast(cr cs, k, cr ty) + | Prod(n,tya,tyr) -> C.mkProd(n, cr tya, cr tyr) + | Lambda(n,ab,bd) -> C.mkLambda(n, cr ab, cr bd) + | LetIn(n,u,ab,bd) -> C.mkLetIn(n, cr u, cr ab, cr bd) + | App(hd, al) -> C.mkApp(cr hd, cra al) + | Const p -> C.mkConstU(p) + | Ind(p,q) -> C.mkIndU(p, q) + | Construct(p) -> C.mkConstructU(p) + | Case(ci, u, ca, (pr,r), pi, c, pb) -> C.mkCase (ci, u, cra ca, (crcr pr,r), crci pi, cr c, Array.map crcb pb) + | Fix (p,(na,u1,u2)) -> C.mkFix(p, (na, cra u1, cra u2)) + | CoFix(p,(na,u1,u2)) -> C.mkCoFix(p, (na, cra u1, cra u2)) + | Proj(p,r,c) -> C.mkProj(p, r, cr c) + | Int i -> C.mkInt i + | Float f -> C.mkFloat f + | String s -> C.mkString s + | Array (u,a,e,t) -> C.mkArray(u, cra a, cr e, cr t) + +module ConstrBij = struct + + type t = Constr.t + + type _t = _constr + [@@deriving sexp,yojson,hash,compare] + + let to_t = _constr_get + let of_t = _constr_put + +end + +module CC = SerType.Biject(ConstrBij) +type constr = CC.t + [@@deriving sexp,yojson,hash,compare] +type types = CC.t + [@@deriving sexp,yojson,hash,compare] + +type t = constr + [@@deriving sexp,yojson,hash,compare] + +type case_invert = + [%import: Constr.case_invert] + [@@deriving sexp,yojson] + +type rec_declaration = + [%import: Constr.rec_declaration] + [@@deriving sexp] + +type fixpoint = + [%import: Constr.fixpoint] + [@@deriving sexp] + +type cofixpoint = + [%import: Constr.cofixpoint] + [@@deriving sexp] + +type existential = + [%import: Constr.existential] + [@@deriving sexp] + +type sorts_family = Sorts.family +let sorts_family_of_sexp = Sorts.family_of_sexp +let sexp_of_sorts_family = Sorts.sexp_of_family + +type named_declaration = + [%import: Constr.named_declaration] + [@@deriving sexp,yojson,hash,compare] + +type named_context = + [%import: Constr.named_context] + [@@deriving sexp,yojson,hash,compare] + +type rel_declaration = + [%import: Constr.rel_declaration] + [@@deriving sexp,yojson,hash,compare] + +type rel_context = + [%import: Constr.rel_context] + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib/ser_constr.mli b/serlib/ser_constr.mli new file mode 100644 index 00000000..82811d13 --- /dev/null +++ b/serlib/ser_constr.mli @@ -0,0 +1,132 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* metavariable +val sexp_of_metavariable : metavariable -> Sexp.t + +type pconstant = Constr.pconstant + +val pconstant_of_sexp : Sexp.t -> pconstant +val sexp_of_pconstant : pconstant -> Sexp.t + +type pinductive = Constr.pinductive + +val pinductive_of_sexp : Sexp.t -> pinductive +val sexp_of_pinductive : pinductive -> Sexp.t + +type pconstructor = Constr.pconstructor + +val pconstructor_of_sexp : Sexp.t -> pconstructor +val sexp_of_pconstructor : pconstructor -> Sexp.t + +type cast_kind = Constr.cast_kind [@@deriving sexp, yojson, hash,compare] +type case_style = Constr.case_style [@@deriving sexp, yojson, hash,compare] + +type case_printing = Constr.case_printing + +val case_printing_of_sexp : Sexp.t -> case_printing +val sexp_of_case_printing : case_printing -> Sexp.t + +type case_info = Constr.case_info + +val case_info_of_sexp : Sexp.t -> case_info +val sexp_of_case_info : case_info -> Sexp.t + +type rec_declaration = Constr.rec_declaration + +val rec_declaration_of_sexp : Sexp.t -> rec_declaration +val sexp_of_rec_declaration : rec_declaration -> Sexp.t + +type fixpoint = Constr.fixpoint + +val fixpoint_of_sexp : Sexp.t -> fixpoint +val sexp_of_fixpoint : fixpoint -> Sexp.t + +type cofixpoint = Constr.cofixpoint + +val cofixpoint_of_sexp : Sexp.t -> cofixpoint +val sexp_of_cofixpoint : cofixpoint -> Sexp.t + +type 'constr pexistential = 'constr Constr.pexistential + [@@deriving sexp, yojson, hash, compare] + +type ('constr, 'types, 'r) prec_declaration = ('constr, 'types, 'r) Constr.prec_declaration + +val prec_declaration_of_sexp : + (Sexp.t -> 'constr) -> (Sexp.t -> 'types) -> (Sexp.t -> 'r) -> + Sexp.t -> ('constr, 'types, 'r) prec_declaration +val sexp_of_prec_declaration : + ('constr -> Sexp.t) -> ('types -> Sexp.t) -> ('r -> Sexp.t) -> + ('constr, 'types, 'r) prec_declaration -> Sexp.t + +type ('constr, 'types, 'r) pfixpoint = ('constr, 'types, 'r) Constr.pfixpoint + +val pfixpoint_of_sexp : + (Sexp.t -> 'constr) -> + (Sexp.t -> 'types) -> + (Sexp.t -> 'r) -> Sexp.t -> ('constr, 'types, 'r) pfixpoint + +val sexp_of_pfixpoint : + ('constr -> Sexp.t) -> + ('types -> Sexp.t) -> + ('r -> Sexp.t) -> ('constr, 'types, 'r) pfixpoint -> Sexp.t + +type ('constr, 'types, 'r) pcofixpoint = ('constr, 'types, 'r) Constr.pcofixpoint + +val pcofixpoint_of_sexp : + (Sexp.t -> 'constr) -> (Sexp.t -> 'types) -> (Sexp.t -> 'r) -> + Sexp.t -> ('constr, 'types, 'r) pcofixpoint + +val sexp_of_pcofixpoint : + ('constr -> Sexp.t) -> ('types -> Sexp.t) -> ('r -> Sexp.t) -> + ('constr, 'types, 'r) pcofixpoint -> Sexp.t + +type t = Constr.t + [@@deriving sexp,yojson,hash,compare] + +type constr = t + [@@deriving sexp,yojson,hash,compare] + +type types = constr + [@@deriving sexp,yojson,hash,compare] + +type existential = Constr.existential +val existential_of_sexp : Sexp.t -> existential +val sexp_of_existential : existential -> Sexp.t + +type sorts_family = Sorts.family +val sorts_family_of_sexp : Sexp.t -> sorts_family +val sexp_of_sorts_family : sorts_family -> Sexp.t + +type named_declaration = Constr.named_declaration +val named_declaration_of_sexp : Sexp.t -> named_declaration +val sexp_of_named_declaration : named_declaration -> Sexp.t + +type named_context = Constr.named_context + [@@deriving sexp,yojson,hash,compare] + +type rel_declaration = Constr.rel_declaration +val rel_declaration_of_sexp : Sexp.t -> rel_declaration +val sexp_of_rel_declaration : rel_declaration -> Sexp.t + +type rel_context = Constr.rel_context + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib/ser_constr_matching.ml b/serlib/ser_constr_matching.ml new file mode 100644 index 00000000..b5b4771a --- /dev/null +++ b/serlib/ser_constr_matching.ml @@ -0,0 +1,23 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* binding_bound_vars +val sexp_of_binding_bound_vars : binding_bound_vars -> Sexp.t diff --git a/serlib/ser_constrexpr.ml b/serlib/ser_constrexpr.ml new file mode 100644 index 00000000..9a30b09f --- /dev/null +++ b/serlib/ser_constrexpr.ml @@ -0,0 +1,194 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* 'c) -> (Sexp.t -> 't) -> (Sexp.t -> 'r) -> Sexp.t -> ('c, 't, 'r) pt + val sexp_of_pt : ('c -> Sexp.t) -> ('t -> Sexp.t) -> ('r -> Sexp.t) -> ('c, 't, 'r) pt -> Sexp.t + + end + + type ('c, 't, 'r) pt = ('c, 't, 'r) Context.Compacted.pt + val pt_of_sexp : (Sexp.t -> 'c) -> (Sexp.t -> 't) -> (Sexp.t -> 'r) -> Sexp.t -> ('c, 't, 'r) pt + val sexp_of_pt : ('c -> Sexp.t) -> ('t -> Sexp.t) -> ('r -> Sexp.t) -> ('c, 't, 'r) pt -> Sexp.t + +end diff --git a/serlib/ser_conv_oracle.ml b/serlib/ser_conv_oracle.ml new file mode 100644 index 00000000..113b1670 --- /dev/null +++ b/serlib/ser_conv_oracle.ml @@ -0,0 +1,34 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t) -> (b -> Sexp.t) -> (a,b) thunk -> Sexp.t = + fun f _ t -> match t with + | Value v -> f v + | Thunk t -> f (Lazy.force t) + +let thunk_of_sexp : type a b. (Sexp.t -> a) -> (Sexp.t -> b) -> Sexp.t -> (a,b) thunk = + fun f _ s -> Value (f s) + +let thunk_of_yojson : type a b. (Yojson.Safe.t -> (a, string) Result.t) -> (Yojson.Safe.t -> (b, string) Result.t) -> Yojson.Safe.t -> ((a,b) thunk, string) Result.t = + fun f _ s -> Result.map (fun s -> Value s) (f s) + +let thunk_to_yojson : type a b. (a -> Yojson.Safe.t) -> (b -> Yojson.Safe.t) -> (a,b) thunk -> Yojson.Safe.t = + fun f _ t -> match t with + | Value v -> f v + | Thunk t -> f (Lazy.force t) + +let _hash : type a b. (a -> int) -> (b -> int) -> (a,b) thunk -> int = + fun f _ t -> match t with + | Value v -> f v + | Thunk t -> f (Lazy.force t) + +let hash_fold_thunk : type a b. (a Ppx_hash_lib.Std.Hash.folder) -> (b Ppx_hash_lib.Std.Hash.folder) -> (a,b) thunk Ppx_hash_lib.Std.Hash.folder = + fun f _ st t -> match t with + | Value v -> f st v + | Thunk t -> f st (Lazy.force t) + +let compare_thunk : type a b. (a Ppx_compare_lib.compare) -> (b Ppx_compare_lib.compare) -> (a,b) thunk Ppx_compare_lib.compare = + fun f _ t1 t2 -> match t1,t2 with + | Value v1, Value v2 -> f v1 v2 + | Thunk t1, Value v2 -> f (Lazy.force t1) v2 + | Value v1, Thunk t2 -> f v1 (Lazy.force t2) + | Thunk t1, Thunk t2 -> f (Lazy.force t1) (Lazy.force t2) + +type ('a, 'b) t = + [%import: ('a, 'b) DAst.t] + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib/ser_dAst.mli b/serlib/ser_dAst.mli new file mode 100644 index 00000000..20b7a1a3 --- /dev/null +++ b/serlib/ser_dAst.mli @@ -0,0 +1,21 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* template_arity +val sexp_of_template_arity : template_arity -> Sexp.t + +type ('a, 'b) declaration_arity = ('a, 'b) Declarations.declaration_arity + +val declaration_arity_of_sexp : + (Sexp.t -> 'a) -> + (Sexp.t -> 'b) -> + Sexp.t -> ('a, 'b) declaration_arity + +val sexp_of_declaration_arity : + ('a -> Sexp.t) -> + ('b -> Sexp.t) -> + ('a, 'b) declaration_arity -> Sexp.t + +type recarg = Declarations.recarg + [@@deriving sexp,yojson,hash,compare] + +type wf_paths = recarg Rtree.t + [@@deriving sexp,yojson,hash,compare] + +type regular_inductive_arity = Declarations.regular_inductive_arity + [@@deriving sexp,yojson,hash,compare] + +type inductive_arity = Declarations.inductive_arity + [@@deriving sexp,yojson,hash,compare] + +type one_inductive_body = Declarations.one_inductive_body + [@@deriving sexp,yojson,hash,compare] + +(* type set_predicativity = Declarations.set_predicativity + * val set_predicativity_of_sexp : Sexp.t -> set_predicativity + * val sexp_of_set_predicativity : set_predicativity -> Sexp.t *) + +(* type engagement = Declarations.engagement + * val engagement_of_sexp : Sexp.t -> engagement + * val sexp_of_engagement : engagement -> Sexp.t *) + +type typing_flags = Declarations.typing_flags + [@@deriving sexp,yojson,hash,compare] + +type inline = Declarations.inline + [@@deriving sexp,yojson,hash,compare] + +(* type work_list = Declarations.work_list *) + +(* type abstr_info = Declarations.abstr_info = { + * abstr_ctx : Constr.named_context; + * abstr_subst : Univ.Instance.t; + * abstr_uctx : Univ.AbstractContext.t; + * } + * + * type cooking_info = Declarations.cooking_info + * val sexp_of_cooking_info : cooking_info -> Sexp.t + * val cooking_info_of_sexp : Sexp.t -> cooking_info *) + +type ('a, 'b) pconstant_body = ('a, 'b) Declarations.pconstant_body + [@@deriving sexp,yojson,hash,compare] + +type constant_body = Declarations.constant_body + [@@deriving sexp,yojson,hash,compare] + +(* type record_body = Declarations.record_body + * val record_body_of_sexp : Sexp.t -> record_body + * val sexp_of_record_body : record_body -> Sexp.t *) + +type recursivity_kind = Declarations.recursivity_kind + [@@deriving sexp,yojson,hash,compare] + +type mutual_inductive_body = Declarations.mutual_inductive_body + [@@deriving sexp,yojson,hash,compare] + +type rewrite_rule = Declarations.rewrite_rule + [@@deriving sexp,yojson,hash,compare] + +type 'a module_alg_expr = 'a Declarations.module_alg_expr + [@@deriving sexp,yojson,hash,compare] + +type structure_body = Declarations.structure_body + [@@deriving sexp,yojson,hash,compare] + +type module_body = Declarations.module_body + [@@deriving sexp,yojson,hash,compare] + +type module_type_body = Declarations.module_type_body + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib/ser_declaremods.ml b/serlib/ser_declaremods.ml new file mode 100644 index 00000000..faab1f64 --- /dev/null +++ b/serlib/ser_declaremods.ml @@ -0,0 +1,39 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* env val sexp_of_env : env -> Sexp.t + +type ('constr, 'types) punsafe_judgment = ('constr, 'types) + Environ.punsafe_judgment + +val punsafe_judgment_of_sexp : (Sexp.t -> 'constr) -> (Sexp.t -> + 'types) -> Sexp.t -> ('constr, 'types) punsafe_judgment val + sexp_of_punsafe_judgment : ('constr -> Sexplib.Sexp.t) -> ('types + -> Sexplib.Sexp.t) -> ('constr, 'types) punsafe_judgment -> Sexp.t + +type unsafe_judgment = Environ.unsafe_judgment val + unsafe_judgment_of_sexp : Sexp.t -> unsafe_judgment val + sexp_of_unsafe_judgment : unsafe_judgment -> Sexp.t diff --git a/serlib/ser_equality.ml b/serlib/ser_equality.ml new file mode 100644 index 00000000..d0780a00 --- /dev/null +++ b/serlib/ser_equality.ml @@ -0,0 +1,25 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* |= _t_get) +let to_yojson level = _t_to_yojson (_t_put level) + +let hash x = hash__t (_t_put x) +let hash_fold_t st id = hash_fold__t st (_t_put id) + +let compare x y = compare__t (_t_put x) (_t_put y) + +end + +include Self + +module Set = Ser_cSet.Make(Evar.Set)(Self) diff --git a/serlib/ser_evar.mli b/serlib/ser_evar.mli new file mode 100644 index 00000000..131d0371 --- /dev/null +++ b/serlib/ser_evar.mli @@ -0,0 +1,23 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* conv_pb +val sexp_of_conv_pb : conv_pb -> Sexp.t + +type evar_constraint = Evd.evar_constraint + +val evar_constraint_of_sexp : Sexp.t -> evar_constraint +val sexp_of_evar_constraint : evar_constraint -> Sexp.t + +type unsolvability_explanation = Evd.unsolvability_explanation + +val unsolvability_explanation_of_sexp : Sexp.t -> unsolvability_explanation +val sexp_of_unsolvability_explanation : unsolvability_explanation -> Sexp.t diff --git a/serlib/ser_extend.ml b/serlib/ser_extend.ml new file mode 100644 index 00000000..365f7511 --- /dev/null +++ b/serlib/ser_extend.ml @@ -0,0 +1,55 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* production_position +val sexp_of_production_position : production_position -> Sexp.t + +type production_level = Extend.production_level [@@deriving sexp,yojson,hash,compare] + +type binder_entry_kind = Extend.binder_entry_kind +val binder_entry_kind_of_sexp : Sexp.t -> binder_entry_kind +val sexp_of_binder_entry_kind : binder_entry_kind -> Sexp.t + +type 'lev constr_entry_key_gen = 'lev Extend.constr_entry_key_gen +val constr_entry_key_gen_of_sexp : (Sexp.t -> 'lev) -> + Sexp.t -> 'lev constr_entry_key_gen +val sexp_of_constr_entry_key_gen : ('lev -> Sexp.t) -> + 'lev constr_entry_key_gen -> Sexp.t + +type constr_entry_key = Extend.constr_entry_key +val constr_entry_key_of_sexp : Sexp.t -> constr_entry_key +val sexp_of_constr_entry_key : constr_entry_key -> Sexp.t + +type constr_prod_entry_key = Extend.constr_prod_entry_key +val constr_prod_entry_key_of_sexp : Sexp.t -> constr_prod_entry_key +val sexp_of_constr_prod_entry_key : constr_prod_entry_key -> Sexp.t + +type simple_constr_prod_entry_key = Extend.simple_constr_prod_entry_key [@@deriving sexp,yojson,hash,compare] diff --git a/serlib/ser_feedback.ml b/serlib/ser_feedback.ml new file mode 100644 index 00000000..23fb4edc --- /dev/null +++ b/serlib/ser_feedback.ml @@ -0,0 +1,46 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t = fun at -> + match at with + | Rawwit w -> List [Atom "Rawwit"; sexp_of_genarg_type w] + | Glbwit w -> List [Atom "Glbwit"; sexp_of_genarg_type w] + | Topwit w -> List [Atom "Topwit"; sexp_of_genarg_type w] + +let rec argument_type_of_sexp : Sexp.t -> argument_type = fun sexp -> + match sexp with + | List [Atom "ExtraArg"; Atom tag] -> + begin match ArgT.name tag with + | None -> raise (Failure "SEXP Exception in argument_type") + | Some (ArgT.Any t) -> ArgumentType (ExtraArg t) + end + | List [Atom "ListArg"; s1] -> + let (ArgumentType t) = argument_type_of_sexp s1 in + ArgumentType (ListArg t) + | List [Atom "OptArg"; s1] -> + let (ArgumentType t) = argument_type_of_sexp s1 in + ArgumentType (OptArg t) + | List [Atom "PairArg"; s1; s2] -> + let (ArgumentType t1) = argument_type_of_sexp s1 in + let (ArgumentType t2) = argument_type_of_sexp s2 in + ArgumentType (PairArg(t1,t2)) + | _ -> raise (Failure "SEXP Exception") + +let hash_fold_abstract_argument_type : type lvl. ('o, lvl) abstract_argument_type Hash.folder = fun st at -> + match at with + | Rawwit w -> hash_tagged hash_fold_genarg_type st "raw" w + | Glbwit w -> hash_tagged hash_fold_genarg_type st "glb" w + | Topwit w -> hash_tagged hash_fold_genarg_type st "top" w + +type ('raw, 'glb, 'top) gen_ser = + { raw_ser : 'raw -> Sexp.t + ; raw_des : Sexp.t -> 'raw + ; raw_hash : 'raw Hash.folder + ; raw_compare : 'raw -> 'raw -> int + + ; glb_ser : 'glb -> Sexp.t + ; glb_des : Sexp.t -> 'glb + ; glb_hash : 'glb Hash.folder + ; glb_compare : 'glb -> 'glb -> int + + ; top_ser : 'top -> Sexp.t + ; top_des : Sexp.t -> 'top + ; top_hash : 'top Ppx_hash_lib.Std.Hash.folder + ; top_compare : 'top -> 'top -> int + } + +module T2_ = struct + type ('a, 'b) t = 'a * 'b [@@deriving hash, compare] +end + +let gen_ser_list : + ('raw, 'glb, 'top) gen_ser -> + ('raw list, 'glb list, 'top list) gen_ser = fun g -> + let open Sexplib.Conv in + { raw_ser = sexp_of_list g.raw_ser + ; raw_des = list_of_sexp g.raw_des + ; raw_hash = Hash.Builtin.hash_fold_list g.raw_hash + ; raw_compare = compare_list g.raw_compare + + ; glb_ser = sexp_of_list g.glb_ser + ; glb_des = list_of_sexp g.glb_des + ; glb_hash = Hash.Builtin.hash_fold_list g.glb_hash + ; glb_compare = compare_list g.glb_compare + + ; top_ser = sexp_of_list g.top_ser + ; top_des = list_of_sexp g.top_des + ; top_hash = Hash.Builtin.hash_fold_list g.top_hash + ; top_compare = compare_list g.top_compare + } + +let gen_ser_opt : + ('raw, 'glb, 'top) gen_ser -> + ('raw option, 'glb option, 'top option) gen_ser = fun g -> + let open Sexplib.Conv in + { raw_ser = sexp_of_option g.raw_ser + ; raw_des = option_of_sexp g.raw_des + ; raw_hash = Hash.Builtin.hash_fold_option g.raw_hash + ; raw_compare = compare_option g.raw_compare + + ; glb_ser = sexp_of_option g.glb_ser + ; glb_des = option_of_sexp g.glb_des + ; glb_hash = Hash.Builtin.hash_fold_option g.glb_hash + ; glb_compare = compare_option g.glb_compare + + ; top_ser = sexp_of_option g.top_ser + ; top_des = option_of_sexp g.top_des + ; top_hash = Hash.Builtin.hash_fold_option g.top_hash + ; top_compare = compare_option g.top_compare + } + +let gen_ser_pair : + ('raw1, 'glb1, 'top1) gen_ser -> + ('raw2, 'glb2, 'top2) gen_ser -> + (('raw1 * 'raw2), ('glb1 * 'glb2), ('top1 * 'top2)) gen_ser = fun g1 g2 -> + let open Sexplib.Conv in + { raw_ser = sexp_of_pair g1.raw_ser g2.raw_ser + ; raw_des = pair_of_sexp g1.raw_des g2.raw_des + ; raw_hash = T2_.hash_fold_t g1.raw_hash g2.raw_hash + ; raw_compare = T2_.compare g1.raw_compare g2.raw_compare + + ; glb_ser = sexp_of_pair g1.glb_ser g2.glb_ser + ; glb_des = pair_of_sexp g1.glb_des g2.glb_des + ; glb_hash = T2_.hash_fold_t g1.glb_hash g2.glb_hash + ; glb_compare = T2_.compare g1.glb_compare g2.glb_compare + + ; top_ser = sexp_of_pair g1.top_ser g2.top_ser + ; top_des = pair_of_sexp g1.top_des g2.top_des + ; top_hash = T2_.hash_fold_t g1.top_hash g2.top_hash + ; top_compare = T2_.compare g1.top_compare g2.top_compare + } + +module SerObj = struct + + type ('raw, 'glb, 'top) obj = ('raw, 'glb, 'top) gen_ser + + let sexp_of_gen typ ga = + let typ = typ ^ ": " ^ Sexp.to_string (sexp_of_genarg_type ga) in + Serlib_base.sexp_of_opaque ~typ + + let name = "ser_arg" + let default _ga = + Some + { + (* raw_ser = (fun _ -> Sexp.(List [Atom "[XXX ser_gen]"; Atom "raw"; sexp_of_genarg_type ga])); *) + raw_ser = sexp_of_gen "raw" _ga + ; raw_des = (Sexplib.Conv_error.no_matching_variant_found "raw_arg") + ; raw_hash = (fun st a -> Hash.fold_int st (Hashtbl.hash a)) + ; raw_compare = Stdlib.compare + + (* glb_ser = (fun _ -> Sexp.(List [Atom "[XXX ser_gen]"; Atom "glb"; sexp_of_genarg_type ga])); *) + ; glb_ser = sexp_of_gen "glb" _ga + ; glb_des = (Sexplib.Conv_error.no_matching_variant_found "glb_arg") + ; glb_hash = (fun st a -> Hash.fold_int st (Hashtbl.hash a)) + ; glb_compare = Stdlib.compare + + (* top_ser = (fun _ -> Sexp.(List [Atom "[XXX ser_gen]"; Atom "top"; sexp_of_genarg_type ga])); *) + ; top_ser = sexp_of_gen "top" _ga + ; top_des = (Sexplib.Conv_error.no_matching_variant_found "top_arg") + ; top_hash = (fun st a -> Hash.fold_int st (Hashtbl.hash a)) + ; top_compare = Stdlib.compare + } +end + +module SerGen = Register(SerObj) +let register_genser ty obj = SerGen.register0 ty obj + +let rec get_gen_ser_ty : type r g t. (r,g,t) Genarg.genarg_type -> (r,g,t) gen_ser = + fun gt -> match gt with + | Genarg.ExtraArg _ -> SerGen.obj gt + | Genarg.ListArg t -> gen_ser_list (get_gen_ser_ty t) + | Genarg.OptArg t -> gen_ser_opt (get_gen_ser_ty t) + | Genarg.PairArg(t1, t2) -> gen_ser_pair (get_gen_ser_ty t1) (get_gen_ser_ty t2) + +let get_gen_ser : type lvl. ('o,lvl) abstract_argument_type -> ('o -> 't) = fun aty -> + match aty with + | Genarg.Rawwit ty -> (get_gen_ser_ty ty).raw_ser + | Genarg.Glbwit ty -> (get_gen_ser_ty ty).glb_ser + | Genarg.Topwit ty -> (get_gen_ser_ty ty).top_ser + +let generic_des : type lvl. ('o,lvl) abstract_argument_type -> Sexp.t -> lvl generic_argument = fun ty s -> + match ty with + | Genarg.Rawwit w -> GenArg(ty, (get_gen_ser_ty w).raw_des s) + | Genarg.Glbwit w -> GenArg(ty, (get_gen_ser_ty w).glb_des s) + | Genarg.Topwit w -> GenArg(ty, (get_gen_ser_ty w).top_des s) + +let hash_fold_generic : type lvl. ('o,lvl) abstract_argument_type -> 'o Ppx_hash_lib.Std.Hash.folder = fun aty -> + match aty with + | Genarg.Rawwit ty -> (get_gen_ser_ty ty).raw_hash + | Genarg.Glbwit ty -> (get_gen_ser_ty ty).glb_hash + | Genarg.Topwit ty -> (get_gen_ser_ty ty).top_hash + +let compare_generic : type lvl. ('o,lvl) abstract_argument_type -> 'o Ppx_compare_lib.compare = fun aty -> + match aty with + | Genarg.Rawwit ty -> (get_gen_ser_ty ty).raw_compare + | Genarg.Glbwit ty -> (get_gen_ser_ty ty).glb_compare + | Genarg.Topwit ty -> (get_gen_ser_ty ty).top_compare + +(* We need to generalize this to use the proper printers for opt *) +let mk_sexparg st so = + Sexp.List [Atom "GenArg"; st; so] + +(* XXX: There is still some duplication here in the traversal of g_ty, but + we can live with that for now. *) +let sexp_of_genarg_val : type a. a generic_argument -> Sexp.t = + fun g -> match g with + | GenArg (g_ty, g_val) -> + mk_sexparg (sexp_of_abstract_argument_type g_ty) (get_gen_ser g_ty g_val) + +let sexp_of_generic_argument : type a. (a -> Sexp.t) -> a generic_argument -> Sexp.t = + fun _level_tag g -> + sexp_of_genarg_val g + +type rgen_argument = RG : 'lvl generic_argument -> rgen_argument + +let hash_fold_genarg_val : type a. a generic_argument Hash.folder = + fun st g -> match g with + | GenArg (g_ty, g_val) -> + let st = hash_fold_abstract_argument_type st g_ty in + hash_fold_generic g_ty st g_val + +let hash_fold_generic_argument : type a. a Hash.folder -> a generic_argument Hash.folder = + fun _level_tag g -> hash_fold_genarg_val g + +let compare_genarg_val : type a. a generic_argument Ppx_compare_lib.compare = + fun g1 g2 -> match g1 with + | GenArg (g1_ty, g1_val) -> + match g2 with + | GenArg (g2_ty, g2_val) -> + match Genarg.abstract_argument_type_eq g1_ty g2_ty with + | Some Refl -> + compare_generic g1_ty g1_val g2_val + (* XXX: Technically, we should implement our own compare so ordering works *) + | None -> 1 + +let compare_generic_argument : type a. a Ppx_compare_lib.compare -> a generic_argument Ppx_compare_lib.compare = + fun _level_tag g -> compare_genarg_val g + +let gen_abstype_of_sexp : Sexp.t -> rgen_argument = fun s -> + match s with + | List [Atom "GenArg"; List [ Atom "Rawwit"; sty]; sobj] -> + let (ArgumentType ty) = argument_type_of_sexp sty in + RG (generic_des (Rawwit ty) sobj) + | List [Atom "GenArg"; List [ Atom "Glbwit"; sty]; sobj] -> + let (ArgumentType ty) = argument_type_of_sexp sty in + RG (generic_des (Glbwit ty) sobj) + | List [Atom "GenArg"; List [ Atom "Topwit"; sty]; sobj] -> + let (ArgumentType ty) = argument_type_of_sexp sty in + RG (generic_des (Topwit ty) sobj) + | _ -> raise (Failure "SEXP Exception in abstype") + +let generic_argument_of_sexp _lvl sexp : 'a Genarg.generic_argument = + let (RG ga) = gen_abstype_of_sexp sexp in + Obj.magic ga + +let rec yojson_to_sexp json = match json with + | `String s -> Sexp.Atom s + | `List s -> Sexp.List (List.map yojson_to_sexp s) + | _ -> raise (Failure "ser_genarg: yojson_to_sexp") + +let rec sexp_to_yojson sexp : Yojson.Safe.t = + match sexp with + | Sexp.Atom s -> `String s + | List l -> `List (List.map sexp_to_yojson l) + +let generic_argument_of_yojson lvl json = + let sexp = yojson_to_sexp json in + Result.Ok (generic_argument_of_sexp lvl sexp) + +let generic_argument_to_yojson : type a. (a -> Yojson.Safe.t) -> a generic_argument -> Yojson.Safe.t = + fun _level_tag g -> + sexp_of_generic_argument (fun _ -> Atom "") g |> sexp_to_yojson + +type 'a generic_argument = 'a Genarg.generic_argument + +type glob_generic_argument = + [%import: Genarg.glob_generic_argument] + [@@deriving sexp,yojson,hash,compare] + +type raw_generic_argument = + [%import: Genarg.raw_generic_argument] + [@@deriving sexp,yojson,hash,compare] + +type typed_generic_argument = + [%import: Genarg.typed_generic_argument] + [@@deriving sexp,yojson,hash,compare] + +let mk_uniform pin pout phash pcompare = + { raw_ser = pin + ; raw_des = pout + ; raw_hash = phash + ; raw_compare = pcompare + + ; glb_ser = pin + ; glb_des = pout + ; glb_hash = phash + ; glb_compare = pcompare + + ; top_ser = pin + ; top_des = pout + ; top_hash = phash + ; top_compare = pcompare + } + +let mk_vernac_arg pin pout phash pcompare = + { raw_ser = pin + ; raw_des = pout + ; raw_hash = phash + ; raw_compare = pcompare + + ; glb_ser = Ser_util.Empty.sexp_of_t + ; glb_des = Ser_util.Empty.t_of_sexp + ; glb_hash = Ser_util.Empty.hash_fold_t + ; glb_compare = Ser_util.Empty.compare + + + ; top_ser = Ser_util.Empty.sexp_of_t + ; top_des = Ser_util.Empty.t_of_sexp + ; top_hash = Ser_util.Empty.hash_fold_t + ; top_compare = Ser_util.Empty.compare + } + +module type GenSer0 = sig + type t [@@deriving sexp,hash,compare] +end + +module GS0 (M : GenSer0) = struct + let genser = mk_uniform M.sexp_of_t M.t_of_sexp M.hash_fold_t M.compare +end + +module GSV (M : GenSer0) = struct + let genser = mk_vernac_arg M.sexp_of_t M.t_of_sexp M.hash_fold_t M.compare +end + +module type GenSer = sig + type raw [@@deriving sexp,hash,compare] + type glb [@@deriving sexp,hash,compare] + type top [@@deriving sexp,hash,compare] +end + +module GS (M : GenSer) = struct + let genser = + { raw_ser = M.sexp_of_raw + ; raw_des = M.raw_of_sexp + ; raw_hash = M.hash_fold_raw + ; raw_compare = M.compare_raw + + ; glb_ser = M.sexp_of_glb + ; glb_des = M.glb_of_sexp + ; glb_hash = M.hash_fold_glb + ; glb_compare = M.compare_glb + + ; top_ser = M.sexp_of_top + ; top_des = M.top_of_sexp + ; top_hash = M.hash_fold_top + ; top_compare = M.compare_top + } +end diff --git a/serlib/ser_genarg.mli b/serlib/ser_genarg.mli new file mode 100644 index 00000000..4cac1409 --- /dev/null +++ b/serlib/ser_genarg.mli @@ -0,0 +1,103 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t) ref *) +(* val sexp_of_tacdef_body : (Tacexpr.tacdef_body -> Sexp.t) ref *) + +(**********************************************************************) +(* GenArg *) +(**********************************************************************) + +type rlevel = Genarg.rlevel + [@@deriving sexp,yojson,hash,compare] +type glevel = Genarg.glevel + [@@deriving sexp,yojson,hash,compare] +type tlevel = Genarg.tlevel + [@@deriving sexp,yojson,hash,compare] + +type 'a generic_argument = 'a Genarg.generic_argument + [@@deriving sexp,yojson,hash,compare] + +type glob_generic_argument = Genarg.glob_generic_argument +[@@deriving sexp,yojson,hash,compare] + +type raw_generic_argument = Genarg.raw_generic_argument +[@@deriving sexp,yojson,hash,compare] + +type typed_generic_argument = Genarg.typed_generic_argument +val typed_generic_argument_of_sexp : Sexp.t -> Genarg.typed_generic_argument +val sexp_of_typed_generic_argument : Genarg.typed_generic_argument -> Sexp.t + +(* Registering serializing functions *) +type ('raw, 'glb, 'top) gen_ser = + { raw_ser : 'raw -> Sexp.t + ; raw_des : Sexp.t -> 'raw + ; raw_hash : 'raw Ppx_hash_lib.Std.Hash.folder + ; raw_compare : 'raw -> 'raw -> int + + ; glb_ser : 'glb -> Sexp.t + ; glb_des : Sexp.t -> 'glb + ; glb_hash : 'glb Ppx_hash_lib.Std.Hash.folder + ; glb_compare : 'glb -> 'glb -> int + + ; top_ser : 'top -> Sexp.t + ; top_des : Sexp.t -> 'top + ; top_hash : 'top Ppx_hash_lib.Std.Hash.folder + ; top_compare : 'top -> 'top -> int + } + +val register_genser : + ('raw, 'glb, 'top) Genarg.genarg_type -> + ('raw, 'glb, 'top) gen_ser -> unit + +val gen_ser_pair : + ('raw1, 'glb1, 'top1) gen_ser -> + ('raw2, 'glb2, 'top2) gen_ser -> + (('raw1 * 'raw2), ('glb1 * 'glb2), ('top1 * 'top2)) gen_ser + +val gen_ser_list : + ('raw, 'glb, 'top) gen_ser -> + ('raw list, 'glb list, 'top list) gen_ser + +val mk_uniform : ('t -> Sexp.t) -> (Sexp.t -> 't) -> + 't Ppx_hash_lib.Std.Hash.folder -> + 't Ppx_compare_lib.compare -> + ('t,'t,'t) gen_ser + +val mk_vernac_arg : ('t -> Sexp.t) -> (Sexp.t -> 't) -> + 't Ppx_hash_lib.Std.Hash.folder -> + 't Ppx_compare_lib.compare -> + ('t,Util.Empty.t,Util.Empty.t) gen_ser + +module type GenSer0 = sig + type t [@@deriving sexp,hash,compare] +end + +module GS0 (M : GenSer0) : sig val genser : (M.t,M.t,M.t) gen_ser end + +module GSV (M : GenSer0) : sig val genser : (M.t,Util.Empty.t,Util.Empty.t) gen_ser end + +module type GenSer = sig + type raw [@@deriving sexp,hash,compare] + type glb [@@deriving sexp,hash,compare] + type top [@@deriving sexp,hash,compare] +end + +module GS (M : GenSer) : sig val genser : (M.raw,M.glb,M.top) gen_ser end diff --git a/serlib/ser_genintern.ml b/serlib/ser_genintern.ml new file mode 100644 index 00000000..eef19d39 --- /dev/null +++ b/serlib/ser_genintern.ml @@ -0,0 +1,53 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* glob_sign +val sexp_of_glob_sign : glob_sign -> Sexp.t + +type glob_constr_and_expr = Genintern.glob_constr_and_expr + [@@deriving sexp, yojson, hash, compare] + +type glob_constr_pattern_and_expr = Genintern.glob_constr_pattern_and_expr + [@@deriving sexp, yojson, hash, compare] diff --git a/serlib/ser_geninterp.ml b/serlib/ser_geninterp.ml new file mode 100644 index 00000000..5075a82b --- /dev/null +++ b/serlib/ser_geninterp.ml @@ -0,0 +1,60 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t -> 'a Glob_term.cast_type + * val sexp_of_cast_type : ('a -> Sexp.t) -> 'a Glob_term.cast_type -> Sexp.t + * val cast_type_of_yojson : (Yojson.Safe.t -> ('a,string) result ) -> Yojson.Safe.t -> ('a cast_type, string) Result.t + * val cast_type_to_yojson : ('a -> Yojson.Safe.t) -> 'a cast_type -> Yojson.Safe.t *) + +type glob_constraint = Glob_term.glob_constraint + [@@deriving sexp,yojson,hash,compare] + +type existential_name = Glob_term.existential_name [@@deriving sexp,yojson,hash,compare] +type cases_pattern = Glob_term.cases_pattern + +type glob_constr = Glob_term.glob_constr +and glob_decl = Glob_term.glob_decl +and predicate_pattern = Glob_term.predicate_pattern +and tomatch_tuple = Glob_term.tomatch_tuple +and tomatch_tuples = Glob_term.tomatch_tuples +and cases_clause = Glob_term.cases_clause +and cases_clauses = Glob_term.cases_clauses + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib/ser_globnames.ml b/serlib/ser_globnames.ml new file mode 100644 index 00000000..c0ee9569 --- /dev/null +++ b/serlib/ser_globnames.ml @@ -0,0 +1,27 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* |= _t_get) +let qualid_r_to_yojson level = _t_to_yojson (_t_put level) + +(* let hash_qualid_r x = hash__t (_t_put x) *) +let hash_fold_qualid_r st x = hash_fold__t st (_t_put x) +let compare_qualid_r x y = compare__t (_t_put x) (_t_put y) + +(* qualid: private *) +type qualid = + [%import: Libnames.qualid] + [@@deriving sexp,yojson,hash,compare] + +module FP = struct + type _t = + { dirpath : Names.DirPath.t + ; basename : Names.Id.t } + [@@deriving sexp,yojson,hash,compare] + + let _t_get { dirpath; basename } = Libnames.make_path dirpath basename + let _t_put fp = let dirpath, basename = Libnames.repr_path fp in { dirpath; basename } +end + +open FP + +type full_path = Libnames.full_path +let full_path_of_sexp sexp = _t_get (_t_of_sexp sexp) +let sexp_of_full_path qid = sexp_of__t (_t_put qid) + +let full_path_of_yojson json = Ppx_deriving_yojson_runtime.(_t_of_yojson json >|= _t_get) +let full_path_to_yojson level = _t_to_yojson (_t_put level) + +let hash_full_path x = hash__t (_t_put x) +let hash_fold_full_path st x = hash_fold__t st (_t_put x) + +let compare_full_path x y = compare__t (_t_put x) (_t_put y) diff --git a/serlib/ser_libnames.mli b/serlib/ser_libnames.mli new file mode 100644 index 00000000..616c7e6a --- /dev/null +++ b/serlib/ser_libnames.mli @@ -0,0 +1,20 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t -> 'a hyp_location_expr +val sexp_of_hyp_location_expr : ('a -> Sexp.t) -> 'a hyp_location_expr -> Sexp.t + +type 'id clause_expr = 'id Locus.clause_expr + [@@deriving sexp,yojson,hash,compare] + +type clause = Locus.clause + +val clause_of_sexp : Sexp.t -> clause +val sexp_of_clause : clause -> Sexp.t + +type clause_atom = Locus.clause_atom + +val clause_atom_of_sexp : Sexp.t -> clause_atom +val sexp_of_clause_atom : clause_atom -> Sexp.t + +type concrete_clause = Locus.concrete_clause + +val concrete_clause_of_sexp : Sexp.t -> concrete_clause +val sexp_of_concrete_clause : concrete_clause -> Sexp.t + +type hyp_location = Locus.hyp_location + [@@deriving sexp,yojson,hash,compare] + +type goal_location = Locus.goal_location + +val goal_location_of_sexp : Sexp.t -> goal_location +val sexp_of_goal_location : goal_location -> Sexp.t + +type simple_clause = Locus.simple_clause +val simple_clause_of_sexp : Sexp.t -> simple_clause +val sexp_of_simple_clause : simple_clause -> Sexp.t + +type 'id or_like_first = 'id Locus.or_like_first + +val or_like_first_of_sexp : (Sexp.t -> 'id) -> Sexp.t -> 'id or_like_first +val sexp_of_or_like_first : ('id -> Sexp.t) -> 'id or_like_first -> Sexp.t diff --git a/serlib/ser_ltac_pretype.ml b/serlib/ser_ltac_pretype.ml new file mode 100644 index 00000000..6428150a --- /dev/null +++ b/serlib/ser_ltac_pretype.ml @@ -0,0 +1,37 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* closure +val sexp_of_closure : closure -> Sexp.t + +type closed_glob_constr = Ltac_pretype.closed_glob_constr + [@@deriving sexp,hash,compare] + +type constr_under_binders = Ltac_pretype.constr_under_binders + +val constr_under_binders_of_sexp : Sexp.t -> constr_under_binders +val sexp_of_constr_under_binders : constr_under_binders -> Sexp.t diff --git a/serlib/ser_mod_subst.ml b/serlib/ser_mod_subst.ml new file mode 100644 index 00000000..9dbb71ed --- /dev/null +++ b/serlib/ser_mod_subst.ml @@ -0,0 +1,37 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t) -> 'a substituted -> Sexp.t + * val substituted_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a substituted *) diff --git a/serlib/ser_namegen.ml b/serlib/ser_namegen.ml new file mode 100644 index 00000000..c21d37a0 --- /dev/null +++ b/serlib/ser_namegen.ml @@ -0,0 +1,23 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* |= _kername_get) +let to_yojson kn = _t_to_yojson (_t_put kn) + +let hash x = hash__t (_t_put x) +let hash_fold_t st id = hash_fold__t st (_t_put id) + +let compare x y = compare__t (_t_put x) (_t_put y) + +let equal = KerName.equal + +end + +module KNmap = Ser_cMap.Make(Names.KNmap)(KerName) + +module Constant = struct + +(* Constant.t: private *) +type t = [%import: Names.Constant.t] + +type _t = Constant of KerName.t * KerName.t option + [@@deriving sexp,yojson,hash,compare] + +let _t_put cs = + let cu, cc = Constant.(user cs, canonical cs) in + if KerName.equal cu cc then Constant (cu, None) else Constant (cu, Some cc) +let _t_get = function + | Constant (cu, None) -> Constant.make1 cu + | Constant (cu, Some cc) -> Constant.make cu cc + +let t_of_sexp sexp = _t_get (_t_of_sexp sexp) +let sexp_of_t dp = sexp_of__t (_t_put dp) + +let of_yojson json = Ppx_deriving_yojson_runtime.(_t_of_yojson json >|= _t_get) +let to_yojson level = _t_to_yojson (_t_put level) + +let hash x = hash__t (_t_put x) +let hash_fold_t st id = hash_fold__t st (_t_put id) + +let compare x y = compare__t (_t_put x) (_t_put y) + +end + +module Cset_env = Ser_cSet.Make(Cset_env)(Constant) + +module Cmap = Ser_cMap.Make(Cmap)(Constant) +module Cmap_env = Ser_cMap.Make(Cmap_env)(Constant) + +module MutInd = struct + +(* MutInd.t: private *) + module BijectSpec = struct + type t = [%import: Names.MutInd.t] + type _t = MutInd of KerName.t * KerName.t option + [@@deriving sexp,yojson,hash,compare] + + let of_t cs = + let cu, cc = MutInd.(user cs, canonical cs) in + if KerName.equal cu cc then MutInd (cu, None) else MutInd (cu, Some cc) + + let to_t = function + | MutInd (cu, None) -> MutInd.make1 cu + | MutInd (cu, Some cc) -> MutInd.make cu cc + end + + include SerType.Biject(BijectSpec) +end + +module Mindmap = Ser_cMap.Make(Mindmap)(MutInd) +module Mindmap_env = Ser_cMap.Make(Mindmap_env)(MutInd) + +type 'a tableKey = + [%import: 'a Names.tableKey] + [@@deriving sexp] + +type variable = + [%import: Names.variable] + [@@deriving sexp,yojson,hash,compare] + +(* Inductive and constructor = public *) +module Ind = struct + type t = + [%import: Names.Ind.t] + [@@deriving sexp,yojson,hash,compare] +end + +module Indset_env = Ser_cSet.Make(Indset_env)(Ind) +module Indmap_env = Ser_cMap.Make(Indmap_env)(Ind) + +type inductive = + [%import: Names.inductive] + [@@deriving sexp,yojson,hash,compare] + +module Construct = struct + type t = + [%import: Names.Construct.t] + [@@deriving sexp,yojson,hash,compare] + +end +type constructor = + [%import: Names.constructor] + [@@deriving sexp,yojson,hash,compare] + +(* Projection: private *) +module Projection = struct + + module Repr = struct + module PierceSpec = struct + type t = Names.Projection.Repr.t + type _t = + { proj_ind : inductive + ; proj_relevant : bool + ; proj_npars : int + ; proj_arg : int + ; proj_name : Label.t + } [@@deriving sexp,yojson,hash,compare] + end + include SerType.Pierce(PierceSpec) + end + + module PierceSpec = struct + type t = [%import: Names.Projection.t] + type _t = Repr.t * bool + [@@deriving sexp,yojson,hash,compare] + end + include SerType.Pierce(PierceSpec) +end + +module GlobRef = struct + +type t = [%import: Names.GlobRef.t] + [@@deriving sexp,yojson,hash,compare] + +end + +type lident = + [%import: Names.lident] + [@@deriving sexp,yojson,hash,compare] + +type lname = + [%import: Names.lname] + [@@deriving sexp,yojson,hash,compare] + +type lstring = + [%import: Names.lstring] + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib/ser_names.mli b/serlib/ser_names.mli new file mode 100644 index 00000000..41ccfd79 --- /dev/null +++ b/serlib/ser_names.mli @@ -0,0 +1,79 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t -> 'a tableKey +val sexp_of_tableKey : ('a -> Sexp.t) -> 'a tableKey -> Sexp.t + +type variable = Names.variable [@@deriving sexp, yojson, hash, compare] +type inductive = Names.inductive [@@deriving sexp, yojson, hash, compare] +type constructor = Names.constructor [@@deriving sexp, yojson, hash, compare] + +module Projection : sig + + include SerType.SJHC with type t = Projection.t + + module Repr : sig + include SerType.SJHC with type t = Projection.Repr.t + end + +end + +module GlobRef : SerType.SJHC with type t = Names.GlobRef.t + +type lident = Names.lident [@@deriving sexp,yojson,hash,compare] +type lname = Names.lname [@@deriving sexp,yojson,hash,compare] +type lstring = Names.lstring [@@deriving sexp,yojson,hash,compare] diff --git a/serlib/ser_nametab.ml b/serlib/ser_nametab.ml new file mode 100644 index 00000000..12ab6da4 --- /dev/null +++ b/serlib/ser_nametab.ml @@ -0,0 +1,23 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* parenRelation + * val sexp_of_parenRelation : parenRelation -> Sexp.t + * + * type precedence = Notation_gram.precedence + * + * val precedence_of_sexp : Sexp.t -> precedence + * val sexp_of_precedence : precedence -> Sexp.t + * + * type tolerability = Notation_gram.tolerability + * + * val tolerability_of_sexp : Sexp.t -> tolerability + * val sexp_of_tolerability : tolerability -> Sexp.t *) + +type grammar_constr_prod_item = Notation_gram.grammar_constr_prod_item +val grammar_constr_prod_item_of_sexp : Sexp.t -> grammar_constr_prod_item +val sexp_of_grammar_constr_prod_item : grammar_constr_prod_item -> Sexp.t + +type notation_grammar = Notation_gram.notation_grammar +val notation_grammar_of_sexp : Sexp.t -> notation_grammar +val sexp_of_notation_grammar : notation_grammar -> Sexp.t + diff --git a/serlib/ser_notation_term.ml b/serlib/ser_notation_term.ml new file mode 100644 index 00000000..88cf6af6 --- /dev/null +++ b/serlib/ser_notation_term.ml @@ -0,0 +1,57 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* case_info_pattern +val sexp_of_case_info_pattern : case_info_pattern -> Sexp.t + +type constr_pattern = Pattern.constr_pattern + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib/ser_pp.ml b/serlib/ser_pp.ml new file mode 100644 index 00000000..3ff76fa8 --- /dev/null +++ b/serlib/ser_pp.ml @@ -0,0 +1,73 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Pp_empty + | Ppcmd_string s -> Pp_string s + | Ppcmd_glue l -> Pp_glue (List.map of_t l) + | Ppcmd_box (bt,d) -> Pp_box(bt, of_t d) + | Ppcmd_tag (t,d) -> Pp_tag(t, of_t d) + | Ppcmd_print_break (n,m) -> Pp_print_break(n,m) + | Ppcmd_force_newline -> Pp_force_newline + | Ppcmd_comment s -> Pp_comment s + + let rec to_t (d : _t) : t = unrepr (match d with + | Pp_empty -> Ppcmd_empty + | Pp_string s -> Ppcmd_string s + | Pp_glue l -> Ppcmd_glue (List.map to_t l) + | Pp_box (bt,d) -> Ppcmd_box(bt, to_t d) + | Pp_tag (t,d) -> Ppcmd_tag(t, to_t d) + | Pp_print_break (n,m) -> Ppcmd_print_break(n,m) + | Pp_force_newline -> Ppcmd_force_newline + | Pp_comment s -> Ppcmd_comment s) + +end + +include SerType.Biject(P) + +type doc_view = + [%import: Pp.doc_view] + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib/ser_pp.mli b/serlib/ser_pp.mli new file mode 100644 index 00000000..512dfdfc --- /dev/null +++ b/serlib/ser_pp.mli @@ -0,0 +1,23 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* ppbox +val sexp_of_ppbox : ppbox -> Sexp.t + +type ppcut = Ppextend.ppcut + +val ppcut_of_sexp : Sexp.t -> ppcut +val sexp_of_ppcut : ppcut -> Sexp.t + +(* type unparsing = Ppextend.unparsing + * val unparsing_of_sexp : Sexp.t -> unparsing + * val sexp_of_unparsing : unparsing -> Sexp.t *) + +type unparsing_rule = Ppextend.unparsing_rule +val unparsing_rule_of_sexp : Sexp.t -> unparsing_rule +val sexp_of_unparsing_rule : unparsing_rule -> Sexp.t + +type notation_printing_rules = Ppextend.notation_printing_rules +val notation_printing_rules_of_sexp : Sexp.t -> notation_printing_rules +val sexp_of_notation_printing_rules : notation_printing_rules -> Sexp.t diff --git a/serlib/ser_pretype_errors.ml b/serlib/ser_pretype_errors.ml new file mode 100644 index 00000000..1f2dfbc3 --- /dev/null +++ b/serlib/ser_pretype_errors.ml @@ -0,0 +1,75 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* + NotClean (e, ee, c) + | ConversionFailed (_, c1, c2) -> + ConversionFailed (ee, c1, c2) + | IncompatibleInstances (_, e, c1, c2) -> + IncompatibleInstances (ee, e, c1, c2) + | InstanceNotSameType (e, _, t1, t2) -> + InstanceNotSameType (e, ee, t1, t2) + | CannotSolveConstraint (e, ue) -> + CannotSolveConstraint (e, (filter_ue ue)) + | ue -> ue + +let sexp_of_unification_error ue = + filter_ue ue |> sexp_of_unification_error + +type position = + [%import: Pretype_errors.position] + [@@deriving sexp] + +type position_reporting = + [%import: Pretype_errors.position_reporting] + [@@deriving sexp] + +type subterm_unification_error = + [%import: Pretype_errors.subterm_unification_error] + [@@deriving sexp] + +type type_error = + [%import: Pretype_errors.type_error] + [@@deriving sexp] + +type pretype_error = + [%import: Pretype_errors.pretype_error] + [@@deriving sexp] diff --git a/serlib/ser_pretype_errors.mli b/serlib/ser_pretype_errors.mli new file mode 100644 index 00000000..fb783695 --- /dev/null +++ b/serlib/ser_pretype_errors.mli @@ -0,0 +1,39 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* unification_error +val sexp_of_unification_error : unification_error -> Sexp.t + +type position = Pretype_errors.position +val position_of_sexp : Sexp.t -> position +val sexp_of_position : position -> Sexp.t + +type position_reporting = Pretype_errors.position_reporting +val position_reporting_of_sexp : Sexp.t -> position_reporting +val sexp_of_position_reporting : position_reporting -> Sexp.t + +type subterm_unification_error = Pretype_errors.subterm_unification_error +val subterm_unification_error_of_sexp : Sexp.t -> subterm_unification_error +val sexp_of_subterm_unification_error : subterm_unification_error -> Sexp.t + +type pretype_error = Pretype_errors.pretype_error +val pretype_error_of_sexp : Sexp.t -> pretype_error +val sexp_of_pretype_error : pretype_error -> Sexp.t diff --git a/serlib/ser_printer.ml b/serlib/ser_printer.ml new file mode 100644 index 00000000..c8164b50 --- /dev/null +++ b/serlib/ser_printer.ml @@ -0,0 +1,22 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* 'b) (x : 'a SList.t) : 'b SList.t = Obj.magic (_map f (Obj.magic x)) diff --git a/serlib/ser_safe_typing.ml b/serlib/ser_safe_typing.ml new file mode 100644 index 00000000..4f5cdb03 --- /dev/null +++ b/serlib/ser_safe_typing.ml @@ -0,0 +1,84 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* 'a) (x : Sexp.t) : 'a effect_entry = + let open Sexp in + match x with + | Atom "PureEntry" -> + Obj__magic PureEntry + | Atom "EffectEntry" -> + Obj__magic EffectEntry + | _ -> + Sexplib.Conv_error.no_variant_match () +*) + +type global_declaration = + [%import: Safe_typing.global_declaration] + [@@deriving sexp] diff --git a/serlib/ser_safe_typing.mli b/serlib/ser_safe_typing.mli new file mode 100644 index 00000000..1613aad1 --- /dev/null +++ b/serlib/ser_safe_typing.mli @@ -0,0 +1,26 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* global_declaration +val sexp_of_global_declaration : global_declaration -> Sexp.t diff --git a/serlib/ser_sorts.ml b/serlib/ser_sorts.ml new file mode 100644 index 00000000..5b3c022d --- /dev/null +++ b/serlib/ser_sorts.ml @@ -0,0 +1,91 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* t +val sexp_of_t : t -> Sexp.t + +type 'c p = 'c Tok.p +val p_of_sexp : (Sexp.t -> 'c) -> Sexp.t -> 'c p +val sexp_of_p : ('c -> Sexp.t) -> 'c p -> Sexp.t diff --git a/serlib/ser_type_errors.ml b/serlib/ser_type_errors.ml new file mode 100644 index 00000000..ccd8141c --- /dev/null +++ b/serlib/ser_type_errors.ml @@ -0,0 +1,59 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* guard_error +val sexp_of_guard_error : guard_error -> Sexp.t + +type ('c,'t) pcant_apply_bad_type = ('c, 't) Type_errors.pcant_apply_bad_type + +val pcant_apply_bad_type_of_sexp : + (Sexp.t -> 'constr) -> (Sexp.t -> 'types) -> + Sexp.t -> ('constr, 'types) pcant_apply_bad_type + +val sexp_of_pcant_apply_bad_type : + ('constr -> Sexp.t) -> + ('types -> Sexp.t) -> + ('constr, 'types) pcant_apply_bad_type -> Sexp.t + +type ('c, 't, 'r) ptype_error = ('c, 't, 'r) Type_errors.ptype_error +val ptype_error_of_sexp : + (Sexp.t -> 'constr) -> (Sexp.t -> 'types) -> (Sexp.t -> 'r) -> + Sexp.t -> ('constr, 'types, 'r) ptype_error + +val sexp_of_ptype_error : + ('constr -> Sexp.t) -> + ('types -> Sexp.t) -> + ('r -> Sexp.t) -> + ('constr, 'types, 'r) ptype_error -> Sexp.t + +type type_error = Type_errors.type_error +val type_error_of_sexp : Sexp.t -> type_error +val sexp_of_type_error : type_error -> Sexp.t + diff --git a/serlib/ser_typeclasses.ml b/serlib/ser_typeclasses.ml new file mode 100644 index 00000000..c22cf055 --- /dev/null +++ b/serlib/ser_typeclasses.ml @@ -0,0 +1,25 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* |= _t_get) +let to_yojson level = _t_to_yojson (_t_put level) + +let hash_fold_t st i = + Ppx_hash_lib.Std.Hash.Builtin.hash_fold_int64 st (Uint63.to_int64 i) + +let compare i1 i2 = + Ppx_compare_lib.Builtin.compare_int64 (Uint63.to_int64 i1) (Uint63.to_int64 i2) diff --git a/serlib/ser_univ.ml b/serlib/ser_univ.ml new file mode 100644 index 00000000..160f470d --- /dev/null +++ b/serlib/ser_univ.ml @@ -0,0 +1,102 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* univ_constraint +val sexp_of_univ_constraint : univ_constraint -> Sexp.t + +module Constraints : SerType.SJHC with type t = Univ.Constraints.t + +module ContextSet : SerType.SJHC with type t = Univ.ContextSet.t + +type 'a in_universe_context_set = 'a Univ.in_universe_context_set +val in_universe_context_set_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a in_universe_context_set +val sexp_of_in_universe_context_set : ('a -> Sexp.t) -> 'a in_universe_context_set -> Sexp.t diff --git a/serlib/ser_univNames.ml b/serlib/ser_univNames.ml new file mode 100644 index 00000000..21b0683f --- /dev/null +++ b/serlib/ser_univNames.ml @@ -0,0 +1,31 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* |= _instance_get) +let to_yojson level = _t_to_yojson (_instance_put level) + +let hash i = hash__t (Instance (UVars.Instance.to_array i)) +let hash_fold_t st i = hash_fold__t st (Instance (UVars.Instance.to_array i)) +let compare i1 i2 = compare__t (Instance (UVars.Instance.to_array i1)) (Instance (UVars.Instance.to_array i2)) + +end + +module UContext = struct + + module I = struct + type t = UVars.UContext.t + type _t = (Names.Name.t array * Names.Name.t array) * (Instance.t * Constraints.t) + [@@deriving sexp,yojson,hash,compare] + + let to_t (un, cs) = UVars.UContext.make un cs + let of_t uc = UVars.UContext.(names uc, (instance uc, constraints uc)) + end + + include SerType.Biject(I) + +end + +module AbstractContext = struct + + let hash_fold_array = hash_fold_array_frozen + module ACPierceDef = struct + + type t = UVars.AbstractContext.t + type _t = (Names.Name.t array * Names.Name.t array) * Constraints.t + [@@deriving sexp,yojson,hash,compare] + end + + include SerType.Pierce(ACPierceDef) + +end + +type 'a in_universe_context = + [%import: 'a UVars.in_universe_context] + [@@deriving sexp] + +type 'a puniverses = + [%import: 'a UVars.puniverses] + [@@deriving sexp, yojson, hash, compare] diff --git a/serlib/ser_uvars.mli b/serlib/ser_uvars.mli new file mode 100644 index 00000000..c17f2fbb --- /dev/null +++ b/serlib/ser_uvars.mli @@ -0,0 +1,35 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t -> 'a in_universe_context +val sexp_of_in_universe_context : ('a -> Sexp.t) -> 'a in_universe_context -> Sexp.t + +type 'a puniverses = 'a * Instance.t + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib/ser_vernacexpr.ml b/serlib/ser_vernacexpr.ml new file mode 100644 index 00000000..fe0a76e9 --- /dev/null +++ b/serlib/ser_vernacexpr.ml @@ -0,0 +1,353 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t +val opaque_of_sexp : typ:string -> Sexp.t -> 'a + +val opaque_of_yojson : typ:string -> Yojson.Safe.t -> ('a, string) Result.t +val opaque_to_yojson : typ:string -> 'a -> Yojson.Safe.t + +val hash_opaque : typ:string -> 'a -> Ppx_hash_lib.Std.Hash.hash_value +val hash_fold_opaque : typ:string -> Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state + +val compare_opaque : typ:string -> 'a -> 'a -> int diff --git a/serlib/serlib_init.ml b/serlib/serlib_init.ml new file mode 100644 index 00000000..d80ff40a --- /dev/null +++ b/serlib/serlib_init.ml @@ -0,0 +1,31 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* unit + diff --git a/serlib_8_19/.ocamlformat b/serlib_8_19/.ocamlformat new file mode 100644 index 00000000..593b6a1f --- /dev/null +++ b/serlib_8_19/.ocamlformat @@ -0,0 +1 @@ +disable diff --git a/serlib_8_19/README.md b/serlib_8_19/README.md new file mode 100644 index 00000000..9edcbe8d --- /dev/null +++ b/serlib_8_19/README.md @@ -0,0 +1,105 @@ +## Serlib README + +Welcome to `coq-serlib` README. + +`coq-serlib` is a library that declares missing serialization +functions (from/to JSON, sexp), comparison, and hash functions for +most Coq datatypes, allowing users to serialize full ASTs faithfully +for example, and many other interesting use cases. + +`coq-serlib` also includes support for [Coq's extensible syntax]() and +plugins. + +### Builtins and Configuration + +`serlib` provides some builtins and configuration values in the +`Serlib_base` and `Serlib_init` modules. + +### Serializing opaque and private types + +`serlib` uses `ppx_import` to retrieve the original type definitions +from Coq; when these are not available, we provide some helpers in the +`SerType` module. Current helpers are: + +- `Biject`: use when it is convenient to provide an isomorphic type to + the one that is "opaque". +- `Pierce`: use when it is not possible to access the type, you really + want to use a copy + `Obj.magic` +- `Opaque`: when you want to declare the type as non-serializable + +**note**: use of `Obj.magic` is now prohibited, all the type piercings +need to use the `Pierce` functor. + +### Serializing GADTS + +Unfortunately, it is not possible to easily serialize GADTS. For now, +we use a very ugly workaround: we basically copy the original Coq +datatype, in non-GADT version, then we pierce the type as their +representation is isomorphic. + +We will use an example from https://github.com/coq/coq/pull/17667#issuecomment-1714473449 : + +```ocaml +type _ gen_pattern = GPat : Genarg.glob_generic_argument -> [ `uninstantiated ] gen_pattern +``` + +In this case, we could indeed derive a serialization function (try +`[@@deriving of_sexp]` for example), however full serialization is +harder, so we may need to provide an alternative data-type: + +```ocaml +module GenPatternRep : SerType.Pierceable1 = struct + + type 'a t = 'a Pattern.gen_pattern + + type _ _t = GPat of Genarg.glob_generic_argument + [@@deriving sexp,yojson,hash,compare] +end + +module GenPatternSer = SerType.Pierce1(GenPatternRep) +type 'a gen_pattern = GenPatternSer.t [@@deriving sexp,yojson,hash,compare] +``` + +and here you go! The main problem with this approach is that it +requires a manual check for each use of `Pierce` and each Coq +version. Fortunately the numbers of `Pierce`'s so far have been very +low. + +### Pre-release checks + +Due to the above, when updating SerAPI for a new release to OPAM, we +must check that the definitions we are piercing are up to date. + +I perform this check with Emacs + Merlin for OCaml: + +- I do `vc-git-grep` for `Pierce(` and `Pierce1(` +- For each use, I use merlin to jump to the original type +- I compare update these types + +That's painful, but takes like 10 minutes, so for now it is doable a +couple of times a year. To illustrate, these are the current +occurrences to check: + +``` +serlib/plugins/ltac2/ser_tac2expr.ml:module T2E = Serlib.SerType.Pierce(T2ESpec) +serlib/plugins/ltac2/ser_tac2expr.ml:module GT2E = Serlib.SerType.Pierce(GT2ESpec) +serlib/ser_cooking.ml:module B_ = SerType.Pierce(CIP) +serlib/ser_environ.ml: include SerType.Pierce(PierceSpec) +serlib/ser_float64.ml:include SerType.Pierce(PierceSpec) +serlib/ser_impargs.ml:module B_ = SerType.Pierce(ISCPierceSpec) +serlib/ser_names.ml:include SerType.Pierce(MBIdBij) +serlib/ser_names.ml: include SerType.Pierce(PierceSpec) +serlib/ser_names.ml: include SerType.Pierce(PierceSpec) +serlib/ser_numTok.ml: include SerType.Pierce(PierceSpec) +serlib/ser_opaqueproof.ml:module B_ = SerType.Pierce(OP) +serlib/ser_opaqueproof.ml:module C_ = SerType.Pierce(OTSpec) +serlib/ser_rtree.ml:include SerType.Pierce1(RTreePierce) +serlib/ser_sList.ml:include SerType.Pierce1(SL) +serlib/ser_safe_typing.ml:module B_ = SerType.Pierce(PC) +serlib/ser_sorts.ml:include SerType.Pierce(PierceSpec) +serlib/ser_stateid.ml:include SerType.Pierce(SId) +serlib/ser_univ.ml: module PierceImp = SerType.Pierce(PierceSpec) +serlib/ser_univ.ml: include SerType.Pierce(PierceSpec) +serlib/ser_univ.ml: include SerType.Pierce(ACPierceDef) +serlib/ser_vmemitcodes.ml:module B = SerType.Pierce(PierceToPatch) +``` diff --git a/serlib_8_19/dune b/serlib_8_19/dune new file mode 100644 index 00000000..bd22ae5a --- /dev/null +++ b/serlib_8_19/dune @@ -0,0 +1,12 @@ +(library + (name serlib) + (public_name coq-lsp.serlib) + (synopsis "Serialization Library for Coq") + (preprocess + (staged_pps + ppx_import + ppx_sexp_conv + ppx_hash + ppx_compare + ppx_deriving_yojson)) + (libraries coq-core.stm sexplib)) diff --git a/serlib_8_19/ide/ser_richpp.ml b/serlib_8_19/ide/ser_richpp.ml new file mode 100644 index 00000000..df057313 --- /dev/null +++ b/serlib_8_19/ide/ser_richpp.ml @@ -0,0 +1,28 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Richpp.richpp +val sexp_of_richpp : Richpp.richpp -> Sexp.t + +type 'a located = 'a Richpp.located + +val located_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a Richpp.located +val sexp_of_located : ('a -> Sexp.t) -> 'a Richpp.located -> Sexp.t diff --git a/serlib_8_19/plugins/btauto/dune b/serlib_8_19/plugins/btauto/dune new file mode 100644 index 00000000..f29b7d50 --- /dev/null +++ b/serlib_8_19/plugins/btauto/dune @@ -0,0 +1,12 @@ +(library + (name serlib_btauto) + (public_name coq-lsp.serlib.btauto) + (synopsis "Serialization Library for Coq BTauto Plugin") + (preprocess + (staged_pps + ppx_import + ppx_sexp_conv + ppx_deriving_yojson + ppx_hash + ppx_compare)) + (libraries coq-core.plugins.btauto serlib sexplib)) diff --git a/serlib_8_19/plugins/cc/dune b/serlib_8_19/plugins/cc/dune new file mode 100644 index 00000000..28ca0e2d --- /dev/null +++ b/serlib_8_19/plugins/cc/dune @@ -0,0 +1,12 @@ +(library + (name serlib_cc) + (public_name coq-lsp.serlib.cc) + (synopsis "Serialization Library for Coq Congruence Plugin") + (preprocess + (staged_pps + ppx_import + ppx_sexp_conv + ppx_deriving_yojson + ppx_hash + ppx_compare)) + (libraries coq-core.plugins.cc serlib sexplib)) diff --git a/serlib_8_19/plugins/extraction/dune b/serlib_8_19/plugins/extraction/dune new file mode 100644 index 00000000..2c19356c --- /dev/null +++ b/serlib_8_19/plugins/extraction/dune @@ -0,0 +1,12 @@ +(library + (name serlib_extraction) + (public_name coq-lsp.serlib.extraction) + (synopsis "Serialization Library for Coq Fundind Plugin") + (preprocess + (staged_pps + ppx_import + ppx_sexp_conv + ppx_deriving_yojson + ppx_hash + ppx_compare)) + (libraries coq-core.plugins.extraction serlib)) diff --git a/serlib_8_19/plugins/extraction/ser_g_extraction.ml b/serlib_8_19/plugins/extraction/ser_g_extraction.ml new file mode 100644 index 00000000..85dc5caa --- /dev/null +++ b/serlib_8_19/plugins/extraction/ser_g_extraction.ml @@ -0,0 +1,60 @@ +(************************************************************************) +(* SerAPI: Coq interaction protocol with bidirectional serialization *) +(************************************************************************) +(* Copyright 2016-2019 MINES ParisTech -- License LGPL 2.1+ *) +(* Copyright 2019-2023 Inria -- License LGPL 2.1+ *) +(* Written by: Emilio J. Gallego Arias and others *) +(************************************************************************) + +open Serlib + +open Sexplib.Conv +open Ppx_compare_lib.Builtin +open Ppx_hash_lib.Std.Hash.Builtin + +module Names = Ser_names + +module Extraction_plugin = struct + module G_extraction = Extraction_plugin.G_extraction + module Table = struct + type int_or_id = + [%import: Extraction_plugin.Table.int_or_id] + [@@deriving sexp,yojson,hash,compare] + type lang = + [%import: Extraction_plugin.Table.lang] + [@@deriving sexp,yojson,hash,compare] + end +end + +module WitII = struct + type t = Extraction_plugin.Table.int_or_id + [@@deriving sexp,yojson,hash,compare] +end + +let ser_wit_int_or_id = let module M = Ser_genarg.GS0(WitII) in M.genser + +module WitL = struct + type raw = Extraction_plugin.Table.lang + [@@deriving sexp,yojson,hash,compare] + type glb = unit + [@@deriving sexp,yojson,hash,compare] + type top = unit + [@@deriving sexp,yojson,hash,compare] +end + +let ser_wit_language = let module M = Ser_genarg.GS(WitL) in M.genser + +module WitMN = struct + type t = string + [@@deriving sexp,yojson,hash,compare] +end + +let ser_wit_mlname = let module M = Ser_genarg.GS0(WitMN) in M.genser + +let register () = + Ser_genarg.register_genser Extraction_plugin.G_extraction.wit_int_or_id ser_wit_int_or_id; + Ser_genarg.register_genser Extraction_plugin.G_extraction.wit_language ser_wit_language; + Ser_genarg.register_genser Extraction_plugin.G_extraction.wit_mlname ser_wit_mlname; + () + +let _ = register () diff --git a/serlib_8_19/plugins/firstorder/dune b/serlib_8_19/plugins/firstorder/dune new file mode 100644 index 00000000..ee351fc9 --- /dev/null +++ b/serlib_8_19/plugins/firstorder/dune @@ -0,0 +1,7 @@ +(library + (name serlib_firstorder) + (public_name coq-lsp.serlib.firstorder) + (synopsis "Serialization Library for Coq Firstorder Plugin") + (preprocess + (staged_pps ppx_import ppx_sexp_conv ppx_hash ppx_compare)) + (libraries coq-core.plugins.firstorder serlib sexplib)) diff --git a/serlib_8_19/plugins/firstorder/ser_g_ground.ml b/serlib_8_19/plugins/firstorder/ser_g_ground.ml new file mode 100644 index 00000000..06d54743 --- /dev/null +++ b/serlib_8_19/plugins/firstorder/ser_g_ground.ml @@ -0,0 +1,55 @@ +(************************************************************************) +(* SerAPI: Coq interaction protocol with bidirectional serialization *) +(************************************************************************) +(* Copyright 2016-2019 MINES ParisTech -- License LGPL 2.1+ *) +(* Copyright 2019-2023 Inria -- License LGPL 2.1+ *) +(* Written by: Emilio J. Gallego Arias and others *) +(************************************************************************) + +open Serlib + +open Sexplib.Conv +open Ppx_compare_lib.Builtin +open Ppx_hash_lib.Std.Hash.Builtin + +module Loc = Ser_loc +module Names = Ser_names +module Libnames = Ser_libnames +module Locus = Ser_locus +(* module Globnames = Ser_globnames *) + +type h1 = Libnames.qualid list + [@@deriving sexp, hash, compare] + +type h2 = Names.GlobRef.t Loc.located Locus.or_var list +[@@deriving sexp, hash, compare] + +type h3 = Names.GlobRef.t list +[@@deriving sexp,hash,compare] + +let ser_wit_firstorder_using : + (Libnames.qualid list, + Names.GlobRef.t Loc.located Locus.or_var list, + Names.GlobRef.t list) Ser_genarg.gen_ser = + Ser_genarg.{ + raw_ser = sexp_of_h1 + ; raw_des = h1_of_sexp + ; raw_hash = hash_fold_h1 + ; raw_compare = compare_h1 + + ; glb_ser = sexp_of_h2 + ; glb_des = h2_of_sexp + ; glb_hash = hash_fold_h2 + ; glb_compare = compare_h2 + + ; top_ser = sexp_of_h3 + ; top_des = h3_of_sexp + ; top_hash = hash_fold_h3 + ; top_compare = compare_h3 + } + +let register () = + Ser_genarg.register_genser Firstorder_plugin.G_ground.wit_firstorder_using ser_wit_firstorder_using; + () + +let _ = register () diff --git a/serlib_8_19/plugins/funind/dune b/serlib_8_19/plugins/funind/dune new file mode 100644 index 00000000..591c0571 --- /dev/null +++ b/serlib_8_19/plugins/funind/dune @@ -0,0 +1,7 @@ +(library + (name serlib_funind) + (public_name coq-lsp.serlib.funind) + (synopsis "Serialization Library for Coq Fundind Plugin") + (preprocess + (staged_pps ppx_import ppx_sexp_conv ppx_hash ppx_compare)) + (libraries coq-core.plugins.funind serlib serlib_ltac sexplib)) diff --git a/serlib_8_19/plugins/funind/ser_g_indfun.ml b/serlib_8_19/plugins/funind/ser_g_indfun.ml new file mode 100644 index 00000000..05b6044a --- /dev/null +++ b/serlib_8_19/plugins/funind/ser_g_indfun.ml @@ -0,0 +1,108 @@ +(************************************************************************) +(* SerAPI: Coq interaction protocol with bidirectional serialization *) +(************************************************************************) +(* Copyright 2016-2019 MINES ParisTech -- License LGPL 2.1+ *) +(* Copyright 2019-2023 Inria -- License LGPL 2.1+ *) +(* Written by: Emilio J. Gallego Arias and others *) +(************************************************************************) + +open Serlib + +open Ppx_compare_lib.Builtin +open Ppx_hash_lib.Std.Hash.Builtin +open Sexplib.Conv + +module CAst = Ser_cAst +module Names = Ser_names +module Sorts = Ser_sorts +module Libnames = Ser_libnames +module Constrexpr = Ser_constrexpr +module Tactypes = Ser_tactypes +module Genintern = Ser_genintern +module EConstr = Ser_eConstr +module Tacexpr = Serlib_ltac.Ser_tacexpr + +module A1 = struct + +type h1 = Constrexpr.constr_expr Tactypes.intro_pattern_expr CAst.t option +[@@deriving sexp,hash,compare] +type h2 = Genintern.glob_constr_and_expr Tactypes.intro_pattern_expr CAst.t option +[@@deriving sexp,hash,compare] +type h3 = Tacexpr.intro_pattern option +[@@deriving sexp,hash,compare] + +end + +let ser_wit_with_names = + let open A1 in + Ser_genarg.{ + raw_ser = sexp_of_h1 + ; raw_des = h1_of_sexp + ; raw_hash = hash_fold_h1 + ; raw_compare = compare_h1 + + ; glb_ser = sexp_of_h2 + ; glb_des = h2_of_sexp + ; glb_hash = hash_fold_h2 + ; glb_compare = compare_h2 + + ; top_ser = sexp_of_h3 + ; top_des = h3_of_sexp + ; top_hash = hash_fold_h3 + ; top_compare = compare_h3 + } + +module WitFI = struct + type raw = Constrexpr.constr_expr Tactypes.with_bindings option + [@@deriving sexp,hash,compare] + type glb = Genintern.glob_constr_and_expr Tactypes.with_bindings option + [@@deriving sexp,hash,compare] + type top = EConstr.t Tactypes.with_bindings Ser_tactypes.delayed_open option + [@@deriving sexp,hash,compare] +end + +let ser_wit_fun_ind_using = let module M = Ser_genarg.GS(WitFI) in M.genser + +module WitFS = struct + type raw = Names.variable * Libnames.qualid * Sorts.family + [@@deriving sexp,hash,compare] + type glb = unit + [@@deriving sexp,hash,compare] + type top = unit + [@@deriving sexp,hash,compare] +end + +let ser_wit_fun_scheme_arg = let module M = Ser_genarg.GS(WitFS) in M.genser + +module Loc = Ser_loc +module Vernacexpr = Ser_vernacexpr + +module WFFD = struct + type t = Vernacexpr.fixpoint_expr Loc.located + [@@deriving sexp,hash,compare] +end + +let ser_wit_function_fix_definition = + let module M = Ser_genarg.GS0(WFFD) in M.genser + +module WAU = struct + type raw = Constrexpr.constr_expr list + [@@deriving sexp,hash,compare] + type glb = Genintern.glob_constr_and_expr list + [@@deriving sexp,hash,compare] + type top = EConstr.constr list + [@@deriving sexp,hash,compare] +end + +let ser_wit_auto_using' = let module M = Ser_genarg.GS(WAU) in M.genser + +let register () = + Ser_genarg.register_genser Funind_plugin.G_indfun.wit_auto_using' ser_wit_auto_using'; + Ser_genarg.register_genser Funind_plugin.G_indfun.wit_constr_comma_sequence' ser_wit_auto_using'; + Ser_genarg.register_genser Funind_plugin.G_indfun.wit_with_names ser_wit_with_names; + Ser_genarg.register_genser Funind_plugin.G_indfun.wit_fun_ind_using ser_wit_fun_ind_using; + Ser_genarg.register_genser Funind_plugin.G_indfun.wit_fun_scheme_arg ser_wit_fun_scheme_arg; + Ser_genarg.register_genser Funind_plugin.G_indfun.wit_function_fix_definition ser_wit_function_fix_definition; + () + +let _ = register () diff --git a/serlib_8_19/plugins/ltac/dune b/serlib_8_19/plugins/ltac/dune new file mode 100644 index 00000000..b2668504 --- /dev/null +++ b/serlib_8_19/plugins/ltac/dune @@ -0,0 +1,12 @@ +(library + (name serlib_ltac) + (public_name coq-lsp.serlib.ltac) + (synopsis "Serialization Library for Coq [LTAC plugin]") + (preprocess + (staged_pps + ppx_import + ppx_sexp_conv + ppx_deriving_yojson + ppx_hash + ppx_compare)) + (libraries coq-core.plugins.ltac serlib sexplib)) diff --git a/serlib_8_19/plugins/ltac/ser_profile_ltac.ml b/serlib_8_19/plugins/ltac/ser_profile_ltac.ml new file mode 100644 index 00000000..2abec9e7 --- /dev/null +++ b/serlib_8_19/plugins/ltac/ser_profile_ltac.ml @@ -0,0 +1,43 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* ITac.TacIntroPattern(a,b) + | Ltac_plugin.Tacexpr.TacApply (a,b,c,d) -> ITac.TacApply (a,b,c,d) + | Ltac_plugin.Tacexpr.TacElim (a,b,c) -> ITac.TacElim (a,b,c) + | Ltac_plugin.Tacexpr.TacCase (a,b) -> ITac.TacCase (a,b) + | Ltac_plugin.Tacexpr.TacMutualFix (a,b,c) -> ITac.TacMutualFix (a,b,c) + | Ltac_plugin.Tacexpr.TacMutualCofix (a,b) -> ITac.TacMutualCofix (a,b) + | Ltac_plugin.Tacexpr.TacAssert (a,b,c,d,e) -> ITac.TacAssert (a,b,c,d,e) + | Ltac_plugin.Tacexpr.TacGeneralize a -> ITac.TacGeneralize a + | Ltac_plugin.Tacexpr.TacLetTac (a,b,c,d,e,f) -> ITac.TacLetTac (a,b,c,d,e,f) + | Ltac_plugin.Tacexpr.TacInductionDestruct (a,b,c) -> ITac.TacInductionDestruct (a,b,c) + | Ltac_plugin.Tacexpr.TacReduce (a,b) -> ITac.TacReduce (a,b) + | Ltac_plugin.Tacexpr.TacChange (a,b,c,d) -> ITac.TacChange (a,b,c,d) + | Ltac_plugin.Tacexpr.TacRewrite (a,b,c,d) -> ITac.TacRewrite (a,b,c,d) + | Ltac_plugin.Tacexpr.TacInversion (a,b) -> ITac.TacInversion (a,b) +and _gen_tactic_arg_put (t : 'a Ltac_plugin.Tacexpr.gen_tactic_arg) : + ('t, 'dtrm, 'p, 'c, 'r, 'n, 'tacexpr, 'l) ITac.gen_tactic_arg = match t with + | Ltac_plugin.Tacexpr.TacGeneric (a,b) -> ITac.TacGeneric (a,b) + | Ltac_plugin.Tacexpr.ConstrMayEval a -> ITac.ConstrMayEval a + | Ltac_plugin.Tacexpr.Reference a -> ITac.Reference a + | Ltac_plugin.Tacexpr.TacCall l -> ITac.TacCall C.(map (fun (b,c) -> (b, List.map _gen_tactic_arg_put c)) l) + | Ltac_plugin.Tacexpr.TacFreshId a -> ITac.TacFreshId a + | Ltac_plugin.Tacexpr.Tacexp a -> ITac.Tacexp a + | Ltac_plugin.Tacexpr.TacPretype a -> ITac.TacPretype a + | Ltac_plugin.Tacexpr.TacNumgoals -> ITac.TacNumgoals +and _gen_tactic_expr_r_put (t : 'a Ltac_plugin.Tacexpr.gen_tactic_expr_r) : + ('t, 'dtrm, 'p, 'c, 'r, 'n, 'tacexpr, 'l) ITac.gen_tactic_expr_r = + let u x = _gen_tactic_expr_put x in + let uu x = List.map u x in + let ua x = Array.map u x in + match t with + | Ltac_plugin.Tacexpr.TacAtom l -> ITac.TacAtom (_gen_atomic_tactic_expr_put l) + | Ltac_plugin.Tacexpr.TacThen (a,b) -> ITac.TacThen (u a, u b) + | Ltac_plugin.Tacexpr.TacDispatch a -> ITac.TacDispatch (uu a) + | Ltac_plugin.Tacexpr.TacExtendTac (a,b,c) -> ITac.TacExtendTac (ua a, u b, ua c) + | Ltac_plugin.Tacexpr.TacThens (a,b) -> ITac.TacThens (u a, uu b) + | Ltac_plugin.Tacexpr.TacThens3parts (a,b,c,d) -> ITac.TacThens3parts (u a, ua b, u c, ua d) + | Ltac_plugin.Tacexpr.TacFirst a -> ITac.TacFirst (uu a) + | Ltac_plugin.Tacexpr.TacSolve a -> ITac.TacSolve (uu a) + | Ltac_plugin.Tacexpr.TacTry a -> ITac.TacTry (u a) + | Ltac_plugin.Tacexpr.TacOr (a,b) -> ITac.TacOr (u a, u b) + | Ltac_plugin.Tacexpr.TacOnce a -> ITac.TacOnce (u a) + | Ltac_plugin.Tacexpr.TacExactlyOnce a -> ITac.TacExactlyOnce (u a) + | Ltac_plugin.Tacexpr.TacIfThenCatch (a,b,c) -> ITac.TacIfThenCatch (u a,u b,u c) + | Ltac_plugin.Tacexpr.TacOrelse (a,b) -> ITac.TacOrelse (u a,u b) + | Ltac_plugin.Tacexpr.TacDo (a,b) -> ITac.TacDo (a,u b) + | Ltac_plugin.Tacexpr.TacTimeout (a,b) -> ITac.TacTimeout (a,u b) + | Ltac_plugin.Tacexpr.TacTime (a,b) -> ITac.TacTime (a,u b) + | Ltac_plugin.Tacexpr.TacRepeat a -> ITac.TacRepeat (u a) + | Ltac_plugin.Tacexpr.TacProgress a -> ITac.TacProgress (u a) + (* | Ltac_plugin.Tacexpr.TacShowHyps a -> ITac.TacShowHyps (u a) *) + | Ltac_plugin.Tacexpr.TacAbstract (a,b) -> ITac.TacAbstract (u a,b) + | Ltac_plugin.Tacexpr.TacId a -> ITac.TacId a + | Ltac_plugin.Tacexpr.TacFail (a,b,c) -> ITac.TacFail (a,b,c) + (* | Ltac_plugin.Tacexpr.TacInfo a -> ITac.TacInfo (u a) *) + (* | TacLetIn of rec_flag * *) + (* (Names.Id.t located * 'a gen_tactic_arg) list * *) + (* 'a gen_tactic_expr *) + | Ltac_plugin.Tacexpr.TacLetIn (a, l, t) -> + let _pt = List.map (fun (a,t) -> (a,_gen_tactic_arg_put t)) in + ITac.TacLetIn (a, _pt l, _gen_tactic_expr_put t) + (* | TacMatch of lazy_flag * *) + (* 'a gen_tactic_expr * *) + (* ('p,'a gen_tactic_expr) match_rule list *) + (* type ('a,'t) match_rule = *) + (* | Pat of 'a match_context_hyps list * 'a match_pattern * 't *) + (* | All of 't *) + | Ltac_plugin.Tacexpr.TacMatch (a, e, mr) -> + let _pmr = List.map (function + | Ltac_plugin.Tacexpr.Pat (a,b,t) -> Ltac_plugin.Tacexpr.Pat (a,b,_gen_tactic_expr_put t) + | Ltac_plugin.Tacexpr.All e -> Ltac_plugin.Tacexpr.All (_gen_tactic_expr_put e) + ) in + ITac.TacMatch(a, _gen_tactic_expr_put e, _pmr mr) + | Ltac_plugin.Tacexpr.TacMatchGoal (e, d, t) -> + let _pmr = List.map (function + | Ltac_plugin.Tacexpr.Pat (a,b,t) -> Ltac_plugin.Tacexpr.Pat (a,b,_gen_tactic_expr_put t) + | Ltac_plugin.Tacexpr.All e -> Ltac_plugin.Tacexpr.All (_gen_tactic_expr_put e) + ) in + ITac.TacMatchGoal(e, d, _pmr t) + | Ltac_plugin.Tacexpr.TacFun a -> ITac.TacFun (_gen_tactic_fun_ast_put a) + | Ltac_plugin.Tacexpr.TacArg l -> ITac.TacArg (_gen_tactic_arg_put l) + | Ltac_plugin.Tacexpr.TacSelect(gs,te) -> ITac.TacSelect(gs, _gen_tactic_expr_put te) + | Ltac_plugin.Tacexpr.TacML (l,m) -> ITac.TacML (l, List.map _gen_tactic_arg_put m) + | Ltac_plugin.Tacexpr.TacAlias (l,m) -> ITac.TacAlias (l, List.map _gen_tactic_arg_put m) +and _gen_tactic_expr_put (t : _ Ltac_plugin.Tacexpr.gen_tactic_expr) = + C.map _gen_tactic_expr_r_put t + +and _gen_tactic_fun_ast_put (t : 'a Ltac_plugin.Tacexpr.gen_tactic_fun_ast) : + ('t, 'dtrm, 'p, 'c, 'r, 'n, 'tacexpr, 'l) ITac.gen_tactic_fun_ast = + match t with + | (a,b) -> (a, _gen_tactic_expr_put b) + +let rec _gen_atom_tactic_expr_get (t : ('t, 'dtrm, 'p, 'c, 'r, 'n, 'tacexpr, 'l) ITac.gen_atomic_tactic_expr) : + 'a Ltac_plugin.Tacexpr.gen_atomic_tactic_expr = match t with + | ITac.TacIntroPattern(a,b) -> Ltac_plugin.Tacexpr.TacIntroPattern(a,b) + | ITac.TacApply (a,b,c,d) -> Ltac_plugin.Tacexpr.TacApply (a,b,c,d) + | ITac.TacElim (a,b,c) -> Ltac_plugin.Tacexpr.TacElim (a,b,c) + | ITac.TacCase (a,b) -> Ltac_plugin.Tacexpr.TacCase (a,b) + | ITac.TacMutualFix (a,b,c) -> Ltac_plugin.Tacexpr.TacMutualFix (a,b,c) + | ITac.TacMutualCofix (a,b) -> Ltac_plugin.Tacexpr.TacMutualCofix (a,b) + | ITac.TacAssert (a,b,c,d,e) -> Ltac_plugin.Tacexpr.TacAssert (a,b,c,d,e) + | ITac.TacGeneralize a -> Ltac_plugin.Tacexpr.TacGeneralize a + | ITac.TacLetTac (a,b,c,d,e,f) -> Ltac_plugin.Tacexpr.TacLetTac (a,b,c,d,e,f) + | ITac.TacInductionDestruct (a,b,c) -> Ltac_plugin.Tacexpr.TacInductionDestruct (a,b,c) + | ITac.TacReduce (a,b) -> Ltac_plugin.Tacexpr.TacReduce (a,b) + | ITac.TacChange (a,b,c,d) -> Ltac_plugin.Tacexpr.TacChange (a,b,c,d) + | ITac.TacRewrite (a,b,c,d) -> Ltac_plugin.Tacexpr.TacRewrite (a,b,c,d) + | ITac.TacInversion (a,b) -> Ltac_plugin.Tacexpr.TacInversion (a,b) +and _gen_tactic_arg_get (t : ('t, 'dtrm, 'p, 'c, 'r, 'n, 'tacexpr, 'l) ITac.gen_tactic_arg) : + 'a Ltac_plugin.Tacexpr.gen_tactic_arg = match t with + | ITac.TacGeneric(a,b) -> Ltac_plugin.Tacexpr.TacGeneric (a,b) + | ITac.ConstrMayEval a -> Ltac_plugin.Tacexpr.ConstrMayEval a + | ITac.Reference a -> Ltac_plugin.Tacexpr.Reference a + | ITac.TacCall l -> Ltac_plugin.Tacexpr.TacCall C.(map (fun (b,c) -> (b, List.map _gen_tactic_arg_get c)) l) + | ITac.TacFreshId a -> Ltac_plugin.Tacexpr.TacFreshId a + | ITac.Tacexp a -> Ltac_plugin.Tacexpr.Tacexp a + | ITac.TacPretype a -> Ltac_plugin.Tacexpr.TacPretype a + | ITac.TacNumgoals -> Ltac_plugin.Tacexpr.TacNumgoals +and _gen_tactic_expr_r_get (t : ('t, 'dtrm, 'p, 'c, 'r, 'n, 'tacexpr, 'l) ITac.gen_tactic_expr_r) : + 'a Ltac_plugin.Tacexpr.gen_tactic_expr_r = + let u x = _gen_tactic_expr_get x in + let uu x = List.map u x in + let ua x = Array.map u x in + match t with + | ITac.TacAtom l -> Ltac_plugin.Tacexpr.TacAtom (_gen_atom_tactic_expr_get l) + | ITac.TacThen (a,b) -> Ltac_plugin.Tacexpr.TacThen (u a, u b) + | ITac.TacDispatch a -> Ltac_plugin.Tacexpr.TacDispatch (uu a) + | ITac.TacExtendTac (a,b,c) -> Ltac_plugin.Tacexpr.TacExtendTac (ua a, u b, ua c) + | ITac.TacThens (a,b) -> Ltac_plugin.Tacexpr.TacThens (u a, uu b) + | ITac.TacThens3parts (a,b,c,d) -> Ltac_plugin.Tacexpr.TacThens3parts (u a, ua b, u c, ua d) + | ITac.TacFirst a -> Ltac_plugin.Tacexpr.TacFirst (uu a) + | ITac.TacSolve a -> Ltac_plugin.Tacexpr.TacSolve (uu a) + | ITac.TacTry a -> Ltac_plugin.Tacexpr.TacTry (u a) + | ITac.TacOr (a,b) -> Ltac_plugin.Tacexpr.TacOr (u a, u b) + | ITac.TacOnce a -> Ltac_plugin.Tacexpr.TacOnce (u a) + | ITac.TacExactlyOnce a -> Ltac_plugin.Tacexpr.TacExactlyOnce (u a) + | ITac.TacIfThenCatch (a,b,c) -> Ltac_plugin.Tacexpr.TacIfThenCatch (u a,u b,u c) + | ITac.TacOrelse (a,b) -> Ltac_plugin.Tacexpr.TacOrelse (u a,u b) + | ITac.TacDo (a,b) -> Ltac_plugin.Tacexpr.TacDo (a,u b) + | ITac.TacTimeout (a,b) -> Ltac_plugin.Tacexpr.TacTimeout (a,u b) + | ITac.TacTime (a,b) -> Ltac_plugin.Tacexpr.TacTime (a,u b) + | ITac.TacRepeat a -> Ltac_plugin.Tacexpr.TacRepeat (u a) + | ITac.TacProgress a -> Ltac_plugin.Tacexpr.TacProgress (u a) + (* | ITac.TacShowHyps a -> Ltac_plugin.Tacexpr.TacShowHyps (u a) *) + | ITac.TacAbstract (a,b) -> Ltac_plugin.Tacexpr.TacAbstract (u a,b) + | ITac.TacId a -> Ltac_plugin.Tacexpr.TacId a + | ITac.TacFail (a,b,c) -> Ltac_plugin.Tacexpr.TacFail (a,b,c) + (* | ITac.TacInfo a -> Ltac_plugin.Tacexpr.TacInfo (u a) *) + | ITac.TacLetIn (a, l, t) -> + let _pt = List.map (fun (a,t) -> (a,_gen_tactic_arg_get t)) in + Ltac_plugin.Tacexpr.TacLetIn (a, _pt l, _gen_tactic_expr_get t) + | ITac.TacMatch (a,e,mr) -> + let _gmr = List.map (function + | Ltac_plugin.Tacexpr.Pat (a,b,t) -> Ltac_plugin.Tacexpr.Pat (a,b,_gen_tactic_expr_get t) + | Ltac_plugin.Tacexpr.All e -> Ltac_plugin.Tacexpr.All (_gen_tactic_expr_get e) + ) in + Ltac_plugin.Tacexpr.TacMatch(a, _gen_tactic_expr_get e, _gmr mr) + | ITac.TacMatchGoal (a,d,t) -> + let _gmr = List.map (function + | Ltac_plugin.Tacexpr.Pat (a,b,t) -> Ltac_plugin.Tacexpr.Pat (a,b,_gen_tactic_expr_get t) + | Ltac_plugin.Tacexpr.All e -> Ltac_plugin.Tacexpr.All (_gen_tactic_expr_get e) + ) in + Ltac_plugin.Tacexpr.TacMatchGoal(a,d, _gmr t) + | ITac.TacFun a -> Ltac_plugin.Tacexpr.TacFun (_gen_tactic_fun_ast_get a) + | ITac.TacArg l -> Ltac_plugin.Tacexpr.TacArg (_gen_tactic_arg_get l) + | ITac.TacSelect(gs,te) -> Ltac_plugin.Tacexpr.TacSelect(gs, _gen_tactic_expr_get te) + | ITac.TacML (l,m) -> Ltac_plugin.Tacexpr.TacML (l, List.map _gen_tactic_arg_get m) + | ITac.TacAlias (l,m) -> Ltac_plugin.Tacexpr.TacAlias (l, List.map _gen_tactic_arg_get m) + +and _gen_tactic_expr_get (t : ('t, 'dtrm, 'p, 'c, 'r, 'n, 'tacexpr, 'l) ITac.gen_tactic_expr) : + 'a Ltac_plugin.Tacexpr.gen_tactic_expr = + C.map _gen_tactic_expr_r_get t + +and _gen_tactic_fun_ast_get (t : ('t, 'dtrm, 'p, 'c, 'r, 'n, 'tacexpr, 'l) ITac.gen_tactic_fun_ast) : + 'a Ltac_plugin.Tacexpr.gen_tactic_fun_ast = + match t with + | (a,b) -> (a, _gen_tactic_expr_get b) + +type 'd gen_atomic_tactic_expr = 'd Ltac_plugin.Tacexpr.gen_atomic_tactic_expr + +(* Sexp part for generic functions *) + +let sexp_of_gen_atomic_tactic_expr + t d p c r n te l (tac : 'a Ltac_plugin.Tacexpr.gen_atomic_tactic_expr) : Sexp.t = + ITac.sexp_of_gen_atomic_tactic_expr t d p c r n te l (_gen_atomic_tactic_expr_put tac) + +let sexp_of_gen_tactic_expr + t d p c r n te l (tac : 'a Ltac_plugin.Tacexpr.gen_tactic_expr) : Sexp.t = + ITac.sexp_of_gen_tactic_expr t d p c r n te l (_gen_tactic_expr_put tac) + +let sexp_of_gen_tactic_arg + t d p c r n te l (tac : 'a Ltac_plugin.Tacexpr.gen_tactic_arg) : Sexp.t = + ITac.sexp_of_gen_tactic_arg t d p c r n te l (_gen_tactic_arg_put tac) + +let sexp_of_gen_fun_ast + t d p c r n te l (tac : 'a Ltac_plugin.Tacexpr.gen_tactic_fun_ast) : Sexp.t = + ITac.sexp_of_gen_tactic_fun_ast t d p c r n te l (_gen_tactic_fun_ast_put tac) + +let gen_atomic_tactic_expr_of_sexp (tac : Sexp.t) + t d p c r n te l : 'a Ltac_plugin.Tacexpr.gen_atomic_tactic_expr = + _gen_atom_tactic_expr_get (ITac.gen_atomic_tactic_expr_of_sexp t d p c r n te l tac) + +let gen_tactic_expr_of_sexp (tac : Sexp.t) + t d p c r n te l : 'a Ltac_plugin.Tacexpr.gen_tactic_expr = + _gen_tactic_expr_get (ITac.gen_tactic_expr_of_sexp t d p c r n te l tac) + +let gen_tactic_arg_of_sexp (tac : Sexp.t) + t d p c r n te l : 'a Ltac_plugin.Tacexpr.gen_tactic_arg = + _gen_tactic_arg_get (ITac.gen_tactic_arg_of_sexp t d p c r n te l tac) + +let gen_fun_ast_of_sexp (tac : Sexp.t) + t d p c r n te l : 'a Ltac_plugin.Tacexpr.gen_tactic_fun_ast = + _gen_tactic_fun_ast_get (ITac.gen_tactic_fun_ast_of_sexp t d p c r n te l tac) + +(* Yojson part for generic functions *) + +let gen_atomic_tactic_expr_to_yojson + t d p c r n te l (tac : 'a Ltac_plugin.Tacexpr.gen_atomic_tactic_expr) : _ = + ITac.gen_atomic_tactic_expr_to_yojson t d p c r n te l (_gen_atomic_tactic_expr_put tac) + +let gen_tactic_expr_to_yojson + t d p c r n te l (tac : 'a Ltac_plugin.Tacexpr.gen_tactic_expr) : Yojson.Safe.t = + ITac.gen_tactic_expr_to_yojson t d p c r n te l (_gen_tactic_expr_put tac) + +let gen_tactic_expr_of_yojson tac + t d p c r n te l : ('a Ltac_plugin.Tacexpr.gen_tactic_expr, _) result = + Result.map _gen_tactic_expr_get (ITac.gen_tactic_expr_of_yojson t d p c r n te l tac) + +let gen_atomic_tactic_expr_of_yojson tac + t d p c r n te l : ('a Ltac_plugin.Tacexpr.gen_atomic_tactic_expr, _) result = + Result.map _gen_atom_tactic_expr_get (ITac.gen_atomic_tactic_expr_of_yojson t d p c r n te l tac) + +(* Hash part for generic functions *) + +let hash_fold_gen_tactic_expr t d p c r n te l st tac = + ITac.hash_fold_gen_tactic_expr t d p c r n te l st (_gen_tactic_expr_put tac) + +let hash_fold_gen_atomic_tactic_expr t d p c r n te l st tac = + ITac.hash_fold_gen_atomic_tactic_expr t d p c r n te l st (_gen_atomic_tactic_expr_put tac) + +(* Compare part for generic functions *) + +let compare_gen_tactic_expr t d p c r n te l t1 t2 : int = + ITac.compare_gen_tactic_expr t d p c r n te l (_gen_tactic_expr_put t1) (_gen_tactic_expr_put t2) + +let compare_gen_atomic_tactic_expr t d p c r n te l t1 t2 = + ITac.compare_gen_atomic_tactic_expr t d p c r n te l (_gen_atomic_tactic_expr_put t1) (_gen_atomic_tactic_expr_put t2) + +(************************************************************************) +(* Main tactics types, we follow tacexpr and provide glob,raw, and *) +(* atomic *) +(************************************************************************) + +(* Glob *) +type glob_tactic_expr = Ltac_plugin.Tacexpr.glob_tactic_expr +type glob_atomic_tactic_expr = Ltac_plugin.Tacexpr.glob_atomic_tactic_expr + +let rec glob_tactic_expr_of_sexp tac = + gen_tactic_expr_of_sexp + tac + Genintern.glob_constr_and_expr_of_sexp + Genintern.glob_constr_and_expr_of_sexp + Genintern.glob_constr_pattern_and_expr_of_sexp + (Locus.or_var_of_sexp (Genredexpr.and_short_name_of_sexp Tacred.evaluable_global_reference_of_sexp)) + (Locus.or_var_of_sexp (Loc.located_of_sexp ltac_constant_of_sexp)) + Names.lident_of_sexp + glob_tactic_expr_of_sexp + Genarg.glevel_of_sexp +and glob_atomic_tactic_expr_of_sexp tac = + gen_atomic_tactic_expr_of_sexp + tac + Genintern.glob_constr_and_expr_of_sexp + Genintern.glob_constr_and_expr_of_sexp + Genintern.glob_constr_pattern_and_expr_of_sexp + (Locus.or_var_of_sexp (Genredexpr.and_short_name_of_sexp Tacred.evaluable_global_reference_of_sexp)) + (Locus.or_var_of_sexp (Loc.located_of_sexp ltac_constant_of_sexp)) + Names.lident_of_sexp + glob_tactic_expr_of_sexp + Genarg.glevel_of_sexp + +let rec sexp_of_glob_tactic_expr (tac : glob_tactic_expr) = + sexp_of_gen_tactic_expr + Genintern.sexp_of_glob_constr_and_expr + Genintern.sexp_of_glob_constr_and_expr + Genintern.sexp_of_glob_constr_pattern_and_expr + (Locus.sexp_of_or_var (Genredexpr.sexp_of_and_short_name Tacred.sexp_of_evaluable_global_reference)) + (Locus.sexp_of_or_var (Loc.sexp_of_located sexp_of_ltac_constant)) + Names.sexp_of_lident + sexp_of_glob_tactic_expr + Genarg.sexp_of_glevel + tac +and sexp_of_glob_atomic_tactic_expr (tac : glob_atomic_tactic_expr) = + sexp_of_gen_atomic_tactic_expr + Genintern.sexp_of_glob_constr_and_expr + Genintern.sexp_of_glob_constr_and_expr + Genintern.sexp_of_glob_constr_pattern_and_expr + (Locus.sexp_of_or_var (Genredexpr.sexp_of_and_short_name Tacred.sexp_of_evaluable_global_reference)) + (Locus.sexp_of_or_var (Loc.sexp_of_located sexp_of_ltac_constant)) + Names.sexp_of_lident + sexp_of_glob_tactic_expr + Genarg.sexp_of_glevel + tac + +let rec glob_tactic_expr_of_yojson tac = + gen_tactic_expr_of_yojson + tac + Genintern.glob_constr_and_expr_of_yojson + Genintern.glob_constr_and_expr_of_yojson + Genintern.glob_constr_pattern_and_expr_of_yojson + (Locus.or_var_of_yojson (Genredexpr.and_short_name_of_yojson Tacred.evaluable_global_reference_of_yojson)) + (Locus.or_var_of_yojson (Loc.located_of_yojson ltac_constant_of_yojson)) + Names.lident_of_yojson + glob_tactic_expr_of_yojson + Genarg.glevel_of_yojson +and glob_atomic_tactic_expr_of_yojson tac = + gen_atomic_tactic_expr_of_yojson + tac + Genintern.glob_constr_and_expr_of_yojson + Genintern.glob_constr_and_expr_of_yojson + Genintern.glob_constr_pattern_and_expr_of_yojson + (Locus.or_var_of_yojson (Genredexpr.and_short_name_of_yojson Tacred.evaluable_global_reference_of_yojson)) + (Locus.or_var_of_yojson (Loc.located_of_yojson ltac_constant_of_yojson)) + Names.lident_of_yojson + glob_tactic_expr_of_yojson + Genarg.glevel_of_yojson + +let rec glob_tactic_expr_to_yojson tac = + gen_tactic_expr_to_yojson + Genintern.glob_constr_and_expr_to_yojson + Genintern.glob_constr_and_expr_to_yojson + Genintern.glob_constr_pattern_and_expr_to_yojson + (Locus.or_var_to_yojson (Genredexpr.and_short_name_to_yojson Tacred.evaluable_global_reference_to_yojson)) + (Locus.or_var_to_yojson (Loc.located_to_yojson ltac_constant_to_yojson)) + Names.lident_to_yojson + glob_tactic_expr_to_yojson + Genarg.glevel_to_yojson + tac +and glob_atomic_tactic_expr_to_yojson tac = + gen_atomic_tactic_expr_to_yojson + Genintern.glob_constr_and_expr_to_yojson + Genintern.glob_constr_and_expr_to_yojson + Genintern.glob_constr_pattern_and_expr_to_yojson + (Locus.or_var_to_yojson (Genredexpr.and_short_name_to_yojson Tacred.evaluable_global_reference_to_yojson)) + (Locus.or_var_to_yojson (Loc.located_to_yojson ltac_constant_to_yojson)) + Names.lident_to_yojson + glob_tactic_expr_to_yojson + Genarg.glevel_to_yojson + tac + +let rec hash_fold_glob_tactic_expr st tac = + hash_fold_gen_tactic_expr + Genintern.hash_fold_glob_constr_and_expr + Genintern.hash_fold_glob_constr_and_expr + Genintern.hash_fold_glob_constr_pattern_and_expr + (Locus.hash_fold_or_var (Genredexpr.hash_fold_and_short_name Tacred.hash_fold_evaluable_global_reference)) + (Locus.hash_fold_or_var (Loc.hash_fold_located hash_fold_ltac_constant)) + Names.hash_fold_lident + hash_fold_glob_tactic_expr + Genarg.hash_fold_glevel + st tac +and hash_fold_glob_atomic_tactic_expr st tac = + hash_fold_gen_atomic_tactic_expr + Genintern.hash_fold_glob_constr_and_expr + Genintern.hash_fold_glob_constr_and_expr + Genintern.hash_fold_glob_constr_pattern_and_expr + (Locus.hash_fold_or_var (Genredexpr.hash_fold_and_short_name Tacred.hash_fold_evaluable_global_reference)) + (Locus.hash_fold_or_var (Loc.hash_fold_located hash_fold_ltac_constant)) + Names.hash_fold_lident + hash_fold_glob_tactic_expr + Genarg.hash_fold_glevel + st tac + +let hash_glob_tactic_expr = Ppx_hash_lib.Std.Hash.of_fold hash_fold_glob_tactic_expr +let hash_glob_atomic_tactic_expr = Ppx_hash_lib.Std.Hash.of_fold hash_fold_glob_atomic_tactic_expr + +let rec compare_glob_tactic_expr tac = + compare_gen_tactic_expr + Genintern.compare_glob_constr_and_expr + Genintern.compare_glob_constr_and_expr + Genintern.compare_glob_constr_pattern_and_expr + (Locus.compare_or_var (Genredexpr.compare_and_short_name Tacred.compare_evaluable_global_reference)) + (Locus.compare_or_var (Loc.compare_located compare_ltac_constant)) + Names.compare_lident + compare_glob_tactic_expr + Genarg.compare_glevel + tac +and compare_glob_atomic_tactic_expr tac = + compare_gen_atomic_tactic_expr + Genintern.compare_glob_constr_and_expr + Genintern.compare_glob_constr_and_expr + Genintern.compare_glob_constr_pattern_and_expr + (Locus.compare_or_var (Genredexpr.compare_and_short_name Tacred.compare_evaluable_global_reference)) + (Locus.compare_or_var (Loc.compare_located compare_ltac_constant)) + Names.compare_lident + compare_glob_tactic_expr + Genarg.compare_glevel + tac + +(* Raw *) +type raw_tactic_expr = Ltac_plugin.Tacexpr.raw_tactic_expr +type raw_atomic_tactic_expr = Ltac_plugin.Tacexpr.raw_atomic_tactic_expr + +let rec raw_tactic_expr_of_sexp tac = + gen_tactic_expr_of_sexp + tac + Constrexpr.constr_expr_of_sexp + Constrexpr.constr_expr_of_sexp + Constrexpr.constr_pattern_expr_of_sexp + (Constrexpr.or_by_notation_of_sexp Libnames.qualid_of_sexp) + Libnames.qualid_of_sexp + Names.lident_of_sexp + raw_tactic_expr_of_sexp + Genarg.rlevel_of_sexp +and raw_atomic_tactic_expr_of_sexp tac = + gen_atomic_tactic_expr_of_sexp + tac + Constrexpr.constr_expr_of_sexp + Constrexpr.constr_expr_of_sexp + Constrexpr.constr_pattern_expr_of_sexp + (Constrexpr.or_by_notation_of_sexp Libnames.qualid_of_sexp) + Libnames.qualid_of_sexp + Names.lident_of_sexp + raw_tactic_expr_of_sexp + Genarg.rlevel_of_sexp + +let rec sexp_of_raw_tactic_expr (tac : raw_tactic_expr) = + sexp_of_gen_tactic_expr + Constrexpr.sexp_of_constr_expr + Constrexpr.sexp_of_constr_expr + Constrexpr.sexp_of_constr_pattern_expr + (Constrexpr.sexp_of_or_by_notation Libnames.sexp_of_qualid) + Libnames.sexp_of_qualid + Names.sexp_of_lident + sexp_of_raw_tactic_expr + Genarg.sexp_of_rlevel + tac +and sexp_of_raw_atomic_tactic_expr tac = + sexp_of_gen_atomic_tactic_expr + Constrexpr.sexp_of_constr_expr + Constrexpr.sexp_of_constr_expr + Constrexpr.sexp_of_constr_pattern_expr + (Constrexpr.sexp_of_or_by_notation Libnames.sexp_of_qualid) + Libnames.sexp_of_qualid + Names.sexp_of_lident + sexp_of_raw_tactic_expr + Genarg.sexp_of_rlevel + tac + +(* Yojson *) +let rec raw_tactic_expr_of_yojson tac = + gen_tactic_expr_of_yojson + tac + Constrexpr.constr_expr_of_yojson + Constrexpr.constr_expr_of_yojson + Constrexpr.constr_pattern_expr_of_yojson + (Constrexpr.or_by_notation_of_yojson Libnames.qualid_of_yojson) + Libnames.qualid_of_yojson + Names.lident_of_yojson + raw_tactic_expr_of_yojson + Genarg.rlevel_of_yojson +and raw_atomic_tactic_expr_of_yojson tac = + gen_atomic_tactic_expr_of_yojson + tac + Constrexpr.constr_expr_of_yojson + Constrexpr.constr_expr_of_yojson + Constrexpr.constr_pattern_expr_of_yojson + (Constrexpr.or_by_notation_of_yojson Libnames.qualid_of_yojson) + Libnames.qualid_of_yojson + Names.lident_of_yojson + raw_tactic_expr_of_yojson + Genarg.rlevel_of_yojson + +let rec raw_tactic_expr_to_yojson (tac : raw_tactic_expr) = + gen_tactic_expr_to_yojson + Constrexpr.constr_expr_to_yojson + Constrexpr.constr_expr_to_yojson + Constrexpr.constr_pattern_expr_to_yojson + (Constrexpr.or_by_notation_to_yojson Libnames.qualid_to_yojson) + Libnames.qualid_to_yojson + Names.lident_to_yojson + raw_tactic_expr_to_yojson + Genarg.rlevel_to_yojson + tac +and raw_atomic_tactic_expr_to_yojson tac = + gen_atomic_tactic_expr_to_yojson + Constrexpr.constr_expr_to_yojson + Constrexpr.constr_expr_to_yojson + Constrexpr.constr_pattern_expr_to_yojson + (Constrexpr.or_by_notation_to_yojson Libnames.qualid_to_yojson) + Libnames.qualid_to_yojson + Names.lident_to_yojson + raw_tactic_expr_to_yojson + Genarg.rlevel_to_yojson + tac + +let rec hash_fold_raw_tactic_expr st tac = + hash_fold_gen_tactic_expr + Constrexpr.hash_fold_constr_expr + Constrexpr.hash_fold_constr_expr + Constrexpr.hash_fold_constr_pattern_expr + (Constrexpr.hash_fold_or_by_notation Libnames.hash_fold_qualid) + Libnames.hash_fold_qualid + Names.hash_fold_lident + hash_fold_raw_tactic_expr + Genarg.hash_fold_rlevel + st tac +and hash_fold_raw_atomic_tactic_expr st tac = + hash_fold_gen_atomic_tactic_expr + Constrexpr.hash_fold_constr_expr + Constrexpr.hash_fold_constr_expr + Constrexpr.hash_fold_constr_pattern_expr + (Constrexpr.hash_fold_or_by_notation Libnames.hash_fold_qualid) + Libnames.hash_fold_qualid + Names.hash_fold_lident + hash_fold_raw_tactic_expr + Genarg.hash_fold_rlevel + st tac + +let hash_raw_tactic_expr = Ppx_hash_lib.Std.Hash.of_fold hash_fold_raw_tactic_expr +let hash_raw_atomic_tactic_expr = Ppx_hash_lib.Std.Hash.of_fold hash_fold_raw_atomic_tactic_expr + +let rec compare_raw_tactic_expr tac = + compare_gen_tactic_expr + Constrexpr.compare_constr_expr + Constrexpr.compare_constr_expr + Constrexpr.compare_constr_pattern_expr + (Constrexpr.compare_or_by_notation Libnames.compare_qualid) + Libnames.compare_qualid + Names.compare_lident + compare_raw_tactic_expr + Genarg.compare_rlevel + tac +and compare_raw_atomic_tactic_expr tac = + compare_gen_atomic_tactic_expr + Constrexpr.compare_constr_expr + Constrexpr.compare_constr_expr + Constrexpr.compare_constr_pattern_expr + (Constrexpr.compare_or_by_notation Libnames.compare_qualid) + Libnames.compare_qualid + Names.compare_lident + compare_raw_tactic_expr + Genarg.compare_rlevel + tac + +(* Atomic *) +type atomic_tactic_expr = Ltac_plugin.Tacexpr.atomic_tactic_expr + +let atomic_tactic_expr_of_sexp tac = + gen_atomic_tactic_expr_of_sexp tac + EConstr.t_of_sexp + Genintern.glob_constr_and_expr_of_sexp + Pattern.constr_pattern_of_sexp + Tacred.evaluable_global_reference_of_sexp + (Loc.located_of_sexp ltac_constant_of_sexp) + Names.Id.t_of_sexp + unit_of_sexp + Genarg.tlevel_of_sexp + +let sexp_of_atomic_tactic_expr tac = + sexp_of_gen_atomic_tactic_expr + EConstr.sexp_of_t + Genintern.sexp_of_glob_constr_and_expr + Pattern.sexp_of_constr_pattern + Tacred.sexp_of_evaluable_global_reference + (Loc.sexp_of_located sexp_of_ltac_constant) + Names.Id.sexp_of_t + sexp_of_unit + Genarg.sexp_of_tlevel + tac + +(* Helpers for raw_red_expr *) +type tacdef_body = + [%import: Ltac_plugin.Tacexpr.tacdef_body] + [@@deriving sexp,yojson,hash,compare] + +(* Unsupported serializers *) +type intro_pattern = + [%import: Ltac_plugin.Tacexpr.intro_pattern] + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib_8_19/plugins/ltac/ser_tacexpr.mli b/serlib_8_19/plugins/ltac/ser_tacexpr.mli new file mode 100644 index 00000000..2d37a768 --- /dev/null +++ b/serlib_8_19/plugins/ltac/ser_tacexpr.mli @@ -0,0 +1,272 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* direction_flag +val sexp_of_direction_flag : direction_flag -> Sexp.t + +type lazy_flag = Tacexpr.lazy_flag = General | Select | Once +val lazy_flag_of_sexp : Sexp.t -> lazy_flag +val sexp_of_lazy_flag : lazy_flag -> Sexp.t + +type global_flag = Tacexpr.global_flag = TacGlobal | TacLocal +val global_flag_of_sexp : Sexp.t -> global_flag +val sexp_of_global_flag : global_flag -> Sexp.t + +type evars_flag = bool +val evars_flag_of_sexp : Sexp.t -> evars_flag +val sexp_of_evars_flag : evars_flag -> Sexp.t + +type rec_flag = bool +val rec_flag_of_sexp : Sexp.t -> rec_flag +val sexp_of_rec_flag : rec_flag -> Sexp.t + +type advanced_flag = bool +val advanced_flag_of_sexp : Sexp.t -> advanced_flag +val sexp_of_advanced_flag : advanced_flag -> Sexp.t + +type letin_flag = bool +val letin_flag_of_sexp : Sexp.t -> letin_flag +val sexp_of_letin_flag : letin_flag -> Sexp.t + +type clear_flag = bool option +val clear_flag_of_sexp : Sexp.t -> clear_flag +val sexp_of_clear_flag : clear_flag -> Sexp.t + +(* type debug = Tacexpr.debug = Debug | Info | Off *) +(* val debug_of_sexp : Sexp.t -> debug *) +(* val sexp_of_debug : debug -> Sexp.t *) + +(* type goal_selector = Tacexpr.goal_selector *) +(* val goal_selector_of_sexp : Sexp.t -> goal_selector *) +(* val sexp_of_goal_selector : goal_selector -> Sexp.t *) + +type ('c, 'd, 'id) inversion_strength = ('c, 'd, 'id) Tacexpr.inversion_strength + +val inversion_strength_of_sexp : + (Sexp.t -> 'c) -> + (Sexp.t -> 'd) -> + (Sexp.t -> 'id) -> + Sexp.t -> ('c, 'd, 'id) inversion_strength + +val sexp_of_inversion_strength : + ('c -> Sexp.t) -> + ('d -> Sexp.t) -> + ('id -> Sexp.t) -> + ('c, 'd, 'id) inversion_strength -> Sexp.t + +type 'id message_token = 'id Tacexpr.message_token + +val message_token_of_sexp : + (Sexp.t -> 'id) -> Sexp.t -> 'id message_token + +val sexp_of_message_token : + ('id -> Sexp.t) -> 'id message_token -> Sexp.t + +type ('dconstr, 'id) induction_clause = ('dconstr, 'id) Tacexpr.induction_clause + +val induction_clause_of_sexp : + (Sexp.t -> 'dconstr) -> + (Sexp.t -> 'id) -> + Sexp.t -> ('dconstr, 'id) induction_clause + +val sexp_of_induction_clause : + ('dconstr -> Sexp.t) -> + ('id -> Sexp.t) -> + ('dconstr, 'id) induction_clause -> Sexp.t + + +type ('constr, 'dconstr, 'id) induction_clause_list = + ('constr, 'dconstr, 'id) Tacexpr.induction_clause_list + +val induction_clause_list_of_sexp : + (Sexp.t -> 'constr) -> + (Sexp.t -> 'dconstr) -> + (Sexp.t -> 'id) -> + Sexp.t -> ('constr, 'dconstr, 'id) induction_clause_list + +val sexp_of_induction_clause_list : + ('constr -> Sexp.t) -> + ('dconstr -> Sexp.t) -> + ('id -> Sexp.t) -> + ('constr, 'dconstr, 'id) induction_clause_list -> Sexp.t + +type 'a with_bindings_arg = 'a Tacexpr.with_bindings_arg + +val with_bindings_arg_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a with_bindings_arg +val sexp_of_with_bindings_arg : ('a -> Sexp.t) -> 'a with_bindings_arg -> Sexp.t + +(* type multi = Tacexpr.multi *) +(* val multi_of_sexp : Sexp.t -> multi *) +(* val sexp_of_multi : multi -> Sexp.t *) + +type 'a match_pattern = 'a Tacexpr.match_pattern + +val match_pattern_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a match_pattern +val sexp_of_match_pattern : ('a -> Sexp.t) -> 'a match_pattern -> Sexp.t + +type 'a match_context_hyps = 'a Tacexpr.match_context_hyps + +val match_context_hyps_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a match_context_hyps +val sexp_of_match_context_hyps : ('a -> Sexp.t) -> 'a match_context_hyps -> Sexp.t + +type ('a, 't) match_rule = ('a, 't) Tacexpr.match_rule + +val match_rule_of_sexp : + (Sexp.t -> 'a) -> + (Sexp.t -> 't) -> Sexp.t -> ('a, 't) match_rule +val sexp_of_match_rule : + ('a -> Sexp.t) -> + ('t -> Sexp.t) -> ('a, 't) match_rule -> Sexp.t + +type ml_tactic_name = Tacexpr.ml_tactic_name + +val ml_tactic_name_of_sexp : Sexp.t -> ml_tactic_name +val sexp_of_ml_tactic_name : ml_tactic_name -> Sexp.t + +type 'd gen_atomic_tactic_expr = 'd Tacexpr.gen_atomic_tactic_expr + +val sexp_of_gen_atomic_tactic_expr : + ('a -> Sexplib.Sexp.t) -> + ('c -> Sexplib.Sexp.t) -> + ('d -> Sexplib.Sexp.t) -> + ('e -> Sexplib.Sexp.t) -> + ('f -> Sexplib.Sexp.t) -> + ('g -> Sexplib.Sexp.t) -> + ('h -> Sexplib.Sexp.t) -> + ('i -> Sexplib.Sexp.t) -> + < constant : 'e; dterm : 'c; level : 'i; name : 'g; pattern : 'd; + reference : 'f; tacexpr : 'h; term : 'a > + Tacexpr.gen_atomic_tactic_expr -> Sexplib.Sexp.t +val sexp_of_gen_tactic_expr : + ('a -> Sexplib.Sexp.t) -> + ('c -> Sexplib.Sexp.t) -> + ('d -> Sexplib.Sexp.t) -> + ('e -> Sexplib.Sexp.t) -> + ('f -> Sexplib.Sexp.t) -> + ('g -> Sexplib.Sexp.t) -> + ('h -> Sexplib.Sexp.t) -> + ('i -> Sexplib.Sexp.t) -> + < constant : 'e; dterm : 'c; level : 'i; name : 'g; pattern : 'd; + reference : 'f; tacexpr : 'h; term : 'a > + Tacexpr.gen_tactic_expr -> Sexplib.Sexp.t +val sexp_of_gen_tactic_arg : + ('a -> Sexplib.Sexp.t) -> + ('c -> Sexplib.Sexp.t) -> + ('d -> Sexplib.Sexp.t) -> + ('e -> Sexplib.Sexp.t) -> + ('f -> Sexplib.Sexp.t) -> + ('g -> Sexplib.Sexp.t) -> + ('h -> Sexplib.Sexp.t) -> + ('i -> Sexplib.Sexp.t) -> + < constant : 'e; dterm : 'c; level : 'i; name : 'g; pattern : 'd; + reference : 'f; tacexpr : 'h; term : 'a > + Tacexpr.gen_tactic_arg -> Sexplib.Sexp.t +val sexp_of_gen_fun_ast : + ('a -> Sexplib.Sexp.t) -> + ('c -> Sexplib.Sexp.t) -> + ('d -> Sexplib.Sexp.t) -> + ('e -> Sexplib.Sexp.t) -> + ('f -> Sexplib.Sexp.t) -> + ('g -> Sexplib.Sexp.t) -> + ('h -> Sexplib.Sexp.t) -> + ('i -> Sexplib.Sexp.t) -> + < constant : 'e; dterm : 'c; level : 'i; name : 'g; pattern : 'd; + reference : 'f; tacexpr : 'h; term : 'a > + Tacexpr.gen_tactic_fun_ast -> Sexplib.Sexp.t + +val gen_atomic_tactic_expr_of_sexp : + Sexplib.Sexp.t -> + (Sexplib.Sexp.t -> 'a) -> + (Sexplib.Sexp.t -> 'c) -> + (Sexplib.Sexp.t -> 'd) -> + (Sexplib.Sexp.t -> 'e) -> + (Sexplib.Sexp.t -> 'f) -> + (Sexplib.Sexp.t -> 'g) -> + (Sexplib.Sexp.t -> 'h) -> + (Sexplib.Sexp.t -> 'i) -> + < constant : 'e; dterm : 'c; level : 'i; name : 'g; pattern : 'd; + reference : 'f; tacexpr : 'h; term : 'a > + Tacexpr.gen_atomic_tactic_expr + +val gen_tactic_expr_of_sexp : + Sexplib.Sexp.t -> + (Sexplib.Sexp.t -> 'a) -> + (Sexplib.Sexp.t -> 'c) -> + (Sexplib.Sexp.t -> 'd) -> + (Sexplib.Sexp.t -> 'e) -> + (Sexplib.Sexp.t -> 'f) -> + (Sexplib.Sexp.t -> 'g) -> + (Sexplib.Sexp.t -> 'h) -> + (Sexplib.Sexp.t -> 'i) -> + < constant : 'e; dterm : 'c; level : 'i; name : 'g; pattern : 'd; + reference : 'f; tacexpr : 'h; term : 'a > + Tacexpr.gen_tactic_expr + +val gen_tactic_arg_of_sexp : + Sexplib.Sexp.t -> + (Sexplib.Sexp.t -> 'a) -> + (Sexplib.Sexp.t -> 'c) -> + (Sexplib.Sexp.t -> 'd) -> + (Sexplib.Sexp.t -> 'e) -> + (Sexplib.Sexp.t -> 'f) -> + (Sexplib.Sexp.t -> 'g) -> + (Sexplib.Sexp.t -> 'h) -> + (Sexplib.Sexp.t -> 'i) -> + < constant : 'e; dterm : 'c; level : 'i; name : 'g; pattern : 'd; + reference : 'f; tacexpr : 'h; term : 'a > + Tacexpr.gen_tactic_arg + +val gen_fun_ast_of_sexp : + Sexplib.Sexp.t -> + (Sexplib.Sexp.t -> 'a) -> + (Sexplib.Sexp.t -> 'c) -> + (Sexplib.Sexp.t -> 'd) -> + (Sexplib.Sexp.t -> 'e) -> + (Sexplib.Sexp.t -> 'f) -> + (Sexplib.Sexp.t -> 'g) -> + (Sexplib.Sexp.t -> 'h) -> + (Sexplib.Sexp.t -> 'i) -> + < constant : 'e; dterm : 'c; level : 'i; name : 'g; pattern : 'd; + reference : 'f; tacexpr : 'h; term : 'a > + Tacexpr.gen_tactic_fun_ast + +type glob_tactic_expr = Tacexpr.glob_tactic_expr + [@@deriving sexp,yojson,hash,compare] + +type glob_atomic_tactic_expr = Tacexpr.glob_atomic_tactic_expr + [@@deriving sexp,yojson,hash,compare] + +type raw_tactic_expr = Tacexpr.raw_tactic_expr + [@@deriving sexp,yojson,hash,compare] + +type raw_atomic_tactic_expr = Tacexpr.raw_atomic_tactic_expr + [@@deriving sexp,yojson,hash,compare] + +type atomic_tactic_expr = Tacexpr.atomic_tactic_expr +val atomic_tactic_expr_of_sexp : Sexp.t -> atomic_tactic_expr +val sexp_of_atomic_tactic_expr : atomic_tactic_expr -> Sexp.t + +type tacdef_body = Tacexpr.tacdef_body + [@@deriving sexp,hash,compare] + +type intro_pattern = Tacexpr.intro_pattern + [@@deriving sexp,hash,compare] diff --git a/serlib_8_19/plugins/ltac2/dune b/serlib_8_19/plugins/ltac2/dune new file mode 100644 index 00000000..fe468ad6 --- /dev/null +++ b/serlib_8_19/plugins/ltac2/dune @@ -0,0 +1,12 @@ +(library + (name serlib_ltac2) + (public_name coq-lsp.serlib.ltac2) + (synopsis "Serialization Library for Coq [LTAC2 plugin]") + (preprocess + (staged_pps + ppx_import + ppx_sexp_conv + ppx_deriving_yojson + ppx_hash + ppx_compare)) + (libraries coq-core.plugins.ltac2 serlib sexplib)) diff --git a/serlib_8_19/plugins/ltac2/ser_g_ltac2.ml b/serlib_8_19/plugins/ltac2/ser_g_ltac2.ml new file mode 100644 index 00000000..9d854f4f --- /dev/null +++ b/serlib_8_19/plugins/ltac2/ser_g_ltac2.ml @@ -0,0 +1,47 @@ +(************************************************************************) +(* SerAPI: Coq interaction protocol with bidirectional serialization *) +(************************************************************************) +(* Copyright 2016-2019 MINES ParisTech -- License LGPL 2.1+ *) +(* Copyright 2019-2023 Inria -- License LGPL 2.1+ *) +(* Written by: Emilio J. Gallego Arias and others *) +(************************************************************************) + +open Serlib +open Ltac2_plugin + +open Sexplib.Std +open Ppx_hash_lib.Std.Hash.Builtin +open Ppx_compare_lib.Builtin + +module Tac2expr = Ser_tac2expr + +(* val Ltac2_plugin.G_ltac2.wit_ltac2_entry: + (Ltac2_plugin.Tac2expr.strexpr, unit, unit) Genarg.genarg_type *) +module L2Entry = struct + type raw = Tac2expr.strexpr + [@@deriving sexp,hash,compare] + type glb = unit + [@@deriving sexp,hash,compare] + type top = unit + [@@deriving sexp,hash,compare] +end + +let ser_wit_ltac2_entry = let module M = Ser_genarg.GS(L2Entry) in M.genser + +module L2Expr = struct + type raw = Tac2expr.raw_tacexpr + [@@deriving sexp,hash,compare] + type glb = unit + [@@deriving sexp,hash,compare] + type top = unit + [@@deriving sexp,hash,compare] +end + +let ser_wit_ltac2_expr = let module M = Ser_genarg.GS(L2Expr) in M.genser + +let register () = + Ser_genarg.register_genser G_ltac2.wit_ltac2_entry ser_wit_ltac2_entry; + Ser_genarg.register_genser G_ltac2.wit_ltac2_expr ser_wit_ltac2_expr; + () + +let () = register () diff --git a/serlib_8_19/plugins/ltac2/ser_tac2env.ml b/serlib_8_19/plugins/ltac2/ser_tac2env.ml new file mode 100644 index 00000000..c5d5dd0c --- /dev/null +++ b/serlib_8_19/plugins/ltac2/ser_tac2env.ml @@ -0,0 +1,89 @@ +(************************************************************************) +(* SerAPI: Coq interaction protocol with bidirectional serialization *) +(************************************************************************) +(* Copyright 2016-2019 MINES ParisTech -- License LGPL 2.1+ *) +(* Copyright 2019-2023 Inria -- License LGPL 2.1+ *) +(* Written by: Emilio J. Gallego Arias and others *) +(************************************************************************) + +open Serlib +open Ltac2_plugin + +open Sexplib.Std +open Ppx_hash_lib.Std.Hash.Builtin +open Ppx_compare_lib.Builtin + +module Util = Ser_util +module Loc = Ser_loc +module CAst = Ser_cAst +module Names = Ser_names +module Tac2expr = Ser_tac2expr + +module WL2in1 = struct + type raw = Tac2expr.uid CAst.t list * Tac2expr.raw_tacexpr + [@@deriving sexp,hash,compare] + type glb = Tac2expr.uid list * Tac2expr.glb_tacexpr + [@@deriving sexp,hash,compare] + type top = Util.Empty.t + [@@deriving sexp,hash,compare] +end + +let ser_wit_ltac2in1 = let module M = Ser_genarg.GS(WL2in1) in M.genser + +module WL2in1V = struct + type raw = Tac2expr.uid CAst.t list * Tac2expr.raw_tacexpr + [@@deriving sexp,hash,compare] + type glb = Tac2expr.glb_tacexpr + [@@deriving sexp,hash,compare] + type top = Util.Empty.t + [@@deriving sexp,hash,compare] +end + +let ser_wit_ltac2in1_val = let module M = Ser_genarg.GS(WL2in1V) in M.genser + +module WLC2 = struct + type raw = Tac2expr.raw_tacexpr + [@@deriving sexp,hash,compare] + type glb = Names.Id.Set.t * Tac2expr.glb_tacexpr + [@@deriving sexp,hash,compare] + type top = Util.Empty.t + [@@deriving sexp,hash,compare] +end + +let ser_wit_ltac2_constr = let module M = Ser_genarg.GS(WLC2) in M.genser + +type var_quotation_kind = + [%import: Ltac2_plugin.Tac2env.var_quotation_kind] + [@@deriving sexp,yojson,hash,compare] + +module WLQ2 = struct + type raw = Names.lident option * Names.lident + [@@deriving sexp,hash,compare] + type glb = var_quotation_kind * Names.Id.t + [@@deriving sexp,hash,compare] + type top = Util.Empty.t + [@@deriving sexp,hash,compare] +end + +let ser_wit_ltac2_var_quotation = let module M = Ser_genarg.GS(WLQ2) in M.genser + +module WLV2 = struct + type raw = Util.Empty.t + [@@deriving sexp,hash,compare] + type glb = unit + [@@deriving sexp,hash,compare] + type top = Util.Empty.t + [@@deriving sexp,hash,compare] +end + +let ser_wit_ltac2_val = let module M = Ser_genarg.GS(WLV2) in M.genser + +let register () = + Ser_genarg.register_genser Tac2env.wit_ltac2in1 ser_wit_ltac2in1; + Ser_genarg.register_genser Tac2env.wit_ltac2in1_val ser_wit_ltac2in1_val; + Ser_genarg.register_genser Tac2env.wit_ltac2_constr ser_wit_ltac2_constr; + Ser_genarg.register_genser Tac2env.wit_ltac2_var_quotation ser_wit_ltac2_var_quotation; + Ser_genarg.register_genser Tac2env.wit_ltac2_val ser_wit_ltac2_val; + () + +let () = register () diff --git a/serlib_8_19/plugins/ltac2/ser_tac2expr.ml b/serlib_8_19/plugins/ltac2/ser_tac2expr.ml new file mode 100644 index 00000000..b087580d --- /dev/null +++ b/serlib_8_19/plugins/ltac2/ser_tac2expr.ml @@ -0,0 +1,197 @@ +(************************************************************************) +(* SerAPI: Coq interaction protocol with bidirectional serialization *) +(************************************************************************) +(* Copyright 2016-2019 MINES ParisTech -- License LGPL 2.1+ *) +(* Copyright 2019-2023 Inria -- License LGPL 2.1+ *) +(* Written by: Emilio J. Gallego Arias and others *) +(************************************************************************) + +open Serlib + +module Loc = Ser_loc +module CAst = Ser_cAst +module Names = Ser_names +module Libnames = Ser_libnames + +open Sexplib.Std +open Ppx_hash_lib.Std.Hash.Builtin +open Ppx_compare_lib.Builtin + +let hash_fold_array = hash_fold_array_frozen + +type mutable_flag = + [%import: Ltac2_plugin.Tac2expr.mutable_flag] + [@@deriving sexp,yojson,hash,compare] + +type uid = + [%import: Ltac2_plugin.Tac2expr.uid] + [@@deriving sexp,yojson,hash,compare] + +type lid = + [%import: Ltac2_plugin.Tac2expr.lid] + [@@deriving sexp,yojson,hash,compare] + +type rec_flag = + [%import: Ltac2_plugin.Tac2expr.rec_flag] + [@@deriving sexp,yojson,hash,compare] + +type redef_flag = + [%import: Ltac2_plugin.Tac2expr.redef_flag] + [@@deriving sexp,yojson,hash,compare] + +type 'a or_relid = + [%import: 'a Ltac2_plugin.Tac2expr.or_relid] + [@@deriving sexp,yojson,hash,compare] + +type 'a or_tuple = + [%import: 'a Ltac2_plugin.Tac2expr.or_tuple] + [@@deriving sexp,yojson,hash,compare] + +type type_constant = + [%import: Ltac2_plugin.Tac2expr.type_constant] + [@@deriving sexp,yojson,hash,compare] + +type raw_typexpr_r = + [%import: Ltac2_plugin.Tac2expr.raw_typexpr_r] + [@@deriving sexp,yojson,hash,compare] +and raw_typexpr = + [%import: Ltac2_plugin.Tac2expr.raw_typexpr] + [@@deriving sexp,yojson,hash,compare] + +type raw_typedef = + [%import: Ltac2_plugin.Tac2expr.raw_typedef] + [@@deriving sexp,yojson,hash,compare] + +type raw_quant_typedef = + [%import: Ltac2_plugin.Tac2expr.raw_quant_typedef] + [@@deriving sexp,yojson,hash,compare] + +type atom = + [%import: Ltac2_plugin.Tac2expr.atom] + [@@deriving sexp,yojson,hash,compare] + +type ltac_constant = + [%import: Ltac2_plugin.Tac2expr.ltac_constant] + [@@deriving sexp,yojson,hash,compare] + +type ltac_alias = + [%import: Ltac2_plugin.Tac2expr.ltac_alias] + [@@deriving sexp,yojson,hash,compare] + +type ltac_constructor = + [%import: Ltac2_plugin.Tac2expr.ltac_constructor] + [@@deriving sexp,yojson,hash,compare] + +type ltac_projection = + [%import: Ltac2_plugin.Tac2expr.ltac_projection] + [@@deriving sexp,yojson,hash,compare] + +type raw_patexpr = + [%import: Ltac2_plugin.Tac2expr.raw_patexpr] + [@@deriving sexp,yojson,hash,compare] +and raw_patexpr_r = + [%import: Ltac2_plugin.Tac2expr.raw_patexpr_r] + [@@deriving sexp,yojson,hash,compare] + +type tacref = + [%import: Ltac2_plugin.Tac2expr.tacref] + [@@deriving sexp,yojson,hash,compare] + +module ObjS = struct type t = Obj.t let name = "Obj.t" end +module Obj = SerType.Opaque(ObjS) + +module T2ESpec = struct + type t = Ltac2_plugin.Tac2expr.raw_tacexpr_r + open Ltac2_plugin.Tac2expr + type _t = + | CTacAtm of atom + | CTacRef of tacref or_relid + | CTacCst of ltac_constructor or_tuple or_relid + | CTacFun of raw_patexpr list * raw_tacexpr + | CTacApp of raw_tacexpr * raw_tacexpr list + | CTacSyn of (raw_patexpr * raw_tacexpr) list * Names.KerName.t + | CTacLet of rec_flag * (raw_patexpr * raw_tacexpr) list * raw_tacexpr + | CTacCnv of raw_tacexpr * raw_typexpr + | CTacSeq of raw_tacexpr * raw_tacexpr + | CTacIft of raw_tacexpr * raw_tacexpr * raw_tacexpr + | CTacCse of raw_tacexpr * raw_taccase list + | CTacRec of raw_tacexpr option * raw_recexpr + | CTacPrj of raw_tacexpr * ltac_projection or_relid + | CTacSet of raw_tacexpr * ltac_projection or_relid * raw_tacexpr + | CTacExt of int * Obj.t + + and raw_tacexpr = _t CAst.t + and raw_taccase = + [%import: Ltac2_plugin.Tac2expr.raw_taccase] + and raw_recexpr = + [%import: Ltac2_plugin.Tac2expr.raw_recexpr] + [@@deriving sexp,yojson,hash,compare] + +end + +module T2E = Serlib.SerType.Pierce(T2ESpec) +type raw_tacexpr_r = T2E.t + [@@deriving sexp,yojson,hash,compare] + +type raw_tacexpr = + [%import: Ltac2_plugin.Tac2expr.raw_tacexpr] + [@@deriving sexp,yojson,hash,compare] + +type ml_tactic_name = + [%import: Ltac2_plugin.Tac2expr.ml_tactic_name] + [@@deriving sexp,yojson,hash,compare] + +type sexpr = + [%import: Ltac2_plugin.Tac2expr.sexpr] + [@@deriving sexp,yojson,hash,compare] + +type strexpr = + [%import: Ltac2_plugin.Tac2expr.strexpr] + [@@deriving sexp,yojson,hash,compare] + +type ctor_indx = + [%import: Ltac2_plugin.Tac2expr.ctor_indx] + [@@deriving sexp,yojson,hash,compare] + +type ctor_data_for_patterns = + [%import: Ltac2_plugin.Tac2expr.ctor_data_for_patterns] + [@@deriving sexp,yojson,hash,compare] + +type glb_pat = + [%import: Ltac2_plugin.Tac2expr.glb_pat] + [@@deriving sexp,yojson,hash,compare] + +type case_info = + [%import: Ltac2_plugin.Tac2expr.case_info] + [@@deriving sexp,yojson,hash,compare] + +type 'a open_match = + [%import: 'a Ltac2_plugin.Tac2expr.open_match] + [@@deriving sexp,yojson,hash,compare] + +module GT2ESpec = struct + type t = Ltac2_plugin.Tac2expr.glb_tacexpr + open Ltac2_plugin.Tac2expr + type _t = + | GTacAtm of atom + | GTacVar of Names.Id.t + | GTacRef of ltac_constant + | GTacFun of Names.Name.t list * _t + | GTacApp of _t * _t list + | GTacLet of rec_flag * (Names.Name.t * _t) list * _t + | GTacCst of case_info * int * _t list + | GTacCse of _t * case_info * _t array * (Names.Name.t array * _t) array + | GTacPrj of type_constant * _t * int + | GTacSet of type_constant * _t * int * _t + | GTacOpn of ltac_constructor * _t list + | GTacWth of _t open_match + | GTacFullMatch of _t * (glb_pat * _t) list + | GTacExt of int * Obj.t + | GTacPrm of ml_tactic_name + [@@deriving sexp,yojson,hash,compare] + +end + +module GT2E = Serlib.SerType.Pierce(GT2ESpec) +type glb_tacexpr = GT2E.t + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib_8_19/plugins/ltac2/ser_tac2quote.ml b/serlib_8_19/plugins/ltac2/ser_tac2quote.ml new file mode 100644 index 00000000..39008770 --- /dev/null +++ b/serlib_8_19/plugins/ltac2/ser_tac2quote.ml @@ -0,0 +1,27 @@ +(************************************************************************) +(* SerAPI: Coq interaction protocol with bidirectional serialization *) +(************************************************************************) +(* Copyright 2016-2019 MINES ParisTech -- License LGPL 2.1+ *) +(* Copyright 2019-2023 Inria -- License LGPL 2.1+ *) +(* Written by: Emilio J. Gallego Arias and others *) +(************************************************************************) + +(* open Sexplib.Std *) +(* open Ppx_hash_lib.Std.Hash.Builtin *) +(* open Ppx_compare_lib.Builtin *) + +(* let b x = Obj.magic x *) + +(* These are all special ltac2 extensible objects, brrrr... *) +let register () = + (* Ser_genarg.register_genser Tac2quote.wit_constr (b()); *) + (* Ser_genarg.register_genser Tac2quote.wit_ident (b()); *) + (* Ser_genarg.register_genser Tac2quote.wit_ltac1 (b()); *) + (* Ser_genarg.register_genser Tac2quote.wit_ltac1val (b()); *) + (* Ser_genarg.register_genser Tac2quote.wit_open_constr (b()); *) + (* Ser_genarg.register_genser Tac2quote.wit_pattern (b()); *) + (* Ser_genarg.register_genser Tac2quote.wit_preterm (b()); *) + (* Ser_genarg.register_genser Tac2quote.wit_reference (b()); *) + () + +let () = register () diff --git a/serlib_8_19/plugins/micromega/dune b/serlib_8_19/plugins/micromega/dune new file mode 100644 index 00000000..9f0296e9 --- /dev/null +++ b/serlib_8_19/plugins/micromega/dune @@ -0,0 +1,12 @@ +(library + (name serlib_micromega) + (public_name coq-lsp.serlib.micromega) + (synopsis "Serialization Library for Coq Congruence Plugin") + (preprocess + (staged_pps + ppx_import + ppx_sexp_conv + ppx_deriving_yojson + ppx_hash + ppx_compare)) + (libraries coq-core.plugins.micromega serlib sexplib)) diff --git a/serlib_8_19/plugins/ring/dune b/serlib_8_19/plugins/ring/dune new file mode 100644 index 00000000..6b7b8e47 --- /dev/null +++ b/serlib_8_19/plugins/ring/dune @@ -0,0 +1,7 @@ +(library + (name serlib_ring) + (public_name coq-lsp.serlib.ring) + (synopsis "Serialization Library for Coq Setoid Newring Plugin") + (preprocess + (staged_pps ppx_import ppx_sexp_conv ppx_hash ppx_compare)) + (libraries coq-core.plugins.ring serlib serlib_ltac sexplib)) diff --git a/serlib_8_19/plugins/ring/ser_g_ring.ml b/serlib_8_19/plugins/ring/ser_g_ring.ml new file mode 100644 index 00000000..684a9985 --- /dev/null +++ b/serlib_8_19/plugins/ring/ser_g_ring.ml @@ -0,0 +1,93 @@ +(************************************************************************) +(* SerAPI: Coq interaction protocol with bidirectional serialization *) +(************************************************************************) +(* Copyright 2016-2019 MINES ParisTech -- License LGPL 2.1+ *) +(* Copyright 2019-2023 Inria -- License LGPL 2.1+ *) +(* Written by: Emilio J. Gallego Arias and others *) +(************************************************************************) + +open Sexplib.Conv +open Ppx_hash_lib.Std.Hash.Builtin +open Ppx_compare_lib.Builtin +open Serlib + +module CAst = Ser_cAst +module Libnames = Ser_libnames +module Constrexpr = Ser_constrexpr +module Tactypes = Ser_tactypes +module Genintern = Ser_genintern +module EConstr = Ser_eConstr +module Tacexpr = Serlib_ltac.Ser_tacexpr + +module Ltac_plugin = struct + module Tacexpr = Serlib_ltac.Ser_tacexpr +end + +type 'constr coeff_spec = + [%import: 'constr Ring_plugin.Ring_ast.coeff_spec] + [@@deriving sexp,hash,compare] + +type cst_tac_spec = + [%import: Ring_plugin.Ring_ast.cst_tac_spec] + [@@deriving sexp,hash,compare] + +type 'constr ring_mod = + [%import: 'constr Ring_plugin.Ring_ast.ring_mod] + [@@deriving sexp,hash,compare] + +type 'a field_mod = + [%import: 'a Ring_plugin.Ring_ast.field_mod] + [@@deriving sexp,hash,compare] + +module A0 = struct + type raw = Constrexpr.constr_expr field_mod + [@@deriving sexp,hash,compare] + type glb = unit + [@@deriving sexp,hash,compare] + type top = unit + [@@deriving sexp,hash,compare] +end + +let ser_wit_field_mod = let module M = Ser_genarg.GS(A0) in M.genser + +module A1 = struct + type raw = Constrexpr.constr_expr field_mod list + [@@deriving sexp,hash,compare] + type glb = unit + [@@deriving sexp,hash,compare] + type top = unit + [@@deriving sexp,hash,compare] +end + +let ser_wit_field_mods = let module M = Ser_genarg.GS(A1) in M.genser + +module A2 = struct + type raw = Constrexpr.constr_expr ring_mod + [@@deriving sexp,hash,compare] + type glb = unit + [@@deriving sexp,hash,compare] + type top = unit + [@@deriving sexp,hash,compare] +end + +let ser_wit_ring_mod = let module M = Ser_genarg.GS(A2) in M.genser + +module A3 = struct + type raw = Constrexpr.constr_expr ring_mod list + [@@deriving sexp,hash,compare] + type glb = unit + [@@deriving sexp,hash,compare] + type top = unit + [@@deriving sexp,hash,compare] +end + +let ser_wit_ring_mods = let module M = Ser_genarg.GS(A3) in M.genser + +let register () = + Ser_genarg.register_genser Ring_plugin.G_ring.wit_field_mod ser_wit_field_mod; + Ser_genarg.register_genser Ring_plugin.G_ring.wit_field_mods ser_wit_field_mods; + Ser_genarg.register_genser Ring_plugin.G_ring.wit_ring_mod ser_wit_ring_mod; + Ser_genarg.register_genser Ring_plugin.G_ring.wit_ring_mods ser_wit_ring_mods; + () + +let _ = register () diff --git a/serlib_8_19/plugins/ssr/dune b/serlib_8_19/plugins/ssr/dune new file mode 100644 index 00000000..277917c8 --- /dev/null +++ b/serlib_8_19/plugins/ssr/dune @@ -0,0 +1,17 @@ +(library + (name serlib_ssr) + (public_name coq-lsp.serlib.ssreflect) + (synopsis "Serialization Library for Coq [SSR plugin]") + (preprocess + (staged_pps + ppx_import + ppx_sexp_conv + ppx_deriving_yojson + ppx_hash + ppx_compare)) + (libraries + coq-core.plugins.ssreflect + serlib + serlib_ltac + serlib_ssrmatching + sexplib)) diff --git a/serlib_8_19/plugins/ssr/ser_ssrast.ml b/serlib_8_19/plugins/ssr/ser_ssrast.ml new file mode 100644 index 00000000..794c354b --- /dev/null +++ b/serlib_8_19/plugins/ssr/ser_ssrast.ml @@ -0,0 +1,221 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* t + val of_t : t -> _t + +end + +module Biject(M : Bijectable) : SJHC with type t = M.t = struct + + type t = M.t + + let sexp_of_t x = M.sexp_of__t (M.of_t x) + let t_of_sexp s = M.to_t (M._t_of_sexp s) + + let to_yojson p = M._t_to_yojson (M.of_t p) + let of_yojson p = M._t_of_yojson p |> Result.map M.to_t + + let hash x = M.hash__t (M.of_t x) + let hash_fold_t st x = M.hash_fold__t st (M.of_t x) + + let compare x1 x2 = M.compare__t (M.of_t x1) (M.of_t x2) +end + +(* Bijection with serializable types *) +module type Bijectable1 = sig + + (* Base Type *) + type 'a t + + (* Representation type *) + type 'a _t [@@deriving sexp,yojson,hash,compare] + + (* Need to be bijetive *) + val to_t : 'a _t -> 'a t + val of_t : 'a t -> 'a _t + +end + +module Biject1(M : Bijectable1) : SJHC1 with type 'a t = 'a M.t = struct + + type 'a t = 'a M.t + + let sexp_of_t f x = M.sexp_of__t f (M.of_t x) + let t_of_sexp f s = M.to_t (M._t_of_sexp f s) + + let to_yojson f p = M._t_to_yojson f (M.of_t p) + let of_yojson f p = M._t_of_yojson f p |> Result.map M.to_t + + let hash_fold_t f st x = M.hash_fold__t f st (M.of_t x) + + let compare f x1 x2 = M.compare__t f (M.of_t x1) (M.of_t x2) +end + +(* We do our own alias as to have better control *) +let _sercast = Obj.magic + +(* Obj.magic piercing *) +module type Pierceable = sig + + (* Type to pierce *) + type t + + (* Representation type *) + type _t [@@deriving sexp,yojson,hash,compare] +end + +module type Pierceable1 = sig + + (* Type to pierce *) + type 'a t + + (* Representation type *) + type 'a _t [@@deriving sexp,yojson,hash,compare] +end + +module Pierce(M : Pierceable) : SJHC with type t = M.t = struct + + type t = M.t + + let sexp_of_t x = M.sexp_of__t (_sercast x) + let t_of_sexp s = _sercast (M._t_of_sexp s) + + let to_yojson p = M._t_to_yojson (_sercast p) + let of_yojson p = M._t_of_yojson p |> Result.map _sercast + + let hash x = M.hash__t (_sercast x) + let hash_fold_t st x = M.hash_fold__t st (_sercast x) + + let compare x1 x2 = M.compare__t (_sercast x1) (_sercast x2) + +end + +module Pierce1(M : Pierceable1) : SJHC1 with type 'a t = 'a M.t = struct + + type 'a t = 'a M.t + + let sexp_of_t f x = M.sexp_of__t f (_sercast x) + let t_of_sexp f s = _sercast (M._t_of_sexp f s) + + let to_yojson f p = M._t_to_yojson f (_sercast p) + let of_yojson f p = M._t_of_yojson f p |> Result.map _sercast + + (* let hash x = M.hash__t (_sercast x) *) + let hash_fold_t f st x = M.hash_fold__t f st (_sercast x) + + let compare f x1 x2 = M.compare__t f (_sercast x1) (_sercast x2) + +end + +(* Unfortunately this doesn't really work for types that are named as + the functions would have to be sexp_of_name etc... Maybe fixme in + the future *) +module PierceAlt(M : Pierceable) : SJHC with type t := M.t = struct + + let sexp_of_t x = M.sexp_of__t (_sercast x) + let t_of_sexp s = _sercast (M._t_of_sexp s) + + let to_yojson p = M._t_to_yojson (_sercast p) + let of_yojson p = M._t_of_yojson p |> Result.map _sercast + + let hash x = M.hash__t (_sercast x) + let hash_fold_t st x = M.hash_fold__t st (_sercast x) + + let compare x1 x2 = M.compare__t (_sercast x1) (_sercast x2) + +end + +module type OpaqueDesc = sig type t val name : string end + +module Opaque(M : OpaqueDesc) : SJHC with type t = M.t = struct + + type t = M.t + let typ = M.name + + let sexp_of_t x = Serlib_base.sexp_of_opaque ~typ x + let t_of_sexp s = Serlib_base.opaque_of_sexp ~typ s + + let to_yojson p = Serlib_base.opaque_to_yojson ~typ p + let of_yojson p = Serlib_base.opaque_of_yojson ~typ p + + let hash x = Serlib_base.hash_opaque ~typ x + let hash_fold_t st x = Serlib_base.hash_fold_opaque ~typ st x + + let compare x1 x2 = Serlib_base.compare_opaque ~typ x1 x2 + +end + +module type OpaqueDesc1 = sig type 'a t val name : string end + +module Opaque1(M : OpaqueDesc1) : SJHC1 with type 'a t = 'a M.t = struct + + type 'a t = 'a M.t + let typ = M.name + + let sexp_of_t _ x = Serlib_base.sexp_of_opaque ~typ x + let t_of_sexp _ s = Serlib_base.opaque_of_sexp ~typ s + + let to_yojson _ p = Serlib_base.opaque_to_yojson ~typ p + let of_yojson _ p = Serlib_base.opaque_of_yojson ~typ p + + let hash_fold_t _ st x = Serlib_base.hash_fold_opaque ~typ st x + + let compare _ x1 x2 = Serlib_base.compare_opaque ~typ x1 x2 + +end diff --git a/serlib_8_19/serType.mli b/serlib_8_19/serType.mli new file mode 100644 index 00000000..5adb4980 --- /dev/null +++ b/serlib_8_19/serType.mli @@ -0,0 +1,91 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* t + val of_t : t -> _t + +end + +module Biject(M : Bijectable) : SJHC with type t = M.t + +(* Bijection with serializable types *) +module type Bijectable1 = sig + + (* Base Type *) + type 'a t + + (* Representation type *) + type 'a _t [@@deriving sexp,yojson,hash,compare] + + (* Need to be bijetive *) + val to_t : 'a _t -> 'a t + val of_t : 'a t -> 'a _t + +end + +module Biject1(M : Bijectable1) : SJHC1 with type 'a t = 'a M.t + +module type Pierceable = sig + + (** Type to pierce *) + type t + + (** Representation type *) + type _t [@@deriving sexp,yojson,hash,compare] + +end + +module type Pierceable1 = sig + + (** Type to pierce *) + type 'a t + + (** Representation type *) + type 'a _t [@@deriving sexp,yojson,hash,compare] +end + +module Pierce(M : Pierceable) : SJHC with type t = M.t +module Pierce1(M : Pierceable1) : SJHC1 with type 'a t = 'a M.t + +module type OpaqueDesc = sig type t val name : string end +module Opaque(M : OpaqueDesc) : SJHC with type t = M.t + +module type OpaqueDesc1 = sig type 'a t val name : string end +module Opaque1(M : OpaqueDesc1) : SJHC1 with type 'a t = 'a M.t diff --git a/serlib_8_19/ser_attributes.ml b/serlib_8_19/ser_attributes.ml new file mode 100644 index 00000000..538f19de --- /dev/null +++ b/serlib_8_19/ser_attributes.ml @@ -0,0 +1,35 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* |= fun { L.v; loc } -> CAst.make ?loc:loc v) +let to_yojson f { CAst.v ; loc } = L.to_yojson f { L.v ; loc } + +let hash_fold_t f st { CAst.v; loc } = L.hash_fold_t f st { L.v; loc } + +let compare f { CAst.v = v1; loc = l1 } { CAst.v = v2; loc = l2 } = L.compare f { L.v = v1; loc = l1 } { L.v = v2; loc = l2 } + +let omit_att = ref false + +let sexp_of_t f x = + if !omit_att then f x.CAst.v else sexp_of_t f x + +(* let to_yojson f x = + if !omit_att then ... *) + diff --git a/serlib_8_19/ser_cAst.mli b/serlib_8_19/ser_cAst.mli new file mode 100644 index 00000000..60ea445a --- /dev/null +++ b/serlib_8_19/ser_cAst.mli @@ -0,0 +1,24 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* M.add k s e) M.empty l + let of_t = M.bindings + end + + include SerType.Biject1(BijectSpec) + +end diff --git a/serlib_8_19/ser_cMap.mli b/serlib_8_19/ser_cMap.mli new file mode 100644 index 00000000..6fa89e8b --- /dev/null +++ b/serlib_8_19/ser_cMap.mli @@ -0,0 +1,32 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* NoInvert + | CaseInvert { indices } -> + CaseInvert { indices = Array.map f indices } + +type 'constr pcase_branch = + [%import: 'constr Constr.pcase_branch] + [@@deriving sexp,yojson,hash,compare] + +let map_pcase_branch f (bi, c) = (bi, f c) + +type 'types pcase_return = + [%import: 'types Constr.pcase_return] + [@@deriving sexp,yojson,hash,compare] + +let map_pcase_return f (bi, c) = (bi, f c) + +type _constr = + | Rel of int + | Var of Names.Id.t + | Meta of int + | Evar of _constr pexistential + | Sort of Sorts.t + | Cast of _constr * cast_kind * _constr + | Prod of Names.Name.t Context.binder_annot * _constr * _constr + | Lambda of Names.Name.t Context.binder_annot * _constr * _constr + | LetIn of Names.Name.t Context.binder_annot * _constr * _constr * _constr + | App of _constr * _constr array + | Const of pconstant + | Ind of pinductive + | Construct of pconstructor + | Case of case_info * UVars.Instance.t * _constr array * _constr pcase_return * _constr pcase_invert * _constr * _constr pcase_branch array + | Fix of (_constr, _constr) pfixpoint + | CoFix of (_constr, _constr) pcofixpoint + | Proj of Names.Projection.t * Sorts.relevance * _constr + | Int of Uint63.t + | Float of Float64.t + | Array of UVars.Instance.t * _constr array * _constr * _constr +[@@deriving sexp,yojson,hash,compare] + +let rec _constr_put (c : Constr.t) : _constr = + let cr = _constr_put in + let crl = SList.map _constr_put in + let cra = Array.map _constr_put in + let crci = map_pcase_invert _constr_put in + let crcb = map_pcase_branch _constr_put in + let crcr = map_pcase_return _constr_put in + let module C = Constr in + match C.kind c with + | C.Rel i -> Rel(i) + | C.Var v -> Var(v) + | C.Meta(mv) -> Meta mv + | C.Evar(ek, csa) -> Evar (ek, crl csa) + | C.Sort(st) -> Sort (st) + | C.Cast(cs,k,ty) -> Cast(cr cs, k, cr ty) + | C.Prod(n,tya,tyr) -> Prod(n, cr tya, cr tyr) + | C.Lambda(n,ab,bd) -> Lambda(n, cr ab, cr bd) + | C.LetIn(n,u,ab,bd) -> LetIn(n, cr u, cr ab, cr bd) + | C.App(hd, al) -> App(cr hd, cra al) + | C.Const p -> Const p + | C.Ind(p,q) -> Ind (p,q) + | C.Construct(p) -> Construct (p) + | C.Case(ci, u, ca, (pr,r), pi, c, pb) -> + Case(ci, u, cra ca, (crcr pr,r), crci pi, cr c, Array.map crcb pb) + (* (int array * int) * (Name.t array * 'types array * 'constr array)) *) + | C.Fix(p,(na,u1,u2)) -> Fix(p, (na, cra u1, cra u2)) + | C.CoFix(p,(na,u1,u2)) -> CoFix(p, (na, cra u1, cra u2)) + | C.Proj(p,r,c) -> Proj(p, r, cr c) + | C.Int i -> Int i + | C.Float i -> Float i + | C.Array (u,a,e,t) -> Array(u, cra a, cr e, cr t) + +let rec _constr_get (c : _constr) : Constr.t = + let cr = _constr_get in + let crl = SList.map _constr_get in + let cra = Array.map _constr_get in + let crci = map_pcase_invert _constr_get in + let crcb = map_pcase_branch _constr_get in + let crcr = map_pcase_return _constr_get in + let module C = Constr in + match c with + | Rel i -> C.mkRel i + | Var v -> C.mkVar v + | Meta(mv) -> C.mkMeta mv + | Evar(ek, csa) -> C.mkEvar (ek, crl csa) + | Sort(st) -> C.mkSort (st) + | Cast(cs,k,ty) -> C.mkCast(cr cs, k, cr ty) + | Prod(n,tya,tyr) -> C.mkProd(n, cr tya, cr tyr) + | Lambda(n,ab,bd) -> C.mkLambda(n, cr ab, cr bd) + | LetIn(n,u,ab,bd) -> C.mkLetIn(n, cr u, cr ab, cr bd) + | App(hd, al) -> C.mkApp(cr hd, cra al) + | Const p -> C.mkConstU(p) + | Ind(p,q) -> C.mkIndU(p, q) + | Construct(p) -> C.mkConstructU(p) + | Case(ci, u, ca, (pr,r), pi, c, pb) -> C.mkCase (ci, u, cra ca, (crcr pr,r), crci pi, cr c, Array.map crcb pb) + | Fix (p,(na,u1,u2)) -> C.mkFix(p, (na, cra u1, cra u2)) + | CoFix(p,(na,u1,u2)) -> C.mkCoFix(p, (na, cra u1, cra u2)) + | Proj(p,r,c) -> C.mkProj(p, r, cr c) + | Int i -> C.mkInt i + | Float f -> C.mkFloat f + | Array (u,a,e,t) -> C.mkArray(u, cra a, cr e, cr t) + +module ConstrBij = struct + + type t = Constr.t + + type _t = _constr + [@@deriving sexp,yojson,hash,compare] + + let to_t = _constr_get + let of_t = _constr_put + +end + +module CC = SerType.Biject(ConstrBij) +type constr = CC.t + [@@deriving sexp,yojson,hash,compare] +type types = CC.t + [@@deriving sexp,yojson,hash,compare] + +type t = constr + [@@deriving sexp,yojson,hash,compare] + +type case_invert = + [%import: Constr.case_invert] + [@@deriving sexp,yojson] + +type rec_declaration = + [%import: Constr.rec_declaration] + [@@deriving sexp] + +type fixpoint = + [%import: Constr.fixpoint] + [@@deriving sexp] + +type cofixpoint = + [%import: Constr.cofixpoint] + [@@deriving sexp] + +type existential = + [%import: Constr.existential] + [@@deriving sexp] + +type sorts_family = Sorts.family +let sorts_family_of_sexp = Sorts.family_of_sexp +let sexp_of_sorts_family = Sorts.sexp_of_family + +type named_declaration = + [%import: Constr.named_declaration] + [@@deriving sexp,yojson,hash,compare] + +type named_context = + [%import: Constr.named_context] + [@@deriving sexp,yojson,hash,compare] + +type rel_declaration = + [%import: Constr.rel_declaration] + [@@deriving sexp,yojson,hash,compare] + +type rel_context = + [%import: Constr.rel_context] + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib_8_19/ser_constr.mli b/serlib_8_19/ser_constr.mli new file mode 100644 index 00000000..4877f888 --- /dev/null +++ b/serlib_8_19/ser_constr.mli @@ -0,0 +1,130 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* metavariable +val sexp_of_metavariable : metavariable -> Sexp.t + +type pconstant = Constr.pconstant + +val pconstant_of_sexp : Sexp.t -> pconstant +val sexp_of_pconstant : pconstant -> Sexp.t + +type pinductive = Constr.pinductive + +val pinductive_of_sexp : Sexp.t -> pinductive +val sexp_of_pinductive : pinductive -> Sexp.t + +type pconstructor = Constr.pconstructor + +val pconstructor_of_sexp : Sexp.t -> pconstructor +val sexp_of_pconstructor : pconstructor -> Sexp.t + +type cast_kind = Constr.cast_kind [@@deriving sexp, yojson, hash,compare] +type case_style = Constr.case_style [@@deriving sexp, yojson, hash,compare] + +type case_printing = Constr.case_printing + +val case_printing_of_sexp : Sexp.t -> case_printing +val sexp_of_case_printing : case_printing -> Sexp.t + +type case_info = Constr.case_info + +val case_info_of_sexp : Sexp.t -> case_info +val sexp_of_case_info : case_info -> Sexp.t + +type rec_declaration = Constr.rec_declaration + +val rec_declaration_of_sexp : Sexp.t -> rec_declaration +val sexp_of_rec_declaration : rec_declaration -> Sexp.t + +type fixpoint = Constr.fixpoint + +val fixpoint_of_sexp : Sexp.t -> fixpoint +val sexp_of_fixpoint : fixpoint -> Sexp.t + +type cofixpoint = Constr.cofixpoint + +val cofixpoint_of_sexp : Sexp.t -> cofixpoint +val sexp_of_cofixpoint : cofixpoint -> Sexp.t + +type 'constr pexistential = 'constr Constr.pexistential + [@@deriving sexp, yojson, hash, compare] + +type ('constr, 'types) prec_declaration = ('constr, 'types) Constr.prec_declaration + +val prec_declaration_of_sexp : + (Sexp.t -> 'constr) -> (Sexp.t -> 'types) -> + Sexp.t -> ('constr, 'types) prec_declaration +val sexp_of_prec_declaration : + ('constr -> Sexp.t) -> ('types -> Sexp.t) -> + ('constr, 'types) prec_declaration -> Sexp.t + +type ('constr, 'types) pfixpoint = ('constr, 'types) Constr.pfixpoint + +val pfixpoint_of_sexp : + (Sexp.t -> 'constr) -> + (Sexp.t -> 'types) -> Sexp.t -> ('constr, 'types) pfixpoint + +val sexp_of_pfixpoint : + ('constr -> Sexp.t) -> + ('types -> Sexp.t) -> ('constr, 'types) pfixpoint -> Sexp.t + +type ('constr, 'types) pcofixpoint = ('constr, 'types) Constr.pcofixpoint + +val pcofixpoint_of_sexp : + (Sexp.t -> 'constr) -> (Sexp.t -> 'types) -> + Sexp.t -> ('constr, 'types) pcofixpoint + +val sexp_of_pcofixpoint : + ('constr -> Sexp.t) -> ('types -> Sexp.t) -> + ('constr, 'types) pcofixpoint -> Sexp.t + +type t = Constr.t + [@@deriving sexp,yojson,hash,compare] + +type constr = t + [@@deriving sexp,yojson,hash,compare] + +type types = constr + [@@deriving sexp,yojson,hash,compare] + +type existential = Constr.existential +val existential_of_sexp : Sexp.t -> existential +val sexp_of_existential : existential -> Sexp.t + +type sorts_family = Sorts.family +val sorts_family_of_sexp : Sexp.t -> sorts_family +val sexp_of_sorts_family : sorts_family -> Sexp.t + +type named_declaration = Constr.named_declaration +val named_declaration_of_sexp : Sexp.t -> named_declaration +val sexp_of_named_declaration : named_declaration -> Sexp.t + +type named_context = Constr.named_context + [@@deriving sexp,yojson,hash,compare] + +type rel_declaration = Constr.rel_declaration +val rel_declaration_of_sexp : Sexp.t -> rel_declaration +val sexp_of_rel_declaration : rel_declaration -> Sexp.t + +type rel_context = Constr.rel_context + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib_8_19/ser_constr_matching.ml b/serlib_8_19/ser_constr_matching.ml new file mode 100644 index 00000000..b5b4771a --- /dev/null +++ b/serlib_8_19/ser_constr_matching.ml @@ -0,0 +1,23 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* binding_bound_vars +val sexp_of_binding_bound_vars : binding_bound_vars -> Sexp.t diff --git a/serlib_8_19/ser_constrexpr.ml b/serlib_8_19/ser_constrexpr.ml new file mode 100644 index 00000000..7be1b26a --- /dev/null +++ b/serlib_8_19/ser_constrexpr.ml @@ -0,0 +1,186 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* 'c) -> (Sexp.t -> 't) -> Sexp.t -> ('c,'t) pt + val sexp_of_pt : ('c -> Sexp.t) -> ('t -> Sexp.t) -> ('c,'t) pt -> Sexp.t + + end + + type ('c, 't) pt = ('c, 't) Context.Compacted.pt + val pt_of_sexp : (Sexp.t -> 'c) -> (Sexp.t -> 't) -> Sexp.t -> ('c,'t) pt + val sexp_of_pt : ('c -> Sexp.t) -> ('t -> Sexp.t) -> ('c,'t) pt -> Sexp.t + +end diff --git a/serlib_8_19/ser_conv_oracle.ml b/serlib_8_19/ser_conv_oracle.ml new file mode 100644 index 00000000..113b1670 --- /dev/null +++ b/serlib_8_19/ser_conv_oracle.ml @@ -0,0 +1,34 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t) -> (b -> Sexp.t) -> (a,b) thunk -> Sexp.t = + fun f _ t -> match t with + | Value v -> f v + | Thunk t -> f (Lazy.force t) + +let thunk_of_sexp : type a b. (Sexp.t -> a) -> (Sexp.t -> b) -> Sexp.t -> (a,b) thunk = + fun f _ s -> Value (f s) + +let thunk_of_yojson : type a b. (Yojson.Safe.t -> (a, string) Result.result) -> (Yojson.Safe.t -> (b, string) Result.result) -> Yojson.Safe.t -> ((a,b) thunk, string) Result.result = + fun f _ s -> Result.map (fun s -> Value s) (f s) + +let thunk_to_yojson : type a b. (a -> Yojson.Safe.t) -> (b -> Yojson.Safe.t) -> (a,b) thunk -> Yojson.Safe.t = + fun f _ t -> match t with + | Value v -> f v + | Thunk t -> f (Lazy.force t) + +let _hash : type a b. (a -> int) -> (b -> int) -> (a,b) thunk -> int = + fun f _ t -> match t with + | Value v -> f v + | Thunk t -> f (Lazy.force t) + +let hash_fold_thunk : type a b. (a Ppx_hash_lib.Std.Hash.folder) -> (b Ppx_hash_lib.Std.Hash.folder) -> (a,b) thunk Ppx_hash_lib.Std.Hash.folder = + fun f _ st t -> match t with + | Value v -> f st v + | Thunk t -> f st (Lazy.force t) + +let compare_thunk : type a b. (a Ppx_compare_lib.compare) -> (b Ppx_compare_lib.compare) -> (a,b) thunk Ppx_compare_lib.compare = + fun f _ t1 t2 -> match t1,t2 with + | Value v1, Value v2 -> f v1 v2 + | Thunk t1, Value v2 -> f (Lazy.force t1) v2 + | Value v1, Thunk t2 -> f v1 (Lazy.force t2) + | Thunk t1, Thunk t2 -> f (Lazy.force t1) (Lazy.force t2) + +type ('a, 'b) t = + [%import: ('a, 'b) DAst.t] + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib_8_19/ser_dAst.mli b/serlib_8_19/ser_dAst.mli new file mode 100644 index 00000000..20b7a1a3 --- /dev/null +++ b/serlib_8_19/ser_dAst.mli @@ -0,0 +1,21 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* template_arity +val sexp_of_template_arity : template_arity -> Sexp.t + +type ('a, 'b) declaration_arity = ('a, 'b) Declarations.declaration_arity + +val declaration_arity_of_sexp : + (Sexp.t -> 'a) -> + (Sexp.t -> 'b) -> + Sexp.t -> ('a, 'b) declaration_arity + +val sexp_of_declaration_arity : + ('a -> Sexp.t) -> + ('b -> Sexp.t) -> + ('a, 'b) declaration_arity -> Sexp.t + +type recarg = Declarations.recarg + [@@deriving sexp,yojson,hash,compare] + +type wf_paths = recarg Rtree.t + [@@deriving sexp,yojson,hash,compare] + +type regular_inductive_arity = Declarations.regular_inductive_arity + [@@deriving sexp,yojson,hash,compare] + +type inductive_arity = Declarations.inductive_arity + [@@deriving sexp,yojson,hash,compare] + +type one_inductive_body = Declarations.one_inductive_body + [@@deriving sexp,yojson,hash,compare] + +(* type set_predicativity = Declarations.set_predicativity + * val set_predicativity_of_sexp : Sexp.t -> set_predicativity + * val sexp_of_set_predicativity : set_predicativity -> Sexp.t *) + +(* type engagement = Declarations.engagement + * val engagement_of_sexp : Sexp.t -> engagement + * val sexp_of_engagement : engagement -> Sexp.t *) + +type typing_flags = Declarations.typing_flags + [@@deriving sexp,yojson,hash,compare] + +type inline = Declarations.inline + [@@deriving sexp,yojson,hash,compare] + +(* type work_list = Declarations.work_list *) + +(* type abstr_info = Declarations.abstr_info = { + * abstr_ctx : Constr.named_context; + * abstr_subst : Univ.Instance.t; + * abstr_uctx : Univ.AbstractContext.t; + * } + * + * type cooking_info = Declarations.cooking_info + * val sexp_of_cooking_info : cooking_info -> Sexp.t + * val cooking_info_of_sexp : Sexp.t -> cooking_info *) + +type 'a pconstant_body = 'a Declarations.pconstant_body + [@@deriving sexp,yojson,hash,compare] + +type constant_body = Declarations.constant_body + [@@deriving sexp,yojson,hash,compare] + +(* type record_body = Declarations.record_body + * val record_body_of_sexp : Sexp.t -> record_body + * val sexp_of_record_body : record_body -> Sexp.t *) + +type recursivity_kind = Declarations.recursivity_kind + [@@deriving sexp,yojson,hash,compare] + +type mutual_inductive_body = Declarations.mutual_inductive_body + [@@deriving sexp,yojson,hash,compare] + +type 'a module_alg_expr = 'a Declarations.module_alg_expr + [@@deriving sexp,yojson,hash,compare] + +type structure_body = Declarations.structure_body + [@@deriving sexp,yojson,hash,compare] + +type module_body = Declarations.module_body + [@@deriving sexp,yojson,hash,compare] + +type module_type_body = Declarations.module_type_body + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib_8_19/ser_declaremods.ml b/serlib_8_19/ser_declaremods.ml new file mode 100644 index 00000000..faab1f64 --- /dev/null +++ b/serlib_8_19/ser_declaremods.ml @@ -0,0 +1,39 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* env val sexp_of_env : env -> Sexp.t + +type ('constr, 'types) punsafe_judgment = ('constr, 'types) + Environ.punsafe_judgment + +val punsafe_judgment_of_sexp : (Sexp.t -> 'constr) -> (Sexp.t -> + 'types) -> Sexp.t -> ('constr, 'types) punsafe_judgment val + sexp_of_punsafe_judgment : ('constr -> Sexplib.Sexp.t) -> ('types + -> Sexplib.Sexp.t) -> ('constr, 'types) punsafe_judgment -> Sexp.t + +type unsafe_judgment = Environ.unsafe_judgment val + unsafe_judgment_of_sexp : Sexp.t -> unsafe_judgment val + sexp_of_unsafe_judgment : unsafe_judgment -> Sexp.t diff --git a/serlib_8_19/ser_equality.ml b/serlib_8_19/ser_equality.ml new file mode 100644 index 00000000..d0780a00 --- /dev/null +++ b/serlib_8_19/ser_equality.ml @@ -0,0 +1,25 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* |= _t_get) +let to_yojson level = _t_to_yojson (_t_put level) + +let hash x = hash__t (_t_put x) +let hash_fold_t st id = hash_fold__t st (_t_put id) + +let compare x y = compare__t (_t_put x) (_t_put y) + +end + +include Self + +module Set = Ser_cSet.Make(Evar.Set)(Self) diff --git a/serlib_8_19/ser_evar.mli b/serlib_8_19/ser_evar.mli new file mode 100644 index 00000000..131d0371 --- /dev/null +++ b/serlib_8_19/ser_evar.mli @@ -0,0 +1,23 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* conv_pb +val sexp_of_conv_pb : conv_pb -> Sexp.t + +type evar_constraint = Evd.evar_constraint + +val evar_constraint_of_sexp : Sexp.t -> evar_constraint +val sexp_of_evar_constraint : evar_constraint -> Sexp.t + +type unsolvability_explanation = Evd.unsolvability_explanation + +val unsolvability_explanation_of_sexp : Sexp.t -> unsolvability_explanation +val sexp_of_unsolvability_explanation : unsolvability_explanation -> Sexp.t diff --git a/serlib_8_19/ser_extend.ml b/serlib_8_19/ser_extend.ml new file mode 100644 index 00000000..365f7511 --- /dev/null +++ b/serlib_8_19/ser_extend.ml @@ -0,0 +1,55 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* production_position +val sexp_of_production_position : production_position -> Sexp.t + +type production_level = Extend.production_level [@@deriving sexp,yojson,hash,compare] + +type binder_entry_kind = Extend.binder_entry_kind +val binder_entry_kind_of_sexp : Sexp.t -> binder_entry_kind +val sexp_of_binder_entry_kind : binder_entry_kind -> Sexp.t + +type 'lev constr_entry_key_gen = 'lev Extend.constr_entry_key_gen +val constr_entry_key_gen_of_sexp : (Sexp.t -> 'lev) -> + Sexp.t -> 'lev constr_entry_key_gen +val sexp_of_constr_entry_key_gen : ('lev -> Sexp.t) -> + 'lev constr_entry_key_gen -> Sexp.t + +type constr_entry_key = Extend.constr_entry_key +val constr_entry_key_of_sexp : Sexp.t -> constr_entry_key +val sexp_of_constr_entry_key : constr_entry_key -> Sexp.t + +type constr_prod_entry_key = Extend.constr_prod_entry_key +val constr_prod_entry_key_of_sexp : Sexp.t -> constr_prod_entry_key +val sexp_of_constr_prod_entry_key : constr_prod_entry_key -> Sexp.t + +type simple_constr_prod_entry_key = Extend.simple_constr_prod_entry_key [@@deriving sexp,yojson,hash,compare] diff --git a/serlib_8_19/ser_feedback.ml b/serlib_8_19/ser_feedback.ml new file mode 100644 index 00000000..23fb4edc --- /dev/null +++ b/serlib_8_19/ser_feedback.ml @@ -0,0 +1,46 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* doc_id +val sexp_of_doc_id : doc_id -> Sexp.t +val doc_id_of_yojson : Yojson.Safe.t -> (doc_id, string) Result.result +val doc_id_to_yojson : doc_id -> Yojson.Safe.t + +type level = Feedback.level + +val level_of_sexp : Sexp.t -> level +val sexp_of_level : level -> Sexp.t +val level_of_yojson : Yojson.Safe.t -> (level, string) Result.result +val level_to_yojson : level -> Yojson.Safe.t + +type route_id = Feedback.route_id +val route_id_of_sexp : Sexp.t -> route_id +val sexp_of_route_id : route_id -> Sexp.t +val route_id_of_yojson : Yojson.Safe.t -> (route_id, string) Result.result +val route_id_to_yojson : route_id -> Yojson.Safe.t + +type feedback_content = Feedback.feedback_content + +val feedback_content_of_sexp : Sexp.t -> feedback_content +val sexp_of_feedback_content : feedback_content -> Sexp.t +val feedback_content_of_yojson : Yojson.Safe.t -> (feedback_content, string) Result.result +val feedback_content_to_yojson : feedback_content -> Yojson.Safe.t + +type feedback = Feedback.feedback + +val feedback_of_sexp : Sexp.t -> feedback +val sexp_of_feedback : feedback -> Sexp.t +val feedback_of_yojson : Yojson.Safe.t -> (feedback, string) Result.result +val feedback_to_yojson : feedback -> Yojson.Safe.t diff --git a/serlib_8_19/ser_flags.ml b/serlib_8_19/ser_flags.ml new file mode 100644 index 00000000..d4e39eae --- /dev/null +++ b/serlib_8_19/ser_flags.ml @@ -0,0 +1,18 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t = fun at -> + match at with + | Rawwit w -> List [Atom "Rawwit"; sexp_of_genarg_type w] + | Glbwit w -> List [Atom "Glbwit"; sexp_of_genarg_type w] + | Topwit w -> List [Atom "Topwit"; sexp_of_genarg_type w] + +let rec argument_type_of_sexp : Sexp.t -> argument_type = fun sexp -> + match sexp with + | List [Atom "ExtraArg"; Atom tag] -> + begin match ArgT.name tag with + | None -> raise (Failure "SEXP Exception in argument_type") + | Some (ArgT.Any t) -> ArgumentType (ExtraArg t) + end + | List [Atom "ListArg"; s1] -> + let (ArgumentType t) = argument_type_of_sexp s1 in + ArgumentType (ListArg t) + | List [Atom "OptArg"; s1] -> + let (ArgumentType t) = argument_type_of_sexp s1 in + ArgumentType (OptArg t) + | List [Atom "PairArg"; s1; s2] -> + let (ArgumentType t1) = argument_type_of_sexp s1 in + let (ArgumentType t2) = argument_type_of_sexp s2 in + ArgumentType (PairArg(t1,t2)) + | _ -> raise (Failure "SEXP Exception") + +let hash_fold_abstract_argument_type : type lvl. ('o, lvl) abstract_argument_type Hash.folder = fun st at -> + match at with + | Rawwit w -> hash_tagged hash_fold_genarg_type st "raw" w + | Glbwit w -> hash_tagged hash_fold_genarg_type st "glb" w + | Topwit w -> hash_tagged hash_fold_genarg_type st "top" w + +type ('raw, 'glb, 'top) gen_ser = + { raw_ser : 'raw -> Sexp.t + ; raw_des : Sexp.t -> 'raw + ; raw_hash : 'raw Hash.folder + ; raw_compare : 'raw -> 'raw -> int + + ; glb_ser : 'glb -> Sexp.t + ; glb_des : Sexp.t -> 'glb + ; glb_hash : 'glb Hash.folder + ; glb_compare : 'glb -> 'glb -> int + + ; top_ser : 'top -> Sexp.t + ; top_des : Sexp.t -> 'top + ; top_hash : 'top Ppx_hash_lib.Std.Hash.folder + ; top_compare : 'top -> 'top -> int + } + +module T2_ = struct + type ('a, 'b) t = 'a * 'b [@@deriving hash, compare] +end + +let gen_ser_list : + ('raw, 'glb, 'top) gen_ser -> + ('raw list, 'glb list, 'top list) gen_ser = fun g -> + let open Sexplib.Conv in + { raw_ser = sexp_of_list g.raw_ser + ; raw_des = list_of_sexp g.raw_des + ; raw_hash = Hash.Builtin.hash_fold_list g.raw_hash + ; raw_compare = compare_list g.raw_compare + + ; glb_ser = sexp_of_list g.glb_ser + ; glb_des = list_of_sexp g.glb_des + ; glb_hash = Hash.Builtin.hash_fold_list g.glb_hash + ; glb_compare = compare_list g.glb_compare + + ; top_ser = sexp_of_list g.top_ser + ; top_des = list_of_sexp g.top_des + ; top_hash = Hash.Builtin.hash_fold_list g.top_hash + ; top_compare = compare_list g.top_compare + } + +let gen_ser_opt : + ('raw, 'glb, 'top) gen_ser -> + ('raw option, 'glb option, 'top option) gen_ser = fun g -> + let open Sexplib.Conv in + { raw_ser = sexp_of_option g.raw_ser + ; raw_des = option_of_sexp g.raw_des + ; raw_hash = Hash.Builtin.hash_fold_option g.raw_hash + ; raw_compare = compare_option g.raw_compare + + ; glb_ser = sexp_of_option g.glb_ser + ; glb_des = option_of_sexp g.glb_des + ; glb_hash = Hash.Builtin.hash_fold_option g.glb_hash + ; glb_compare = compare_option g.glb_compare + + ; top_ser = sexp_of_option g.top_ser + ; top_des = option_of_sexp g.top_des + ; top_hash = Hash.Builtin.hash_fold_option g.top_hash + ; top_compare = compare_option g.top_compare + } + +let gen_ser_pair : + ('raw1, 'glb1, 'top1) gen_ser -> + ('raw2, 'glb2, 'top2) gen_ser -> + (('raw1 * 'raw2), ('glb1 * 'glb2), ('top1 * 'top2)) gen_ser = fun g1 g2 -> + let open Sexplib.Conv in + { raw_ser = sexp_of_pair g1.raw_ser g2.raw_ser + ; raw_des = pair_of_sexp g1.raw_des g2.raw_des + ; raw_hash = T2_.hash_fold_t g1.raw_hash g2.raw_hash + ; raw_compare = T2_.compare g1.raw_compare g2.raw_compare + + ; glb_ser = sexp_of_pair g1.glb_ser g2.glb_ser + ; glb_des = pair_of_sexp g1.glb_des g2.glb_des + ; glb_hash = T2_.hash_fold_t g1.glb_hash g2.glb_hash + ; glb_compare = T2_.compare g1.glb_compare g2.glb_compare + + ; top_ser = sexp_of_pair g1.top_ser g2.top_ser + ; top_des = pair_of_sexp g1.top_des g2.top_des + ; top_hash = T2_.hash_fold_t g1.top_hash g2.top_hash + ; top_compare = T2_.compare g1.top_compare g2.top_compare + } + +module SerObj = struct + + type ('raw, 'glb, 'top) obj = ('raw, 'glb, 'top) gen_ser + + let sexp_of_gen typ ga = + let typ = typ ^ ": " ^ Sexp.to_string (sexp_of_genarg_type ga) in + Serlib_base.sexp_of_opaque ~typ + + let name = "ser_arg" + let default _ga = + Some + { + (* raw_ser = (fun _ -> Sexp.(List [Atom "[XXX ser_gen]"; Atom "raw"; sexp_of_genarg_type ga])); *) + raw_ser = sexp_of_gen "raw" _ga + ; raw_des = (Sexplib.Conv_error.no_matching_variant_found "raw_arg") + ; raw_hash = (fun st a -> Hash.fold_int st (Hashtbl.hash a)) + ; raw_compare = Stdlib.compare + + (* glb_ser = (fun _ -> Sexp.(List [Atom "[XXX ser_gen]"; Atom "glb"; sexp_of_genarg_type ga])); *) + ; glb_ser = sexp_of_gen "glb" _ga + ; glb_des = (Sexplib.Conv_error.no_matching_variant_found "glb_arg") + ; glb_hash = (fun st a -> Hash.fold_int st (Hashtbl.hash a)) + ; glb_compare = Stdlib.compare + + (* top_ser = (fun _ -> Sexp.(List [Atom "[XXX ser_gen]"; Atom "top"; sexp_of_genarg_type ga])); *) + ; top_ser = sexp_of_gen "top" _ga + ; top_des = (Sexplib.Conv_error.no_matching_variant_found "top_arg") + ; top_hash = (fun st a -> Hash.fold_int st (Hashtbl.hash a)) + ; top_compare = Stdlib.compare + } +end + +module SerGen = Register(SerObj) +let register_genser ty obj = SerGen.register0 ty obj + +let rec get_gen_ser_ty : type r g t. (r,g,t) Genarg.genarg_type -> (r,g,t) gen_ser = + fun gt -> match gt with + | Genarg.ExtraArg _ -> SerGen.obj gt + | Genarg.ListArg t -> gen_ser_list (get_gen_ser_ty t) + | Genarg.OptArg t -> gen_ser_opt (get_gen_ser_ty t) + | Genarg.PairArg(t1, t2) -> gen_ser_pair (get_gen_ser_ty t1) (get_gen_ser_ty t2) + +let get_gen_ser : type lvl. ('o,lvl) abstract_argument_type -> ('o -> 't) = fun aty -> + match aty with + | Genarg.Rawwit ty -> (get_gen_ser_ty ty).raw_ser + | Genarg.Glbwit ty -> (get_gen_ser_ty ty).glb_ser + | Genarg.Topwit ty -> (get_gen_ser_ty ty).top_ser + +let generic_des : type lvl. ('o,lvl) abstract_argument_type -> Sexp.t -> lvl generic_argument = fun ty s -> + match ty with + | Genarg.Rawwit w -> GenArg(ty, (get_gen_ser_ty w).raw_des s) + | Genarg.Glbwit w -> GenArg(ty, (get_gen_ser_ty w).glb_des s) + | Genarg.Topwit w -> GenArg(ty, (get_gen_ser_ty w).top_des s) + +let hash_fold_generic : type lvl. ('o,lvl) abstract_argument_type -> 'o Ppx_hash_lib.Std.Hash.folder = fun aty -> + match aty with + | Genarg.Rawwit ty -> (get_gen_ser_ty ty).raw_hash + | Genarg.Glbwit ty -> (get_gen_ser_ty ty).glb_hash + | Genarg.Topwit ty -> (get_gen_ser_ty ty).top_hash + +let compare_generic : type lvl. ('o,lvl) abstract_argument_type -> 'o Ppx_compare_lib.compare = fun aty -> + match aty with + | Genarg.Rawwit ty -> (get_gen_ser_ty ty).raw_compare + | Genarg.Glbwit ty -> (get_gen_ser_ty ty).glb_compare + | Genarg.Topwit ty -> (get_gen_ser_ty ty).top_compare + +(* We need to generalize this to use the proper printers for opt *) +let mk_sexparg st so = + Sexp.List [Atom "GenArg"; st; so] + +(* XXX: There is still some duplication here in the traversal of g_ty, but + we can live with that for now. *) +let sexp_of_genarg_val : type a. a generic_argument -> Sexp.t = + fun g -> match g with + | GenArg (g_ty, g_val) -> + mk_sexparg (sexp_of_abstract_argument_type g_ty) (get_gen_ser g_ty g_val) + +let sexp_of_generic_argument : type a. (a -> Sexp.t) -> a generic_argument -> Sexp.t = + fun _level_tag g -> + sexp_of_genarg_val g + +type rgen_argument = RG : 'lvl generic_argument -> rgen_argument + +let hash_fold_genarg_val : type a. a generic_argument Hash.folder = + fun st g -> match g with + | GenArg (g_ty, g_val) -> + let st = hash_fold_abstract_argument_type st g_ty in + hash_fold_generic g_ty st g_val + +let hash_fold_generic_argument : type a. a Hash.folder -> a generic_argument Hash.folder = + fun _level_tag g -> hash_fold_genarg_val g + +let compare_genarg_val : type a. a generic_argument Ppx_compare_lib.compare = + fun g1 g2 -> match g1 with + | GenArg (g1_ty, g1_val) -> + match g2 with + | GenArg (g2_ty, g2_val) -> + match Genarg.abstract_argument_type_eq g1_ty g2_ty with + | Some Refl -> + compare_generic g1_ty g1_val g2_val + (* XXX: Technically, we should implement our own compare so ordering works *) + | None -> 1 + +let compare_generic_argument : type a. a Ppx_compare_lib.compare -> a generic_argument Ppx_compare_lib.compare = + fun _level_tag g -> compare_genarg_val g + +let gen_abstype_of_sexp : Sexp.t -> rgen_argument = fun s -> + match s with + | List [Atom "GenArg"; List [ Atom "Rawwit"; sty]; sobj] -> + let (ArgumentType ty) = argument_type_of_sexp sty in + RG (generic_des (Rawwit ty) sobj) + | List [Atom "GenArg"; List [ Atom "Glbwit"; sty]; sobj] -> + let (ArgumentType ty) = argument_type_of_sexp sty in + RG (generic_des (Glbwit ty) sobj) + | List [Atom "GenArg"; List [ Atom "Topwit"; sty]; sobj] -> + let (ArgumentType ty) = argument_type_of_sexp sty in + RG (generic_des (Topwit ty) sobj) + | _ -> raise (Failure "SEXP Exception in abstype") + +let generic_argument_of_sexp _lvl sexp : 'a Genarg.generic_argument = + let (RG ga) = gen_abstype_of_sexp sexp in + Obj.magic ga + +let rec yojson_to_sexp json = match json with + | `String s -> Sexp.Atom s + | `List s -> Sexp.List (List.map yojson_to_sexp s) + | _ -> raise (Failure "ser_genarg: yojson_to_sexp") + +let rec sexp_to_yojson sexp : Yojson.Safe.t = + match sexp with + | Sexp.Atom s -> `String s + | List l -> `List (List.map sexp_to_yojson l) + +let generic_argument_of_yojson lvl json = + let sexp = yojson_to_sexp json in + Result.Ok (generic_argument_of_sexp lvl sexp) + +let generic_argument_to_yojson : type a. (a -> Yojson.Safe.t) -> a generic_argument -> Yojson.Safe.t = + fun _level_tag g -> + sexp_of_generic_argument (fun _ -> Atom "") g |> sexp_to_yojson + +type 'a generic_argument = 'a Genarg.generic_argument + +type glob_generic_argument = + [%import: Genarg.glob_generic_argument] + [@@deriving sexp,yojson,hash,compare] + +type raw_generic_argument = + [%import: Genarg.raw_generic_argument] + [@@deriving sexp,yojson,hash,compare] + +type typed_generic_argument = + [%import: Genarg.typed_generic_argument] + [@@deriving sexp,yojson,hash,compare] + +let mk_uniform pin pout phash pcompare = + { raw_ser = pin + ; raw_des = pout + ; raw_hash = phash + ; raw_compare = pcompare + + ; glb_ser = pin + ; glb_des = pout + ; glb_hash = phash + ; glb_compare = pcompare + + ; top_ser = pin + ; top_des = pout + ; top_hash = phash + ; top_compare = pcompare + } + +module type GenSer0 = sig + type t [@@deriving sexp,hash,compare] +end + +module GS0 (M : GenSer0) = struct + let genser = mk_uniform M.sexp_of_t M.t_of_sexp M.hash_fold_t M.compare +end + +module type GenSer = sig + type raw [@@deriving sexp,hash,compare] + type glb [@@deriving sexp,hash,compare] + type top [@@deriving sexp,hash,compare] +end + +module GS (M : GenSer) = struct + let genser = + { raw_ser = M.sexp_of_raw + ; raw_des = M.raw_of_sexp + ; raw_hash = M.hash_fold_raw + ; raw_compare = M.compare_raw + + ; glb_ser = M.sexp_of_glb + ; glb_des = M.glb_of_sexp + ; glb_hash = M.hash_fold_glb + ; glb_compare = M.compare_glb + + ; top_ser = M.sexp_of_top + ; top_des = M.top_of_sexp + ; top_hash = M.hash_fold_top + ; top_compare = M.compare_top + } +end diff --git a/serlib_8_19/ser_genarg.mli b/serlib_8_19/ser_genarg.mli new file mode 100644 index 00000000..083b82d4 --- /dev/null +++ b/serlib_8_19/ser_genarg.mli @@ -0,0 +1,96 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t) ref *) +(* val sexp_of_tacdef_body : (Tacexpr.tacdef_body -> Sexp.t) ref *) + +(**********************************************************************) +(* GenArg *) +(**********************************************************************) + +type rlevel = Genarg.rlevel + [@@deriving sexp,yojson,hash,compare] +type glevel = Genarg.glevel + [@@deriving sexp,yojson,hash,compare] +type tlevel = Genarg.tlevel + [@@deriving sexp,yojson,hash,compare] + +type 'a generic_argument = 'a Genarg.generic_argument + [@@deriving sexp,yojson,hash,compare] + +type glob_generic_argument = Genarg.glob_generic_argument +[@@deriving sexp,yojson,hash,compare] + +type raw_generic_argument = Genarg.raw_generic_argument +[@@deriving sexp,yojson,hash,compare] + +type typed_generic_argument = Genarg.typed_generic_argument +val typed_generic_argument_of_sexp : Sexp.t -> Genarg.typed_generic_argument +val sexp_of_typed_generic_argument : Genarg.typed_generic_argument -> Sexp.t + +(* Registering serializing functions *) +type ('raw, 'glb, 'top) gen_ser = + { raw_ser : 'raw -> Sexp.t + ; raw_des : Sexp.t -> 'raw + ; raw_hash : 'raw Ppx_hash_lib.Std.Hash.folder + ; raw_compare : 'raw -> 'raw -> int + + ; glb_ser : 'glb -> Sexp.t + ; glb_des : Sexp.t -> 'glb + ; glb_hash : 'glb Ppx_hash_lib.Std.Hash.folder + ; glb_compare : 'glb -> 'glb -> int + + ; top_ser : 'top -> Sexp.t + ; top_des : Sexp.t -> 'top + ; top_hash : 'top Ppx_hash_lib.Std.Hash.folder + ; top_compare : 'top -> 'top -> int + } + +val register_genser : + ('raw, 'glb, 'top) Genarg.genarg_type -> + ('raw, 'glb, 'top) gen_ser -> unit + +val gen_ser_pair : + ('raw1, 'glb1, 'top1) gen_ser -> + ('raw2, 'glb2, 'top2) gen_ser -> + (('raw1 * 'raw2), ('glb1 * 'glb2), ('top1 * 'top2)) gen_ser + +val gen_ser_list : + ('raw, 'glb, 'top) gen_ser -> + ('raw list, 'glb list, 'top list) gen_ser + +val mk_uniform : ('t -> Sexp.t) -> (Sexp.t -> 't) -> + 't Ppx_hash_lib.Std.Hash.folder -> + 't Ppx_compare_lib.compare -> + ('t,'t,'t) gen_ser + +module type GenSer0 = sig + type t [@@deriving sexp,hash,compare] +end + +module GS0 (M : GenSer0) : sig val genser : (M.t,M.t,M.t) gen_ser end + +module type GenSer = sig + type raw [@@deriving sexp,hash,compare] + type glb [@@deriving sexp,hash,compare] + type top [@@deriving sexp,hash,compare] +end + +module GS (M : GenSer) : sig val genser : (M.raw,M.glb,M.top) gen_ser end diff --git a/serlib_8_19/ser_genintern.ml b/serlib_8_19/ser_genintern.ml new file mode 100644 index 00000000..eef19d39 --- /dev/null +++ b/serlib_8_19/ser_genintern.ml @@ -0,0 +1,53 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* glob_sign +val sexp_of_glob_sign : glob_sign -> Sexp.t + +type glob_constr_and_expr = Genintern.glob_constr_and_expr + [@@deriving sexp, yojson, hash, compare] + +type glob_constr_pattern_and_expr = Genintern.glob_constr_pattern_and_expr + [@@deriving sexp, yojson, hash, compare] diff --git a/serlib_8_19/ser_geninterp.ml b/serlib_8_19/ser_geninterp.ml new file mode 100644 index 00000000..5075a82b --- /dev/null +++ b/serlib_8_19/ser_geninterp.ml @@ -0,0 +1,60 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t -> 'a red_atom +val sexp_of_red_atom : ('a -> Sexp.t) -> 'a red_atom -> Sexp.t + +type 'a glob_red_flag = 'a Genredexpr.glob_red_flag + +val glob_red_flag_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a glob_red_flag +val sexp_of_glob_red_flag : ('a -> Sexp.t) -> 'a glob_red_flag -> Sexp.t +val glob_red_flag_of_yojson : (Yojson.Safe.t -> ('a, string) Result.result) -> Yojson.Safe.t -> ('a glob_red_flag, string) Result.result +val glob_red_flag_to_yojson : ('a -> Yojson.Safe.t) -> 'a glob_red_flag -> Yojson.Safe.t + +type ('a, 'b, 'c) red_expr_gen = ('a, 'b, 'c) Genredexpr.red_expr_gen + [@@deriving sexp,yojson,hash,compare] + +type ('a, 'b, 'c) may_eval = ('a, 'b, 'c) Genredexpr.may_eval + [@@deriving sexp,yojson,hash,compare] + +type raw_red_expr = Genredexpr.raw_red_expr [@@deriving sexp,yojson,hash,compare] + +type 'a and_short_name = 'a Genredexpr.and_short_name + [@@deriving sexp,yojson,hash,compare] + +type glob_red_expr = Genredexpr.glob_red_expr + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib_8_19/ser_glob_term.ml b/serlib_8_19/ser_glob_term.ml new file mode 100644 index 00000000..4d9acb57 --- /dev/null +++ b/serlib_8_19/ser_glob_term.ml @@ -0,0 +1,157 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t -> 'a Glob_term.cast_type + * val sexp_of_cast_type : ('a -> Sexp.t) -> 'a Glob_term.cast_type -> Sexp.t + * val cast_type_of_yojson : (Yojson.Safe.t -> ('a,string) result ) -> Yojson.Safe.t -> ('a cast_type, string) Result.result + * val cast_type_to_yojson : ('a -> Yojson.Safe.t) -> 'a cast_type -> Yojson.Safe.t *) + +type glob_constraint = Glob_term.glob_constraint +val glob_constraint_of_sexp : Sexp.t -> Glob_term.glob_constraint +val sexp_of_glob_constraint : Glob_term.glob_constraint -> Sexp.t +val glob_constraint_of_yojson : Yojson.Safe.t -> (glob_constraint, string) Result.result +val glob_constraint_to_yojson : glob_constraint -> Yojson.Safe.t + +type existential_name = Glob_term.existential_name [@@deriving sexp,yojson,hash,compare] +type cases_pattern = Glob_term.cases_pattern + +type glob_constr = Glob_term.glob_constr +and glob_decl = Glob_term.glob_decl +and predicate_pattern = Glob_term.predicate_pattern +and tomatch_tuple = Glob_term.tomatch_tuple +and tomatch_tuples = Glob_term.tomatch_tuples +and cases_clause = Glob_term.cases_clause +and cases_clauses = Glob_term.cases_clauses + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib_8_19/ser_globnames.ml b/serlib_8_19/ser_globnames.ml new file mode 100644 index 00000000..c0ee9569 --- /dev/null +++ b/serlib_8_19/ser_globnames.ml @@ -0,0 +1,27 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* option_value +val sexp_of_option_value : option_value -> Sexp.t +val option_value_of_yojson : Yojson.Safe.t -> (option_value, string) Result.result +val option_value_to_yojson : option_value -> Yojson.Safe.t + +type option_state = Goptions.option_state + +val option_state_of_sexp : Sexp.t -> option_state +val sexp_of_option_state : option_state -> Sexp.t + +type table_value = Goptions.table_value [@@deriving sexp, yojson, hash,compare] diff --git a/serlib_8_19/ser_gramlib.ml b/serlib_8_19/ser_gramlib.ml new file mode 100644 index 00000000..0743815d --- /dev/null +++ b/serlib_8_19/ser_gramlib.ml @@ -0,0 +1,23 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* |= _t_get) +let qualid_r_to_yojson level = _t_to_yojson (_t_put level) + +(* let hash_qualid_r x = hash__t (_t_put x) *) +let hash_fold_qualid_r st x = hash_fold__t st (_t_put x) +let compare_qualid_r x y = compare__t (_t_put x) (_t_put y) + +(* qualid: private *) +type qualid = + [%import: Libnames.qualid] + [@@deriving sexp,yojson,hash,compare] + +module FP = struct + type _t = + { dirpath : Names.DirPath.t + ; basename : Names.Id.t } + [@@deriving sexp,yojson,hash,compare] + + let _t_get { dirpath; basename } = Libnames.make_path dirpath basename + let _t_put fp = let dirpath, basename = Libnames.repr_path fp in { dirpath; basename } +end + +open FP + +type full_path = Libnames.full_path +let full_path_of_sexp sexp = _t_get (_t_of_sexp sexp) +let sexp_of_full_path qid = sexp_of__t (_t_put qid) + +let full_path_of_yojson json = Ppx_deriving_yojson_runtime.(_t_of_yojson json >|= _t_get) +let full_path_to_yojson level = _t_to_yojson (_t_put level) + +let hash_full_path x = hash__t (_t_put x) +let hash_fold_full_path st x = hash_fold__t st (_t_put x) + +let compare_full_path x y = compare__t (_t_put x) (_t_put y) diff --git a/serlib_8_19/ser_libnames.mli b/serlib_8_19/ser_libnames.mli new file mode 100644 index 00000000..616c7e6a --- /dev/null +++ b/serlib_8_19/ser_libnames.mli @@ -0,0 +1,20 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t -> 'a occurrences_gen +val sexp_of_occurrences_gen : ('a -> Sexp.t) -> 'a occurrences_gen -> Sexp.t + +type occurrences_expr = Locus.occurrences_expr + +val occurrences_expr_of_sexp : Sexp.t -> occurrences_expr +val sexp_of_occurrences_expr : occurrences_expr -> Sexp.t + +type 'a with_occurrences = 'a Locus.with_occurrences [@@deriving sexp, yojson, hash,compare] + +type occurrences = Locus.occurrences +val occurrences_of_sexp : Sexp.t -> occurrences +val sexp_of_occurrences : occurrences -> Sexp.t + +type hyp_location_flag = Locus.hyp_location_flag + [@@deriving sexp,hash,compare] + +type 'a hyp_location_expr = 'a Locus.hyp_location_expr +val hyp_location_expr_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a hyp_location_expr +val sexp_of_hyp_location_expr : ('a -> Sexp.t) -> 'a hyp_location_expr -> Sexp.t + +type 'id clause_expr = 'id Locus.clause_expr + [@@deriving sexp,yojson,hash,compare] + +type clause = Locus.clause + +val clause_of_sexp : Sexp.t -> clause +val sexp_of_clause : clause -> Sexp.t + +type clause_atom = Locus.clause_atom + +val clause_atom_of_sexp : Sexp.t -> clause_atom +val sexp_of_clause_atom : clause_atom -> Sexp.t + +type concrete_clause = Locus.concrete_clause + +val concrete_clause_of_sexp : Sexp.t -> concrete_clause +val sexp_of_concrete_clause : concrete_clause -> Sexp.t + +type hyp_location = Locus.hyp_location + [@@deriving sexp,yojson,hash,compare] + +type goal_location = Locus.goal_location + +val goal_location_of_sexp : Sexp.t -> goal_location +val sexp_of_goal_location : goal_location -> Sexp.t + +type simple_clause = Locus.simple_clause +val simple_clause_of_sexp : Sexp.t -> simple_clause +val sexp_of_simple_clause : simple_clause -> Sexp.t + +type 'id or_like_first = 'id Locus.or_like_first + +val or_like_first_of_sexp : (Sexp.t -> 'id) -> Sexp.t -> 'id or_like_first +val sexp_of_or_like_first : ('id -> Sexp.t) -> 'id or_like_first -> Sexp.t diff --git a/serlib_8_19/ser_ltac_pretype.ml b/serlib_8_19/ser_ltac_pretype.ml new file mode 100644 index 00000000..6428150a --- /dev/null +++ b/serlib_8_19/ser_ltac_pretype.ml @@ -0,0 +1,37 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* closure +val sexp_of_closure : closure -> Sexp.t + +type closed_glob_constr = Ltac_pretype.closed_glob_constr + [@@deriving sexp,hash,compare] + +type constr_under_binders = Ltac_pretype.constr_under_binders + +val constr_under_binders_of_sexp : Sexp.t -> constr_under_binders +val sexp_of_constr_under_binders : constr_under_binders -> Sexp.t diff --git a/serlib_8_19/ser_mod_subst.ml b/serlib_8_19/ser_mod_subst.ml new file mode 100644 index 00000000..9dbb71ed --- /dev/null +++ b/serlib_8_19/ser_mod_subst.ml @@ -0,0 +1,37 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t) -> 'a substituted -> Sexp.t + * val substituted_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a substituted *) diff --git a/serlib_8_19/ser_namegen.ml b/serlib_8_19/ser_namegen.ml new file mode 100644 index 00000000..c21d37a0 --- /dev/null +++ b/serlib_8_19/ser_namegen.ml @@ -0,0 +1,23 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* |= _kername_get) +let to_yojson kn = _t_to_yojson (_t_put kn) + +let hash x = hash__t (_t_put x) +let hash_fold_t st id = hash_fold__t st (_t_put id) + +let compare x y = compare__t (_t_put x) (_t_put y) + +let equal = KerName.equal + +end + +module KNmap = Ser_cMap.Make(Names.KNmap)(KerName) + +module Constant = struct + +(* Constant.t: private *) +type t = [%import: Names.Constant.t] + +type _t = Constant of KerName.t * KerName.t option + [@@deriving sexp,yojson,hash,compare] + +let _t_put cs = + let cu, cc = Constant.(user cs, canonical cs) in + if KerName.equal cu cc then Constant (cu, None) else Constant (cu, Some cc) +let _t_get = function + | Constant (cu, None) -> Constant.make1 cu + | Constant (cu, Some cc) -> Constant.make cu cc + +let t_of_sexp sexp = _t_get (_t_of_sexp sexp) +let sexp_of_t dp = sexp_of__t (_t_put dp) + +let of_yojson json = Ppx_deriving_yojson_runtime.(_t_of_yojson json >|= _t_get) +let to_yojson level = _t_to_yojson (_t_put level) + +let hash x = hash__t (_t_put x) +let hash_fold_t st id = hash_fold__t st (_t_put id) + +let compare x y = compare__t (_t_put x) (_t_put y) + +end + +module Cset_env = Ser_cSet.Make(Cset_env)(Constant) + +module Cmap = Ser_cMap.Make(Cmap)(Constant) +module Cmap_env = Ser_cMap.Make(Cmap_env)(Constant) + +module MutInd = struct + +(* MutInd.t: private *) + module BijectSpec = struct + type t = [%import: Names.MutInd.t] + type _t = MutInd of KerName.t * KerName.t option + [@@deriving sexp,yojson,hash,compare] + + let of_t cs = + let cu, cc = MutInd.(user cs, canonical cs) in + if KerName.equal cu cc then MutInd (cu, None) else MutInd (cu, Some cc) + + let to_t = function + | MutInd (cu, None) -> MutInd.make1 cu + | MutInd (cu, Some cc) -> MutInd.make cu cc + end + + include SerType.Biject(BijectSpec) +end + +module Mindmap = Ser_cMap.Make(Mindmap)(MutInd) +module Mindmap_env = Ser_cMap.Make(Mindmap_env)(MutInd) + +type 'a tableKey = + [%import: 'a Names.tableKey] + [@@deriving sexp] + +type variable = + [%import: Names.variable] + [@@deriving sexp,yojson,hash,compare] + +(* Inductive and constructor = public *) +module Ind = struct + type t = + [%import: Names.Ind.t] + [@@deriving sexp,yojson,hash,compare] +end + +module Indset_env = Ser_cSet.Make(Indset_env)(Ind) +module Indmap_env = Ser_cMap.Make(Indmap_env)(Ind) + +type inductive = + [%import: Names.inductive] + [@@deriving sexp,yojson,hash,compare] + +module Construct = struct + type t = + [%import: Names.Construct.t] + [@@deriving sexp,yojson,hash,compare] + +end +type constructor = + [%import: Names.constructor] + [@@deriving sexp,yojson,hash,compare] + +(* Projection: private *) +module Projection = struct + + module Repr = struct + module PierceSpec = struct + type t = Names.Projection.Repr.t + type _t = + { proj_ind : inductive + ; proj_relevant : bool + ; proj_npars : int + ; proj_arg : int + ; proj_name : Label.t + } [@@deriving sexp,yojson,hash,compare] + end + include SerType.Pierce(PierceSpec) + end + + module PierceSpec = struct + type t = [%import: Names.Projection.t] + type _t = Repr.t * bool + [@@deriving sexp,yojson,hash,compare] + end + include SerType.Pierce(PierceSpec) +end + +module GlobRef = struct + +type t = [%import: Names.GlobRef.t] + [@@deriving sexp,yojson,hash,compare] + +end + +(* Evaluable global reference: public *) +(* type evaluable_global_reference = + * [%import: Names.evaluable_global_reference] + * [@@deriving sexp] *) + +type lident = + [%import: Names.lident] + [@@deriving sexp,yojson,hash,compare] + +type lname = + [%import: Names.lname] + [@@deriving sexp,yojson,hash,compare] + +type lstring = + [%import: Names.lstring] + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib_8_19/ser_names.mli b/serlib_8_19/ser_names.mli new file mode 100644 index 00000000..41ccfd79 --- /dev/null +++ b/serlib_8_19/ser_names.mli @@ -0,0 +1,79 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t -> 'a tableKey +val sexp_of_tableKey : ('a -> Sexp.t) -> 'a tableKey -> Sexp.t + +type variable = Names.variable [@@deriving sexp, yojson, hash, compare] +type inductive = Names.inductive [@@deriving sexp, yojson, hash, compare] +type constructor = Names.constructor [@@deriving sexp, yojson, hash, compare] + +module Projection : sig + + include SerType.SJHC with type t = Projection.t + + module Repr : sig + include SerType.SJHC with type t = Projection.Repr.t + end + +end + +module GlobRef : SerType.SJHC with type t = Names.GlobRef.t + +type lident = Names.lident [@@deriving sexp,yojson,hash,compare] +type lname = Names.lname [@@deriving sexp,yojson,hash,compare] +type lstring = Names.lstring [@@deriving sexp,yojson,hash,compare] diff --git a/serlib_8_19/ser_nametab.ml b/serlib_8_19/ser_nametab.ml new file mode 100644 index 00000000..12ab6da4 --- /dev/null +++ b/serlib_8_19/ser_nametab.ml @@ -0,0 +1,23 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* parenRelation + * val sexp_of_parenRelation : parenRelation -> Sexp.t + * + * type precedence = Notation_gram.precedence + * + * val precedence_of_sexp : Sexp.t -> precedence + * val sexp_of_precedence : precedence -> Sexp.t + * + * type tolerability = Notation_gram.tolerability + * + * val tolerability_of_sexp : Sexp.t -> tolerability + * val sexp_of_tolerability : tolerability -> Sexp.t *) + +type grammar_constr_prod_item = Notation_gram.grammar_constr_prod_item +val grammar_constr_prod_item_of_sexp : Sexp.t -> grammar_constr_prod_item +val sexp_of_grammar_constr_prod_item : grammar_constr_prod_item -> Sexp.t + +type notation_grammar = Notation_gram.notation_grammar +val notation_grammar_of_sexp : Sexp.t -> notation_grammar +val sexp_of_notation_grammar : notation_grammar -> Sexp.t + diff --git a/serlib_8_19/ser_notation_term.ml b/serlib_8_19/ser_notation_term.ml new file mode 100644 index 00000000..88cf6af6 --- /dev/null +++ b/serlib_8_19/ser_notation_term.ml @@ -0,0 +1,57 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* case_info_pattern +val sexp_of_case_info_pattern : case_info_pattern -> Sexp.t + +type constr_pattern = Pattern.constr_pattern + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib_8_19/ser_pp.ml b/serlib_8_19/ser_pp.ml new file mode 100644 index 00000000..2499cfbe --- /dev/null +++ b/serlib_8_19/ser_pp.ml @@ -0,0 +1,75 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Pp_empty + | Ppcmd_string s -> Pp_string s + | Ppcmd_glue l -> Pp_glue (List.map from_t l) + | Ppcmd_box (bt,d) -> Pp_box(bt, from_t d) + | Ppcmd_tag (t,d) -> Pp_tag(t, from_t d) + | Ppcmd_print_break (n,m) -> Pp_print_break(n,m) + | Ppcmd_force_newline -> Pp_force_newline + | Ppcmd_comment s -> Pp_comment s + + let rec to_t (d : _t) : t = unrepr (match d with + | Pp_empty -> Ppcmd_empty + | Pp_string s -> Ppcmd_string s + | Pp_glue l -> Ppcmd_glue (List.map to_t l) + | Pp_box (bt,d) -> Ppcmd_box(bt, to_t d) + | Pp_tag (t,d) -> Ppcmd_tag(t, to_t d) + | Pp_print_break (n,m) -> Ppcmd_print_break(n,m) + | Pp_force_newline -> Ppcmd_force_newline + | Pp_comment s -> Ppcmd_comment s) + +end + +type t = Pp.t +let t_of_sexp s = P.(to_t (_t_of_sexp s)) +let sexp_of_t d = P.(sexp_of__t (from_t d)) + +let of_yojson json = Ppx_deriving_yojson_runtime.(P.(_t_of_yojson json >|= to_t)) +let to_yojson level = P.(_t_to_yojson (from_t level)) + +type doc_view = + [%import: Pp.doc_view] + [@@deriving sexp, yojson] diff --git a/serlib_8_19/ser_pp.mli b/serlib_8_19/ser_pp.mli new file mode 100644 index 00000000..3b8696eb --- /dev/null +++ b/serlib_8_19/ser_pp.mli @@ -0,0 +1,32 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* t +val sexp_of_t : t -> Sexp.t +val of_yojson : Yojson.Safe.t -> (t, string) Result.result +val to_yojson : t -> Yojson.Safe.t + +val doc_view_of_sexp : Sexp.t -> doc_view +val sexp_of_doc_view : doc_view -> Sexp.t +val doc_view_of_yojson : Yojson.Safe.t -> (doc_view, string) Result.result +val doc_view_to_yojson : doc_view -> Yojson.Safe.t diff --git a/serlib_8_19/ser_ppextend.ml b/serlib_8_19/ser_ppextend.ml new file mode 100644 index 00000000..d2d1c2eb --- /dev/null +++ b/serlib_8_19/ser_ppextend.ml @@ -0,0 +1,49 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* ppbox +val sexp_of_ppbox : ppbox -> Sexp.t + +type ppcut = Ppextend.ppcut + +val ppcut_of_sexp : Sexp.t -> ppcut +val sexp_of_ppcut : ppcut -> Sexp.t + +(* type unparsing = Ppextend.unparsing + * val unparsing_of_sexp : Sexp.t -> unparsing + * val sexp_of_unparsing : unparsing -> Sexp.t *) + +type unparsing_rule = Ppextend.unparsing_rule +val unparsing_rule_of_sexp : Sexp.t -> unparsing_rule +val sexp_of_unparsing_rule : unparsing_rule -> Sexp.t + +type notation_printing_rules = Ppextend.notation_printing_rules +val notation_printing_rules_of_sexp : Sexp.t -> notation_printing_rules +val sexp_of_notation_printing_rules : notation_printing_rules -> Sexp.t diff --git a/serlib_8_19/ser_pretype_errors.ml b/serlib_8_19/ser_pretype_errors.ml new file mode 100644 index 00000000..1f2dfbc3 --- /dev/null +++ b/serlib_8_19/ser_pretype_errors.ml @@ -0,0 +1,75 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* + NotClean (e, ee, c) + | ConversionFailed (_, c1, c2) -> + ConversionFailed (ee, c1, c2) + | IncompatibleInstances (_, e, c1, c2) -> + IncompatibleInstances (ee, e, c1, c2) + | InstanceNotSameType (e, _, t1, t2) -> + InstanceNotSameType (e, ee, t1, t2) + | CannotSolveConstraint (e, ue) -> + CannotSolveConstraint (e, (filter_ue ue)) + | ue -> ue + +let sexp_of_unification_error ue = + filter_ue ue |> sexp_of_unification_error + +type position = + [%import: Pretype_errors.position] + [@@deriving sexp] + +type position_reporting = + [%import: Pretype_errors.position_reporting] + [@@deriving sexp] + +type subterm_unification_error = + [%import: Pretype_errors.subterm_unification_error] + [@@deriving sexp] + +type type_error = + [%import: Pretype_errors.type_error] + [@@deriving sexp] + +type pretype_error = + [%import: Pretype_errors.pretype_error] + [@@deriving sexp] diff --git a/serlib_8_19/ser_pretype_errors.mli b/serlib_8_19/ser_pretype_errors.mli new file mode 100644 index 00000000..fb783695 --- /dev/null +++ b/serlib_8_19/ser_pretype_errors.mli @@ -0,0 +1,39 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* unification_error +val sexp_of_unification_error : unification_error -> Sexp.t + +type position = Pretype_errors.position +val position_of_sexp : Sexp.t -> position +val sexp_of_position : position -> Sexp.t + +type position_reporting = Pretype_errors.position_reporting +val position_reporting_of_sexp : Sexp.t -> position_reporting +val sexp_of_position_reporting : position_reporting -> Sexp.t + +type subterm_unification_error = Pretype_errors.subterm_unification_error +val subterm_unification_error_of_sexp : Sexp.t -> subterm_unification_error +val sexp_of_subterm_unification_error : subterm_unification_error -> Sexp.t + +type pretype_error = Pretype_errors.pretype_error +val pretype_error_of_sexp : Sexp.t -> pretype_error +val sexp_of_pretype_error : pretype_error -> Sexp.t diff --git a/serlib_8_19/ser_printer.ml b/serlib_8_19/ser_printer.ml new file mode 100644 index 00000000..c8164b50 --- /dev/null +++ b/serlib_8_19/ser_printer.ml @@ -0,0 +1,22 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* 'b) (x : 'a SList.t) : 'b SList.t = Obj.magic (_map f (Obj.magic x)) diff --git a/serlib_8_19/ser_safe_typing.ml b/serlib_8_19/ser_safe_typing.ml new file mode 100644 index 00000000..275a5b39 --- /dev/null +++ b/serlib_8_19/ser_safe_typing.ml @@ -0,0 +1,83 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* 'a) (x : Sexp.t) : 'a effect_entry = + let open Sexp in + match x with + | Atom "PureEntry" -> + Obj__magic PureEntry + | Atom "EffectEntry" -> + Obj__magic EffectEntry + | _ -> + Sexplib.Conv_error.no_variant_match () +*) + +type global_declaration = + [%import: Safe_typing.global_declaration] + [@@deriving sexp] diff --git a/serlib_8_19/ser_safe_typing.mli b/serlib_8_19/ser_safe_typing.mli new file mode 100644 index 00000000..1613aad1 --- /dev/null +++ b/serlib_8_19/ser_safe_typing.mli @@ -0,0 +1,26 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* global_declaration +val sexp_of_global_declaration : global_declaration -> Sexp.t diff --git a/serlib_8_19/ser_sorts.ml b/serlib_8_19/ser_sorts.ml new file mode 100644 index 00000000..a40d6e30 --- /dev/null +++ b/serlib_8_19/ser_sorts.ml @@ -0,0 +1,78 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* t +val sexp_of_t : t -> Sexp.t + +type 'c p = 'c Tok.p +val p_of_sexp : (Sexp.t -> 'c) -> Sexp.t -> 'c p +val sexp_of_p : ('c -> Sexp.t) -> 'c p -> Sexp.t diff --git a/serlib_8_19/ser_type_errors.ml b/serlib_8_19/ser_type_errors.ml new file mode 100644 index 00000000..82180116 --- /dev/null +++ b/serlib_8_19/ser_type_errors.ml @@ -0,0 +1,59 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* guard_error +val sexp_of_guard_error : guard_error -> Sexp.t + +type ('c,'t) pcant_apply_bad_type = ('c, 't) Type_errors.pcant_apply_bad_type + +val pcant_apply_bad_type_of_sexp : + (Sexp.t -> 'constr) -> (Sexp.t -> 'types) -> + Sexp.t -> ('constr, 'types) pcant_apply_bad_type + +val sexp_of_pcant_apply_bad_type : + ('constr -> Sexp.t) -> + ('types -> Sexp.t) -> + ('constr, 'types) pcant_apply_bad_type -> Sexp.t + +type ('c, 't) ptype_error = ('c, 't) Type_errors.ptype_error +val ptype_error_of_sexp : + (Sexp.t -> 'constr) -> (Sexp.t -> 'types) -> + Sexp.t -> ('constr, 'types) ptype_error + +val sexp_of_ptype_error : + ('constr -> Sexp.t) -> + ('types -> Sexp.t) -> + ('constr, 'types) ptype_error -> Sexp.t + +type type_error = Type_errors.type_error +val type_error_of_sexp : Sexp.t -> type_error +val sexp_of_type_error : type_error -> Sexp.t + diff --git a/serlib_8_19/ser_typeclasses.ml b/serlib_8_19/ser_typeclasses.ml new file mode 100644 index 00000000..c22cf055 --- /dev/null +++ b/serlib_8_19/ser_typeclasses.ml @@ -0,0 +1,25 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* |= _t_get) +let to_yojson level = _t_to_yojson (_t_put level) + +let hash_fold_t st i = + Ppx_hash_lib.Std.Hash.Builtin.hash_fold_int64 st (Uint63.to_int64 i) + +let compare i1 i2 = + Ppx_compare_lib.Builtin.compare_int64 (Uint63.to_int64 i1) (Uint63.to_int64 i2) diff --git a/serlib_8_19/ser_univ.ml b/serlib_8_19/ser_univ.ml new file mode 100644 index 00000000..160f470d --- /dev/null +++ b/serlib_8_19/ser_univ.ml @@ -0,0 +1,102 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* univ_constraint +val sexp_of_univ_constraint : univ_constraint -> Sexp.t + +module Constraints : SerType.SJHC with type t = Univ.Constraints.t + +module ContextSet : SerType.SJHC with type t = Univ.ContextSet.t + +type 'a in_universe_context_set = 'a Univ.in_universe_context_set +val in_universe_context_set_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a in_universe_context_set +val sexp_of_in_universe_context_set : ('a -> Sexp.t) -> 'a in_universe_context_set -> Sexp.t diff --git a/serlib_8_19/ser_univNames.ml b/serlib_8_19/ser_univNames.ml new file mode 100644 index 00000000..21b0683f --- /dev/null +++ b/serlib_8_19/ser_univNames.ml @@ -0,0 +1,31 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* |= _instance_get) +let to_yojson level = _t_to_yojson (_instance_put level) + +let hash i = hash__t (Instance (UVars.Instance.to_array i)) +let hash_fold_t st i = hash_fold__t st (Instance (UVars.Instance.to_array i)) +let compare i1 i2 = compare__t (Instance (UVars.Instance.to_array i1)) (Instance (UVars.Instance.to_array i2)) + +end + +module UContext = struct + + module I = struct + type t = UVars.UContext.t + type _t = (Names.Name.t array * Names.Name.t array) * (Instance.t * Constraints.t) + [@@deriving sexp,yojson,hash,compare] + + let to_t (un, cs) = UVars.UContext.make un cs + let of_t uc = UVars.UContext.(names uc, (instance uc, constraints uc)) + end + + include SerType.Biject(I) + +end + +module AbstractContext = struct + + let hash_fold_array = hash_fold_array_frozen + module ACPierceDef = struct + + type t = UVars.AbstractContext.t + type _t = (Names.Name.t array * Names.Name.t array) * Constraints.t + [@@deriving sexp,yojson,hash,compare] + end + + include SerType.Pierce(ACPierceDef) + +end + +type 'a in_universe_context = + [%import: 'a UVars.in_universe_context] + [@@deriving sexp] + +type 'a puniverses = + [%import: 'a UVars.puniverses] + [@@deriving sexp, yojson, hash, compare] diff --git a/serlib_8_19/ser_uvars.mli b/serlib_8_19/ser_uvars.mli new file mode 100644 index 00000000..c17f2fbb --- /dev/null +++ b/serlib_8_19/ser_uvars.mli @@ -0,0 +1,35 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t -> 'a in_universe_context +val sexp_of_in_universe_context : ('a -> Sexp.t) -> 'a in_universe_context -> Sexp.t + +type 'a puniverses = 'a * Instance.t + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib_8_19/ser_vernacexpr.ml b/serlib_8_19/ser_vernacexpr.ml new file mode 100644 index 00000000..fe0a76e9 --- /dev/null +++ b/serlib_8_19/ser_vernacexpr.ml @@ -0,0 +1,353 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t + * val to_patch_substituted_of_sexp : Sexp.t -> to_patch_substituted *) diff --git a/serlib_8_19/ser_vmvalues.ml b/serlib_8_19/ser_vmvalues.ml new file mode 100644 index 00000000..130d5549 --- /dev/null +++ b/serlib_8_19/ser_vmvalues.ml @@ -0,0 +1,63 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* tag +val sexp_of_tag : tag -> Sexp.t + +type structured_constant = Vmvalues.structured_constant + [@@deriving sexp,yojson,hash,compare] + +type reloc_table = Vmvalues.reloc_table + [@@deriving sexp,yojson,hash,compare] + +type annot_switch = Vmvalues.annot_switch + [@@deriving sexp,yojson,hash,compare] diff --git a/serlib_8_19/ser_xml_datatype.ml b/serlib_8_19/ser_xml_datatype.ml new file mode 100644 index 00000000..7edc7f44 --- /dev/null +++ b/serlib_8_19/ser_xml_datatype.ml @@ -0,0 +1,28 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* Sexp.t -> 'a gxml +val sexp_of_gxml : ('a -> Sexp.t) -> 'a gxml -> Sexp.t +val gxml_of_yojson : (Yojson.Safe.t -> ('a, string) Result.result) -> Yojson.Safe.t -> ('a gxml, string) Result.result +val gxml_to_yojson : ('a -> Yojson.Safe.t) -> 'a gxml -> Yojson.Safe.t + +type xml = Xml_datatype.xml + +val xml_of_sexp : Sexp.t -> xml +val sexp_of_xml : xml -> Sexp.t +val xml_of_yojson : Yojson.Safe.t -> (xml, string) Result.result +val xml_to_yojson : xml -> Yojson.Safe.t diff --git a/serlib_8_19/serlib_base.ml b/serlib_8_19/serlib_base.ml new file mode 100644 index 00000000..df11d059 --- /dev/null +++ b/serlib_8_19/serlib_base.ml @@ -0,0 +1,52 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* + Some Pp.(seq [str "Serlib Error: "; str msg]) + | _ -> + None) + +let opaque_of_sexp ~typ _obj = + raise (Ser_error ("["^typ^": ABSTRACT / cannot deserialize]")) + +let exn_on_opaque = ref true + +let sexp_of_opaque ~typ _exp = + let msg = "["^typ^": ABSTRACT]" in + if !exn_on_opaque then + raise (Ser_error msg) + else + Sexplib.Sexp.Atom ("["^typ^": ABSTRACT]") + +let opaque_of_yojson ~typ _obj = + raise (Ser_error ("["^typ^": ABSTRACT / cannot deserialize]")) + +let opaque_to_yojson ~typ _obj = + let msg = "["^typ^": ABSTRACT]" in + if !exn_on_opaque then + raise (Ser_error msg) + else + `String ("["^typ^": ABSTRACT]") + +let hash_opaque ~typ:_ x = Hashtbl.hash x +let hash_fold_opaque ~typ st x = Ppx_hash_lib.Std.Hash.Builtin.hash_fold_int st (hash_opaque ~typ x) +let compare_opaque ~typ:_ x y = Stdlib.compare x y + diff --git a/serlib_8_19/serlib_base.mli b/serlib_8_19/serlib_base.mli new file mode 100644 index 00000000..66f728da --- /dev/null +++ b/serlib_8_19/serlib_base.mli @@ -0,0 +1,34 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* 'a -> Sexp.t +val opaque_of_sexp : typ:string -> Sexp.t -> 'a + +val opaque_of_yojson : typ:string -> Yojson.Safe.t -> ('a, string) Result.t +val opaque_to_yojson : typ:string -> 'a -> Yojson.Safe.t + +val hash_opaque : typ:string -> 'a -> Ppx_hash_lib.Std.Hash.hash_value +val hash_fold_opaque : typ:string -> Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state + +val compare_opaque : typ:string -> 'a -> 'a -> int diff --git a/serlib_8_19/serlib_init.ml b/serlib_8_19/serlib_init.ml new file mode 100644 index 00000000..d80ff40a --- /dev/null +++ b/serlib_8_19/serlib_init.ml @@ -0,0 +1,31 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* unit + diff --git a/test/compiler/basic/run.t b/test/compiler/basic/run.t index ac7db57b..94ea7aa1 100644 --- a/test/compiler/basic/run.t +++ b/test/compiler/basic/run.t @@ -260,6 +260,6 @@ We do the same for the goaldump plugin: + findlib default location: [TEST_PATH] [message] compiling file proj1/a.v [message] [goaldump plugin] dumping goals for proj1/a.v ... - [message] [ast plugin] dumping ast for proj1/a.v was completed! + [message] [goaldump plugin] dumping ast for proj1/a.v was completed! $ ls proj1/a.v.json.goaldump proj1/a.v.json.goaldump diff --git a/test/serlib/genarg/abstract.v b/test/serlib/genarg/abstract.v new file mode 100644 index 00000000..102a446c --- /dev/null +++ b/test/serlib/genarg/abstract.v @@ -0,0 +1,280 @@ +Require Import ZArith. + +Definition outside_interval (a b : Z) := (Z.sgn a + Z.sgn b)%Z. + +Definition inside_interval_1 (o1 o2 : Z) := + (0 < o1)%Z /\ (0 < o2)%Z \/ (o1 < 0)%Z /\ (o2 < 0)%Z. + +Definition inside_interval_2 (o1 o2 : Z) := + (0 < o1)%Z /\ (o2 < 0)%Z \/ (o1 < 0)%Z /\ (0 < o2)%Z. + +Lemma inside_interval_1_dec_inf : + forall o1 o2 : Z, {inside_interval_1 o1 o2} + {~ inside_interval_1 o1 o2}. +Proof. + intros. + abstract (case (Z_lt_dec 0 o1); intro Ho1; + [ case (Z_lt_dec 0 o2); intro Ho2; + [ left; left; split + | right; intro H; + match goal with + | id1:(~ ?X1) |- ?X2 => + apply id1; case H; intros (H1, H2); + [ idtac + | apply False_ind; apply Z.lt_irrefl with o1; + apply Z.lt_trans with 0%Z ] + end ] + | case (Z_lt_dec o1 0); intro Ho1'; + [ case (Z_lt_dec o2 0); intro Ho2; + [ left; right; split + | right; intro H; case H; intros (H1, H2); + [ apply Ho1 | apply Ho2 ] ] + | right; intro H; apply Ho1; case H; intros (H1, H2); + [ idtac | apply False_ind; apply Ho1' ] ] ]; + try assumption). +Defined. + +Lemma inside_interval_2_dec_inf : + forall o1 o2 : Z, {inside_interval_2 o1 o2} + {~ inside_interval_2 o1 o2}. +Proof. + intros. + abstract (case (Z_lt_dec 0 o1); intro Ho1; + [ case (Z_lt_dec o2 0); intro Ho2; + [ left; left; split + | right; intro H; + match goal with + | id1:(~ ?X1) |- ?X2 => + apply id1; case H; intros (H1, H2); + [ idtac + | apply False_ind; apply Z.lt_irrefl with o1; + apply Z.lt_trans with 0%Z ] + end ] + | case (Z_lt_dec o1 0); intro Ho1'; + [ case (Z_lt_dec 0 o2); intro Ho2; + [ left; right; split + | right; intro H; case H; intros (H1, H2); + [ apply Ho1 | apply Ho2 ] ] + | right; intro H; apply Ho1; case H; intros (H1, H2); + [ idtac | apply False_ind; apply Ho1' ] ] ]; + try assumption). +Defined. + +Inductive Qpositive : Set := + | nR : Qpositive -> Qpositive + | dL : Qpositive -> Qpositive + | One : Qpositive. + +Inductive Qhomographic_sg_denom_nonzero : Z -> Z -> Qpositive -> Prop := + | Qhomographic_signok0 : + forall (c d : Z) (p : Qpositive), + p = One -> (c + d)%Z <> 0%Z -> Qhomographic_sg_denom_nonzero c d p + | Qhomographic_signok1 : + forall (c d : Z) (xs : Qpositive), + Qhomographic_sg_denom_nonzero c (c + d)%Z xs -> + Qhomographic_sg_denom_nonzero c d (nR xs) + | Qhomographic_signok2 : + forall (c d : Z) (xs : Qpositive), + Qhomographic_sg_denom_nonzero (c + d)%Z d xs -> + Qhomographic_sg_denom_nonzero c d (dL xs). + +Lemma Qhomographic_signok_1 : + forall c d : Z, Qhomographic_sg_denom_nonzero c d One -> (c + d)%Z <> 0%Z. +Proof. + intros. + inversion H. + assumption. +Defined. + +Lemma Qhomographic_signok_2 : + forall (c d : Z) (xs : Qpositive), + Qhomographic_sg_denom_nonzero c d (nR xs) -> + Qhomographic_sg_denom_nonzero c (c + d) xs. +Proof. + intros. + inversion H. + discriminate H0. + assumption. +Defined. + +Lemma Qhomographic_signok_3 : + forall (c d : Z) (xs : Qpositive), + Qhomographic_sg_denom_nonzero c d (dL xs) -> + Qhomographic_sg_denom_nonzero (c + d) d xs. +Proof. + intros. + inversion H. + discriminate H0. + assumption. +Defined. + +Fixpoint Qhomographic_sign (a b c d : Z) (p : Qpositive) {struct p} : + forall (H_Qhomographic_sg_denom_nonzero : Qhomographic_sg_denom_nonzero c d p), + Z * (Z * (Z * (Z * Z)) * Qpositive). +set (o1 := outside_interval a b) in *. +set (o2 := outside_interval c d) in *. +destruct p as [q| q| ]; intros H_Qhomographic_sg_denom_nonzero. + (* p=(nR xs) *) + case (Z_zerop b). + (* b=0 *) + intro Hb. + case (Z_zerop d). + (* d=0 *) + intro Hd. + exact ((Z.sgn a * Z.sgn c)%Z, (a, (b, (c, d)), nR q)). + (* d<>0 *) + intro Hd'. + case (Z_lt_dec 0 o2). + (* `0 < o2` *) + intro Ho2. + exact (Z.sgn a, (a, (b, (c, d)), nR q)). + (* ~( 00 *) + intro Ho2''. + exact + (Qhomographic_sign a (a + b)%Z c (c + d)%Z q + (Qhomographic_signok_2 c d q H_Qhomographic_sg_denom_nonzero)). + (* b<>0 *) + intro Hb. + case (Z_zerop d). + (* d=0 *) + intro Hd. + case (Z_lt_dec 0 o1). + (* `0 < o1` *) + intro Ho1. + exact (Z.sgn c, (a, (b, (c, d)), nR q)). + (* ~( 00 *) + intro Ho1''. + exact + (Qhomographic_sign a (a + b)%Z c (c + d)%Z q + (Qhomographic_signok_2 c d q H_Qhomographic_sg_denom_nonzero)). + (* d<>0 *) + intro Hd'. + case (inside_interval_1_dec_inf o1 o2). + (* (inside_interval_1 o1 o2) *) + intro H_inside_1. + exact (1%Z, (a, (b, (c, d)), nR q)). + (* ~(inside_interval_1 o1 o2) *) + intro H_inside_1'. + case (inside_interval_2_dec_inf o1 o2). + (* (inside_interval_2 o1 o2) *) + intro H_inside_2. + exact ((-1)%Z, (a, (b, (c, d)), nR q)). + (* ~(inside_interval_1 o1 o2)/\~(inside_interval_2 o1 o2) *) + intros H_inside_2'. + exact + (Qhomographic_sign a (a + b)%Z c (c + d)%Z q + (Qhomographic_signok_2 c d q H_Qhomographic_sg_denom_nonzero)). + (* p=(dL xs) *) + case (Z_zerop b). + (* b=0 *) + intro Hb. + case (Z_zerop d). + (* d=0 *) + intro Hd. + exact ((Z.sgn a * Z.sgn c)%Z, (a, (b, (c, d)), dL q)). + (* d<>0 *) + intro Hd'. + case (Z_lt_dec 0 o2). + (* `0 < o2` *) + intro Ho2. + exact (Z.sgn a, (a, (b, (c, d)), dL q)). + (* ~( 00 *) + intro Ho2''. + exact + (Qhomographic_sign (a + b)%Z b (c + d)%Z d q + (Qhomographic_signok_3 c d q H_Qhomographic_sg_denom_nonzero)). + (* b<>0 *) + intro Hb. + case (Z_zerop d). + (* d=0 *) + intro Hd. + case (Z_lt_dec 0 o1). + (* `0 < o1` *) + intro Ho1. + exact (Z.sgn c, (a, (b, (c, d)), dL q)). + (* ~( 00 *) + intro Ho1''. + exact + (Qhomographic_sign (a + b)%Z b (c + d)%Z d q + (Qhomographic_signok_3 c d q H_Qhomographic_sg_denom_nonzero)). + (* d<>0 *) + intro Hd'. + case (inside_interval_1_dec_inf o1 o2). + (* (inside_interval_1 o1 o2) *) + intro H_inside_1. + exact (1%Z, (a, (b, (c, d)), dL q)). + (* ~(inside_interval_1 o1 o2) *) + intro H_inside_1'. + case (inside_interval_2_dec_inf o1 o2). + (* (inside_interval_2 o1 o2) *) + intro H_inside_2. + exact ((-1)%Z, (a, (b, (c, d)), dL q)). + (* ~(inside_interval_1 o1 o2)/\~(inside_interval_2 o1 o2) *) + intros H_inside_2'. + exact + (Qhomographic_sign (a + b)%Z b (c + d)%Z d q + (Qhomographic_signok_3 c d q H_Qhomographic_sg_denom_nonzero)). + + (* p = One *) + set (soorat := Z.sgn (a + b)) in *. + set (makhraj := Z.sgn (c + d)) in *. + + case (Z.eq_dec soorat 0). + (* `soorat = 0` *) + intro eq_numerator0. + exact (0%Z, (a, (b, (c, d)), One)). + (* `soorat <> 0` *) + intro. + case (Z.eq_dec soorat makhraj). + (* soorat = makhraj *) + intro. + exact (1%Z, (a, (b, (c, d)), One)). + (* soorat <> makhraj *) + intro. + exact ((-1)%Z, (a, (b, (c, d)), One)). +Defined. + +Scheme Qhomographic_sg_denom_nonzero_inv_dep := + Induction for Qhomographic_sg_denom_nonzero Sort Prop. + +Lemma Qhomographic_sign_equal : + forall (a b c d : Z) (p : Qpositive) + (H1 H2 : Qhomographic_sg_denom_nonzero c d p), + Qhomographic_sign a b c d p H1 = Qhomographic_sign a b c d p H2. +Proof. + intros. + generalize H2 H1 a b. + intro. + abstract let T_local := (intros; simpl in |- *; rewrite H; reflexivity) in + (elim H0 using Qhomographic_sg_denom_nonzero_inv_dep; intros; + [ destruct p0 as [q| q| ]; + [ discriminate e + | discriminate e + | simpl in |- *; case (Z.eq_dec (Z.sgn (a0 + b0)) 0); + case (Z.eq_dec (Z.sgn (a0 + b0)) (Z.sgn (c0 + d0))); + intros; reflexivity ] + | T_local + | T_local ]). +Defined. diff --git a/test/serlib/genarg/add_field.v b/test/serlib/genarg/add_field.v new file mode 100644 index 00000000..fe252d88 --- /dev/null +++ b/test/serlib/genarg/add_field.v @@ -0,0 +1,7 @@ +Require Import Qfield. + +Add Field Qfield : Qsft + (decidable Qeq_bool_eq, + completeness Qeq_eq_bool, + constants [Qcst], + power_tac Qpower_theory [Qpow_tac]). diff --git a/test/serlib/genarg/auto.v b/test/serlib/genarg/auto.v new file mode 100644 index 00000000..4c20fb3d --- /dev/null +++ b/test/serlib/genarg/auto.v @@ -0,0 +1,21 @@ +Require Import List. +Import ListNotations. + +Set Implicit Arguments. + +Section list_util. + Variables A : Type. + + Lemma NoDup_app3_not_in_2 : + forall (xs ys zs : list A) b, + NoDup (xs ++ ys ++ b :: zs) -> + In b ys -> + False. + Proof using. + intros. + rewrite <- app_ass in *. + apply NoDup_remove_2 in H. + rewrite app_ass in *. + auto 10 with *. + Qed. +End list_util. diff --git a/test/serlib/genarg/case.v b/test/serlib/genarg/case.v new file mode 100644 index 00000000..5443896d --- /dev/null +++ b/test/serlib/genarg/case.v @@ -0,0 +1,9 @@ +From Coq Require Import ssreflect. + +Structure stuff := + Stuff { one : bool; two : nat }. + +Lemma stuff_one s b n : s = Stuff b n -> one s = b. +Proof. +by case: s => [b' n']; case =>->. +Qed. diff --git a/test/serlib/genarg/clear.v b/test/serlib/genarg/clear.v new file mode 100644 index 00000000..b1a81838 --- /dev/null +++ b/test/serlib/genarg/clear.v @@ -0,0 +1,66 @@ +Require Import List. +Import ListNotations. +Require Import Sumbool. + +Ltac break_let := + match goal with + | [ H : context [ (let (_,_) := ?X in _) ] |- _ ] => destruct X eqn:? + | [ |- context [ (let (_,_) := ?X in _) ] ] => destruct X eqn:? + end. + +Ltac find_injection := + match goal with + | [ H : ?X _ _ = ?X _ _ |- _ ] => injection H; intros; subst + end. + +Ltac break_and := + repeat match goal with + | [H : _ /\ _ |- _ ] => destruct H + end. + +Ltac break_if := + match goal with + | [ |- context [ if ?X then _ else _ ] ] => + match type of X with + | sumbool _ _ => destruct X + | _ => destruct X eqn:? + end + end. + +Definition update2 {A B : Type} (A_eq_dec : forall x y : A, {x = y} + {x <> y}) (f : A -> A -> B) (x y : A) (v : B) := + fun x' y' => if sumbool_and _ _ _ _ (A_eq_dec x x') (A_eq_dec y y') then v else f x' y'. + +Fixpoint collate {A B : Type} (A_eq_dec : forall x y : A, {x = y} + {x <> y}) (from : A) (f : A -> A -> list B) (ms : list (A * B)) := + match ms with + | [] => f + | (to, m) :: ms' => collate A_eq_dec from (update2 A_eq_dec f from to (f from to ++ [m])) ms' + end. + +Section Update2. + Variables A B : Type. + Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}. + + Lemma collate_f_eq : + forall (f : A -> A -> list B) g h n n' l, + f n n' = g n n' -> + collate A_eq_dec h f l n n' = collate A_eq_dec h g l n n'. + Proof using. + intros f g h n n' l. + generalize f g; clear f g. + induction l; auto. + intros. + simpl in *. + break_let. + destruct a. + find_injection. + set (f' := update2 _ _ _ _ _). + set (g' := update2 _ _ _ _ _). + rewrite (IHl f' g'); auto. + unfold f', g', update2. + break_if; auto. + break_and. + subst. + rewrite H. + trivial. + Qed. +End Update2. \ No newline at end of file diff --git a/test/serlib/genarg/dune b/test/serlib/genarg/dune new file mode 100644 index 00000000..d4a74cda --- /dev/null +++ b/test/serlib/genarg/dune @@ -0,0 +1,264 @@ +; Eventually we should use the "put binaries in scope feature of Dune" + +(rule + (targets test_roundtrip) + (deps + (:input test_roundtrip.in) + (package coq-lsp)) + (action + (progn + ; Avoid issues on windows, (copy ) seems to add \r chars... + (bash "sed 's/\r$//' test_roundtrip.in > test_roundtrip") + (run chmod +wx test_roundtrip) + ; We insert the digest of the binaries to force a rebuild of the + ; test cases if the binary has been modified. + (bash + "for i in ../../../compiler/fcc.exe ../../../serlib/plugins/*/*.cmxs; do echo \"# $(md5sum $i)\"; done >> test_roundtrip")))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input abstract.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input add_field.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input auto.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input case.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input clear.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input eauto.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input elim.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input exact.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input exists.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input extraction.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input firstorder.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input fix.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input functional_induction.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input functional_scheme.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input hint_rewrite.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input instantiate.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input intropattern.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input intros.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input libTactics.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input mbid.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input move.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input now.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input rename.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input replace.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input revert.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input setoid_rewrite.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input specialize.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input subst.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input symmetry.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input tactic_notation.v)) + (action + (bash "./%{script} %{input}"))) + +(rule + (alias runtest) + (deps + (:script test_roundtrip) + (:input primitives.v)) + (action + (bash "./%{script} %{input}"))) diff --git a/test/serlib/genarg/eauto.v b/test/serlib/genarg/eauto.v new file mode 100644 index 00000000..354e5cf6 --- /dev/null +++ b/test/serlib/genarg/eauto.v @@ -0,0 +1,27 @@ +Require Import List. +Import ListNotations. + +Set Implicit Arguments. + +Section list_util. + Variables A : Type. + + Lemma in_firstn : forall n (x : A) xs, + In x (firstn n xs) -> In x xs. + Proof using. + induction n; simpl; intuition. + destruct xs;simpl in *; intuition. + Qed. + + Lemma firstn_NoDup : forall n (xs : list A), + NoDup xs -> + NoDup (firstn n xs). + Proof using. + induction n; intros; simpl; destruct xs; auto. + - apply NoDup_nil. + - inversion H; subst. + apply NoDup_cons. + * eauto 6 using in_firstn. + * apply IHn; auto. + Qed. +End list_util. diff --git a/test/serlib/genarg/elim.v b/test/serlib/genarg/elim.v new file mode 100644 index 00000000..a11f0f38 --- /dev/null +++ b/test/serlib/genarg/elim.v @@ -0,0 +1,70 @@ +Require Import ZArith. +Require Import ZArith.Zmax. +Require Import ssr.ssreflect. + +Open Scope Z_scope. + +Section BinaryTree. + +Inductive Tree : Set := +| leaf : Tree +| node : Tree -> Tree -> Tree. + +Definition max := Z.max. + +Fixpoint height (t : Tree) : Z := +match t with +| leaf => 0 +| node t1 t2 => 1 + (max (height t1) (height t2)) +end. + +Fixpoint numleaves (t : Tree) : Z := +match t with +| leaf => 1 +| node t1 t2 => numleaves t1 + numleaves t2 +end. + +Inductive complete : Tree -> Prop := +| complete_leaf : complete leaf +| complete_node : + forall t1 t2, + complete t1 -> + complete t2 -> + height t1 = height t2 -> + complete (node t1 t2). + +Lemma height_nonnegative : forall t, height t >= 0. +Proof. +elim => //=. +move => t1 Ht1 t2 Ht2. +have H0: height (node t1 t2) = 1 + max (height t1) (height t2) by auto. +have H1: height t1 <= max (height t1) (height t2) by apply Z.le_max_l. +have H2: 1 + max (height t1) (height t2) >= 0 by auto with zarith. +by []. +Qed. + +Theorem complete_numleaves_height : forall t, complete t -> numleaves t = 2^(height t). +Proof. +elim => //=. +move => t1 IHt1 t2 IHt2 Hc. +have H1: complete t1 by inversion Hc. +have H2: complete t2 by inversion Hc. +have H3: (height t1 = height t2) by inversion Hc; auto. +apply IHt1 in H1. +apply IHt2 in H2. +have H6: (1 >= 0) by intuition. +have H7: (height t1 >= 0) by apply height_nonnegative. +have H8: (height t1 = max (height t1) (height t1)) by erewrite Zmax_idempotent. +simpl numleaves. +rewrite H1 H2. +rewrite -H3. +have Hh: 2 ^ height t1 + 2 ^ height t1 = (2 * 2^(height t1)) by auto with zarith. +rewrite Hh. +have Hh': (2 * 2^(height t1)) = (2^1 * 2^(height t1)) by auto with zarith. +rewrite Hh'. +have Hh'': 2^(1 + height t1) = (2^1 * 2^(height t1)). + by apply (Zpower_exp 2 1 (height t1) H6 H7). +by rewrite -Hh'' {1}H8. +Qed. + +End BinaryTree. diff --git a/test/serlib/genarg/exact.v b/test/serlib/genarg/exact.v new file mode 100644 index 00000000..73c73f37 --- /dev/null +++ b/test/serlib/genarg/exact.v @@ -0,0 +1,66 @@ +Require Import String. +Require Import Ascii. +Require Import Orders. + +Inductive lex_lt: string -> string -> Prop := +| lex_lt_lt : forall (c1 c2 : ascii) (s1 s2 : string), + nat_of_ascii c1 < nat_of_ascii c2 -> + lex_lt (String c1 s1) (String c2 s2) +| lex_lt_eq : forall (c : ascii) (s1 s2 : string), + lex_lt s1 s2 -> + lex_lt (String c s1) (String c s2) +| lex_lt_empty : forall (c : ascii) (s : string), + lex_lt EmptyString (String c s). + +Theorem lex_lt_not_eq : forall s0 s1, + lex_lt s0 s1 -> s0 <> s1. +Proof. + induction s0. + - intros. + inversion H; subst. + congruence. + - intros. + inversion H; subst. + * intro H_eq. + injection H_eq; intros; subst. + contradict H3. + auto with arith. + * intro H_eq. + injection H_eq; intros; subst. + specialize (IHs0 s3). + apply IHs0 in H3. + auto. +Qed. + +Lemma lex_lt_irrefl : Irreflexive lex_lt. +Proof. + intros s0 H_lt. + apply lex_lt_not_eq in H_lt. + auto. +Qed. + +Theorem lex_lt_trans : forall s0 s1 s2, + lex_lt s0 s1 -> lex_lt s1 s2 -> lex_lt s0 s2. +Proof. +induction s0. +- intros. + inversion H; subst. + inversion H0; subst. + * apply lex_lt_empty. + * apply lex_lt_empty. +- intros. + inversion H; subst; inversion H0; subst. + * apply lex_lt_lt. + eauto with arith. + * apply lex_lt_lt. + assumption. + * apply lex_lt_lt. + assumption. + * apply lex_lt_eq. + eapply IHs0; eauto. +Qed. + +Theorem lex_lt_strorder : StrictOrder lex_lt. +Proof. + exact (Build_StrictOrder _ lex_lt_irrefl lex_lt_trans). +Qed. diff --git a/test/serlib/genarg/exists.v b/test/serlib/genarg/exists.v new file mode 100644 index 00000000..96c7a1f6 --- /dev/null +++ b/test/serlib/genarg/exists.v @@ -0,0 +1,52 @@ +Require Import List. +Import ListNotations. + +Set Implicit Arguments. + +Fixpoint before {A: Type} (x : A) y l : Prop := + match l with + | [] => False + | a :: l' => + a = x \/ + (a <> y /\ before x y l') + end. + +Section before. + Variable A : Type. + + Lemma before_In : + forall x y l, + before (A:=A) x y l -> + In x l. + Proof using. + induction l; intros; simpl in *; intuition. + Qed. + + Lemma before_split : + forall l (x y : A), + before x y l -> + x <> y -> + In x l -> + In y l -> + exists xs ys zs, + l = xs ++ x :: ys ++ y :: zs. + Proof using. + induction l; intros; simpl in *; intuition; subst; try congruence. + - exists []. simpl. + apply in_split in H1. + destruct H1; destruct H1. + subst. eauto. + - exists []. simpl. + apply in_split in H1. + destruct H1; destruct H1. subst. eauto. + - exists []. simpl. + apply in_split in H1. + destruct H1; destruct H1. subst. eauto. + - match goal with + | [ H : context [ In ], H' : context [ In ] |- _ ] => + eapply H in H' + end; eauto. + destruct H1; destruct H1; destruct H1. subst. + exists (a :: x0), x1, x2. auto. + Qed. +End before. \ No newline at end of file diff --git a/test/serlib/genarg/extraction.v b/test/serlib/genarg/extraction.v new file mode 100644 index 00000000..ec92c845 --- /dev/null +++ b/test/serlib/genarg/extraction.v @@ -0,0 +1,8 @@ +Require Coq.extraction.Extraction. + +Extraction Language Haskell. + +Extraction Implicit pred [1]. + +Axiom Y : Set -> Set -> Set. +Extract Constant Y "'a" "'b" => " 'a * 'b ". diff --git a/test/serlib/genarg/firstorder.v b/test/serlib/genarg/firstorder.v new file mode 100644 index 00000000..d2a874a9 --- /dev/null +++ b/test/serlib/genarg/firstorder.v @@ -0,0 +1,69 @@ +Require Import List. +Import ListNotations. + +Set Implicit Arguments. + +Fixpoint fin (n : nat) : Type := + match n with + | 0 => False + | S n' => option (fin n') + end. + +Fixpoint fin_eq_dec (n : nat) : forall (a b : fin n), {a = b} + {a <> b}. + refine + (match n with + | 0 => fun a b : fin 0 => right (match b with end) + | S n' => fun a b : fin (S n') => + match a, b with + | Some a', Some b' => + match fin_eq_dec n' a' b' with + | left _ _ => left _ + | right _ _ => right _ + end + | Some a', None => right _ + | None, Some b' => right _ + | None, None => left eq_refl + end + end); congruence. +Defined. + +Fixpoint all_fin (n : nat) : list (fin n) := + match n with + | 0 => [] + | S n' => None :: map (fun x => Some x) (all_fin n') + end. + +Lemma all_fin_all : + forall n (x : fin n), + In x (all_fin n). +Proof. + induction n; intros. + - inversion x. + - simpl in *. destruct x; auto using in_map. +Qed. + +Lemma NoDup_map_injective : forall A B (f : A -> B) xs, + (forall x y, In x xs -> In y xs -> + f x = f y -> x = y) -> + NoDup xs -> NoDup (map f xs). +Proof using. + induction xs; intros. + - constructor. + - simpl. inversion H0. subst. constructor. + + intro. + apply in_map_iff in H1. + destruct H1. + destruct H1. + assert (x = a) by intuition. + subst. + congruence. + + intuition. +Qed. + +Lemma all_fin_NoDup : + forall n, NoDup (all_fin n). +Proof. + induction n; intros; simpl; constructor. + - intro. apply in_map_iff in H. firstorder. discriminate. + - apply NoDup_map_injective; auto. congruence. +Qed. \ No newline at end of file diff --git a/test/serlib/genarg/fix.v b/test/serlib/genarg/fix.v new file mode 100644 index 00000000..8db31ef0 --- /dev/null +++ b/test/serlib/genarg/fix.v @@ -0,0 +1,64 @@ +Require Import ZArith. + +Ltac Falsum := + try intro; apply False_ind; + repeat + match goal with + | id1:(~ ?X1) |- ?X2 => + (apply id1; assumption || reflexivity) || clear id1 + end. + +Inductive Qpositive : Set := + | nR : Qpositive -> Qpositive + | dL : Qpositive -> Qpositive + | One : Qpositive. + +Inductive fractionalAcc : Z -> Z -> Prop := + | fractionalacc0 : forall m n : Z, m = n -> fractionalAcc m n + | fractionalacc1 : + forall m n : Z, + (0 < m)%Z -> + (m < n)%Z -> fractionalAcc m (n - m)%Z -> fractionalAcc m n + | fractionalacc2 : + forall m n : Z, + (0 < n)%Z -> + (n < m)%Z -> fractionalAcc (m - n)%Z n -> fractionalAcc m n. + +Lemma fractionalacc_1 : + forall m n : Z, + fractionalAcc m n -> (0 < m)%Z -> (m < n)%Z -> fractionalAcc m (n - m). +Proof. + simple destruct 1; intros; trivial; Falsum; apply (Z.lt_irrefl n0); + [ rewrite H0 in H2 | apply Z.lt_trans with m0 ]; assumption. +Defined. + + +Lemma fractionalacc_2 : + forall m n : Z, + fractionalAcc m n -> (0 < n)%Z -> (n < m)%Z -> fractionalAcc (m - n) n. +Proof. + simple destruct 1; intros; trivial; Falsum; apply (Z.lt_irrefl n0); + [ rewrite H0 in H2 | apply Z.lt_trans with m0 ]; assumption. +Defined. + +Definition encoding_algorithm : + forall (x y : Z) (h1 : (0 < x)%Z) (h2 : (0 < y)%Z) (H : fractionalAcc x y), + Qpositive. +fix encoding_algorithm 5. +intros x y h1 h2 H. +refine + match Z_dec' x y with + | inleft H_x_neq_y => + match H_x_neq_y with + | left Hx_lt_y => + dL + (encoding_algorithm x (y - x)%Z h1 _ + (fractionalacc_1 x y H h1 Hx_lt_y)) + | right Hy_lt_x => + nR + (encoding_algorithm (x - y)%Z y _ h2 + (fractionalacc_2 x y H h2 Hy_lt_x)) + end + | inright _ => One + end; unfold Zminus in |- *; apply Zlt_left_lt; assumption. +Defined. diff --git a/test/serlib/genarg/functional_induction.v b/test/serlib/genarg/functional_induction.v new file mode 100644 index 00000000..3fb517e2 --- /dev/null +++ b/test/serlib/genarg/functional_induction.v @@ -0,0 +1,22 @@ +Set Implicit Arguments. + +Require Import Arith. +Require Import Recdef. + +Function ceil_log2_S (n: nat) {wf lt n}: nat := + match n with + | 0 => 0 + | S _ => S (ceil_log2_S (Nat.div2 n)) + end. +Proof. + intros. + apply Nat.lt_div2; auto with arith. + apply lt_wf. +Defined. + +Lemma ceil_log2_S_def n: ceil_log2_S n = + match n with + | 0 => 0 + | S _ => S (ceil_log2_S (Nat.div2 n)) + end. +Proof. functional induction (ceil_log2_S n); auto. Qed. diff --git a/test/serlib/genarg/functional_scheme.v b/test/serlib/genarg/functional_scheme.v new file mode 100644 index 00000000..7d0390e6 --- /dev/null +++ b/test/serlib/genarg/functional_scheme.v @@ -0,0 +1,28 @@ +Require Import FunInd. +Require Import ZArith. + +Inductive Qpositive : Set := + | nR : Qpositive -> Qpositive + | dL : Qpositive -> Qpositive + | One : Qpositive. + +Fixpoint Qpositive_c (p q n : nat) {struct n} : Qpositive := + match n with + | O => One + | S n' => + match p - q with + | O => match q - p with + | O => One + | v => dL (Qpositive_c p v n') + end + | v => nR (Qpositive_c v q n') + end + end. + +Functional Scheme Qpositive_c_ind := Induction for Qpositive_c Sort Prop. + +Lemma Qpositive_c_0 : forall p q n : nat, n = 0 -> Qpositive_c p q n = One. +Proof. + intros p q n. + functional induction (Qpositive_c p q n); trivial || (intros; discriminate). +Qed. diff --git a/test/serlib/genarg/hint_rewrite.v b/test/serlib/genarg/hint_rewrite.v new file mode 100644 index 00000000..1ebf2c52 --- /dev/null +++ b/test/serlib/genarg/hint_rewrite.v @@ -0,0 +1,24 @@ +Set Implicit Arguments. + +Section Definitions. +Variables (A : Type). +Implicit Types f g : A -> A -> A. +Implicit Types i : A -> A. + +Definition involutive i := forall x, + i (i x) = x. +End Definitions. + +Definition neg (x:bool) : bool := + match x with + | true => false + | false => true + end. + +Lemma neg_neg : involutive neg. +Proof. +intros x. +destruct x; auto. +Qed. + +#[global] Hint Rewrite neg_neg : rew_neg_neg. diff --git a/test/serlib/genarg/instantiate.v b/test/serlib/genarg/instantiate.v new file mode 100644 index 00000000..5e450746 --- /dev/null +++ b/test/serlib/genarg/instantiate.v @@ -0,0 +1,20 @@ +Set Implicit Arguments. + +Require Import List. + +Section Filter. + +Variable A : Type. + +Lemma In_filter_In : + forall (f : A -> bool) x l l', + filter f l = l' -> + In x l' -> In x l. +Proof. + intros. subst. + eapply filter_In. + instantiate (1 := f). + assumption. +Qed. + +End Filter. diff --git a/test/serlib/genarg/intropattern.v b/test/serlib/genarg/intropattern.v new file mode 100644 index 00000000..f6892c72 --- /dev/null +++ b/test/serlib/genarg/intropattern.v @@ -0,0 +1,79 @@ +Inductive Qpositive : Set := + | nR : Qpositive -> Qpositive + | dL : Qpositive -> Qpositive + | One : Qpositive. + +Fixpoint Qpositive_le_bool (w w' : Qpositive) {struct w'} : bool := + match w with + | One => match w' with + | dL y => false + | _ => true + end + | dL y => match w' with + | dL y' => Qpositive_le_bool y y' + | _ => true + end + | nR y => match w' with + | nR y' => Qpositive_le_bool y y' + | _ => false + end + end. + +Definition Qpositive_le (w w' : Qpositive) := Qpositive_le_bool w w' = true. + +Fixpoint Qpositive_i (w : Qpositive) : nat * nat := + match w with + | One => (1, 1) + | nR w' => match Qpositive_i w' with + | (p, q) => (p + q, q) + end + | dL w' => match Qpositive_i w' with + | (p, q) => (p, p + q) + end + end. + +Fixpoint Qpositive_c (p q n : nat) {struct n} : Qpositive := + match n with + | O => One + | S n' => + match p - q with + | O => match q - p with + | O => One + | v => dL (Qpositive_c p v n') + end + | v => nR (Qpositive_c v q n') + end + end. + +Definition Qpositive_sub (w w' : Qpositive) := + let (p, q) := Qpositive_i w in + let (p', q') := Qpositive_i w' in + Qpositive_c (p * q' - p' * q) (q * q') (p * q' + p' * q + q * q'). + +Theorem interp_non_zero : + forall w : Qpositive, + exists p : nat, (exists q : nat, Qpositive_i w = (S p, S q)). +simple induction w; simpl in |- *; + (repeat exists 0; auto; fail) || + (intros w' Hrec; elim Hrec; intros p' Hex; elim Hex; intros q' Heq; + rewrite Heq). +exists (p' + S q'); exists q'; auto. +exists p'; exists (p' + S q'); auto. +Qed. + +Ltac make_fraction w p q Heq := elim (interp_non_zero w); intros p (q, Heq). + +Theorem Qpositive_le_sub_l : + forall w w' w'' : Qpositive, + w <> w'' -> + w' <> w'' -> + Qpositive_le w w'' -> + Qpositive_le w' w'' -> + Qpositive_le w w' -> + Qpositive_le (Qpositive_sub w'' w') (Qpositive_sub w'' w). +Proof. +intros w w' w''; make_fraction w ipattern:(p) ipattern:(q) ipattern:(Heq); + make_fraction w' ipattern:(p') ipattern:(q') ipattern:(Heq'); + make_fraction w'' ipattern:(p'') ipattern:(q'') ipattern:(Heq''); + intros Hneq1 Hneq2. +Admitted. diff --git a/test/serlib/genarg/intros.v b/test/serlib/genarg/intros.v new file mode 100644 index 00000000..4ee9aafa --- /dev/null +++ b/test/serlib/genarg/intros.v @@ -0,0 +1,37 @@ +Require Import List. +Import ListNotations. + +Set Implicit Arguments. + +Section list_util. + Variables A B : Type. + Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}. + + Lemma In_cons_neq : + forall a x xs, + In(A:=A) a (x :: xs) -> + a <> x -> + In a xs. + Proof using. + simpl. + intuition congruence. + Qed. + + Lemma in_fold_left_by_cons_in : + forall (l : list B) (g : B -> A) x acc, + In x (fold_left (fun a b => g b :: a) l acc) -> + In x acc \/ exists y, In y l /\ x = g y. + Proof using A_eq_dec. + intros until l. + induction l. + - auto. + - simpl; intros. + destruct (A_eq_dec x (g a)); subst. + + right; exists a; tauto. + + apply IHl in H. + case H; [left|right]. + * apply In_cons_neq in H0; tauto. + * destruct H0; destruct H0. + exists x0; split; auto. + Qed. +End list_util. diff --git a/test/serlib/genarg/libTactics.v b/test/serlib/genarg/libTactics.v new file mode 100644 index 00000000..451a77ad --- /dev/null +++ b/test/serlib/genarg/libTactics.v @@ -0,0 +1,5285 @@ +(************************************************************************** +* Useful General-Purpose Tactics for Coq * +* Arthur Chargueraud * +* Distributed under the terms of the LGPL-v3 license * +***************************************************************************) + +(** This file contains a set of tactics that extends the set of builtin + tactics provided with the standard distribution of Coq. It intends + to overcome a number of limitations of the standard set of tactics, + and thereby to help user to write shorter and more robust scripts. + + Hopefully, Coq tactics will be improved as time goes by, and this + file should ultimately be useless. In the meanwhile, serious Coq + users will probably find it very useful. +*) + +(** The main features offered are: + - More convenient syntax for naming hypotheses, with tactics for + introduction and inversion that take as input only the name of + hypotheses of type [Prop], rather than the name of all variables. + - Tactics providing true support for manipulating N-ary conjunctions, + disjunctions and existentials, hidding the fact that the underlying + implementation is based on binary propositions. + - Convenient support for automation: tactic followed with the symbol + "~" or "*" will call automation on the generated subgoals. + The symbol "~" stands for [auto] and "*" for [intuition eauto]. + These bindings can be customized. + - Forward-chaining tactics are provided to instantiate lemmas + either with variable or hypotheses or a mix of both. + - A more powerful implementation of [apply] is provided (it is based + on [refine] and thus behaves better with respect to conversion). + - An improved inversion tactic which substitutes equalities on variables + generated by the standard inversion mecanism. Moreover, it supports + the elimination of dependently-typed equalities (requires axiom [K], + which is a weak form of Proof Irrelevance). + - Tactics for saving time when writing proofs, with tactics to + asserts hypotheses or sub-goals, and improved tactics for + clearing, renaming, and sorting hypotheses. *) + +(** External credits: + - thanks to Xavier Leroy for providing the idea of tactic [forward], + - thanks to Georges Gonthier for the implementation trick in [rapply], +*) + +Set Implicit Arguments. + +Require Import Coq.Lists.List. + + +(* ********************************************************************** *) +(** * Fixing Stdlib *) + +(* Very important to remove hint trans_eq_bool from LibBool, + otherwise eauto slows down dramatically: + Lemma test : forall b, b = false. + time eauto 7. (* takes over 4 seconds to fail! *) *) + +#[global] Remove Hints Bool.trans_eq_bool. + + +(* ********************************************************************** *) +(** * Tools for programming with Ltac *) + +(* ---------------------------------------------------------------------- *) +(** ** Identity continuation *) + +Ltac idcont tt := + idtac. + +(* ---------------------------------------------------------------------- *) +(** ** Untyped arguments for tactics *) + +(** Any Coq value can be boxed into the type [Boxer]. This is + useful to use Coq computations for implementing tactics. *) + +Inductive Boxer : Type := + | boxer : forall (A:Type), A -> Boxer. + + +(* ---------------------------------------------------------------------- *) +(** ** Optional arguments for tactics *) + +(** [ltac_no_arg] is a constant that can be used to simulate + optional arguments in tactic definitions. + Use [mytactic ltac_no_arg] on the tactic invokation, + and use [match arg with ltac_no_arg => ..] or + [match type of arg with ltac_No_arg => ..] to + test whether an argument was provided. *) + +Inductive ltac_No_arg : Set := + | ltac_no_arg : ltac_No_arg. + + +(* ---------------------------------------------------------------------- *) +(** ** Wildcard arguments for tactics *) + +(** [ltac_wild] is a constant that can be used to simulate + wildcard arguments in tactic definitions. Notation is [__]. *) + +Inductive ltac_Wild : Set := + | ltac_wild : ltac_Wild. + +Notation "'__'" := ltac_wild : ltac_scope. + +(** [ltac_wilds] is another constant that is typically used to + simulate a sequence of [N] wildcards, with [N] chosen + appropriately depending on the context. Notation is [___]. *) + +Inductive ltac_Wilds : Set := + | ltac_wilds : ltac_Wilds. + +Notation "'___'" := ltac_wilds : ltac_scope. + +Open Scope ltac_scope. + + +(* ---------------------------------------------------------------------- *) +(** ** Position markers *) + +(** [ltac_Mark] and [ltac_mark] are dummy definitions used as sentinel + by tactics, to mark a certain position in the context or in the goal. *) + +Inductive ltac_Mark : Type := + | ltac_mark : ltac_Mark. + +(** [gen_until_mark] repeats [generalize] on hypotheses from the + context, starting from the bottom and stopping as soon as reaching + an hypothesis of type [Mark]. If fails if [Mark] does not + appear in the context. *) + +Ltac gen_until_mark := + match goal with H: ?T |- _ => + match T with + | ltac_Mark => clear H + | _ => generalize H; clear H; gen_until_mark + end end. + +(** [gen_until_mark_with_processing F] is similar to [gen_until_mark] + except that it calls [F] on each hypothesis immediately before + generalizing it. This is useful for processing the hypotheses. *) + +Ltac gen_until_mark_with_processing cont := + match goal with H: ?T |- _ => + match T with + | ltac_Mark => clear H + | _ => cont H; generalize H; clear H; + gen_until_mark_with_processing cont + end end. + +(** [intro_until_mark] repeats [intro] until reaching an hypothesis of + type [Mark]. It throws away the hypothesis [Mark]. + It fails if [Mark] does not appear as an hypothesis in the + goal. *) + +Ltac intro_until_mark := + match goal with + | |- (ltac_Mark -> _) => intros _ + | _ => intro; intro_until_mark + end. + + +(* ---------------------------------------------------------------------- *) +(** ** List of arguments for tactics *) + +(** A datatype of type [list Boxer] is used to manipulate list of + Coq values in ltac. Notation is [>> v1 v2 ... vN] for building + a list containing the values [v1] through [vN]. *) + +Notation "'>>'" := + (@nil Boxer) + (at level 0) + : ltac_scope. +Notation "'>>' v1" := + ((boxer v1)::nil) + (at level 0, v1 at level 0) + : ltac_scope. +Notation "'>>' v1 v2" := + ((boxer v1)::(boxer v2)::nil) + (at level 0, v1 at level 0, v2 at level 0) + : ltac_scope. +Notation "'>>' v1 v2 v3" := + ((boxer v1)::(boxer v2)::(boxer v3)::nil) + (at level 0, v1 at level 0, v2 at level 0, v3 at level 0) + : ltac_scope. +Notation "'>>' v1 v2 v3 v4" := + ((boxer v1)::(boxer v2)::(boxer v3)::(boxer v4)::nil) + (at level 0, v1 at level 0, v2 at level 0, v3 at level 0, + v4 at level 0) + : ltac_scope. +Notation "'>>' v1 v2 v3 v4 v5" := + ((boxer v1)::(boxer v2)::(boxer v3)::(boxer v4)::(boxer v5)::nil) + (at level 0, v1 at level 0, v2 at level 0, v3 at level 0, + v4 at level 0, v5 at level 0) + : ltac_scope. +Notation "'>>' v1 v2 v3 v4 v5 v6" := + ((boxer v1)::(boxer v2)::(boxer v3)::(boxer v4)::(boxer v5) + ::(boxer v6)::nil) + (at level 0, v1 at level 0, v2 at level 0, v3 at level 0, + v4 at level 0, v5 at level 0, v6 at level 0) + : ltac_scope. +Notation "'>>' v1 v2 v3 v4 v5 v6 v7" := + ((boxer v1)::(boxer v2)::(boxer v3)::(boxer v4)::(boxer v5) + ::(boxer v6)::(boxer v7)::nil) + (at level 0, v1 at level 0, v2 at level 0, v3 at level 0, + v4 at level 0, v5 at level 0, v6 at level 0, v7 at level 0) + : ltac_scope. +Notation "'>>' v1 v2 v3 v4 v5 v6 v7 v8" := + ((boxer v1)::(boxer v2)::(boxer v3)::(boxer v4)::(boxer v5) + ::(boxer v6)::(boxer v7)::(boxer v8)::nil) + (at level 0, v1 at level 0, v2 at level 0, v3 at level 0, + v4 at level 0, v5 at level 0, v6 at level 0, v7 at level 0, + v8 at level 0) + : ltac_scope. +Notation "'>>' v1 v2 v3 v4 v5 v6 v7 v8 v9" := + ((boxer v1)::(boxer v2)::(boxer v3)::(boxer v4)::(boxer v5) + ::(boxer v6)::(boxer v7)::(boxer v8)::(boxer v9)::nil) + (at level 0, v1 at level 0, v2 at level 0, v3 at level 0, + v4 at level 0, v5 at level 0, v6 at level 0, v7 at level 0, + v8 at level 0, v9 at level 0) + : ltac_scope. +Notation "'>>' v1 v2 v3 v4 v5 v6 v7 v8 v9 v10" := + ((boxer v1)::(boxer v2)::(boxer v3)::(boxer v4)::(boxer v5) + ::(boxer v6)::(boxer v7)::(boxer v8)::(boxer v9)::(boxer v10)::nil) + (at level 0, v1 at level 0, v2 at level 0, v3 at level 0, + v4 at level 0, v5 at level 0, v6 at level 0, v7 at level 0, + v8 at level 0, v9 at level 0, v10 at level 0) + : ltac_scope. +Notation "'>>' v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11" := + ((boxer v1)::(boxer v2)::(boxer v3)::(boxer v4)::(boxer v5) + ::(boxer v6)::(boxer v7)::(boxer v8)::(boxer v9)::(boxer v10) + ::(boxer v11)::nil) + (at level 0, v1 at level 0, v2 at level 0, v3 at level 0, + v4 at level 0, v5 at level 0, v6 at level 0, v7 at level 0, + v8 at level 0, v9 at level 0, v10 at level 0, v11 at level 0) + : ltac_scope. +Notation "'>>' v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12" := + ((boxer v1)::(boxer v2)::(boxer v3)::(boxer v4)::(boxer v5) + ::(boxer v6)::(boxer v7)::(boxer v8)::(boxer v9)::(boxer v10) + ::(boxer v11)::(boxer v12)::nil) + (at level 0, v1 at level 0, v2 at level 0, v3 at level 0, + v4 at level 0, v5 at level 0, v6 at level 0, v7 at level 0, + v8 at level 0, v9 at level 0, v10 at level 0, v11 at level 0, + v12 at level 0) + : ltac_scope. +Notation "'>>' v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13" := + ((boxer v1)::(boxer v2)::(boxer v3)::(boxer v4)::(boxer v5) + ::(boxer v6)::(boxer v7)::(boxer v8)::(boxer v9)::(boxer v10) + ::(boxer v11)::(boxer v12)::(boxer v13)::nil) + (at level 0, v1 at level 0, v2 at level 0, v3 at level 0, + v4 at level 0, v5 at level 0, v6 at level 0, v7 at level 0, + v8 at level 0, v9 at level 0, v10 at level 0, v11 at level 0, + v12 at level 0, v13 at level 0) + : ltac_scope. + + +(** The tactic [list_boxer_of] inputs a term [E] and returns a term + of type "list boxer", according to the following rules: + - if [E] is already of type "list Boxer", then it returns [E]; + - otherwise, it returns the list [(boxer E)::nil]. *) + +Ltac list_boxer_of E := + match type of E with + | List.list Boxer => constr:(E) + | _ => constr:((boxer E)::nil) + end. + + +(* ---------------------------------------------------------------------- *) +(** ** Databases of lemmas *) + +(** Use the hint facility to implement a database mapping + terms to terms. To declare a new database, use a definition: + [Definition mydatabase := True.] + + Then, to map [mykey] to [myvalue], write the hint: + [Hint Extern 1 (Register mydatabase mykey) => Provide myvalue.] + + Finally, to query the value associated with a key, run the + tactic [ltac_database_get mydatabase mykey]. This will leave + at the head of the goal the term [myvalue]. It can then be + named and exploited using [intro]. *) + +Inductive Ltac_database_token : Prop := ltac_database_token. + +Definition ltac_database (D:Boxer) (T:Boxer) (A:Boxer) := Ltac_database_token. + +Notation "'Register' D T" := (ltac_database (boxer D) (boxer T) _) + (at level 69, D at level 0, T at level 0). + +Lemma ltac_database_provide : forall (A:Boxer) (D:Boxer) (T:Boxer), + ltac_database D T A. +Proof using. split. Qed. + +Ltac Provide T := apply (@ltac_database_provide (boxer T)). + +Ltac ltac_database_get D T := + let A := fresh "TEMP" in evar (A:Boxer); + let H := fresh "TEMP" in + assert (H : ltac_database (boxer D) (boxer T) A); + [ subst A; auto + | subst A; match type of H with ltac_database _ _ (boxer ?L) => + generalize L end; clear H ]. + +(* Note for a possible alternative implementation of the ltac_database_token: + Inductive Ltac_database : Type := + | ltac_database : forall A, A -> Ltac_database. + Implicit Arguments ltac_database [A]. +*) + +(* ---------------------------------------------------------------------- *) +(** ** On-the-fly removal of hypotheses *) + +(** In a list of arguments [>> H1 H2 .. HN] passed to a tactic + such as [lets] or [applys] or [forwards] or [specializes], + the term [rm], an identity function, can be placed in front + of the name of an hypothesis to be deleted. *) + +Definition rm (A:Type) (X:A) := X. + +(** [rm_term E] removes one hypothesis that admits the same + type as [E]. *) + +Ltac rm_term E := + let T := type of E in + match goal with H: T |- _ => try clear H end. + +(** [rm_inside E] calls [rm_term Ei] for any subterm + of the form [rm Ei] found in E *) + +Ltac rm_inside E := + let go E := rm_inside E in + match E with + | rm ?X => rm_term X + | ?X1 ?X2 => + go X1; go X2 + | ?X1 ?X2 ?X3 => + go X1; go X2; go X3 + | ?X1 ?X2 ?X3 ?X4 => + go X1; go X2; go X3; go X4 + | ?X1 ?X2 ?X3 ?X4 ?X5 => + go X1; go X2; go X3; go X4; go X5 + | ?X1 ?X2 ?X3 ?X4 ?X5 ?X6 => + go X1; go X2; go X3; go X4; go X5; go X6 + | ?X1 ?X2 ?X3 ?X4 ?X5 ?X6 ?X7 => + go X1; go X2; go X3; go X4; go X5; go X6; go X7 + | ?X1 ?X2 ?X3 ?X4 ?X5 ?X6 ?X7 ?X8 => + go X1; go X2; go X3; go X4; go X5; go X6; go X7; go X8 + | ?X1 ?X2 ?X3 ?X4 ?X5 ?X6 ?X7 ?X8 ?X9 => + go X1; go X2; go X3; go X4; go X5; go X6; go X7; go X8; go X9 + | ?X1 ?X2 ?X3 ?X4 ?X5 ?X6 ?X7 ?X8 ?X9 ?X10 => + go X1; go X2; go X3; go X4; go X5; go X6; go X7; go X8; go X9; go X10 + | _ => idtac + end. + +(** For faster performance, one may deactivate [rm_inside] by + replacing the body of this definition with [idtac]. *) + +Ltac fast_rm_inside E := + rm_inside E. + + +(* ---------------------------------------------------------------------- *) +(** ** Numbers as arguments *) + +(** When tactic takes a natural number as argument, it may be + parsed either as a natural number or as a relative number. + In order for tactics to convert their arguments into natural numbers, + we provide a conversion tactic. + + Note: the tactic [number_to_nat] is extended in [LibInt] to + take into account the [int] type, alias for [Z]. *) + +Require Coq.Numbers.BinNums Coq.ZArith.BinInt. + +Definition ltac_int_to_nat (x:BinInt.Z) : nat := + match x with + | BinInt.Z0 => 0%nat + | BinInt.Zpos p => BinPos.nat_of_P p + | BinInt.Zneg p => 0%nat + end. + +Ltac number_to_nat N := + match type of N with + | nat => constr:(N) + | BinInt.Z => let N' := constr:(ltac_int_to_nat N) in eval compute in N' + end. + +(** [ltac_pattern E at K] is the same as [pattern E at K] except that + [K] is a Coq number (nat or Z) rather than a Ltac integer. Syntax + [ltac_pattern E as K in H] is also available. *) + +Tactic Notation "ltac_pattern" constr(E) "at" constr(K) := + match number_to_nat K with + | 1 => pattern E at 1 + | 2 => pattern E at 2 + | 3 => pattern E at 3 + | 4 => pattern E at 4 + | 5 => pattern E at 5 + | 6 => pattern E at 6 + | 7 => pattern E at 7 + | 8 => pattern E at 8 + | _ => fail "ltac_pattern: arity not supported" + end. + +Tactic Notation "ltac_pattern" constr(E) "at" constr(K) "in" hyp(H) := + match number_to_nat K with + | 1 => pattern E at 1 in H + | 2 => pattern E at 2 in H + | 3 => pattern E at 3 in H + | 4 => pattern E at 4 in H + | 5 => pattern E at 5 in H + | 6 => pattern E at 6 in H + | 7 => pattern E at 7 in H + | 8 => pattern E at 8 in H + | _ => fail "ltac_pattern: arity not supported" + end. + +(** [ltac_set (x := E) at K] is the same as [set (x := E) at K] except + that [K] is a Coq number (nat or Z) rather than a Ltac integer. *) + +Tactic Notation "ltac_set" "(" ident(X) ":=" constr(E) ")" "at" constr(K) := + match number_to_nat K with + | 1%nat => set (X := E) at 1 + | 2%nat => set (X := E) at 2 + | 3%nat => set (X := E) at 3 + | 4%nat => set (X := E) at 4 + | 5%nat => set (X := E) at 5 + | 6%nat => set (X := E) at 6 + | 7%nat => set (X := E) at 7 + | 8%nat => set (X := E) at 8 + | 9%nat => set (X := E) at 9 + | 10%nat => set (X := E) at 10 + | 11%nat => set (X := E) at 11 + | 12%nat => set (X := E) at 12 + | 13%nat => set (X := E) at 13 + | _ => fail "ltac_set: arity not supported" + end. + + +(* ---------------------------------------------------------------------- *) +(** ** Testing tactics *) + +(** [show tac] executes a tactic [tac] that produces a result, + and then display its result. *) + +Tactic Notation "show" tactic(tac) := + let R := tac in pose R. + +(** [dup N] produces [N] copies of the current goal. It is useful + for building examples on which to illustrate behaviour of tactics. + [dup] is short for [dup 2]. *) + +Lemma dup_lemma : forall P, P -> P -> P. +Proof using. auto. Qed. + +Ltac dup_tactic N := + match number_to_nat N with + | 0 => idtac + | S 0 => idtac + | S ?N' => apply dup_lemma; [ | dup_tactic N' ] + end. + +Tactic Notation "dup" constr(N) := + dup_tactic N. +Tactic Notation "dup" := + dup 2. + + +(* ---------------------------------------------------------------------- *) +(** ** Testing evars and non-evars *) + +(** [is_not_evar E] succeeds only if [E] is not an evar; + it fails otherwise. It thus implements the negation of [is_evar] *) + +Ltac is_not_evar E := + first [ is_evar E; fail 1 + | idtac ]. + +(** [is_evar_as_bool E] evaluates to [true] if [E] is an evar + and to [false] otherwise. *) + +Ltac is_evar_as_bool E := + constr:(ltac:(first + [ is_evar E; exact true + | exact false ])). + + +(* ---------------------------------------------------------------------- *) +(** ** Check no evar in goal *) + +Ltac check_noevar M := + first [ has_evar M; fail 2 | idtac ]. + +Ltac check_noevar_hyp H := + let T := type of H in check_noevar T. + +Ltac check_noevar_goal := + match goal with |- ?G => check_noevar G end. + + +(* ---------------------------------------------------------------------- *) +(** ** Helper function for introducing evars *) + +(** [with_evar T (fun M => tac)] creates a new evar that can + be used in the tactic [tac] under the name [M]. *) + +Ltac with_evar_base T cont := + let x := fresh "TEMP" in evar (x:T); cont x; subst x. + +Tactic Notation "with_evar" constr(T) tactic(cont) := + with_evar_base T cont. + + +(* ---------------------------------------------------------------------- *) +(** ** Tagging of hypotheses *) + +(** [get_last_hyp tt] is a function that returns the last hypothesis + at the bottom of the context. It is useful to obtain the default + name associated with the hypothesis, e.g. + [intro; let H := get_last_hyp tt in let H' := fresh "P" H in ...] *) + +Ltac get_last_hyp tt := + match goal with H: _ |- _ => constr:(H) end. + + +(* ---------------------------------------------------------------------- *) +(** ** Tagging of hypotheses *) + +(** [ltac_tag_subst] is a specific marker for hypotheses + which is used to tag hypotheses that are equalities to + be substituted. *) + +Definition ltac_tag_subst (A:Type) (x:A) := x. + +(** [ltac_to_generalize] is a specific marker for hypotheses + to be generalized. *) + +Definition ltac_to_generalize (A:Type) (x:A) := x. + +Ltac gen_to_generalize := + repeat match goal with + H: ltac_to_generalize _ |- _ => generalize H; clear H end. + +Ltac mark_to_generalize H := + let T := type of H in + change T with (ltac_to_generalize T) in H. + + +(* ---------------------------------------------------------------------- *) +(** ** Deconstructing terms *) + +(** [get_head E] is a tactic that returns the head constant of the + term [E], ie, when applied to a term of the form [P x1 ... xN] + it returns [P]. If [E] is not an application, it returns [E]. + Warning: the tactic seems to loop in some cases when the goal is + a product and one uses the result of this function. *) + +Ltac get_head E := + match E with + | ?P _ _ _ _ _ _ _ _ _ _ _ _ => constr:(P) + | ?P _ _ _ _ _ _ _ _ _ _ _ => constr:(P) + | ?P _ _ _ _ _ _ _ _ _ _ => constr:(P) + | ?P _ _ _ _ _ _ _ _ _ => constr:(P) + | ?P _ _ _ _ _ _ _ _ => constr:(P) + | ?P _ _ _ _ _ _ _ => constr:(P) + | ?P _ _ _ _ _ _ => constr:(P) + | ?P _ _ _ _ _ => constr:(P) + | ?P _ _ _ _ => constr:(P) + | ?P _ _ _ => constr:(P) + | ?P _ _ => constr:(P) + | ?P _ => constr:(P) + | ?P => constr:(P) + end. + +(** [get_fun_arg E] is a tactic that decomposes an application + term [E], ie, when applied to a term of the form [X1 ... XN] + it returns a pair made of [X1 .. X(N-1)] and [XN]. *) + +Ltac get_fun_arg E := + match E with + | ?X1 ?X2 ?X3 ?X4 ?X5 ?X6 ?X7 ?X => constr:((X1 X2 X3 X4 X5 X6 X7,X)) + | ?X1 ?X2 ?X3 ?X4 ?X5 ?X6 ?X => constr:((X1 X2 X3 X4 X5 X6,X)) + | ?X1 ?X2 ?X3 ?X4 ?X5 ?X => constr:((X1 X2 X3 X4 X5,X)) + | ?X1 ?X2 ?X3 ?X4 ?X => constr:((X1 X2 X3 X4,X)) + | ?X1 ?X2 ?X3 ?X => constr:((X1 X2 X3,X)) + | ?X1 ?X2 ?X => constr:((X1 X2,X)) + | ?X1 ?X => constr:((X1,X)) + end. + + +(* ---------------------------------------------------------------------- *) +(** ** Action at occurence and action not at occurence *) + +(** [ltac_action_at K of E do Tac] isolates the [K]-th occurence of [E] in the + goal, setting it in the form [P E] for some named pattern [P], + then calls tactic [Tac], and finally unfolds [P]. Syntax + [ltac_action_at K of E in H do Tac] is also available. *) + +Tactic Notation "ltac_action_at" constr(K) "of" constr(E) "do" tactic(Tac) := + let p := fresh "TEMP" in ltac_pattern E at K; + match goal with |- ?P _ => set (p:=P) end; + Tac; unfold p; clear p. + +Tactic Notation "ltac_action_at" constr(K) "of" constr(E) "in" hyp(H) "do" tactic(Tac) := + let p := fresh "TEMP" in ltac_pattern E at K in H; + match type of H with ?P _ => set (p:=P) in H end; + Tac; unfold p in H; clear p. + +(** [protects E do Tac] temporarily assigns a name to the expression [E] + so that the execution of tactic [Tac] will not modify [E]. This is + useful for instance to restrict the action of [simpl]. *) + +Tactic Notation "protects" constr(E) "do" tactic(Tac) := + (* let x := fresh "TEMP" in sets_eq x: E; T; subst x. *) + let x := fresh "TEMP" in let H := fresh "TEMP" in + set (X := E) in *; assert (H : X = E) by reflexivity; + clearbody X; Tac; subst x. + +Tactic Notation "protects" constr(E) "do" tactic(Tac) "/" := + protects E do Tac. + +(* ---------------------------------------------------------------------- *) +(** ** An alias for [eq] *) + +(** [eq'] is an alias for [eq] to be used for equalities in + inductive definitions, so that they don't get mixed with + equalities generated by [inversion]. *) + +Definition eq' := @eq. + +#[global] Hint Unfold eq'. + +Notation "x '='' y" := (@eq' _ x y) + (at level 70, y at next level). + + +(* ********************************************************************** *) +(** * Common tactics for simplifying goals like [intuition] *) + +Ltac jauto_set_hyps := + repeat match goal with H: ?T |- _ => + match T with + | _ /\ _ => destruct H + | exists a, _ => destruct H + | _ => generalize H; clear H + end + end. + +Ltac jauto_set_goal := + repeat match goal with + | |- exists a, _ => esplit + | |- _ /\ _ => split + end. + +Ltac jauto_set := + intros; jauto_set_hyps; + intros; jauto_set_goal; + unfold not in *. + + + +(* ********************************************************************** *) +(** * Backward and forward chaining *) + +(* ---------------------------------------------------------------------- *) +(** ** Application *) + +Ltac old_refine f := + refine f. (* ; shelve_unifiable. *) + +(** [rapply] is a tactic similar to [eapply] except that it is + based on the [refine] tactics, and thus is strictly more + powerful (at least in theory :). In short, it is able to perform + on-the-fly conversions when required for arguments to match, + and it is able to instantiate existentials when required. *) + +Tactic Notation "rapply" constr(t) := + first (* --TODO: the @ are not useful *) + [ eexact (@t) + | old_refine (@t) + | old_refine (@t _) + | old_refine (@t _ _) + | old_refine (@t _ _ _) + | old_refine (@t _ _ _ _) + | old_refine (@t _ _ _ _ _) + | old_refine (@t _ _ _ _ _ _) + | old_refine (@t _ _ _ _ _ _ _) + | old_refine (@t _ _ _ _ _ _ _ _) + | old_refine (@t _ _ _ _ _ _ _ _ _) + | old_refine (@t _ _ _ _ _ _ _ _ _ _) + | old_refine (@t _ _ _ _ _ _ _ _ _ _ _) + | old_refine (@t _ _ _ _ _ _ _ _ _ _ _ _) + | old_refine (@t _ _ _ _ _ _ _ _ _ _ _ _ _) + | old_refine (@t _ _ _ _ _ _ _ _ _ _ _ _ _ _) + | old_refine (@t _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) + ]. + +(** The tactics [applys_N T], where [N] is a natural number, + provides a more efficient way of using [applys T]. It avoids + trying out all possible arities, by specifying explicitely + the arity of function [T]. *) + +Tactic Notation "rapply_0" constr(t) := + old_refine (@t). +Tactic Notation "rapply_1" constr(t) := + old_refine (@t _). +Tactic Notation "rapply_2" constr(t) := + old_refine (@t _ _). +Tactic Notation "rapply_3" constr(t) := + old_refine (@t _ _ _). +Tactic Notation "rapply_4" constr(t) := + old_refine (@t _ _ _ _). +Tactic Notation "rapply_5" constr(t) := + old_refine (@t _ _ _ _ _). +Tactic Notation "rapply_6" constr(t) := + old_refine (@t _ _ _ _ _ _). +Tactic Notation "rapply_7" constr(t) := + old_refine (@t _ _ _ _ _ _ _). +Tactic Notation "rapply_8" constr(t) := + old_refine (@t _ _ _ _ _ _ _ _). +Tactic Notation "rapply_9" constr(t) := + old_refine (@t _ _ _ _ _ _ _ _ _). +Tactic Notation "rapply_10" constr(t) := + old_refine (@t _ _ _ _ _ _ _ _ _ _). + +(** [lets_base H E] adds an hypothesis [H : T] to the context, where [T] is + the type of term [E]. If [H] is an introduction pattern, it will + destruct [H] according to the pattern. *) + +Ltac lets_base I E := generalize E; intros I. + +(** [applys_to H E] transform the type of hypothesis [H] by + replacing it by the result of the application of the term + [E] to [H]. Intuitively, it is equivalent to [lets H: (E H)]. *) + +Tactic Notation "applys_to" hyp(H) constr(E) := + let H' := fresh "TEMP" in rename H into H'; + (first [ lets_base H (E H') + | lets_base H (E _ H') + | lets_base H (E _ _ H') + | lets_base H (E _ _ _ H') + | lets_base H (E _ _ _ _ H') + | lets_base H (E _ _ _ _ _ H') + | lets_base H (E _ _ _ _ _ _ H') + | lets_base H (E _ _ _ _ _ _ _ H') + | lets_base H (E _ _ _ _ _ _ _ _ H') + | lets_base H (E _ _ _ _ _ _ _ _ _ H') ] + ); clear H'. + +(** [applys_to H1,...,HN E] applys [E] to several hypotheses *) + +Tactic Notation "applys_to" hyp(H1) "," hyp(H2) constr(E) := + applys_to H1 E; applys_to H2 E. +Tactic Notation "applys_to" hyp(H1) "," hyp(H2) "," hyp(H3) constr(E) := + applys_to H1 E; applys_to H2 E; applys_to H3 E. +Tactic Notation "applys_to" hyp(H1) "," hyp(H2) "," hyp(H3) "," hyp(H4) constr(E) := + applys_to H1 E; applys_to H2 E; applys_to H3 E; applys_to H4 E. + +(** [constructors] calls [constructor] or [econstructor]. *) + +Tactic Notation "constructors" := + first [ constructor | econstructor ]; unfold eq'. + +(* ---------------------------------------------------------------------- *) +(** ** Assertions *) + +(** [asserts H: T] is another syntax for [assert (H : T)], which + also works with introduction patterns. For instance, one can write: + [asserts \[x P\] (exists n, n = 3)], or + [asserts \[H|H\] (n = 0 \/ n = 1). *) + +Tactic Notation "asserts" simple_intropattern(I) ":" constr(T) := + let H := fresh "TEMP" in assert (H : T); + [ | generalize H; clear H; intros I ]. + +(** [asserts H1 .. HN: T] is a shorthand for + [asserts \[H1 \[H2 \[.. HN\]\]\]\]: T]. *) + +Tactic Notation "asserts" simple_intropattern(I1) + simple_intropattern(I2) ":" constr(T) := + asserts [I1 I2]: T. +Tactic Notation "asserts" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) ":" constr(T) := + asserts [I1 [I2 I3]]: T. +Tactic Notation "asserts" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) + simple_intropattern(I4) ":" constr(T) := + asserts [I1 [I2 [I3 I4]]]: T. +Tactic Notation "asserts" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) + simple_intropattern(I4) simple_intropattern(I5) ":" constr(T) := + asserts [I1 [I2 [I3 [I4 I5]]]]: T. +Tactic Notation "asserts" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) + simple_intropattern(I4) simple_intropattern(I5) + simple_intropattern(I6) ":" constr(T) := + asserts [I1 [I2 [I3 [I4 [I5 I6]]]]]: T. + +(** [asserts: T] is [asserts H: T] with [H] being chosen automatically. *) + +Tactic Notation "asserts" ":" constr(T) := + let H := fresh "TEMP" in asserts H : T. + +(** [cuts H: T] is the same as [asserts H: T] except that the two subgoals + generated are swapped: the subgoal [T] comes second. Note that contrary + to [cut], it introduces the hypothesis. *) + +Tactic Notation "cuts" simple_intropattern(I) ":" constr(T) := + cut (T); [ intros I | idtac ]. + +(** [cuts: T] is [cuts H: T] with [H] being chosen automatically. *) + +Tactic Notation "cuts" ":" constr(T) := + let H := fresh "TEMP" in cuts H: T. + +(** [cuts H1 .. HN: T] is a shorthand for + [cuts \[H1 \[H2 \[.. HN\]\]\]\]: T]. *) + +Tactic Notation "cuts" simple_intropattern(I1) + simple_intropattern(I2) ":" constr(T) := + cuts [I1 I2]: T. +Tactic Notation "cuts" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) ":" constr(T) := + cuts [I1 [I2 I3]]: T. +Tactic Notation "cuts" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) + simple_intropattern(I4) ":" constr(T) := + cuts [I1 [I2 [I3 I4]]]: T. +Tactic Notation "cuts" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) + simple_intropattern(I4) simple_intropattern(I5) ":" constr(T) := + cuts [I1 [I2 [I3 [I4 I5]]]]: T. +Tactic Notation "cuts" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) + simple_intropattern(I4) simple_intropattern(I5) + simple_intropattern(I6) ":" constr(T) := + cuts [I1 [I2 [I3 [I4 [I5 I6]]]]]: T. + + +(* ---------------------------------------------------------------------- *) +(** ** Instantiation and forward-chaining *) + +(** The instantiation tactics are used to instantiate a lemma [E] + (whose type is a product) on some arguments. The type of [E] is + made of implications and universal quantifications, e.g. + [forall x, P x -> forall y z, Q x y z -> R z]. + + The first possibility is to provide arguments in order: first [x], + then a proof of [P x], then [y] etc... In this mode, called "Args", + all the arguments are to be provided. If a wildcard is provided + (written [__]), then an existential variable will be introduced in + place of the argument. + + It is very convenient to give some arguments the lemma should be + instantiated on, and let the tactic find out automatically where + underscores should be insterted. Underscore arguments [__] are + interpret as follows: an underscore means that we want to skip the + argument that has the same type as the next real argument provided + (real means not an underscore). If there is no real argument after + underscore, then the underscore is used for the first possible argument. + + The general syntax is [tactic (>> E1 .. EN)] where [tactic] is + the name of the tactic (possibly with some arguments) and [Ei] + are the arguments. Moreover, some tactics accept the syntax + [tactic E1 .. EN] as short for [tactic (>> E1 .. EN)] for + values of [N] up to 5. + + Finally, if the argument [EN] given is a triple-underscore [___], + then it is equivalent to providing a list of wildcards, with + the appropriate number of wildcards. This means that all + the remaining arguments of the lemma will be instantiated. + Definitions in the conclusion are not unfolded in this case. *) + +(* Underlying implementation *) + +Ltac app_assert t P cont := + let H := fresh "TEMP" in + assert (H : P); [ | cont(t H); clear H ]. + +Ltac app_evar t A cont := + let x := fresh "TEMP" in + evar (x:A); + let t' := constr:(t x) in + let t'' := (eval unfold x in t') in + subst x; cont t''. + +Ltac app_arg t P v cont := + let H := fresh "TEMP" in + assert (H : P); [ apply v | cont(t H); try clear H ]. + +Ltac build_app_alls t final := + let rec go t := + match type of t with + | ?P -> ?Q => app_assert t P go + | forall _:?A, _ => app_evar t A go + | _ => final t + end in + go t. + +Ltac boxerlist_next_type vs := + match vs with + | nil => constr:(ltac_wild) + | (boxer ltac_wild)::?vs' => boxerlist_next_type vs' + | (boxer ltac_wilds)::_ => constr:(ltac_wild) + | (@boxer ?T _)::_ => constr:(T) + end. + +(* Note: refuse to instantiate a dependent hypothesis with a proposition; + refuse to instantiate an argument of type Type with one that + does not have the type Type. +*) + +Ltac build_app_hnts t vs final := + let rec go t vs := + match vs with + | nil => first [ final t | fail 1 ] + | (boxer ltac_wilds)::_ => first [ build_app_alls t final | fail 1 ] + | (boxer ?v)::?vs' => + let cont t' := go t' vs in + let cont' t' := go t' vs' in + let T := type of t in + let T := eval hnf in T in + match v with + | ltac_wild => + first [ let U := boxerlist_next_type vs' in + match U with + | ltac_wild => + match T with + | ?P -> ?Q => first [ app_assert t P cont' | fail 3 ] + | forall _:?A, _ => first [ app_evar t A cont' | fail 3 ] + end + | _ => + match T with (* should test T for unifiability *) + | U -> ?Q => first [ app_assert t U cont' | fail 3 ] + | forall _:U, _ => first [ app_evar t U cont' | fail 3 ] + | ?P -> ?Q => first [ app_assert t P cont | fail 3 ] + | forall _:?A, _ => first [ app_evar t A cont | fail 3 ] + end + end + | fail 2 ] + | _ => + match T with + | ?P -> ?Q => first [ app_arg t P v cont' + | app_assert t P cont + | fail 3 ] + | forall _:Type, _ => + match type of v with + | Type => first [ cont' (t v) + | app_evar t Type cont + | fail 3 ] + | _ => first [ app_evar t Type cont + | fail 3 ] + end + | forall _:?A, _ => + let V := type of v in + match type of V with + | Prop => first [ app_evar t A cont + | fail 3 ] + | _ => first [ cont' (t v) + | app_evar t A cont + | fail 3 ] + end + end + end + end in + go t vs. + + +(** newer version : support for typeclasses *) + +Ltac app_typeclass t cont := + let t' := constr:(t _) in + cont t'. + +Ltac build_app_alls t final ::= + let rec go t := + match type of t with + | ?P -> ?Q => app_assert t P go + | forall _:?A, _ => + first [ app_evar t A go + | app_typeclass t go + | fail 3 ] + | _ => final t + end in + go t. + +Ltac build_app_hnts t vs final ::= + let rec go t vs := + match vs with + | nil => first [ final t | fail 1 ] + | (boxer ltac_wilds)::_ => first [ build_app_alls t final | fail 1 ] + | (boxer ?v)::?vs' => + let cont t' := go t' vs in + let cont' t' := go t' vs' in + let T := type of t in + let T := eval hnf in T in + match v with + | ltac_wild => + first [ let U := boxerlist_next_type vs' in + match U with + | ltac_wild => + match T with + | ?P -> ?Q => first [ app_assert t P cont' | fail 3 ] + | forall _:?A, _ => first [ app_typeclass t cont' + | app_evar t A cont' + | fail 3 ] + end + | _ => + match T with (* should test T for unifiability *) + | U -> ?Q => first [ app_assert t U cont' | fail 3 ] + | forall _:U, _ => first + [ app_typeclass t cont' + | app_evar t U cont' + | fail 3 ] + | ?P -> ?Q => first [ app_assert t P cont | fail 3 ] + | forall _:?A, _ => first + [ app_typeclass t cont + | app_evar t A cont + | fail 3 ] + end + end + | fail 2 ] + | _ => + match T with + | ?P -> ?Q => first [ app_arg t P v cont' + | app_assert t P cont + | fail 3 ] + | forall _:Type, _ => + match type of v with + | Type => first [ cont' (t v) + | app_evar t Type cont + | fail 3 ] + | _ => first [ app_evar t Type cont + | fail 3 ] + end + | forall _:?A, _ => + let V := type of v in + match type of V with + | Prop => first [ app_typeclass t cont + | app_evar t A cont + | fail 3 ] + | _ => first [ cont' (t v) + | app_typeclass t cont + | app_evar t A cont + | fail 3 ] + end + end + end + end in + go t vs. + (* --TODO: use local function for first [...] *) + + +(*--old version +Ltac build_app_hnts t vs final := + let rec go t vs := + match vs with + | nil => first [ final t | fail 1 ] + | (boxer ltac_wilds)::_ => first [ build_app_alls t final | fail 1 ] + | (boxer ?v)::?vs' => + let cont t' := go t' vs in + let cont' t' := go t' vs' in + let T := type of t in + let T := eval hnf in T in + match v with + | ltac_wild => + first [ let U := boxerlist_next_type vs' in + match U with + | ltac_wild => + match T with + | ?P -> ?Q => first [ app_assert t P cont' | fail 3 ] + | forall _:?A, _ => first [ app_evar t A cont' | fail 3 ] + end + | _ => + match T with (* should test T for unifiability *) + | U -> ?Q => first [ app_assert t U cont' | fail 3 ] + | forall _:U, _ => first [ app_evar t U cont' | fail 3 ] + | ?P -> ?Q => first [ app_assert t P cont | fail 3 ] + | forall _:?A, _ => first [ app_evar t A cont | fail 3 ] + end + end + | fail 2 ] + | _ => + match T with + | ?P -> ?Q => first [ app_arg t P v cont' + | app_assert t P cont + | fail 3 ] + | forall _:?A, _ => first [ cont' (t v) + | app_evar t A cont + | fail 3 ] + end + end + end in + go t vs. +*) + + +Ltac build_app args final := + first [ + match args with (@boxer ?T ?t)::?vs => + let t := constr:(t:T) in + build_app_hnts t vs final; + fast_rm_inside args + end + | fail 1 "Instantiation fails for:" args]. + +Ltac unfold_head_until_product T := + eval hnf in T. + +Ltac args_unfold_head_if_not_product args := + match args with (@boxer ?T ?t)::?vs => + let T' := unfold_head_until_product T in + constr:((@boxer T' t)::vs) + end. + +Ltac args_unfold_head_if_not_product_but_params args := + match args with + | (boxer ?t)::(boxer ?v)::?vs => + args_unfold_head_if_not_product args + | _ => constr:(args) + end. + +(** [lets H: (>> E0 E1 .. EN)] will instantiate lemma [E0] + on the arguments [Ei] (which may be wildcards [__]), + and name [H] the resulting term. [H] may be an introduction + pattern, or a sequence of introduction patterns [I1 I2 IN], + or empty. + Syntax [lets H: E0 E1 .. EN] is also available. If the last + argument [EN] is [___] (triple-underscore), then all + arguments of [H] will be instantiated. *) + +Ltac lets_build I Ei := + let args := list_boxer_of Ei in + let args := args_unfold_head_if_not_product_but_params args in +(* let Ei''' := args_unfold_head_if_not_product Ei'' in*) + build_app args ltac:(fun R => lets_base I R). + +Tactic Notation "lets" simple_intropattern(I) ":" constr(E) := + lets_build I E. +Tactic Notation "lets" ":" constr(E) := + let H := fresh in lets H: E. +Tactic Notation "lets" ":" constr(E0) + constr(A1) := + lets: (>> E0 A1). +Tactic Notation "lets" ":" constr(E0) + constr(A1) constr(A2) := + lets: (>> E0 A1 A2). +Tactic Notation "lets" ":" constr(E0) + constr(A1) constr(A2) constr(A3) := + lets: (>> E0 A1 A2 A3). +Tactic Notation "lets" ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) := + lets: (>> E0 A1 A2 A3 A4). +Tactic Notation "lets" ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + lets: (>> E0 A1 A2 A3 A4 A5). + +(* --todo: deprecated, do not use *) +Tactic Notation "lets" simple_intropattern(I1) simple_intropattern(I2) + ":" constr(E) := + lets [I1 I2]: E. +Tactic Notation "lets" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) ":" constr(E) := + lets [I1 [I2 I3]]: E. +Tactic Notation "lets" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) ":" constr(E) := + lets [I1 [I2 [I3 I4]]]: E. +Tactic Notation "lets" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) + ":" constr(E) := + lets [I1 [I2 [I3 [I4 I5]]]]: E. + +Tactic Notation "lets" simple_intropattern(I) ":" constr(E0) + constr(A1) := + lets I: (>> E0 A1). +Tactic Notation "lets" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) := + lets I: (>> E0 A1 A2). +Tactic Notation "lets" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) constr(A3) := + lets I: (>> E0 A1 A2 A3). +Tactic Notation "lets" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) := + lets I: (>> E0 A1 A2 A3 A4). +Tactic Notation "lets" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + lets I: (>> E0 A1 A2 A3 A4 A5). + +Tactic Notation "lets" simple_intropattern(I1) simple_intropattern(I2) ":" constr(E0) + constr(A1) := + lets [I1 I2]: E0 A1. +Tactic Notation "lets" simple_intropattern(I1) simple_intropattern(I2) ":" constr(E0) + constr(A1) constr(A2) := + lets [I1 I2]: E0 A1 A2. +Tactic Notation "lets" simple_intropattern(I1) simple_intropattern(I2) ":" constr(E0) + constr(A1) constr(A2) constr(A3) := + lets [I1 I2]: E0 A1 A2 A3. +Tactic Notation "lets" simple_intropattern(I1) simple_intropattern(I2) ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) := + lets [I1 I2]: E0 A1 A2 A3 A4. +Tactic Notation "lets" simple_intropattern(I1) simple_intropattern(I2) ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + lets [I1 I2]: E0 A1 A2 A3 A4 A5. + + +(** [forwards H: (>> E0 E1 .. EN)] is short for + [forwards H: (>> E0 E1 .. EN ___)]. + The arguments [Ei] can be wildcards [__] (except [E0]). + [H] may be an introduction pattern, or a sequence of + introduction pattern, or empty. + Syntax [forwards H: E0 E1 .. EN] is also available. *) + +Ltac forwards_build_app_arg Ei := + let args := list_boxer_of Ei in + let args := (eval simpl in (args ++ ((boxer ___)::nil))) in + let args := args_unfold_head_if_not_product args in + args. + +Ltac forwards_then Ei cont := + let args := forwards_build_app_arg Ei in + let args := args_unfold_head_if_not_product_but_params args in + build_app args cont. + +Tactic Notation "forwards" simple_intropattern(I) ":" constr(Ei) := + let args := forwards_build_app_arg Ei in + lets I: args. + +Tactic Notation "forwards" ":" constr(E) := + let H := fresh in forwards H: E. +Tactic Notation "forwards" ":" constr(E0) + constr(A1) := + forwards: (>> E0 A1). +Tactic Notation "forwards" ":" constr(E0) + constr(A1) constr(A2) := + forwards: (>> E0 A1 A2). +Tactic Notation "forwards" ":" constr(E0) + constr(A1) constr(A2) constr(A3) := + forwards: (>> E0 A1 A2 A3). +Tactic Notation "forwards" ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) := + forwards: (>> E0 A1 A2 A3 A4). +Tactic Notation "forwards" ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + forwards: (>> E0 A1 A2 A3 A4 A5). + +(* --TODO: deprecated, do not use *) +Tactic Notation "forwards" simple_intropattern(I1) simple_intropattern(I2) + ":" constr(E) := + forwards [I1 I2]: E. +Tactic Notation "forwards" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) ":" constr(E) := + forwards [I1 [I2 I3]]: E. +Tactic Notation "forwards" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) ":" constr(E) := + forwards [I1 [I2 [I3 I4]]]: E. +Tactic Notation "forwards" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) + ":" constr(E) := + forwards [I1 [I2 [I3 [I4 I5]]]]: E. + +Tactic Notation "forwards" simple_intropattern(I) ":" constr(E0) + constr(A1) := + forwards I: (>> E0 A1). +Tactic Notation "forwards" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) := + forwards I: (>> E0 A1 A2). +Tactic Notation "forwards" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) constr(A3) := + forwards I: (>> E0 A1 A2 A3). +Tactic Notation "forwards" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) := + forwards I: (>> E0 A1 A2 A3 A4). +Tactic Notation "forwards" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + forwards I: (>> E0 A1 A2 A3 A4 A5). + +(** [forwards_nounfold I: E] is like [forwards I: E] but does not + unfold the head constant of [E] if there is no visible quantification + or hypothesis in [E]. It is meant to be used mainly by tactics. *) + +Tactic Notation "forwards_nounfold" simple_intropattern(I) ":" constr(Ei) := + let args := list_boxer_of Ei in + let args := (eval simpl in (args ++ ((boxer ___)::nil))) in + build_app args ltac:(fun R => lets_base I R). + +(** [forwards_nounfold_then E ltac:(fun K => ..)] + is like [forwards: E] but it provides the resulting term + to a continuation, under the name [K]. *) + +Ltac forwards_nounfold_then Ei cont := + let args := list_boxer_of Ei in + let args := (eval simpl in (args ++ ((boxer ___)::nil))) in + build_app args cont. + +(** [applys (>> E0 E1 .. EN)] instantiates lemma [E0] + on the arguments [Ei] (which may be wildcards [__]), + and apply the resulting term to the current goal, + using the tactic [applys] defined earlier on. + [applys E0 E1 E2 .. EN] is also available. *) + +Ltac applys_build Ei := + let args := list_boxer_of Ei in + let args := args_unfold_head_if_not_product_but_params args in + build_app args ltac:(fun R => + first [ apply R | eapply R | rapply R ]). + +Ltac applys_base E := + match type of E with + | list Boxer => applys_build E + | _ => first [ rapply E | applys_build E ] + end; fast_rm_inside E. + +Tactic Notation "applys" constr(E) := + applys_base E. +Tactic Notation "applys" constr(E0) constr(A1) := + applys (>> E0 A1). +Tactic Notation "applys" constr(E0) constr(A1) constr(A2) := + applys (>> E0 A1 A2). +Tactic Notation "applys" constr(E0) constr(A1) constr(A2) constr(A3) := + applys (>> E0 A1 A2 A3). +Tactic Notation "applys" constr(E0) constr(A1) constr(A2) constr(A3) constr(A4) := + applys (>> E0 A1 A2 A3 A4). +Tactic Notation "applys" constr(E0) constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + applys (>> E0 A1 A2 A3 A4 A5). + +(** [fapplys (>> E0 E1 .. EN)] instantiates lemma [E0] + on the arguments [Ei] and on the argument [___] meaning + that all evars should be explicitly instantiated, + and apply the resulting term to the current goal. + [fapplys E0 E1 E2 .. EN] is also available. *) + +Ltac fapplys_build Ei := + let args := list_boxer_of Ei in + let args := (eval simpl in (args ++ ((boxer ___)::nil))) in + let args := args_unfold_head_if_not_product_but_params args in + build_app args ltac:(fun R => apply R). + +Tactic Notation "fapplys" constr(E0) := (* --TODO: use the tactic for that*) + match type of E0 with + | list Boxer => fapplys_build E0 + | _ => fapplys_build (>> E0) + end. +Tactic Notation "fapplys" constr(E0) constr(A1) := + fapplys (>> E0 A1). +Tactic Notation "fapplys" constr(E0) constr(A1) constr(A2) := + fapplys (>> E0 A1 A2). +Tactic Notation "fapplys" constr(E0) constr(A1) constr(A2) constr(A3) := + fapplys (>> E0 A1 A2 A3). +Tactic Notation "fapplys" constr(E0) constr(A1) constr(A2) constr(A3) constr(A4) := + fapplys (>> E0 A1 A2 A3 A4). +Tactic Notation "fapplys" constr(E0) constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + fapplys (>> E0 A1 A2 A3 A4 A5). + +(** [specializes H (>> E1 E2 .. EN)] will instantiate hypothesis [H] + on the arguments [Ei] (which may be wildcards [__]). If the last + argument [EN] is [___] (triple-underscore), then all arguments of + [H] get instantiated. *) + +Ltac specializes_build H Ei := + let H' := fresh "TEMP" in rename H into H'; + let args := list_boxer_of Ei in + let args := constr:((boxer H')::args) in + let args := args_unfold_head_if_not_product args in + build_app args ltac:(fun R => lets H: R); + clear H'. + +Ltac specializes_base H Ei := + specializes_build H Ei; fast_rm_inside Ei. + +Tactic Notation "specializes" hyp(H) := + specializes_base H (___). +Tactic Notation "specializes" hyp(H) constr(A) := + specializes_base H A. +Tactic Notation "specializes" hyp(H) constr(A1) constr(A2) := + specializes H (>> A1 A2). +Tactic Notation "specializes" hyp(H) constr(A1) constr(A2) constr(A3) := + specializes H (>> A1 A2 A3). +Tactic Notation "specializes" hyp(H) constr(A1) constr(A2) constr(A3) constr(A4) := + specializes H (>> A1 A2 A3 A4). +Tactic Notation "specializes" hyp(H) constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + specializes H (>> A1 A2 A3 A4 A5). + +(** [specializes_vars H] is equivalent to [specializes H __ .. __] + with as many double underscore as the number of dependent arguments + visible from the type of [H]. Note that no unfolding is currently + being performed (this behavior might change in the future). + The current implementation is restricted to the case where + [H] is an existing hypothesis -- TODO: generalize. *) + +Ltac specializes_var_base H := + match type of H with + | ?P -> ?Q => fail 1 + | forall _:_, _ => specializes H __ + end. + +Ltac specializes_vars_base H := + repeat (specializes_var_base H). + +Tactic Notation "specializes_var" hyp(H) := + specializes_var_base H. + +Tactic Notation "specializes_vars" hyp(H) := + specializes_vars_base H. + +(* ---------------------------------------------------------------------- *) +(** ** Experimental tactics for application *) + +(** [fapply] is a version of [apply] based on [forwards]. *) + +Tactic Notation "fapply" constr(E) := + let H := fresh "TEMP" in forwards H: E; + first [ apply H | eapply H | rapply H | hnf; apply H + | hnf; eapply H | applys H ]. + (* --TODO: is applys redundant with rapply ? *) + +(** [sapply] stands for "super apply". It tries + [apply], [eapply], [applys] and [fapply], + and also tries to head-normalize the goal first. *) + +Tactic Notation "sapply" constr(H) := + first [ apply H | eapply H | rapply H | applys H + | hnf; apply H | hnf; eapply H | hnf; applys H + | fapply H ]. + +(* ---------------------------------------------------------------------- *) +(** ** Adding assumptions *) + +(** [lets_simpl H: E] is the same as [lets H: E] excepts that it + calls [simpl] on the hypothesis H. + [lets_simpl: E] is also provided. *) + +Tactic Notation "lets_simpl" ident(H) ":" constr(E) := + lets H: E; try simpl in H. + +Tactic Notation "lets_simpl" ":" constr(T) := + let H := fresh "TEMP" in lets_simpl H: T. + +(** [lets_hnf H: E] is the same as [lets H: E] excepts that it + calls [hnf] to set the definition in head normal form. + [lets_hnf: E] is also provided. *) + +Tactic Notation "lets_hnf" ident(H) ":" constr(E) := + lets H: E; hnf in H. + +Tactic Notation "lets_hnf" ":" constr(T) := + let H := fresh "TEMP" in lets_hnf H: T. + +(** [puts X: E] is a synonymous for [pose (X := E)]. + Alternative syntax is [puts: E]. *) + +Tactic Notation "puts" ident(X) ":" constr(E) := + pose (X := E). +Tactic Notation "puts" ":" constr(E) := + let X := fresh "X" in pose (X := E). + + +(* ---------------------------------------------------------------------- *) +(** ** Application of tautologies *) + +(** [logic E], where [E] is a fact, is equivalent to + [assert H:E; [tauto | eapply H; clear H]. It is useful for instance + to prove a conjunction [A /\ B] by showing first [A] and then [A -> B], + through the command [logic (foral A B, A -> (A -> B) -> A /\ B)] *) + +Ltac logic_base E cont := + assert (H:E); [ cont tt | eapply H; clear H ]. + +Tactic Notation "logic" constr(E) := + logic_base E ltac:(fun _ => tauto). + + +(* ---------------------------------------------------------------------- *) +(** ** Application modulo equalities *) + +(** The tactic [equates] replaces a goal of the form + [P x y z] with a goal of the form [P x ?a z] and a + subgoal [?a = y]. The introduction of the evar [?a] makes + it possible to apply lemmas that would not apply to the + original goal, for example a lemma of the form + [forall n m, P n n m], because [x] and [y] might be equal + but not convertible. + + Usage is [equates i1 ... ik], where the indices are the + positions of the arguments to be replaced by evars, + counting from the right-hand side. If [0] is given as + argument, then the entire goal is replaced by an evar. *) + +Section equatesLemma. +Variables (A0 A1 : Type). +Variables (A2 : forall (x1 : A1), Type). +Variables (A3 : forall (x1 : A1) (x2 : A2 x1), Type). +Variables (A4 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2), Type). +Variables (A5 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3), Type). +Variables (A6 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4), Type). + +Lemma equates_0 : forall (P Q:Prop), + P -> P = Q -> Q. +Proof using. intros. subst. auto. Qed. + +Lemma equates_1 : + forall (P:A0->Prop) x1 y1, + P y1 -> x1 = y1 -> P x1. +Proof using. intros. subst. auto. Qed. + +Lemma equates_2 : + forall y1 (P:A0->forall(x1:A1),Prop) x1 x2, + P y1 x2 -> x1 = y1 -> P x1 x2. +Proof using. intros. subst. auto. Qed. + +Lemma equates_3 : + forall y1 (P:A0->forall(x1:A1)(x2:A2 x1),Prop) x1 x2 x3, + P y1 x2 x3 -> x1 = y1 -> P x1 x2 x3. +Proof using. intros. subst. auto. Qed. + +Lemma equates_4 : + forall y1 (P:A0->forall(x1:A1)(x2:A2 x1)(x3:A3 x2),Prop) x1 x2 x3 x4, + P y1 x2 x3 x4 -> x1 = y1 -> P x1 x2 x3 x4. +Proof using. intros. subst. auto. Qed. + +Lemma equates_5 : + forall y1 (P:A0->forall(x1:A1)(x2:A2 x1)(x3:A3 x2)(x4:A4 x3),Prop) x1 x2 x3 x4 x5, + P y1 x2 x3 x4 x5 -> x1 = y1 -> P x1 x2 x3 x4 x5. +Proof using. intros. subst. auto. Qed. + +Lemma equates_6 : + forall y1 (P:A0->forall(x1:A1)(x2:A2 x1)(x3:A3 x2)(x4:A4 x3)(x5:A5 x4),Prop) + x1 x2 x3 x4 x5 x6, + P y1 x2 x3 x4 x5 x6 -> x1 = y1 -> P x1 x2 x3 x4 x5 x6. +Proof using. intros. subst. auto. Qed. + +End equatesLemma. + +Ltac equates_lemma n := + match number_to_nat n with + | 0 => constr:(equates_0) + | 1 => constr:(equates_1) + | 2 => constr:(equates_2) + | 3 => constr:(equates_3) + | 4 => constr:(equates_4) + | 5 => constr:(equates_5) + | 6 => constr:(equates_6) + end. + +Ltac equates_one n := + let L := equates_lemma n in + eapply L. + +Ltac equates_several E cont := + let all_pos := match type of E with + | List.list Boxer => constr:(E) + | _ => constr:((boxer E)::nil) + end in + let rec go pos := + match pos with + | nil => cont tt + | (boxer ?n)::?pos' => equates_one n; [ go pos' | ] + end in + go all_pos. + +Tactic Notation "equates" constr(E) := + equates_several E ltac:(fun _ => idtac). +Tactic Notation "equates" constr(n1) constr(n2) := + equates (>> n1 n2). +Tactic Notation "equates" constr(n1) constr(n2) constr(n3) := + equates (>> n1 n2 n3). +Tactic Notation "equates" constr(n1) constr(n2) constr(n3) constr(n4) := + equates (>> n1 n2 n3 n4). + +(** [applys_eq H i1 .. iK] is the same as + [equates i1 .. iK] followed by [apply H] + on the first subgoal. *) + +Tactic Notation "applys_eq" constr(H) constr(E) := + equates_several E ltac:(fun _ => sapply H). +Tactic Notation "applys_eq" constr(H) constr(n1) constr(n2) := + applys_eq H (>> n1 n2). +Tactic Notation "applys_eq" constr(H) constr(n1) constr(n2) constr(n3) := + applys_eq H (>> n1 n2 n3). +Tactic Notation "applys_eq" constr(H) constr(n1) constr(n2) constr(n3) constr(n4) := + applys_eq H (>> n1 n2 n3 n4). + + +(* ---------------------------------------------------------------------- *) +(** ** Absurd goals *) + +(** [false_goal] replaces any goal by the goal [False]. + Contrary to the tactic [false] (below), it does not try to do + anything else *) + +Tactic Notation "false_goal" := + exfalso. + +(** [false_post] is the underlying tactic used to prove goals + of the form [False]. In the default implementation, it proves + the goal if the context contains [False] or an hypothesis of the + form [C x1 .. xN = D y1 .. yM], or if the [congruence] tactic + finds a proof of [x <> x] for some [x]. *) + +Ltac false_post := + solve [ assumption | discriminate | congruence ]. + +(** [false] replaces any goal by the goal [False], and calls [false_post] *) + +Tactic Notation "false" := + false_goal; try false_post. + +(** [tryfalse] tries to solve a goal by contradiction, and leaves + the goal unchanged if it cannot solve it. + It is equivalent to [try solve \[ false \]]. *) + +Tactic Notation "tryfalse" := + try solve [ false ]. + +(** [false E] tries to exploit lemma [E] to prove the goal false. + [false E1 .. EN] is equivalent to [false (>> E1 .. EN)], + which tries to apply [applys (>> E1 .. EN)] and if it + does not work then tries [forwards H: (>> E1 .. EN)] + followed with [false] *) + +Ltac false_then E cont := + false_goal; first + [ applys E + | forwards_then E ltac:(fun M => + pose M; jauto_set_hyps; intros; false) ]; + cont tt. + (* --TODO: is [cont] needed? *) + +Tactic Notation "false" constr(E) := + false_then E ltac:(fun _ => idtac). +Tactic Notation "false" constr(E) constr(E1) := + false (>> E E1). +Tactic Notation "false" constr(E) constr(E1) constr(E2) := + false (>> E E1 E2). +Tactic Notation "false" constr(E) constr(E1) constr(E2) constr(E3) := + false (>> E E1 E2 E3). +Tactic Notation "false" constr(E) constr(E1) constr(E2) constr(E3) constr(E4) := + false (>> E E1 E2 E3 E4). + +(** [false_invert H] proves a goal if it absurd after + calling [inversion H] and [false] *) + +Ltac false_invert_for H := + let M := fresh "TEMP" in pose (M := H); inversion H; false. + +Tactic Notation "false_invert" constr(H) := + try solve [ false_invert_for H | false ]. + +(** [false_invert] proves any goal provided there is at least + one hypothesis [H] in the context (or as a universally quantified + hypothesis visible at the head of the goal) that can be proved absurd by calling + [inversion H]. *) + +Ltac false_invert_iter := + match goal with H:_ |- _ => + solve [ inversion H; false + | clear H; false_invert_iter + | fail 2 ] end. + +Tactic Notation "false_invert" := + intros; solve [ false_invert_iter | false ]. + +(** [tryfalse_invert H] and [tryfalse_invert] are like the + above but leave the goal unchanged if they don't solve it. *) + +Tactic Notation "tryfalse_invert" constr(H) := + try (false_invert H). + +Tactic Notation "tryfalse_invert" := + try false_invert. + +(** [false_neq_self_hyp] proves any goal if the context + contains an hypothesis of the form [E <> E]. It is + a restricted and optimized version of [false]. It is + intended to be used by other tactics only. *) + +Ltac false_neq_self_hyp := + match goal with H: ?x <> ?x |- _ => + false_goal; apply H; reflexivity end. + + + +(* ********************************************************************** *) +(** * Introduction and generalization *) + +(* ---------------------------------------------------------------------- *) +(** ** Introduction using [=>>] *) + +(** [introv] is used to name only non-dependent hypothesis. + - If [introv] is called on a goal of the form [forall x, H], + it should introduce all the variables quantified with a + [forall] at the head of the goal, but it does not introduce + hypotheses that preceed an arrow constructor, like in [P -> Q]. + - If [introv] is called on a goal that is not of the form + [forall x, H] nor [P -> Q], the tactic unfolds definitions + until the goal takes the form [forall x, H] or [P -> Q]. + If unfolding definitions does not produces a goal of this form, + then the tactic [introv] does nothing at all. *) + +(* [introv_rec] introduces all visible variables. + It does not try to unfold any definition. *) + +Ltac introv_rec := + match goal with + | |- ?P -> ?Q => idtac + | |- forall _, _ => intro; introv_rec + | |- _ => idtac + end. + +(* [introv_noarg] forces the goal to be a [forall] or an [->], + and then calls [introv_rec] to introduces variables + (possibly none, in which case [introv] is the same as [hnf]). + If the goal is not a product, then it does not do anything. *) + +Ltac introv_noarg := + match goal with + | |- ?P -> ?Q => idtac + | |- forall _, _ => introv_rec + | |- ?G => hnf; + match goal with + | |- ?P -> ?Q => idtac + | |- forall _, _ => introv_rec + end + | |- _ => idtac + end. + + (* simpler yet perhaps less efficient imlementation *) + Ltac introv_noarg_not_optimized := + intro; match goal with H:_|-_ => revert H end; introv_rec. + +(* [introv_arg H] introduces one non-dependent hypothesis + under the name [H], after introducing the variables + quantified with a [forall] that preceeds this hypothesis. + This tactic fails if there does not exist a hypothesis + to be introduced. *) + (* --TODO: __ in introv means "intros" *) + +Ltac introv_arg H := + hnf; match goal with + | |- ?P -> ?Q => intros H + | |- forall _, _ => intro; introv_arg H + end. + +(* [introv I1 .. IN] iterates [introv Ik] *) + +Tactic Notation "introv" := + introv_noarg. +Tactic Notation "introv" simple_intropattern(I1) := + introv_arg I1. +Tactic Notation "introv" simple_intropattern(I1) simple_intropattern(I2) := + introv I1; introv I2. +Tactic Notation "introv" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) := + introv I1; introv I2 I3. +Tactic Notation "introv" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) := + introv I1; introv I2 I3 I4. +Tactic Notation "introv" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) := + introv I1; introv I2 I3 I4 I5. +Tactic Notation "introv" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) + simple_intropattern(I6) := + introv I1; introv I2 I3 I4 I5 I6. +Tactic Notation "introv" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) + simple_intropattern(I6) simple_intropattern(I7) := + introv I1; introv I2 I3 I4 I5 I6 I7. +Tactic Notation "introv" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) + simple_intropattern(I6) simple_intropattern(I7) simple_intropattern(I8) := + introv I1; introv I2 I3 I4 I5 I6 I7 I8. +Tactic Notation "introv" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) + simple_intropattern(I6) simple_intropattern(I7) simple_intropattern(I8) + simple_intropattern(I9) := + introv I1; introv I2 I3 I4 I5 I6 I7 I8 I9. +Tactic Notation "introv" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) + simple_intropattern(I6) simple_intropattern(I7) simple_intropattern(I8) + simple_intropattern(I9) simple_intropattern(I10) := + introv I1; introv I2 I3 I4 I5 I6 I7 I8 I9 I10. + +(** [intros_all] repeats [intro] as long as possible. Contrary to [intros], + it unfolds any definition on the way. Remark that it also unfolds the + definition of negation, so applying [intros_all] to a goal of the form + [forall x, P x -> ~Q] will introduce [x] and [P x] and [Q], and will + leave [False] in the goal. *) + +Tactic Notation "intros_all" := + repeat intro. + +(** [intros_hnf] introduces an hypothesis and sets in head normal form *) + +Tactic Notation "intro_hnf" := + intro; match goal with H: _ |- _ => hnf in H end. + + +(* ---------------------------------------------------------------------- *) +(** ** Introduction using [=>] and [=>>] *) + +(* [=> I1 .. IN] is the same as [intros I1 .. IN] *) + +Ltac ltac_intros_post := idtac. + +Tactic Notation "=>" := + intros. +Tactic Notation "=>" simple_intropattern(I1) := + intros I1. +Tactic Notation "=>" simple_intropattern(I1) simple_intropattern(I2) := + intros I1 I2. +Tactic Notation "=>" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) := + intros I1 I2 I3. +Tactic Notation "=>" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) := + intros I1 I2 I3 I4. +Tactic Notation "=>" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) := + intros I1 I2 I3 I4 I5. +Tactic Notation "=>" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) + simple_intropattern(I6) := + intros I1 I2 I3 I4 I5 I6. +Tactic Notation "=>" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) + simple_intropattern(I6) simple_intropattern(I7) := + intros I1 I2 I3 I4 I5 I6 I7. +Tactic Notation "=>" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) + simple_intropattern(I6) simple_intropattern(I7) simple_intropattern(I8) := + intros I1 I2 I3 I4 I5 I6 I7 I8. +Tactic Notation "=>" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) + simple_intropattern(I6) simple_intropattern(I7) simple_intropattern(I8) + simple_intropattern(I9) := + intros I1 I2 I3 I4 I5 I6 I7 I8 I9. +Tactic Notation "=>" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) + simple_intropattern(I6) simple_intropattern(I7) simple_intropattern(I8) + simple_intropattern(I9) simple_intropattern(I10) := + intros I1 I2 I3 I4 I5 I6 I7 I8 I9 I10. + +(* [=>>] first introduces all non-dependent variables, + then behaves as [intros]. It unfolds the head of the goal using [hnf] + if there are not head visible quantifiers. + + Remark: instances of [Inhab] are treated as non-dependent and + are introduced automatically. *) + +(* NOTE: this tactic is later redefined for supporting Inhab *) +Ltac intro_nondeps_aux_special_intro G := + fail. + +Ltac intro_nondeps_aux is_already_hnf := + match goal with + | |- (?P -> ?Q) => idtac + | |- ?G -> _ => intro_nondeps_aux_special_intro G; + intro; intro_nondeps_aux true + | |- (forall _,_) => intros ?; intro_nondeps_aux true + | |- _ => + match is_already_hnf with + | true => idtac + | false => hnf; intro_nondeps_aux true + end + end. + +Ltac intro_nondeps tt := intro_nondeps_aux false. + +Tactic Notation "=>>" := + intro_nondeps tt. +Tactic Notation "=>>" simple_intropattern(I1) := + =>>; intros I1. +Tactic Notation "=>>" simple_intropattern(I1) simple_intropattern(I2) := + =>>; intros I1 I2. +Tactic Notation "=>>" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) := + =>>; intros I1 I2 I3. +Tactic Notation "=>>" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) := + =>>; intros I1 I2 I3 I4. +Tactic Notation "=>>" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) := + =>>; intros I1 I2 I3 I4 I5. +Tactic Notation "=>>" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) + simple_intropattern(I6) := + =>>; intros I1 I2 I3 I4 I5 I6. +Tactic Notation "=>>" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) + simple_intropattern(I6) simple_intropattern(I7) := + =>>; intros I1 I2 I3 I4 I5 I6 I7. +Tactic Notation "=>>" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) + simple_intropattern(I6) simple_intropattern(I7) simple_intropattern(I8) := + =>>; intros I1 I2 I3 I4 I5 I6 I7 I8. +Tactic Notation "=>>" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) + simple_intropattern(I6) simple_intropattern(I7) simple_intropattern(I8) + simple_intropattern(I9) := + =>>; intros I1 I2 I3 I4 I5 I6 I7 I8 I9. +Tactic Notation "=>>" simple_intropattern(I1) simple_intropattern(I2) + simple_intropattern(I3) simple_intropattern(I4) simple_intropattern(I5) + simple_intropattern(I6) simple_intropattern(I7) simple_intropattern(I8) + simple_intropattern(I9) simple_intropattern(I10) := + =>>; intros I1 I2 I3 I4 I5 I6 I7 I8 I9 I10. + + +(* ---------------------------------------------------------------------- *) +(** ** Generalization *) + +(** [gen X1 .. XN] is a shorthand for calling [generalize dependent] + successively on variables [XN]...[X1]. Note that the variables + are generalized in reverse order, following the convention of + the [generalize] tactic: it means that [X1] will be the first + quantified variable in the resulting goal. *) + +Tactic Notation "gen" ident(X1) := + generalize dependent X1. +Tactic Notation "gen" ident(X1) ident(X2) := + gen X2; gen X1. +Tactic Notation "gen" ident(X1) ident(X2) ident(X3) := + gen X3; gen X2; gen X1. +Tactic Notation "gen" ident(X1) ident(X2) ident(X3) ident(X4) := + gen X4; gen X3; gen X2; gen X1. +Tactic Notation "gen" ident(X1) ident(X2) ident(X3) ident(X4) ident(X5) := + gen X5; gen X4; gen X3; gen X2; gen X1. +Tactic Notation "gen" ident(X1) ident(X2) ident(X3) ident(X4) ident(X5) + ident(X6) := + gen X6; gen X5; gen X4; gen X3; gen X2; gen X1. +Tactic Notation "gen" ident(X1) ident(X2) ident(X3) ident(X4) ident(X5) + ident(X6) ident(X7) := + gen X7; gen X6; gen X5; gen X4; gen X3; gen X2; gen X1. +Tactic Notation "gen" ident(X1) ident(X2) ident(X3) ident(X4) ident(X5) + ident(X6) ident(X7) ident(X8) := + gen X8; gen X7; gen X6; gen X5; gen X4; gen X3; gen X2; gen X1. +Tactic Notation "gen" ident(X1) ident(X2) ident(X3) ident(X4) ident(X5) + ident(X6) ident(X7) ident(X8) ident(X9) := + gen X9; gen X8; gen X7; gen X6; gen X5; gen X4; gen X3; gen X2; gen X1. +Tactic Notation "gen" ident(X1) ident(X2) ident(X3) ident(X4) ident(X5) + ident(X6) ident(X7) ident(X8) ident(X9) ident(X10) := + gen X10; gen X9; gen X8; gen X7; gen X6; gen X5; gen X4; gen X3; gen X2; gen X1. + +(** [generalizes X] is a shorthand for calling [generalize X; clear X]. + It is weaker than tactic [gen X] since it does not support + dependencies. It is mainly intended for writing tactics. *) + +Tactic Notation "generalizes" hyp(X) := + generalize X; clear X. +Tactic Notation "generalizes" hyp(X1) hyp(X2) := + generalizes X1; generalizes X2. +Tactic Notation "generalizes" hyp(X1) hyp(X2) hyp(X3) := + generalizes X1 X2; generalizes X3. +Tactic Notation "generalizes" hyp(X1) hyp(X2) hyp(X3) hyp(X4) := + generalizes X1 X2 X3; generalizes X4. + + +(* ---------------------------------------------------------------------- *) +(** ** Naming *) + +(** [sets X: E] is the same as [set (X := E) in *], that is, + it replaces all occurences of [E] by a fresh meta-variable [X] + whose definition is [E]. *) + +Tactic Notation "sets" ident(X) ":" constr(E) := + set (X := E) in *. + +(** [def_to_eq E X H] applies when [X := E] is a local + definition. It adds an assumption [H: X = E] + and then clears the definition of [X]. + [def_to_eq_sym] is similar except that it generates + the equality [H: E = X]. *) + +Ltac def_to_eq X HX E := + assert (HX : X = E) by reflexivity; clearbody X. +Ltac def_to_eq_sym X HX E := + assert (HX : E = X) by reflexivity; clearbody X. + +(** [set_eq X H: E] generates the equality [H: X = E], + for a fresh name [X], and replaces [E] by [X] in the + current goal. Syntaxes [set_eq X: E] and + [set_eq: E] are also available. Similarly, + [set_eq <- X H: E] generates the equality [H: E = X]. + + [sets_eq X HX: E] does the same but replaces [E] by [X] + everywhere in the goal. [sets_eq X HX: E in H] replaces in [H]. + [set_eq X HX: E in |-] performs no substitution at all. *) + +Tactic Notation "set_eq" ident(X) ident(HX) ":" constr(E) := + set (X := E); def_to_eq X HX E. +Tactic Notation "set_eq" ident(X) ":" constr(E) := + let HX := fresh "EQ" X in set_eq X HX: E. +Tactic Notation "set_eq" ":" constr(E) := + let X := fresh "X" in set_eq X: E. + +Tactic Notation "set_eq" "<-" ident(X) ident(HX) ":" constr(E) := + set (X := E); def_to_eq_sym X HX E. +Tactic Notation "set_eq" "<-" ident(X) ":" constr(E) := + let HX := fresh "EQ" X in set_eq <- X HX: E. +Tactic Notation "set_eq" "<-" ":" constr(E) := + let X := fresh "X" in set_eq <- X: E. + +Tactic Notation "sets_eq" ident(X) ident(HX) ":" constr(E) := + set (X := E) in *; def_to_eq X HX E. +Tactic Notation "sets_eq" ident(X) ":" constr(E) := + let HX := fresh "EQ" X in sets_eq X HX: E. +Tactic Notation "sets_eq" ":" constr(E) := + let X := fresh "X" in sets_eq X: E. + +Tactic Notation "sets_eq" "<-" ident(X) ident(HX) ":" constr(E) := + set (X := E) in *; def_to_eq_sym X HX E. +Tactic Notation "sets_eq" "<-" ident(X) ":" constr(E) := + let HX := fresh "EQ" X in sets_eq <- X HX: E. +Tactic Notation "sets_eq" "<-" ":" constr(E) := + let X := fresh "X" in sets_eq <- X: E. + +Tactic Notation "set_eq" ident(X) ident(HX) ":" constr(E) "in" hyp(H) := + set (X := E) in H; def_to_eq X HX E. +Tactic Notation "set_eq" ident(X) ":" constr(E) "in" hyp(H) := + let HX := fresh "EQ" X in set_eq X HX: E in H. +Tactic Notation "set_eq" ":" constr(E) "in" hyp(H) := + let X := fresh "X" in set_eq X: E in H. + +Tactic Notation "set_eq" "<-" ident(X) ident(HX) ":" constr(E) "in" hyp(H) := + set (X := E) in H; def_to_eq_sym X HX E. +Tactic Notation "set_eq" "<-" ident(X) ":" constr(E) "in" hyp(H) := + let HX := fresh "EQ" X in set_eq <- X HX: E in H. +Tactic Notation "set_eq" "<-" ":" constr(E) "in" hyp(H) := + let X := fresh "X" in set_eq <- X: E in H. + +Tactic Notation "set_eq" ident(X) ident(HX) ":" constr(E) "in" "|-" := + set (X := E) in |-; def_to_eq X HX E. +Tactic Notation "set_eq" ident(X) ":" constr(E) "in" "|-" := + let HX := fresh "EQ" X in set_eq X HX: E in |-. +Tactic Notation "set_eq" ":" constr(E) "in" "|-" := + let X := fresh "X" in set_eq X: E in |-. + +Tactic Notation "set_eq" "<-" ident(X) ident(HX) ":" constr(E) "in" "|-" := + set (X := E) in |-; def_to_eq_sym X HX E. +Tactic Notation "set_eq" "<-" ident(X) ":" constr(E) "in" "|-" := + let HX := fresh "EQ" X in set_eq <- X HX: E in |-. +Tactic Notation "set_eq" "<-" ":" constr(E) "in" "|-" := + let X := fresh "X" in set_eq <- X: E in |-. + +(** [gen_eq X: E] is a tactic whose purpose is to introduce + equalities so as to work around the limitation of the [induction] + tactic which typically loses information. [gen_eq E as X] replaces + all occurences of term [E] with a fresh variable [X] and the equality + [X = E] as extra hypothesis to the current conclusion. In other words + a conclusion [C] will be turned into [(X = E) -> C]. + [gen_eq: E] and [gen_eq: E as X] are also accepted. *) + +Tactic Notation "gen_eq" ident(X) ":" constr(E) := + let EQ := fresh "EQ" X in sets_eq X EQ: E; revert EQ. +Tactic Notation "gen_eq" ":" constr(E) := + let X := fresh "X" in gen_eq X: E. +Tactic Notation "gen_eq" ":" constr(E) "as" ident(X) := + gen_eq X: E. +Tactic Notation "gen_eq" ident(X1) ":" constr(E1) "," + ident(X2) ":" constr(E2) := + gen_eq X2: E2; gen_eq X1: E1. +Tactic Notation "gen_eq" ident(X1) ":" constr(E1) "," + ident(X2) ":" constr(E2) "," ident(X3) ":" constr(E3) := + gen_eq X3: E3; gen_eq X2: E2; gen_eq X1: E1. + +(** [sets_let X] finds the first let-expression in the goal + and names its body [X]. [sets_eq_let X] is similar, + except that it generates an explicit equality. + Tactics [sets_let X in H] and [sets_eq_let X in H] + allow specifying a particular hypothesis (by default, + the first one that contains a [let] is considered). + + Known limitation: it does not seem possible to support + naming of multiple let-in constructs inside a term, from ltac. *) + +Ltac sets_let_base tac := + match goal with + | |- context[let _ := ?E in _] => tac E; cbv zeta + | H: context[let _ := ?E in _] |- _ => tac E; cbv zeta in H + end. + +Ltac sets_let_in_base H tac := + match type of H with context[let _ := ?E in _] => + tac E; cbv zeta in H end. + +Tactic Notation "sets_let" ident(X) := + sets_let_base ltac:(fun E => sets X: E). +Tactic Notation "sets_let" ident(X) "in" hyp(H) := + sets_let_in_base H ltac:(fun E => sets X: E). +Tactic Notation "sets_eq_let" ident(X) := + sets_let_base ltac:(fun E => sets_eq X: E). +Tactic Notation "sets_eq_let" ident(X) "in" hyp(H) := + sets_let_in_base H ltac:(fun E => sets_eq X: E). + + +(* ********************************************************************** *) +(** * Rewriting *) + +(** [rewrites E] is similar to [rewrite] except that + it supports the [rm] directives to clear hypotheses + on the fly, and that it supports a list of arguments in the form + [rewrites (>> E1 E2 E3)] to indicate that [forwards] should be + invoked first before [rewrites] is called. *) + +Ltac rewrites_base E cont := + match type of E with + | List.list Boxer => forwards_then E cont + | _ => cont E; fast_rm_inside E + end. + +Tactic Notation "rewrites" constr(E) := + rewrites_base E ltac:(fun M => rewrite M ). +Tactic Notation "rewrites" constr(E) "in" hyp(H) := + rewrites_base E ltac:(fun M => rewrite M in H). +Tactic Notation "rewrites" constr(E) "in" "*" := + rewrites_base E ltac:(fun M => rewrite M in *). +Tactic Notation "rewrites" "<-" constr(E) := + rewrites_base E ltac:(fun M => rewrite <- M ). +Tactic Notation "rewrites" "<-" constr(E) "in" hyp(H) := + rewrites_base E ltac:(fun M => rewrite <- M in H). +Tactic Notation "rewrites" "<-" constr(E) "in" "*" := + rewrites_base E ltac:(fun M => rewrite <- M in *). + +(* --TODO: extend tactics below to use [rewrites] *) + +(** [rewrite_all E] iterates version of [rewrite E] as long as possible. + Warning: this tactic can easily get into an infinite loop. + Syntax for rewriting from right to left and/or into an hypothese + is similar to the one of [rewrite]. *) + +Tactic Notation "rewrite_all" constr(E) := + repeat rewrite E. +Tactic Notation "rewrite_all" "<-" constr(E) := + repeat rewrite <- E. +Tactic Notation "rewrite_all" constr(E) "in" ident(H) := + repeat rewrite E in H. +Tactic Notation "rewrite_all" "<-" constr(E) "in" ident(H) := + repeat rewrite <- E in H. +Tactic Notation "rewrite_all" constr(E) "in" "*" := + repeat rewrite E in *. +Tactic Notation "rewrite_all" "<-" constr(E) "in" "*" := + repeat rewrite <- E in *. + +(** [asserts_rewrite E] asserts that an equality [E] holds (generating a + corresponding subgoal) and rewrite it straight away in the current + goal. It avoids giving a name to the equality and later clearing it. + Syntax for rewriting from right to left and/or into an hypothese + is similar to the one of [rewrite]. Note: the tactic [replaces] + plays a similar role. *) + +Ltac asserts_rewrite_tactic E action := + let EQ := fresh "TEMP" in (assert (EQ : E); + [ idtac | action EQ; clear EQ ]). + +Tactic Notation "asserts_rewrite" constr(E) := + asserts_rewrite_tactic E ltac:(fun EQ => rewrite EQ). +Tactic Notation "asserts_rewrite" "<-" constr(E) := + asserts_rewrite_tactic E ltac:(fun EQ => rewrite <- EQ). +Tactic Notation "asserts_rewrite" constr(E) "in" hyp(H) := + asserts_rewrite_tactic E ltac:(fun EQ => rewrite EQ in H). +Tactic Notation "asserts_rewrite" "<-" constr(E) "in" hyp(H) := + asserts_rewrite_tactic E ltac:(fun EQ => rewrite <- EQ in H). +Tactic Notation "asserts_rewrite" constr(E) "in" "*" := + asserts_rewrite_tactic E ltac:(fun EQ => rewrite EQ in *). +Tactic Notation "asserts_rewrite" "<-" constr(E) "in" "*" := + asserts_rewrite_tactic E ltac:(fun EQ => rewrite <- EQ in *). + +(** [cuts_rewrite E] is the same as [asserts_rewrite E] except + that subgoals are permuted. *) + +Ltac cuts_rewrite_tactic E action := + let EQ := fresh "TEMP" in (cuts EQ: E; + [ action EQ; clear EQ | idtac ]). + +Tactic Notation "cuts_rewrite" constr(E) := + cuts_rewrite_tactic E ltac:(fun EQ => rewrite EQ). +Tactic Notation "cuts_rewrite" "<-" constr(E) := + cuts_rewrite_tactic E ltac:(fun EQ => rewrite <- EQ). +Tactic Notation "cuts_rewrite" constr(E) "in" hyp(H) := + cuts_rewrite_tactic E ltac:(fun EQ => rewrite EQ in H). +Tactic Notation "cuts_rewrite" "<-" constr(E) "in" hyp(H) := + cuts_rewrite_tactic E ltac:(fun EQ => rewrite <- EQ in H). + +(** [rewrite_except H EQ] rewrites equality [EQ] everywhere + but in hypothesis [H]. Mainly useful for other tactics. *) + +Ltac rewrite_except H EQ := + let K := fresh "TEMP" in let T := type of H in + set (K := T) in H; + rewrite EQ in *; unfold K in H; clear K. + +(** [rewrites E at K] applies when [E] is of the form [T1 = T2] + rewrites the equality [E] at the [K]-th occurence of [T1] + in the current goal. + Syntaxes [rewrites <- E at K] and [rewrites E at K in H] + are also available. *) + +Tactic Notation "rewrites" constr(E) "at" constr(K) := + match type of E with ?T1 = ?T2 => + ltac_action_at K of T1 do (rewrites E) end. +Tactic Notation "rewrites" "<-" constr(E) "at" constr(K) := + match type of E with ?T1 = ?T2 => + ltac_action_at K of T2 do (rewrites <- E) end. +Tactic Notation "rewrites" constr(E) "at" constr(K) "in" hyp(H) := + match type of E with ?T1 = ?T2 => + ltac_action_at K of T1 in H do (rewrites E in H) end. +Tactic Notation "rewrites" "<-" constr(E) "at" constr(K) "in" hyp(H) := + match type of E with ?T1 = ?T2 => + ltac_action_at K of T2 in H do (rewrites <- E in H) end. + + +(* ---------------------------------------------------------------------- *) +(** ** Replace *) + +(** [replaces E with F] is the same as [replace E with F] except that + the equality [E = F] is generated as first subgoal. Syntax + [replaces E with F in H] is also available. Note that contrary to + [replace], [replaces] does not try to solve the equality + by [assumption]. Note: [replaces E with F] is similar to + [asserts_rewrite (E = F)]. *) + +Tactic Notation "replaces" constr(E) "with" constr(F) := + let T := fresh "TEMP" in assert (T: E = F); [ | replace E with F; clear T ]. + +Tactic Notation "replaces" constr(E) "with" constr(F) "in" hyp(H) := + let T := fresh "TEMP" in assert (T: E = F); [ | replace E with F in H; clear T ]. + + +(** [replaces E at K with F] replaces the [K]-th occurence of [E] + with [F] in the current goal. Syntax [replaces E at K with F in H] + is also available. *) + +Tactic Notation "replaces" constr(E) "at" constr(K) "with" constr(F) := + let T := fresh "TEMP" in assert (T: E = F); [ | rewrites T at K; clear T ]. + +Tactic Notation "replaces" constr(E) "at" constr(K) "with" constr(F) "in" hyp(H) := + let T := fresh "TEMP" in assert (T: E = F); [ | rewrites T at K in H; clear T ]. + + +(* ---------------------------------------------------------------------- *) +(** ** Change *) + +(** [changes] is like [change] except that it does not silently + fail to perform its task. (Note that, [changes] is implemented + using [rewrite], meaning that it might perform additional + beta-reductions compared with the original [change] tactic. *) +(* --TODO: support "changes (E1 = E2)" *) + +Tactic Notation "changes" constr(E1) "with" constr(E2) "in" hyp(H) := + asserts_rewrite (E1 = E2) in H; [ reflexivity | ]. + +Tactic Notation "changes" constr(E1) "with" constr(E2) := + asserts_rewrite (E1 = E2); [ reflexivity | ]. + +Tactic Notation "changes" constr(E1) "with" constr(E2) "in" "*" := + asserts_rewrite (E1 = E2) in *; [ reflexivity | ]. + + + +(* ---------------------------------------------------------------------- *) +(** ** Renaming *) + +(** [renames X1 to Y1, ..., XN to YN] is a shorthand for a sequence of + renaming operations [rename Xi into Yi]. *) + +Tactic Notation "renames" ident(X1) "to" ident(Y1) := + rename X1 into Y1. +Tactic Notation "renames" ident(X1) "to" ident(Y1) "," + ident(X2) "to" ident(Y2) := + renames X1 to Y1; renames X2 to Y2. +Tactic Notation "renames" ident(X1) "to" ident(Y1) "," + ident(X2) "to" ident(Y2) "," ident(X3) "to" ident(Y3) := + renames X1 to Y1; renames X2 to Y2, X3 to Y3. +Tactic Notation "renames" ident(X1) "to" ident(Y1) "," + ident(X2) "to" ident(Y2) "," ident(X3) "to" ident(Y3) "," + ident(X4) "to" ident(Y4) := + renames X1 to Y1; renames X2 to Y2, X3 to Y3, X4 to Y4. +Tactic Notation "renames" ident(X1) "to" ident(Y1) "," + ident(X2) "to" ident(Y2) "," ident(X3) "to" ident(Y3) "," + ident(X4) "to" ident(Y4) "," ident(X5) "to" ident(Y5) := + renames X1 to Y1; renames X2 to Y2, X3 to Y3, X4 to Y4, X5 to Y5. +Tactic Notation "renames" ident(X1) "to" ident(Y1) "," + ident(X2) "to" ident(Y2) "," ident(X3) "to" ident(Y3) "," + ident(X4) "to" ident(Y4) "," ident(X5) "to" ident(Y5) "," + ident(X6) "to" ident(Y6) := + renames X1 to Y1; renames X2 to Y2, X3 to Y3, X4 to Y4, X5 to Y5, X6 to Y6. + + +(* ---------------------------------------------------------------------- *) +(** ** Unfolding *) + +(** [unfolds] unfolds the head definition in the goal, i.e. if the + goal has form [P x1 ... xN] then it calls [unfold P]. + If the goal is an equality, it tries to unfold the head constant + on the left-hand side, and otherwise tries on the right-hand side. + If the goal is a product, it calls [intros] first. + -- warning: this tactic is overriden in LibReflect. *) + +Ltac apply_to_head_of E cont := + let go E := + let P := get_head E in cont P in + match E with + | forall _,_ => intros; apply_to_head_of E cont + | ?A = ?B => first [ go A | go B ] + | ?A => go A + end. + +Ltac unfolds_base := + match goal with |- ?G => + apply_to_head_of G ltac:(fun P => unfold P) end. + +Tactic Notation "unfolds" := + unfolds_base. + +(** [unfolds in H] unfolds the head definition of hypothesis [H], i.e. if + [H] has type [P x1 ... xN] then it calls [unfold P in H]. *) + +Ltac unfolds_in_base H := + match type of H with ?G => + apply_to_head_of G ltac:(fun P => unfold P in H) end. + +Tactic Notation "unfolds" "in" hyp(H) := + unfolds_in_base H. + +(** [unfolds in H1,H2,..,HN] allows unfolding the head constant + in several hypotheses at once. *) + +Tactic Notation "unfolds" "in" hyp(H1) hyp(H2) := + unfolds in H1; unfolds in H2. +Tactic Notation "unfolds" "in" hyp(H1) hyp(H2) hyp(H3) := + unfolds in H1; unfolds in H2 H3. +Tactic Notation "unfolds" "in" hyp(H1) hyp(H2) hyp(H3) hyp(H4) := + unfolds in H1; unfolds in H2 H3 H4. +Tactic Notation "unfolds" "in" hyp(H1) hyp(H2) hyp(H3) hyp(H4) hyp(H5) := + unfolds in H1; unfolds in H2 H3 H4 H5. + +(** [unfolds P1,..,PN] is a shortcut for [unfold P1,..,PN in *]. *) + +Tactic Notation "unfolds" constr(F1) := + unfold F1 in *. +Tactic Notation "unfolds" constr(F1) "," constr(F2) := + unfold F1,F2 in *. +Tactic Notation "unfolds" constr(F1) "," constr(F2) + "," constr(F3) := + unfold F1,F2,F3 in *. +Tactic Notation "unfolds" constr(F1) "," constr(F2) + "," constr(F3) "," constr(F4) := + unfold F1,F2,F3,F4 in *. +Tactic Notation "unfolds" constr(F1) "," constr(F2) + "," constr(F3) "," constr(F4) "," constr(F5) := + unfold F1,F2,F3,F4,F5 in *. +Tactic Notation "unfolds" constr(F1) "," constr(F2) + "," constr(F3) "," constr(F4) "," constr(F5) "," constr(F6) := + unfold F1,F2,F3,F4,F5,F6 in *. +Tactic Notation "unfolds" constr(F1) "," constr(F2) + "," constr(F3) "," constr(F4) "," constr(F5) + "," constr(F6) "," constr(F7) := + unfold F1,F2,F3,F4,F5,F6,F7 in *. +Tactic Notation "unfolds" constr(F1) "," constr(F2) + "," constr(F3) "," constr(F4) "," constr(F5) + "," constr(F6) "," constr(F7) "," constr(F8) := + unfold F1,F2,F3,F4,F5,F6,F7,F8 in *. + +(** [folds P1,..,PN] is a shortcut for [fold P1 in *; ..; fold PN in *]. *) + +Tactic Notation "folds" constr(H) := + fold H in *. +Tactic Notation "folds" constr(H1) "," constr(H2) := + folds H1; folds H2. +Tactic Notation "folds" constr(H1) "," constr(H2) "," constr(H3) := + folds H1; folds H2; folds H3. +Tactic Notation "folds" constr(H1) "," constr(H2) "," constr(H3) + "," constr(H4) := + folds H1; folds H2; folds H3; folds H4. +Tactic Notation "folds" constr(H1) "," constr(H2) "," constr(H3) + "," constr(H4) "," constr(H5) := + folds H1; folds H2; folds H3; folds H4; folds H5. + + +(* ---------------------------------------------------------------------- *) +(** ** Simplification *) + +(** [simpls] is a shortcut for [simpl in *]. *) + +Tactic Notation "simpls" := + simpl in *. + +(** [simpls P1,..,PN] is a shortcut for + [simpl P1 in *; ..; simpl PN in *]. *) + +Tactic Notation "simpls" constr(F1) := + simpl F1 in *. +Tactic Notation "simpls" constr(F1) "," constr(F2) := + simpls F1; simpls F2. +Tactic Notation "simpls" constr(F1) "," constr(F2) + "," constr(F3) := + simpls F1; simpls F2; simpls F3. +Tactic Notation "simpls" constr(F1) "," constr(F2) + "," constr(F3) "," constr(F4) := + simpls F1; simpls F2; simpls F3; simpls F4. + +(** [unsimpl E] replaces all occurence of [X] by [E], where [X] is + the result which the tactic [simpl] would give when applied to [E]. + It is useful to undo what [simpl] has simplified too far. *) + +Tactic Notation "unsimpl" constr(E) := + let F := (eval simpl in E) in change F with E. + +(** [unsimpl E in H] is similar to [unsimpl E] but it applies + inside a particular hypothesis [H]. *) + +Tactic Notation "unsimpl" constr(E) "in" hyp(H) := + let F := (eval simpl in E) in change F with E in H. + +(** [unsimpl E in *] applies [unsimpl E] everywhere possible. + [unsimpls E] is a synonymous. *) + +Tactic Notation "unsimpl" constr(E) "in" "*" := + let F := (eval simpl in E) in change F with E in *. +Tactic Notation "unsimpls" constr(E) := + unsimpl E in *. + +(** [nosimpl t] protects the Coq term[t] against some forms of + simplification. See Gonthier's work for details on this trick. *) + +Notation "'nosimpl' t" := (match tt with tt => t end) + (at level 10). + + +(* ---------------------------------------------------------------------- *) +(** ** Evaluation *) + +Tactic Notation "hnfs" := hnf in *. + +(* ---------------------------------------------------------------------- *) +(** ** Substitution *) + +(** [substs] does the same as [subst], except that it does not fail + when there are circular equalities in the context. *) + +Tactic Notation "substs" := + repeat (match goal with H: ?x = ?y |- _ => + first [ subst x | subst y ] end). + +(** Implementation of [substs below], which allows to call + [subst] on all the hypotheses that lie beyond a given + position in the proof context. *) + +Ltac substs_below limit := + match goal with H: ?T |- _ => + match T with + | limit => idtac + | ?x = ?y => + first [ subst x; substs_below limit + | subst y; substs_below limit + | generalizes H; substs_below limit; intro ] + end end. + +(** [substs below body E] applies [subst] on all equalities that appear + in the context below the first hypothesis whose body is [E]. + If there is no such hypothesis in the context, it is equivalent + to [subst]. For instance, if [H] is an hypothesis, then + [substs below H] will substitute equalities below hypothesis [H]. *) + +Tactic Notation "substs" "below" "body" constr(M) := + substs_below M. + +(** [substs below H] applies [subst] on all equalities that appear + in the context below the hypothesis named [H]. Note that + the current implementation is technically incorrect since it + will confuse different hypotheses with the same body. *) + +Tactic Notation "substs" "below" hyp(H) := + match type of H with ?M => substs below body M end. + +(** [subst_hyp H] substitutes the equality contained in the + first hypothesis from the context. *) + +Ltac intro_subst_hyp := fail. (* definition further on *) + +(** [subst_hyp H] substitutes the equality contained in [H]. *) + +Ltac subst_hyp_base H := + match type of H with + | (_,_,_,_,_) = (_,_,_,_,_) => injection H; clear H; do 4 intro_subst_hyp + | (_,_,_,_) = (_,_,_,_) => injection H; clear H; do 4 intro_subst_hyp + | (_,_,_) = (_,_,_) => injection H; clear H; do 3 intro_subst_hyp + | (_,_) = (_,_) => injection H; clear H; do 2 intro_subst_hyp + | ?x = ?x => clear H + | ?x = ?y => first [ subst x | subst y ] + end. + +Tactic Notation "subst_hyp" hyp(H) := subst_hyp_base H. + +Ltac intro_subst_hyp ::= + let H := fresh "TEMP" in intros H; subst_hyp H. + +(** [intro_subst] is a shorthand for [intro H; subst_hyp H]: + it introduces and substitutes the equality at the head + of the current goal. *) + +Tactic Notation "intro_subst" := + let H := fresh "TEMP" in intros H; subst_hyp H. + +(** [subst_local] substitutes all local definition from the context *) + +Ltac subst_local := + repeat match goal with H:=_ |- _ => subst H end. + +(** [subst_eq E] takes an equality [x = t] and replace [x] + with [t] everywhere in the goal *) + +Ltac subst_eq_base E := + let H := fresh "TEMP" in lets H: E; subst_hyp H. + +Tactic Notation "subst_eq" constr(E) := + subst_eq_base E. + + +(* ---------------------------------------------------------------------- *) +(** ** Tactics to work with proof irrelevance *) + +Require Import Coq.Logic.ProofIrrelevance. + +(** [pi_rewrite E] replaces [E] of type [Prop] with a fresh + unification variable, and is thus a practical way to + exploit proof irrelevance, without writing explicitly + [rewrite (proof_irrelevance E E')]. Particularly useful + when [E'] is a big expression. *) + +Ltac pi_rewrite_base E rewrite_tac := + let E' := fresh "TEMP" in let T := type of E in evar (E':T); + rewrite_tac (@proof_irrelevance _ E E'); subst E'. + +Tactic Notation "pi_rewrite" constr(E) := + pi_rewrite_base E ltac:(fun X => rewrite X). +Tactic Notation "pi_rewrite" constr(E) "in" hyp(H) := + pi_rewrite_base E ltac:(fun X => rewrite X in H). + + +(* ---------------------------------------------------------------------- *) +(** ** Proving equalities *) + +(** Note: current implementation only supports up to arity 5 *) + +(** [fequal] is a variation on [f_equal] which has a better behaviour + on equalities between n-ary tuples. *) + +Ltac fequal_base := + let go := f_equal; [ fequal_base | ] in + match goal with + | |- (_,_,_) = (_,_,_) => go + | |- (_,_,_,_) = (_,_,_,_) => go + | |- (_,_,_,_,_) = (_,_,_,_,_) => go + | |- (_,_,_,_,_,_) = (_,_,_,_,_,_) => go + | |- _ => f_equal + end. + +Tactic Notation "fequal" := + fequal_base. + +(** [fequals] is the same as [fequal] except that it tries and solve + all trivial subgoals, using [reflexivity] and [congruence] + (as well as the proof-irrelevance principle). + [fequals] applies to goals of the form [f x1 .. xN = f y1 .. yN] + and produces some subgoals of the form [xi = yi]). *) + +Ltac fequal_post := + first [ reflexivity | congruence | apply proof_irrelevance | idtac ]. + +Tactic Notation "fequals" := + fequal; fequal_post. + +(** [fequals_rec] calls [fequals] recursively. + It is equivalent to [repeat (progress fequals)]. *) + +Tactic Notation "fequals_rec" := + repeat (progress fequals). + + + +(* ********************************************************************** *) +(** * Inversion *) + +(* ---------------------------------------------------------------------- *) +(** ** Basic inversion *) + +(** [invert keep H] is same to [inversion H] except that it puts all the + facts obtained in the goal. The keyword [keep] means that the + hypothesis [H] should not be removed. *) + +Tactic Notation "invert" "keep" hyp(H) := + pose ltac_mark; inversion H; gen_until_mark. + +(** [invert keep H as X1 .. XN] is the same as [inversion H as ...] except + that only hypotheses which are not variable need to be named + explicitely, in a similar fashion as [introv] is used to name + only hypotheses. *) + +Tactic Notation "invert" "keep" hyp(H) "as" simple_intropattern(I1) := + invert keep H; introv I1. +Tactic Notation "invert" "keep" hyp(H) "as" simple_intropattern(I1) + simple_intropattern(I2) := + invert keep H; introv I1 I2. +Tactic Notation "invert" "keep" hyp(H) "as" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) := + invert keep H; introv I1 I2 I3. + +(** [invert H] is same to [inversion H] except that it puts all the + facts obtained in the goal and clears hypothesis [H]. + In other words, it is equivalent to [invert keep H; clear H]. *) + +Tactic Notation "invert" hyp(H) := + invert keep H; clear H. + +(** [invert H as X1 .. XN] is the same as [invert keep H as X1 .. XN] + but it also clears hypothesis [H]. *) + +Tactic Notation "invert_tactic" hyp(H) tactic(tac) := + let H' := fresh "TEMP" in rename H into H'; tac H'; clear H'. +Tactic Notation "invert" hyp(H) "as" simple_intropattern(I1) := + invert_tactic H (fun H => invert keep H as I1). +Tactic Notation "invert" hyp(H) "as" simple_intropattern(I1) + simple_intropattern(I2) := + invert_tactic H (fun H => invert keep H as I1 I2). +Tactic Notation "invert" hyp(H) "as" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) := + invert_tactic H (fun H => invert keep H as I1 I2 I3). + + +(* ---------------------------------------------------------------------- *) +(** ** Inversion with substitution *) + +(** Our inversion tactics is able to get rid of dependent equalities + generated by [inversion], using proof irrelevance. *) + +(* --we do not import Eqdep because it imports nasty hints automatically + From TLC Require Import Eqdep. *) + +Axiom inj_pair2 : (* is in fact derivable from the axioms in LibAxiom.v *) + forall (U : Type) (P : U -> Type) (p : U) (x y : P p), + existT P p x = existT P p y -> x = y. +(* Proof using. apply Eqdep.EqdepTheory.inj_pair2. Qed.*) + +Ltac inverts_tactic H i1 i2 i3 i4 i5 i6 := + let rec go i1 i2 i3 i4 i5 i6 := + match goal with + | |- (ltac_Mark -> _) => intros _ + | |- (?x = ?y -> _) => let H := fresh "TEMP" in intro H; + first [ subst x | subst y ]; + go i1 i2 i3 i4 i5 i6 + | |- (existT ?P ?p ?x = existT ?P ?p ?y -> _) => + let H := fresh "TEMP" in intro H; + generalize (@inj_pair2 _ P p x y H); + clear H; go i1 i2 i3 i4 i5 i6 + | |- (?P -> ?Q) => i1; go i2 i3 i4 i5 i6 ltac:(intro) + | |- (forall _, _) => intro; go i1 i2 i3 i4 i5 i6 + end in + generalize ltac_mark; invert keep H; go i1 i2 i3 i4 i5 i6; + unfold eq' in *. + +(** [inverts keep H] is same to [invert keep H] except that it + applies [subst] to all the equalities generated by the inversion. *) + +Tactic Notation "inverts" "keep" hyp(H) := + inverts_tactic H ltac:(intro) ltac:(intro) ltac:(intro) + ltac:(intro) ltac:(intro) ltac:(intro). + +(** [inverts keep H as X1 .. XN] is the same as + [invert keep H as X1 .. XN] except that it applies [subst] to all the + equalities generated by the inversion *) + +Tactic Notation "inverts" "keep" hyp(H) "as" simple_intropattern(I1) := + inverts_tactic H ltac:(intros I1) + ltac:(intro) ltac:(intro) ltac:(intro) ltac:(intro) ltac:(intro). +Tactic Notation "inverts" "keep" hyp(H) "as" simple_intropattern(I1) + simple_intropattern(I2) := + inverts_tactic H ltac:(intros I1) ltac:(intros I2) + ltac:(intro) ltac:(intro) ltac:(intro) ltac:(intro). +Tactic Notation "inverts" "keep" hyp(H) "as" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) := + inverts_tactic H ltac:(intros I1) ltac:(intros I2) ltac:(intros I3) + ltac:(intro) ltac:(intro) ltac:(intro). +Tactic Notation "inverts" "keep" hyp(H) "as" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) simple_intropattern(I4) := + inverts_tactic H ltac:(intros I1) ltac:(intros I2) ltac:(intros I3) + ltac:(intros I4) ltac:(intro) ltac:(intro). +Tactic Notation "inverts" "keep" hyp(H) "as" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) simple_intropattern(I4) + simple_intropattern(I5) := + inverts_tactic H ltac:(intros I1) ltac:(intros I2) ltac:(intros I3) + ltac:(intros I4) ltac:(intros I5) ltac:(intro). +Tactic Notation "inverts" "keep" hyp(H) "as" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) simple_intropattern(I4) + simple_intropattern(I5) simple_intropattern(I6) := + inverts_tactic H ltac:(intros I1) ltac:(intros I2) ltac:(intros I3) + ltac:(intros I4) ltac:(intros I5) ltac:(intros I6). + +(** [inverts H] is same to [inverts keep H] except that it + clears hypothesis [H]. *) + +Tactic Notation "inverts" hyp(H) := + inverts keep H; try clear H. + +(** [inverts H as X1 .. XN] is the same as [inverts keep H as X1 .. XN] + but it also clears the hypothesis [H]. *) + +Tactic Notation "inverts_tactic" hyp(H) tactic(tac) := + let H' := fresh "TEMP" in rename H into H'; tac H'; clear H'. +Tactic Notation "inverts" hyp(H) "as" simple_intropattern(I1) := + invert_tactic H (fun H => inverts keep H as I1). +Tactic Notation "inverts" hyp(H) "as" simple_intropattern(I1) + simple_intropattern(I2) := + invert_tactic H (fun H => inverts keep H as I1 I2). +Tactic Notation "inverts" hyp(H) "as" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) := + invert_tactic H (fun H => inverts keep H as I1 I2 I3). +Tactic Notation "inverts" hyp(H) "as" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) simple_intropattern(I4) := + invert_tactic H (fun H => inverts keep H as I1 I2 I3 I4). +Tactic Notation "inverts" hyp(H) "as" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) simple_intropattern(I4) + simple_intropattern(I5) := + invert_tactic H (fun H => inverts keep H as I1 I2 I3 I4 I5). +Tactic Notation "inverts" hyp(H) "as" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) simple_intropattern(I4) + simple_intropattern(I5) simple_intropattern(I6) := + invert_tactic H (fun H => inverts keep H as I1 I2 I3 I4 I5 I6). + +(** [inverts H as] performs an inversion on hypothesis [H], substitutes + generated equalities, and put in the goal the other freshly-created + hypotheses, for the user to name explicitly. + [inverts keep H as] is the same except that it does not clear [H]. + --TODO: reimplement [inverts] above using this one *) + +Ltac inverts_as_tactic H := + let rec go tt := + match goal with + | |- (ltac_Mark -> _) => intros _ + | |- (?x = ?y -> _) => let H := fresh "TEMP" in intro H; + first [ subst x | subst y ]; + go tt + | |- (existT ?P ?p ?x = existT ?P ?p ?y -> _) => + let H := fresh "TEMP" in intro H; + generalize (@inj_pair2 _ P p x y H); + clear H; go tt + | |- (forall _, _) => + intro; let H := get_last_hyp tt in mark_to_generalize H; go tt + end in + pose ltac_mark; inversion H; + generalize ltac_mark; gen_until_mark; + go tt; gen_to_generalize; unfolds ltac_to_generalize; + unfold eq' in *. + +Tactic Notation "inverts" "keep" hyp(H) "as" := + inverts_as_tactic H. + +Tactic Notation "inverts" hyp(H) "as" := + inverts_as_tactic H; clear H. + +Tactic Notation "inverts" hyp(H) "as" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) simple_intropattern(I4) + simple_intropattern(I5) simple_intropattern(I6) simple_intropattern(I7) := + inverts H as; introv I1 I2 I3 I4 I5 I6 I7. +Tactic Notation "inverts" hyp(H) "as" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) simple_intropattern(I4) + simple_intropattern(I5) simple_intropattern(I6) simple_intropattern(I7) + simple_intropattern(I8) := + inverts H as; introv I1 I2 I3 I4 I5 I6 I7 I8. + + +(** [lets_inverts E as I1 .. IN] is intuitively equivalent to + [inverts E], with the difference that it applies to any + expression and not just to the name of an hypothesis. *) + +Ltac lets_inverts_base E cont := + let H := fresh "TEMP" in lets H: E; try cont H. + +Tactic Notation "lets_inverts" constr(E) := + lets_inverts_base E ltac:(fun H => inverts H). +Tactic Notation "lets_inverts" constr(E) "as" simple_intropattern(I1) := + lets_inverts_base E ltac:(fun H => inverts H as I1). +Tactic Notation "lets_inverts" constr(E) "as" simple_intropattern(I1) + simple_intropattern(I2) := + lets_inverts_base E ltac:(fun H => inverts H as I1 I2). +Tactic Notation "lets_inverts" constr(E) "as" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) := + lets_inverts_base E ltac:(fun H => inverts H as I1 I2 I3). +Tactic Notation "lets_inverts" constr(E) "as" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) simple_intropattern(I4) := + lets_inverts_base E ltac:(fun H => inverts H as I1 I2 I3 I4). + + + +(* ---------------------------------------------------------------------- *) +(** ** Injection with substitution *) + +(** Underlying implementation of [injects] *) + +Ltac injects_tactic H := + let rec go _ := + match goal with + | |- (ltac_Mark -> _) => intros _ + | |- (?x = ?y -> _) => let H := fresh "TEMP" in intro H; + first [ subst x | subst y | idtac ]; + go tt + end in + generalize ltac_mark; injection H; go tt. + +(** [injects keep H] takes an hypothesis [H] of the form + [C a1 .. aN = C b1 .. bN] and substitute all equalities + [ai = bi] that have been generated. *) + +Tactic Notation "injects" "keep" hyp(H) := + injects_tactic H. + +(** [injects H] is similar to [injects keep H] but clears + the hypothesis [H]. *) + +Tactic Notation "injects" hyp(H) := + injects_tactic H; clear H. + +(** [inject H as X1 .. XN] is the same as [injection] + followed by [intros X1 .. XN] *) + +Tactic Notation "inject" hyp(H) := + injection H. +Tactic Notation "inject" hyp(H) "as" ident(X1) := + injection H; intros X1. +Tactic Notation "inject" hyp(H) "as" ident(X1) ident(X2) := + injection H; intros X1 X2. +Tactic Notation "inject" hyp(H) "as" ident(X1) ident(X2) ident(X3) := + injection H; intros X1 X2 X3. +Tactic Notation "inject" hyp(H) "as" ident(X1) ident(X2) ident(X3) + ident(X4) := + injection H; intros X1 X2 X3 X4. +Tactic Notation "inject" hyp(H) "as" ident(X1) ident(X2) ident(X3) + ident(X4) ident(X5) := + injection H; intros X1 X2 X3 X4 X5. + + +(* ---------------------------------------------------------------------- *) +(** ** Inversion and injection with substitution --rough implementation *) + +(** The tactics [inversions] and [injections] provided in this section + are similar to [inverts] and [injects] except that they perform + substitution on all equalities from the context and not only + the ones freshly generated. The counterpart is that they have + simpler implementations. + + DEPRECATED: these tactics should no longer be used. *) + +(** [inversions keep H] is the same as [inversions H] but it does + not clear hypothesis [H]. *) + +Tactic Notation "inversions" "keep" hyp(H) := + inversion H; subst. + +(** [inversions H] is a shortcut for [inversion H] followed by [subst] + and [clear H]. + It is a rough implementation of [inverts keep H] which behave + badly when the proof context already contains equalities. + It is provided in case the better implementation turns out to be + too slow. *) + +Tactic Notation "inversions" hyp(H) := + inversion H; subst; try clear H. + +(** [injections keep H] is the same as [injection H] followed + by [intros] and [subst]. It is a rough implementation of + [injects keep H] which behave + badly when the proof context already contains equalities, + or when the goal starts with a forall or an implication. *) + +Tactic Notation "injections" "keep" hyp(H) := + injection H; intros; subst. + +(** [injections H] is the same as [injection H] followed + by [clear H] and [intros] and [subst]. It is a rough + implementation of [injects keep H] which behave + badly when the proof context already contains equalities, + or when the goal starts with a forall or an implication. *) + +Tactic Notation "injections" "keep" hyp(H) := + injection H; clear H; intros; subst. + + +(* ---------------------------------------------------------------------- *) +(** ** Case analysis *) + +(** [cases] is similar to [case_eq E] except that it generates the + equality in the context and not in the goal, and generates the + equality the other way round. The syntax [cases E as H] + allows specifying the name [H] of that hypothesis. *) + +Tactic Notation "cases" constr(E) "as" ident(H) := + let X := fresh "TEMP" in + set (X := E) in *; def_to_eq_sym X H E; + destruct X. + +Tactic Notation "cases" constr(E) := + let H := fresh "Eq" in cases E as H. + +(** [case_if_post H] is to be defined later as a tactic to clean + up hypothesis [H] and the goal. + By defaults, it looks for obvious contradictions. + Currently, this tactic is extended in LibReflect to clean up + boolean propositions. *) + +Ltac case_if_post H := + tryfalse. + +(** [case_if] looks for a pattern of the form [if ?B then ?E1 else ?E2] + in the goal, and perform a case analysis on [B] by calling + [destruct B]. Subgoals containing a contradiction are discarded. + [case_if] looks in the goal first, and otherwise in the + first hypothesis that contains an [if] statement. + [case_if in H] can be used to specify which hypothesis to consider. + Syntaxes [case_if as Eq] and [case_if in H as Eq] allows to name + the hypothesis coming from the case analysis. *) + +Ltac case_if_on_tactic_core E Eq := + match type of E with + | {_}+{_} => destruct E as [Eq | Eq] + | _ => let X := fresh "TEMP" in + sets_eq <- X Eq: E; + destruct X + end. + +Ltac case_if_on_tactic E Eq := + case_if_on_tactic_core E Eq; case_if_post Eq. + +Tactic Notation "case_if_on" constr(E) "as" simple_intropattern(Eq) := + case_if_on_tactic E Eq. + +Tactic Notation "case_if" "as" simple_intropattern(Eq) := + match goal with + | |- context [if ?B then _ else _] => case_if_on B as Eq + | K: context [if ?B then _ else _] |- _ => case_if_on B as Eq + end. + +Tactic Notation "case_if" "in" hyp(H) "as" simple_intropattern(Eq) := + match type of H with context [if ?B then _ else _] => + case_if_on B as Eq end. + +Tactic Notation "case_if" := + let Eq := fresh "C" in case_if as Eq. + +Tactic Notation "case_if" "in" hyp(H) := + let Eq := fresh "C" in case_if in H as Eq. + + +(** [cases_if] is similar to [case_if] with two main differences: + if it creates an equality of the form [x = y] and then + substitutes it in the goal *) + +Ltac cases_if_on_tactic_core E Eq := + match type of E with + | {_}+{_} => destruct E as [Eq|Eq]; try subst_hyp Eq + | _ => let X := fresh "TEMP" in + sets_eq <- X Eq: E; + destruct X + end. + +Ltac cases_if_on_tactic E Eq := + cases_if_on_tactic_core E Eq; tryfalse; case_if_post Eq. + +Tactic Notation "cases_if_on" constr(E) "as" simple_intropattern(Eq) := + cases_if_on_tactic E Eq. + +Tactic Notation "cases_if" "as" simple_intropattern(Eq) := + match goal with + | |- context [if ?B then _ else _] => cases_if_on B as Eq + | K: context [if ?B then _ else _] |- _ => cases_if_on B as Eq + end. + +Tactic Notation "cases_if" "in" hyp(H) "as" simple_intropattern(Eq) := + match type of H with context [if ?B then _ else _] => + cases_if_on B as Eq end. + +Tactic Notation "cases_if" := + let Eq := fresh "C" in cases_if as Eq. + +Tactic Notation "cases_if" "in" hyp(H) := + let Eq := fresh "C" in cases_if in H as Eq. + +(** [case_ifs] is like [repeat case_if] *) + +Ltac case_ifs_core := + repeat case_if. + +Tactic Notation "case_ifs" := + case_ifs_core. + +(** [destruct_if] looks for a pattern of the form [if ?B then ?E1 else ?E2] + in the goal, and perform a case analysis on [B] by calling + [destruct B]. It looks in the goal first, and otherwise in the + first hypothesis that contains an [if] statement. *) + +Ltac destruct_if_post := tryfalse. + +Tactic Notation "destruct_if" + "as" simple_intropattern(Eq1) simple_intropattern(Eq2) := + match goal with + | |- context [if ?B then _ else _] => destruct B as [Eq1|Eq2] + | K: context [if ?B then _ else _] |- _ => destruct B as [Eq1|Eq2] + end; + destruct_if_post. + +Tactic Notation "destruct_if" "in" hyp(H) + "as" simple_intropattern(Eq1) simple_intropattern(Eq2) := + match type of H with context [if ?B then _ else _] => + destruct B as [Eq1|Eq2] end; + destruct_if_post. + +Tactic Notation "destruct_if" "as" simple_intropattern(Eq) := + destruct_if as Eq Eq. +Tactic Notation "destruct_if" "in" hyp(H) "as" simple_intropattern(Eq) := + destruct_if in H as Eq Eq. + +Tactic Notation "destruct_if" := + let Eq := fresh "C" in destruct_if as Eq Eq. +Tactic Notation "destruct_if" "in" hyp(H) := + let Eq := fresh "C" in destruct_if in H as Eq Eq. + + +(** ---BROKEN since v8.5beta2. TODO: cleanup. + + [destruct_head_match] performs a case analysis on the argument + of the head pattern matching when the goal has the form + [match ?E with ...] or [match ?E with ... = _] or + [_ = match ?E with ...]. Due to the limits of Ltac, this tactic + will not fail if a match does not occur. Instead, it might + perform a case analysis on an unspecified subterm from the goal. + Warning: experimental. *) + +Ltac find_head_match T := + match T with context [?E] => + match T with + | E => fail 1 + | _ => constr:(E) + end + end. + +Ltac destruct_head_match_core cont := + match goal with + | |- ?T1 = ?T2 => first [ let E := find_head_match T1 in cont E + | let E := find_head_match T2 in cont E ] + | |- ?T1 => let E := find_head_match T1 in cont E + end; + destruct_if_post. + +Tactic Notation "destruct_head_match" "as" simple_intropattern(I) := + destruct_head_match_core ltac:(fun E => destruct E as I). + +Tactic Notation "destruct_head_match" := + destruct_head_match_core ltac:(fun E => destruct E). + + +(**--provided for compatibility with [remember] *) + +(** [cases' E] is similar to [case_eq E] except that it generates the + equality in the context and not in the goal. The syntax [cases' E as H] + allows specifying the name [H] of that hypothesis. *) + +Tactic Notation "cases'" constr(E) "as" ident(H) := + let X := fresh "TEMP" in + set (X := E) in *; def_to_eq X H E; + destruct X. + +Tactic Notation "cases'" constr(E) := + let x := fresh "Eq" in cases' E as H. + +(** [cases_if'] is similar to [cases_if] except that it generates + the symmetric equality. *) + +Ltac cases_if_on' E Eq := + match type of E with + | {_}+{_} => destruct E as [Eq|Eq]; try subst_hyp Eq + | _ => let X := fresh "TEMP" in + sets_eq X Eq: E; + destruct X + end; case_if_post Eq. + +Tactic Notation "cases_if'" "as" simple_intropattern(Eq) := + match goal with + | |- context [if ?B then _ else _] => cases_if_on' B Eq + | K: context [if ?B then _ else _] |- _ => cases_if_on' B Eq + end. + +Tactic Notation "cases_if'" := + let Eq := fresh "C" in cases_if' as Eq. + + +(* ********************************************************************** *) +(** * Induction *) + +(** [inductions E] is a shorthand for [dependent induction E]. + [inductions E gen X1 .. XN] is a shorthand for + [dependent induction E generalizing X1 .. XN]. *) + +Require Import Coq.Program.Equality. + +Ltac inductions_post := + unfold eq' in *. + +Tactic Notation "inductions" ident(E) := + dependent induction E; inductions_post. +Tactic Notation "inductions" ident(E) "gen" ident(X1) := + dependent induction E generalizing X1; inductions_post. +Tactic Notation "inductions" ident(E) "gen" ident(X1) ident(X2) := + dependent induction E generalizing X1 X2; inductions_post. +Tactic Notation "inductions" ident(E) "gen" ident(X1) ident(X2) + ident(X3) := + dependent induction E generalizing X1 X2 X3; inductions_post. +Tactic Notation "inductions" ident(E) "gen" ident(X1) ident(X2) + ident(X3) ident(X4) := + dependent induction E generalizing X1 X2 X3 X4; inductions_post. +Tactic Notation "inductions" ident(E) "gen" ident(X1) ident(X2) + ident(X3) ident(X4) ident(X5) := + dependent induction E generalizing X1 X2 X3 X4 X5; inductions_post. +Tactic Notation "inductions" ident(E) "gen" ident(X1) ident(X2) + ident(X3) ident(X4) ident(X5) ident(X6) := + dependent induction E generalizing X1 X2 X3 X4 X5 X6; inductions_post. +Tactic Notation "inductions" ident(E) "gen" ident(X1) ident(X2) + ident(X3) ident(X4) ident(X5) ident(X6) ident(X7) := + dependent induction E generalizing X1 X2 X3 X4 X5 X6 X7; inductions_post. +Tactic Notation "inductions" ident(E) "gen" ident(X1) ident(X2) + ident(X3) ident(X4) ident(X5) ident(X6) ident(X7) ident(X8) := + dependent induction E generalizing X1 X2 X3 X4 X5 X6 X7 X8; inductions_post. + +(** [induction_wf IH: E X] is used to apply the well-founded induction + principle, for a given well-founded relation. It applies to a goal + [PX] where [PX] is a proposition on [X]. First, it sets up the + goal in the form [(fun a => P a) X], using [pattern X], and then + it applies the well-founded induction principle instantiated on [E]. + + Here [E] may be either: + - a proof of [wf R] for [R] of type [A->A->Prop] + - a binary relation of type [A->A->Prop] + - a measure of type [A -> nat] // only when LibWf is used + + Syntaxes [induction_wf: E X] and [induction_wf E X]. *) + +(* DEPRECATED +Tactic Notation "induction_wf" ident(IH) ":" constr(E) ident(X) := + pattern X; apply (well_founded_ind E); clear X; intros X IH. +*) + +(* Tactic is later extended in module LibWf *) +Ltac induction_wf_core_then IH E X cont := + let T := type of E in + let T := eval hnf in T in + let clearX tt := + first [ clear X | fail 3 "the variable on which the induction is done appears in the hypotheses" ] in + match T with + (* Support for measures from LibWf, add this: + | ?A -> nat => + induction_wf_core_then IH (wf_measure E) X cont + *) + | ?A -> ?A -> Prop => + pattern X; + first [ + applys well_founded_ind E; + clearX tt; + [ (* Support for [wf] from LibWf + change well_founded with wf; auto with wf *) + | intros X IH; cont tt ] + | fail 2 ] + | _ => + pattern X; + applys well_founded_ind E; + clearX tt; + intros X IH; + cont tt + end. + +Ltac induction_wf_core IH E X := + induction_wf_core_then IH E X ltac:(fun _ => idtac). + +Tactic Notation "induction_wf" ident(IH) ":" constr(E) ident(X) := + induction_wf_core IH E X. +Tactic Notation "induction_wf" ":" constr(E) ident(X) := + let IH := fresh "IH" in induction_wf IH: E X. +Tactic Notation "induction_wf" ":" constr(E) ident(X) := + induction_wf: E X. + +(** Induction on the height of a derivation: the helper tactic + [induct_height] helps proving the equivalence of the auxiliary + judgment that includes a counter for the maximal height + (see LibTacticsDemos for an example) *) + +Require Import Coq.Arith.Compare_dec. +Require Import Lia. + +Lemma induct_height_max2 : forall n1 n2 : nat, + exists n, n1 < n /\ n2 < n. +Proof using. + intros. destruct (lt_dec n1 n2). + exists (S n2). lia. + exists (S n1). lia. +Qed. + +Ltac induct_height_step x := + match goal with + | H: exists _, _ |- _ => + let n := fresh "n" in let y := fresh "x" in + destruct H as [n ?]; + forwards (y&?&?): induct_height_max2 n x; + induct_height_step y + | _ => exists (S x); eauto + end. + +Ltac induct_height := induct_height_step O. + + +(* ********************************************************************** *) +(** * Coinduction *) + +(** Tactic [cofixs IH] is like [cofix IH] except that the + coinduction hypothesis is tagged in the form [IH: COIND P] + instead of being just [IH: P]. This helps other tactics + clearing the coinduction hypothesis using [clear_coind] *) + +Definition COIND (P:Prop) := P. + +Tactic Notation "cofixs" ident(IH) := + cofix IH; + match type of IH with ?P => change P with (COIND P) in IH end. + +(** Tactic [clear_coind] clears all the coinduction hypotheses, + assuming that they have been tagged *) + +Ltac clear_coind := + repeat match goal with H: COIND _ |- _ => clear H end. + +(** Tactic [abstracts tac] is like [abstract tac] except that + it clears the coinduction hypotheses so that the productivity + check will be happy. For example, one can use [abstracts omega] + to obtain the same behavior as [omega] but with an auxiliary + lemma being generated. *) + +Tactic Notation "abstracts" tactic(tac) := + clear_coind; tac. + + + +(* ********************************************************************** *) +(** * Decidable equality *) + +(** [decides_equality] is the same as [decide equality] excepts that it + is able to unfold definitions at head of the current goal. *) + +Ltac decides_equality_tactic := + first [ decide equality | progress(unfolds); decides_equality_tactic ]. + +Tactic Notation "decides_equality" := + decides_equality_tactic. + + +(* ********************************************************************** *) +(** * Equivalence *) + +(** [iff H] can be used to prove an equivalence [P <-> Q] and name [H] + the hypothesis obtained in each case. The syntaxes [iff] and [iff H1 H2] + are also available to specify zero or two names. The tactic [iff <- H] + swaps the two subgoals, i.e. produces (Q -> P) as first subgoal. *) + +Lemma iff_intro_swap : forall (P Q : Prop), + (Q -> P) -> (P -> Q) -> (P <-> Q). +Proof using. intuition. Qed. + +Tactic Notation "iff" simple_intropattern(H1) simple_intropattern(H2) := + split; [ intros H1 | intros H2 ]. +Tactic Notation "iff" simple_intropattern(H) := + iff H H. +Tactic Notation "iff" := + let H := fresh "H" in iff H. + +Tactic Notation "iff" "<-" simple_intropattern(H1) simple_intropattern(H2) := + apply iff_intro_swap; [ intros H1 | intros H2 ]. +Tactic Notation "iff" "<-" simple_intropattern(H) := + iff <- H H. +Tactic Notation "iff" "<-" := + let H := fresh "H" in iff <- H. + + +(* ********************************************************************** *) +(** * N-ary Conjunctions and Disjunctions *) + +(* ---------------------------------------------------------------------- *) +(** N-ary Conjunctions Splitting in Goals *) + +(** Underlying implementation of [splits]. *) + +Ltac splits_tactic N := + match N with + | O => fail + | S O => idtac + | S ?N' => split; [| splits_tactic N'] + end. + +Ltac unfold_goal_until_conjunction := + match goal with + | |- _ /\ _ => idtac + | _ => progress(unfolds); unfold_goal_until_conjunction + end. + +Ltac get_term_conjunction_arity T := + match T with + | _ /\ _ /\ _ /\ _ /\ _ /\ _ /\ _ /\ _ => constr:(8) + | _ /\ _ /\ _ /\ _ /\ _ /\ _ /\ _ => constr:(7) + | _ /\ _ /\ _ /\ _ /\ _ /\ _ => constr:(6) + | _ /\ _ /\ _ /\ _ /\ _ => constr:(5) + | _ /\ _ /\ _ /\ _ => constr:(4) + | _ /\ _ /\ _ => constr:(3) + | _ /\ _ => constr:(2) + | _ -> ?T' => get_term_conjunction_arity T' + | _ => let P := get_head T in + let T' := eval unfold P in T in + match T' with + | T => fail 1 + | _ => get_term_conjunction_arity T' + end + (* --TODO: warning this can loop... *) + end. + +Ltac get_goal_conjunction_arity := + match goal with |- ?T => get_term_conjunction_arity T end. + +(** [splits] applies to a goal of the form [(T1 /\ .. /\ TN)] and + destruct it into [N] subgoals [T1] .. [TN]. If the goal is not a + conjunction, then it unfolds the head definition. *) + +Tactic Notation "splits" := + unfold_goal_until_conjunction; + let N := get_goal_conjunction_arity in + splits_tactic N. + +(** [splits N] is similar to [splits], except that it will unfold as many + definitions as necessary to obtain an [N]-ary conjunction. *) + +Tactic Notation "splits" constr(N) := + let N := number_to_nat N in + splits_tactic N. + + +(* ---------------------------------------------------------------------- *) +(** N-ary Conjunctions Deconstruction *) + +(** Underlying implementation of [destructs]. *) + +Ltac destructs_conjunction_tactic N T := + match N with + | 2 => destruct T as [? ?] + | 3 => destruct T as [? [? ?]] + | 4 => destruct T as [? [? [? ?]]] + | 5 => destruct T as [? [? [? [? ?]]]] + | 6 => destruct T as [? [? [? [? [? ?]]]]] + | 7 => destruct T as [? [? [? [? [? [? ?]]]]]] + end. + +(** [destructs T] allows destructing a term [T] which is a N-ary + conjunction. It is equivalent to [destruct T as (H1 .. HN)], + except that it does not require to manually specify N different + names. *) + +Tactic Notation "destructs" constr(T) := + let TT := type of T in + let N := get_term_conjunction_arity TT in + destructs_conjunction_tactic N T. + +(** [destructs N T] is equivalent to [destruct T as (H1 .. HN)], + except that it does not require to manually specify N different + names. Remark that it is not restricted to N-ary conjunctions. *) + +Tactic Notation "destructs" constr(N) constr(T) := + let N := number_to_nat N in + destructs_conjunction_tactic N T. + + +(* ---------------------------------------------------------------------- *) +(** Proving goals which are N-ary disjunctions *) + +(** Underlying implementation of [branch]. *) + +Ltac branch_tactic K N := + match constr:((K,N)) with + | (_,0) => fail 1 + | (0,_) => fail 1 + | (1,1) => idtac + | (1,_) => left + | (S ?K', S ?N') => right; branch_tactic K' N' + end. + +Ltac unfold_goal_until_disjunction := + match goal with + | |- _ \/ _ => idtac + | _ => progress(unfolds); unfold_goal_until_disjunction + end. + +Ltac get_term_disjunction_arity T := + match T with + | _ \/ _ \/ _ \/ _ \/ _ \/ _ \/ _ \/ _ => constr:(8) + | _ \/ _ \/ _ \/ _ \/ _ \/ _ \/ _ => constr:(7) + | _ \/ _ \/ _ \/ _ \/ _ \/ _ => constr:(6) + | _ \/ _ \/ _ \/ _ \/ _ => constr:(5) + | _ \/ _ \/ _ \/ _ => constr:(4) + | _ \/ _ \/ _ => constr:(3) + | _ \/ _ => constr:(2) + | _ -> ?T' => get_term_disjunction_arity T' + | _ => let P := get_head T in + let T' := eval unfold P in T in + match T' with + | T => fail 1 + | _ => get_term_disjunction_arity T' + end + end. + +Ltac get_goal_disjunction_arity := + match goal with |- ?T => get_term_disjunction_arity T end. + +(** [branch N] applies to a goal of the form + [P1 \/ ... \/ PK \/ ... \/ PN] and leaves the goal [PK]. + It only able to unfold the head definition (if there is one), + but for more complex unfolding one should use the tactic + [branch K of N]. *) + +Tactic Notation "branch" constr(K) := + let K := number_to_nat K in + unfold_goal_until_disjunction; + let N := get_goal_disjunction_arity in + branch_tactic K N. + +(** [branch K of N] is similar to [branch K] except that the + arity of the disjunction [N] is given manually, and so this + version of the tactic is able to unfold definitions. + In other words, applies to a goal of the form + [P1 \/ ... \/ PK \/ ... \/ PN] and leaves the goal [PK]. *) + +Tactic Notation "branch" constr(K) "of" constr(N) := + let N := number_to_nat N in + let K := number_to_nat K in + branch_tactic K N. + + +(* ---------------------------------------------------------------------- *) +(** N-ary Disjunction Deconstruction *) + +(** Underlying implementation of [branches]. *) + +Ltac destructs_disjunction_tactic N T := + match N with + | 2 => destruct T as [? | ?] + | 3 => destruct T as [? | [? | ?]] + | 4 => destruct T as [? | [? | [? | ?]]] + | 5 => destruct T as [? | [? | [? | [? | ?]]]] + end. + +(** [branches T] allows destructing a term [T] which is a N-ary + disjunction. It is equivalent to [destruct T as [ H1 | .. | HN ] ], + and produces [N] subgoals corresponding to the [N] possible cases. *) + +Tactic Notation "branches" constr(T) := + let TT := type of T in + let N := get_term_disjunction_arity TT in + destructs_disjunction_tactic N T. + +(** [branches N T] is the same as [branches T] except that the arity is + forced to [N]. This version is useful to unfold definitions + on the fly. *) + +Tactic Notation "branches" constr(N) constr(T) := + let N := number_to_nat N in + destructs_disjunction_tactic N T. + +(** [branches] automatically finds a hypothesis [h] that is a disjunction + and destructs it. *) + +Tactic Notation "branches" := + match goal with h: _ \/ _ |- _ => branches h end. + +(* ---------------------------------------------------------------------- *) +(** N-ary Existentials *) + +(* Underlying implementation of [exists]. *) + +Ltac get_term_existential_arity T := + match T with + | exists x1 x2 x3 x4 x5 x6 x7 x8, _ => constr:(8) + | exists x1 x2 x3 x4 x5 x6 x7, _ => constr:(7) + | exists x1 x2 x3 x4 x5 x6, _ => constr:(6) + | exists x1 x2 x3 x4 x5, _ => constr:(5) + | exists x1 x2 x3 x4, _ => constr:(4) + | exists x1 x2 x3, _ => constr:(3) + | exists x1 x2, _ => constr:(2) + | exists x1, _ => constr:(1) + | _ -> ?T' => get_term_existential_arity T' + | _ => let P := get_head T in + let T' := eval unfold P in T in + match T' with + | T => fail 1 + | _ => get_term_existential_arity T' + end + end. + +Ltac get_goal_existential_arity := + match goal with |- ?T => get_term_existential_arity T end. + +(** [exists T1 ... TN] is a shorthand for [exists T1; ...; exists TN]. + It is intended to prove goals of the form [exist X1 .. XN, P]. + If an argument provided is [__] (double underscore), then an + evar is introduced. [exists T1 .. TN ___] is equivalent to + [exists T1 .. TN __ __ __] with as many [__] as possible. *) + +Tactic Notation "exists_original" constr(T1) := + exists T1. +Tactic Notation "exists" constr(T1) := + match T1 with + | ltac_wild => esplit + | ltac_wilds => repeat esplit + | _ => exists T1 + end. +Tactic Notation "exists" constr(T1) constr(T2) := + exists T1; exists T2. +Tactic Notation "exists" constr(T1) constr(T2) constr(T3) := + exists T1; exists T2; exists T3. +Tactic Notation "exists" constr(T1) constr(T2) constr(T3) constr(T4) := + exists T1; exists T2; exists T3; exists T4. +Tactic Notation "exists" constr(T1) constr(T2) constr(T3) constr(T4) + constr(T5) := + exists T1; exists T2; exists T3; exists T4; exists T5. +Tactic Notation "exists" constr(T1) constr(T2) constr(T3) constr(T4) + constr(T5) constr(T6) := + exists T1; exists T2; exists T3; exists T4; exists T5; exists T6. + +(** For compatibility with Coq syntax, [exists T1, .., TN] is also provided. *) + +Tactic Notation "exists" constr(T1) "," constr(T2) := + exists T1 T2. +Tactic Notation "exists" constr(T1) "," constr(T2) "," constr(T3) := + exists T1 T2 T3. +Tactic Notation "exists" constr(T1) "," constr(T2) "," constr(T3) "," constr(T4) := + exists T1 T2 T3 T4. +Tactic Notation "exists" constr(T1) "," constr(T2) "," constr(T3) "," constr(T4) "," + constr(T5) := + exists T1 T2 T3 T4 T5. +Tactic Notation "exists" constr(T1) "," constr(T2) "," constr(T3) "," constr(T4) "," + constr(T5) "," constr(T6) := + exists T1 T2 T3 T4 T5 T6. + +(* The tactic [exists___ N] is short for [exists __ ... __] + with [N] double-underscores. The tactic [exists] is equivalent + to calling [exists___ N], where the value of [N] is obtained + by counting the number of existentials syntactically present + at the head of the goal. The behaviour of [exists] differs + from that of [exists ___] is the case where the goal is a + definition which yields an existential only after unfolding. *) + +Tactic Notation "exists___" constr(N) := + let rec aux N := + match N with + | 0 => idtac + | S ?N' => esplit; aux N' + end in + let N := number_to_nat N in aux N. + + (* --TODO: deprecated *) +Tactic Notation "exists___" := + let N := get_goal_existential_arity in + exists___ N. + + (* --TODO: does not seem to work *) +Tactic Notation "exists" := + exists___. + + (* --TODO: [exists_all] is the new syntax for [exists___] *) +Tactic Notation "exists_all" := exists___. + +(* ---------------------------------------------------------------------- *) +(** Existentials and conjunctions in hypotheses *) + +(** [unpack] or [unpack H] destructs conjunctions and existentials in + all or one hypothesis. *) + +Ltac unpack_core := + repeat match goal with + | H: _ /\ _ |- _ => destruct H + | H: exists (varname: _), _ |- _ => + (* kludge to preserve the name of the quantified variable *) + let name := fresh varname in + destruct H as [name ?] + end. + +Ltac unpack_hypothesis H := + try match type of H with + | _ /\ _ => + let h1 := fresh "TEMP" in + let h2 := fresh "TEMP" in + destruct H as [ h1 h2 ]; + unpack_hypothesis h1; + unpack_hypothesis h2 + | exists (varname: _), _ => + (* kludge to preserve the name of the quantified variable *) + let name := fresh varname in + let body := fresh "TEMP" in + destruct H as [name body]; + unpack_hypothesis body + end. + +Tactic Notation "unpack" := + unpack_core. +Tactic Notation "unpack" constr(H) := + unpack_hypothesis H. + + +(* ********************************************************************** *) +(** * Tactics to prove typeclass instances *) + +(** [typeclass] is an automation tactic specialized for finding + typeclass instances. *) + +Tactic Notation "typeclass" := + let go _ := eauto with typeclass_instances in + solve [ go tt | constructor; go tt ]. + +(** [solve_typeclass] is a simpler version of [typeclass], to use + in hint tactics for resolving instances *) + +Tactic Notation "solve_typeclass" := + solve [ eauto with typeclass_instances ]. + + +(* ********************************************************************** *) +(** * Tactics to invoke automation *) + + +(* ---------------------------------------------------------------------- *) +(** ** Definitions for parsing compatibility *) + +Tactic Notation "f_equal" := + f_equal. +Tactic Notation "constructor" := + constructor. +Tactic Notation "simple" := + simpl. + +Tactic Notation "split" := + split. + +Tactic Notation "right" := + right. +Tactic Notation "left" := + left. + + +(* ---------------------------------------------------------------------- *) +(** ** [hint] to add hints local to a lemma *) + +(** [hint E] adds [E] as an hypothesis so that automation can use it. + Syntax [hint E1,..,EN] is available *) + +Tactic Notation "hint" constr(E) := + let H := fresh "Hint" in lets H: E. +Tactic Notation "hint" constr(E1) "," constr(E2) := + hint E1; hint E2. +Tactic Notation "hint" constr(E1) "," constr(E2) "," constr(E3) := + hint E1; hint E2; hint(E3). +Tactic Notation "hint" constr(E1) "," constr(E2) "," constr(E3) "," constr(E4) := + hint E1; hint E2; hint(E3); hint(E4 ). + + +(* ---------------------------------------------------------------------- *) +(** ** [jauto], a new automation tactics *) + +(** [jauto] is better at [intuition eauto] because it can open existentials + from the context. In the same time, [jauto] can be faster than + [intuition eauto] because it does not destruct disjunctions from the + context. The strategy of [jauto] can be summarized as follows: + - open all the existentials and conjunctions from the context + - call esplit and split on the existentials and conjunctions in the goal + - call eauto. *) + +Tactic Notation "jauto" := + try solve [ jauto_set; eauto ]. + +Tactic Notation "jauto_fast" := + try solve [ auto | eauto | jauto ]. + +(** [iauto] is a shorthand for [intuition eauto] *) + +Tactic Notation "iauto" := try solve [intuition eauto]. + + +(* ---------------------------------------------------------------------- *) +(** ** Definitions of automation tactics *) + +(** The two following tactics defined the default behaviour of + "light automation" and "strong automation". These tactics + may be redefined at any time using the syntax [Ltac .. ::= ..]. *) + +(** [auto_tilde] is the tactic which will be called each time a symbol + [~] is used after a tactic. *) + +Ltac auto_tilde_default := auto. +Ltac auto_tilde := auto_tilde_default. + +(** [auto_star] is the tactic which will be called each time a symbol + [*] is used after a tactic. *) + +Ltac auto_star_default := try solve [ auto | eauto | intuition eauto ]. + (* --TODO: should be jauto *) +Ltac auto_star := auto_star_default. + + +(** [autos~] is a notation for tactic [auto_tilde]. It may be followed + by lemmas (or proofs terms) which auto will be able to use + for solving the goal. *) +(** [autos] is an alias for [autos~] *) + +Tactic Notation "autos" := + auto_tilde. +Tactic Notation "autos" "~" := + auto_tilde. +Tactic Notation "autos" "~" constr(E1) := + lets: E1; auto_tilde. +Tactic Notation "autos" "~" constr(E1) constr(E2) := + lets: E1; lets: E2; auto_tilde. +Tactic Notation "autos" "~" constr(E1) constr(E2) constr(E3) := + lets: E1; lets: E2; lets: E3; auto_tilde. + +(** [autos*] is a notation for tactic [auto_star]. It may be followed + by lemmas (or proofs terms) which auto will be able to use + for solving the goal. *) + +Tactic Notation "autos" "*" := + auto_star. +Tactic Notation "autos" "*" constr(E1) := + lets: E1; auto_star. +Tactic Notation "autos" "*" constr(E1) constr(E2) := + lets: E1; lets: E2; auto_star. +Tactic Notation "autos" "*" constr(E1) constr(E2) constr(E3) := + lets: E1; lets: E2; lets: E3; auto_star. + +(** [auto_false] is a version of [auto] able to spot some contradictions. + There is an ad-hoc support for goals in [<->]: split is called first. + [auto_false~] and [auto_false*] are also available. *) + +Ltac auto_false_base cont := + try solve [ + intros_all; try match goal with |- _ <-> _ => split end; + solve [ cont tt | intros_all; false; cont tt ] ]. + +Tactic Notation "auto_false" := + auto_false_base ltac:(fun tt => auto). +Tactic Notation "auto_false" "~" := + auto_false_base ltac:(fun tt => auto_tilde). +Tactic Notation "auto_false" "*" := + auto_false_base ltac:(fun tt => auto_star). + +Tactic Notation "dauto" := + dintuition eauto. + + + +(* ---------------------------------------------------------------------- *) +(** ** Parsing for light automation *) + +(** Any tactic followed by the symbol [~] will have [auto_tilde] called + on all of its subgoals. Three exceptions: + - [cuts] and [asserts] only call [auto] on their first subgoal, + - [apply~] relies on [sapply] rather than [apply], + - [tryfalse~] is defined as [tryfalse by auto_tilde]. + + Some builtin tactics are not defined using tactic notations + and thus cannot be extended, e.g. [simpl] and [unfold]. + For these, notation such as [simpl~] will not be available. *) + +Tactic Notation "equates" "~" constr(E) := + equates E; auto_tilde. +Tactic Notation "equates" "~" constr(n1) constr(n2) := + equates n1 n2; auto_tilde. +Tactic Notation "equates" "~" constr(n1) constr(n2) constr(n3) := + equates n1 n2 n3; auto_tilde. +Tactic Notation "equates" "~" constr(n1) constr(n2) constr(n3) constr(n4) := + equates n1 n2 n3 n4; auto_tilde. + +Tactic Notation "applys_eq" "~" constr(H) constr(E) := + applys_eq H E; auto_tilde. +Tactic Notation "applys_eq" "~" constr(H) constr(n1) constr(n2) := + applys_eq H n1 n2; auto_tilde. +Tactic Notation "applys_eq" "~" constr(H) constr(n1) constr(n2) constr(n3) := + applys_eq H n1 n2 n3; auto_tilde. +Tactic Notation "applys_eq" "~" constr(H) constr(n1) constr(n2) constr(n3) constr(n4) := + applys_eq H n1 n2 n3 n4; auto_tilde. + +Tactic Notation "apply" "~" constr(H) := + sapply H; auto_tilde. + +Tactic Notation "destruct" "~" constr(H) := + destruct H; auto_tilde. +Tactic Notation "destruct" "~" constr(H) "as" simple_intropattern(I) := + destruct H as I; auto_tilde. +Tactic Notation "f_equal" "~" := + f_equal; auto_tilde. +Tactic Notation "induction" "~" constr(H) := + induction H; auto_tilde. +Tactic Notation "inversion" "~" constr(H) := + inversion H; auto_tilde. +Tactic Notation "split" "~" := + split; auto_tilde. +Tactic Notation "subst" "~" := + subst; auto_tilde. +Tactic Notation "right" "~" := + right; auto_tilde. +Tactic Notation "left" "~" := + left; auto_tilde. +Tactic Notation "constructor" "~" := + constructor; auto_tilde. +Tactic Notation "constructors" "~" := + constructors; auto_tilde. + +Tactic Notation "false" "~" := + false; auto_tilde. +Tactic Notation "false" "~" constr(E) := + false_then E ltac:(fun _ => auto_tilde). +Tactic Notation "false" "~" constr(E0) constr(E1) := + false~ (>> E0 E1). +Tactic Notation "false" "~" constr(E0) constr(E1) constr(E2) := + false~ (>> E0 E1 E2). +Tactic Notation "false" "~" constr(E0) constr(E1) constr(E2) constr(E3) := + false~ (>> E0 E1 E2 E3). +Tactic Notation "false" "~" constr(E0) constr(E1) constr(E2) constr(E3) constr(E4) := + false~ (>> E0 E1 E2 E3 E4). +Tactic Notation "tryfalse" "~" := + try solve [ false~ ]. + +Tactic Notation "asserts" "~" simple_intropattern(H) ":" constr(E) := + asserts H: E; [ auto_tilde | idtac ]. +Tactic Notation "asserts" "~" ":" constr(E) := + let H := fresh "H" in asserts~ H: E. +Tactic Notation "cuts" "~" simple_intropattern(H) ":" constr(E) := + cuts H: E; [ auto_tilde | idtac ]. +Tactic Notation "cuts" "~" ":" constr(E) := + cuts: E; [ auto_tilde | idtac ]. + +Tactic Notation "lets" "~" simple_intropattern(I) ":" constr(E) := + lets I: E; auto_tilde. +Tactic Notation "lets" "~" simple_intropattern(I) ":" constr(E0) + constr(A1) := + lets I: E0 A1; auto_tilde. +Tactic Notation "lets" "~" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) := + lets I: E0 A1 A2; auto_tilde. +Tactic Notation "lets" "~" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) constr(A3) := + lets I: E0 A1 A2 A3; auto_tilde. +Tactic Notation "lets" "~" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) := + lets I: E0 A1 A2 A3 A4; auto_tilde. +Tactic Notation "lets" "~" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + lets I: E0 A1 A2 A3 A4 A5; auto_tilde. + +Tactic Notation "lets" "~" ":" constr(E) := + lets: E; auto_tilde. +Tactic Notation "lets" "~" ":" constr(E0) + constr(A1) := + lets: E0 A1; auto_tilde. +Tactic Notation "lets" "~" ":" constr(E0) + constr(A1) constr(A2) := + lets: E0 A1 A2; auto_tilde. +Tactic Notation "lets" "~" ":" constr(E0) + constr(A1) constr(A2) constr(A3) := + lets: E0 A1 A2 A3; auto_tilde. +Tactic Notation "lets" "~" ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) := + lets: E0 A1 A2 A3 A4; auto_tilde. +Tactic Notation "lets" "~" ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + lets: E0 A1 A2 A3 A4 A5; auto_tilde. + +Tactic Notation "forwards" "~" simple_intropattern(I) ":" constr(E) := + forwards I: E; auto_tilde. +Tactic Notation "forwards" "~" simple_intropattern(I) ":" constr(E0) + constr(A1) := + forwards I: E0 A1; auto_tilde. +Tactic Notation "forwards" "~" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) := + forwards I: E0 A1 A2; auto_tilde. +Tactic Notation "forwards" "~" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) constr(A3) := + forwards I: E0 A1 A2 A3; auto_tilde. +Tactic Notation "forwards" "~" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) := + forwards I: E0 A1 A2 A3 A4; auto_tilde. +Tactic Notation "forwards" "~" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + forwards I: E0 A1 A2 A3 A4 A5; auto_tilde. + +Tactic Notation "forwards" "~" ":" constr(E) := + forwards: E; auto_tilde. +Tactic Notation "forwards" "~" ":" constr(E0) + constr(A1) := + forwards: E0 A1; auto_tilde. +Tactic Notation "forwards" "~" ":" constr(E0) + constr(A1) constr(A2) := + forwards: E0 A1 A2; auto_tilde. +Tactic Notation "forwards" "~" ":" constr(E0) + constr(A1) constr(A2) constr(A3) := + forwards: E0 A1 A2 A3; auto_tilde. +Tactic Notation "forwards" "~" ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) := + forwards: E0 A1 A2 A3 A4; auto_tilde. +Tactic Notation "forwards" "~" ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + forwards: E0 A1 A2 A3 A4 A5; auto_tilde. + +Tactic Notation "applys" "~" constr(H) := + sapply H; auto_tilde. (*todo?*) +Tactic Notation "applys" "~" constr(E0) constr(A1) := + applys E0 A1; auto_tilde. +Tactic Notation "applys" "~" constr(E0) constr(A1) := + applys E0 A1; auto_tilde. +Tactic Notation "applys" "~" constr(E0) constr(A1) constr(A2) := + applys E0 A1 A2; auto_tilde. +Tactic Notation "applys" "~" constr(E0) constr(A1) constr(A2) constr(A3) := + applys E0 A1 A2 A3; auto_tilde. +Tactic Notation "applys" "~" constr(E0) constr(A1) constr(A2) constr(A3) constr(A4) := + applys E0 A1 A2 A3 A4; auto_tilde. +Tactic Notation "applys" "~" constr(E0) constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + applys E0 A1 A2 A3 A4 A5; auto_tilde. + +Tactic Notation "specializes" "~" hyp(H) := + specializes H; auto_tilde. +Tactic Notation "specializes" "~" hyp(H) constr(A1) := + specializes H A1; auto_tilde. +Tactic Notation "specializes" hyp(H) constr(A1) constr(A2) := + specializes H A1 A2; auto_tilde. +Tactic Notation "specializes" hyp(H) constr(A1) constr(A2) constr(A3) := + specializes H A1 A2 A3; auto_tilde. +Tactic Notation "specializes" hyp(H) constr(A1) constr(A2) constr(A3) constr(A4) := + specializes H A1 A2 A3 A4; auto_tilde. +Tactic Notation "specializes" hyp(H) constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + specializes H A1 A2 A3 A4 A5; auto_tilde. + +Tactic Notation "fapply" "~" constr(E) := + fapply E; auto_tilde. +Tactic Notation "sapply" "~" constr(E) := + sapply E; auto_tilde. + +Tactic Notation "logic" "~" constr(E) := + logic_base E ltac:(fun _ => auto_tilde). + +Tactic Notation "intros_all" "~" := + intros_all; auto_tilde. + +Tactic Notation "unfolds" "~" := + unfolds; auto_tilde. +Tactic Notation "unfolds" "~" constr(F1) := + unfolds F1; auto_tilde. +Tactic Notation "unfolds" "~" constr(F1) "," constr(F2) := + unfolds F1, F2; auto_tilde. +Tactic Notation "unfolds" "~" constr(F1) "," constr(F2) "," constr(F3) := + unfolds F1, F2, F3; auto_tilde. +Tactic Notation "unfolds" "~" constr(F1) "," constr(F2) "," constr(F3) "," + constr(F4) := + unfolds F1, F2, F3, F4; auto_tilde. + +Tactic Notation "simple" "~" := + simpl; auto_tilde. +Tactic Notation "simple" "~" "in" hyp(H) := + simpl in H; auto_tilde. +Tactic Notation "simpls" "~" := + simpls; auto_tilde. +Tactic Notation "hnfs" "~" := + hnfs; auto_tilde. +Tactic Notation "hnfs" "~" "in" hyp(H) := + hnf in H; auto_tilde. +Tactic Notation "substs" "~" := + substs; auto_tilde. +Tactic Notation "intro_hyp" "~" hyp(H) := + subst_hyp H; auto_tilde. +Tactic Notation "intro_subst" "~" := + intro_subst; auto_tilde. +Tactic Notation "subst_eq" "~" constr(E) := + subst_eq E; auto_tilde. + +Tactic Notation "rewrite" "~" constr(E) := + rewrite E; auto_tilde. +Tactic Notation "rewrite" "~" "<-" constr(E) := + rewrite <- E; auto_tilde. +Tactic Notation "rewrite" "~" constr(E) "in" hyp(H) := + rewrite E in H; auto_tilde. +Tactic Notation "rewrite" "~" "<-" constr(E) "in" hyp(H) := + rewrite <- E in H; auto_tilde. + +Tactic Notation "rewrites" "~" constr(E) := + rewrites E; auto_tilde. +Tactic Notation "rewrites" "~" constr(E) "in" hyp(H) := + rewrites E in H; auto_tilde. +Tactic Notation "rewrites" "~" constr(E) "in" "*" := + rewrites E in *; auto_tilde. +Tactic Notation "rewrites" "~" "<-" constr(E) := + rewrites <- E; auto_tilde. +Tactic Notation "rewrites" "~" "<-" constr(E) "in" hyp(H) := + rewrites <- E in H; auto_tilde. +Tactic Notation "rewrites" "~" "<-" constr(E) "in" "*" := + rewrites <- E in *; auto_tilde. + +Tactic Notation "rewrite_all" "~" constr(E) := + rewrite_all E; auto_tilde. +Tactic Notation "rewrite_all" "~" "<-" constr(E) := + rewrite_all <- E; auto_tilde. +Tactic Notation "rewrite_all" "~" constr(E) "in" ident(H) := + rewrite_all E in H; auto_tilde. +Tactic Notation "rewrite_all" "~" "<-" constr(E) "in" ident(H) := + rewrite_all <- E in H; auto_tilde. +Tactic Notation "rewrite_all" "~" constr(E) "in" "*" := + rewrite_all E in *; auto_tilde. +Tactic Notation "rewrite_all" "~" "<-" constr(E) "in" "*" := + rewrite_all <- E in *; auto_tilde. + +Tactic Notation "asserts_rewrite" "~" constr(E) := + asserts_rewrite E; auto_tilde. +Tactic Notation "asserts_rewrite" "~" "<-" constr(E) := + asserts_rewrite <- E; auto_tilde. +Tactic Notation "asserts_rewrite" "~" constr(E) "in" hyp(H) := + asserts_rewrite E in H; auto_tilde. +Tactic Notation "asserts_rewrite" "~" "<-" constr(E) "in" hyp(H) := + asserts_rewrite <- E in H; auto_tilde. +Tactic Notation "asserts_rewrite" "~" constr(E) "in" "*" := + asserts_rewrite E in *; auto_tilde. +Tactic Notation "asserts_rewrite" "~" "<-" constr(E) "in" "*" := + asserts_rewrite <- E in *; auto_tilde. + +Tactic Notation "cuts_rewrite" "~" constr(E) := + cuts_rewrite E; auto_tilde. +Tactic Notation "cuts_rewrite" "~" "<-" constr(E) := + cuts_rewrite <- E; auto_tilde. +Tactic Notation "cuts_rewrite" "~" constr(E) "in" hyp(H) := + cuts_rewrite E in H; auto_tilde. +Tactic Notation "cuts_rewrite" "~" "<-" constr(E) "in" hyp(H) := + cuts_rewrite <- E in H; auto_tilde. + +Tactic Notation "erewrite" "~" constr(E) := + erewrite E; auto_tilde. + +Tactic Notation "fequal" "~" := + fequal; auto_tilde. +Tactic Notation "fequals" "~" := + fequals; auto_tilde. +Tactic Notation "pi_rewrite" "~" constr(E) := + pi_rewrite E; auto_tilde. +Tactic Notation "pi_rewrite" "~" constr(E) "in" hyp(H) := + pi_rewrite E in H; auto_tilde. + +Tactic Notation "invert" "~" hyp(H) := + invert H; auto_tilde. +Tactic Notation "inverts" "~" hyp(H) := + inverts H; auto_tilde. +Tactic Notation "inverts" "~" hyp(E) "as" := + inverts E as; auto_tilde. +Tactic Notation "injects" "~" hyp(H) := + injects H; auto_tilde. +Tactic Notation "inversions" "~" hyp(H) := + inversions H; auto_tilde. + +Tactic Notation "cases" "~" constr(E) "as" ident(H) := + cases E as H; auto_tilde. +Tactic Notation "cases" "~" constr(E) := + cases E; auto_tilde. +Tactic Notation "case_if" "~" := + case_if; auto_tilde. +Tactic Notation "case_ifs" "~" := + case_ifs; auto_tilde. +Tactic Notation "case_if" "~" "in" hyp(H) := + case_if in H; auto_tilde. +Tactic Notation "cases_if" "~" := + cases_if; auto_tilde. +Tactic Notation "cases_if" "~" "in" hyp(H) := + cases_if in H; auto_tilde. +Tactic Notation "destruct_if" "~" := + destruct_if; auto_tilde. +Tactic Notation "destruct_if" "~" "in" hyp(H) := + destruct_if in H; auto_tilde. +Tactic Notation "destruct_head_match" "~" := + destruct_head_match; auto_tilde. + +Tactic Notation "cases'" "~" constr(E) "as" ident(H) := + cases' E as H; auto_tilde. +Tactic Notation "cases'" "~" constr(E) := + cases' E; auto_tilde. +Tactic Notation "cases_if'" "~" "as" ident(H) := + cases_if' as H; auto_tilde. +Tactic Notation "cases_if'" "~" := + cases_if'; auto_tilde. + +Tactic Notation "decides_equality" "~" := + decides_equality; auto_tilde. + +Tactic Notation "iff" "~" := + iff; auto_tilde. +Tactic Notation "iff" "~" simple_intropattern(I) := + iff I; auto_tilde. +Tactic Notation "splits" "~" := + splits; auto_tilde. +Tactic Notation "splits" "~" constr(N) := + splits N; auto_tilde. + +Tactic Notation "destructs" "~" constr(T) := + destructs T; auto_tilde. +Tactic Notation "destructs" "~" constr(N) constr(T) := + destructs N T; auto_tilde. + +Tactic Notation "branch" "~" constr(N) := + branch N; auto_tilde. +Tactic Notation "branch" "~" constr(K) "of" constr(N) := + branch K of N; auto_tilde. + +Tactic Notation "branches" "~" := + branches; auto_tilde. +Tactic Notation "branches" "~" constr(T) := + branches T; auto_tilde. +Tactic Notation "branches" "~" constr(N) constr(T) := + branches N T; auto_tilde. + +Tactic Notation "exists" "~" := + exists; auto_tilde. +Tactic Notation "exists___" "~" := + exists___; auto_tilde. +Tactic Notation "exists" "~" constr(T1) := + exists T1; auto_tilde. +Tactic Notation "exists" "~" constr(T1) constr(T2) := + exists T1 T2; auto_tilde. +Tactic Notation "exists" "~" constr(T1) constr(T2) constr(T3) := + exists T1 T2 T3; auto_tilde. +Tactic Notation "exists" "~" constr(T1) constr(T2) constr(T3) constr(T4) := + exists T1 T2 T3 T4; auto_tilde. +Tactic Notation "exists" "~" constr(T1) constr(T2) constr(T3) constr(T4) + constr(T5) := + exists T1 T2 T3 T4 T5; auto_tilde. +Tactic Notation "exists" "~" constr(T1) constr(T2) constr(T3) constr(T4) + constr(T5) constr(T6) := + exists T1 T2 T3 T4 T5 T6; auto_tilde. + +Tactic Notation "exists" "~" constr(T1) "," constr(T2) := + exists T1 T2; auto_tilde. +Tactic Notation "exists" "~" constr(T1) "," constr(T2) "," constr(T3) := + exists T1 T2 T3; auto_tilde. +Tactic Notation "exists" "~" constr(T1) "," constr(T2) "," constr(T3) "," + constr(T4) := + exists T1 T2 T3 T4; auto_tilde. +Tactic Notation "exists" "~" constr(T1) "," constr(T2) "," constr(T3) "," + constr(T4) "," constr(T5) := + exists T1 T2 T3 T4 T5; auto_tilde. +Tactic Notation "exists" "~" constr(T1) "," constr(T2) "," constr(T3) "," + constr(T4) "," constr(T5) "," constr(T6) := + exists T1 T2 T3 T4 T5 T6; auto_tilde. + + +(* ---------------------------------------------------------------------- *) +(** ** Parsing for strong automation *) + +(** Any tactic followed by the symbol [*] will have [auto*] called + on all of its subgoals. The exceptions to these rules are the + same as for light automation. + + Exception: use [subs*] instead of [subst*] if you + import the library [Coq.Classes.Equivalence]. *) + +Tactic Notation "equates" "*" constr(E) := + equates E; auto_star. +Tactic Notation "equates" "*" constr(n1) constr(n2) := + equates n1 n2; auto_star. +Tactic Notation "equates" "*" constr(n1) constr(n2) constr(n3) := + equates n1 n2 n3; auto_star. +Tactic Notation "equates" "*" constr(n1) constr(n2) constr(n3) constr(n4) := + equates n1 n2 n3 n4; auto_star. + +Tactic Notation "applys_eq" "*" constr(H) constr(E) := + applys_eq H E; auto_star. +Tactic Notation "applys_eq" "*" constr(H) constr(n1) constr(n2) := + applys_eq H n1 n2; auto_star. +Tactic Notation "applys_eq" "*" constr(H) constr(n1) constr(n2) constr(n3) := + applys_eq H n1 n2 n3; auto_star. +Tactic Notation "applys_eq" "*" constr(H) constr(n1) constr(n2) constr(n3) constr(n4) := + applys_eq H n1 n2 n3 n4; auto_star. + +Tactic Notation "apply" "*" constr(H) := + sapply H; auto_star. + +Tactic Notation "destruct" "*" constr(H) := + destruct H; auto_star. +Tactic Notation "destruct" "*" constr(H) "as" simple_intropattern(I) := + destruct H as I; auto_star. +Tactic Notation "f_equal" "*" := + f_equal; auto_star. +Tactic Notation "induction" "*" constr(H) := + induction H; auto_star. +Tactic Notation "inversion" "*" constr(H) := + inversion H; auto_star. +Tactic Notation "split" "*" := + split; auto_star. +Tactic Notation "subs" "*" := + subst; auto_star. +Tactic Notation "subst" "*" := + subst; auto_star. +Tactic Notation "right" "*" := + right; auto_star. +Tactic Notation "left" "*" := + left; auto_star. +Tactic Notation "constructor" "*" := + constructor; auto_star. +Tactic Notation "constructors" "*" := + constructors; auto_star. + +Tactic Notation "false" "*" := + false; auto_star. +Tactic Notation "false" "*" constr(E) := + false_then E ltac:(fun _ => auto_star). +Tactic Notation "false" "*" constr(E0) constr(E1) := + false* (>> E0 E1). +Tactic Notation "false" "*" constr(E0) constr(E1) constr(E2) := + false* (>> E0 E1 E2). +Tactic Notation "false" "*" constr(E0) constr(E1) constr(E2) constr(E3) := + false* (>> E0 E1 E2 E3). +Tactic Notation "false" "*" constr(E0) constr(E1) constr(E2) constr(E3) constr(E4) := + false* (>> E0 E1 E2 E3 E4). +Tactic Notation "tryfalse" "*" := + try solve [ false* ]. + +Tactic Notation "asserts" "*" simple_intropattern(H) ":" constr(E) := + asserts H: E; [ auto_star | idtac ]. +Tactic Notation "asserts" "*" ":" constr(E) := + let H := fresh "H" in asserts* H: E. +Tactic Notation "cuts" "*" simple_intropattern(H) ":" constr(E) := + cuts H: E; [ auto_star | idtac ]. +Tactic Notation "cuts" "*" ":" constr(E) := + cuts: E; [ auto_star | idtac ]. + +Tactic Notation "lets" "*" simple_intropattern(I) ":" constr(E) := + lets I: E; auto_star. +Tactic Notation "lets" "*" simple_intropattern(I) ":" constr(E0) + constr(A1) := + lets I: E0 A1; auto_star. +Tactic Notation "lets" "*" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) := + lets I: E0 A1 A2; auto_star. +Tactic Notation "lets" "*" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) constr(A3) := + lets I: E0 A1 A2 A3; auto_star. +Tactic Notation "lets" "*" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) := + lets I: E0 A1 A2 A3 A4; auto_star. +Tactic Notation "lets" "*" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + lets I: E0 A1 A2 A3 A4 A5; auto_star. + +Tactic Notation "lets" "*" ":" constr(E) := + lets: E; auto_star. +Tactic Notation "lets" "*" ":" constr(E0) + constr(A1) := + lets: E0 A1; auto_star. +Tactic Notation "lets" "*" ":" constr(E0) + constr(A1) constr(A2) := + lets: E0 A1 A2; auto_star. +Tactic Notation "lets" "*" ":" constr(E0) + constr(A1) constr(A2) constr(A3) := + lets: E0 A1 A2 A3; auto_star. +Tactic Notation "lets" "*" ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) := + lets: E0 A1 A2 A3 A4; auto_star. +Tactic Notation "lets" "*" ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + lets: E0 A1 A2 A3 A4 A5; auto_star. + +Tactic Notation "forwards" "*" simple_intropattern(I) ":" constr(E) := + forwards I: E; auto_star. +Tactic Notation "forwards" "*" simple_intropattern(I) ":" constr(E0) + constr(A1) := + forwards I: E0 A1; auto_star. +Tactic Notation "forwards" "*" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) := + forwards I: E0 A1 A2; auto_star. +Tactic Notation "forwards" "*" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) constr(A3) := + forwards I: E0 A1 A2 A3; auto_star. +Tactic Notation "forwards" "*" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) := + forwards I: E0 A1 A2 A3 A4; auto_star. +Tactic Notation "forwards" "*" simple_intropattern(I) ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + forwards I: E0 A1 A2 A3 A4 A5; auto_star. + +Tactic Notation "forwards" "*" ":" constr(E) := + forwards: E; auto_star. +Tactic Notation "forwards" "*" ":" constr(E0) + constr(A1) := + forwards: E0 A1; auto_star. +Tactic Notation "forwards" "*" ":" constr(E0) + constr(A1) constr(A2) := + forwards: E0 A1 A2; auto_star. +Tactic Notation "forwards" "*" ":" constr(E0) + constr(A1) constr(A2) constr(A3) := + forwards: E0 A1 A2 A3; auto_star. +Tactic Notation "forwards" "*" ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) := + forwards: E0 A1 A2 A3 A4; auto_star. +Tactic Notation "forwards" "*" ":" constr(E0) + constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + forwards: E0 A1 A2 A3 A4 A5; auto_star. + +Tactic Notation "applys" "*" constr(H) := + sapply H; auto_star. (*todo?*) +Tactic Notation "applys" "*" constr(E0) constr(A1) := + applys E0 A1; auto_star. +Tactic Notation "applys" "*" constr(E0) constr(A1) := + applys E0 A1; auto_star. +Tactic Notation "applys" "*" constr(E0) constr(A1) constr(A2) := + applys E0 A1 A2; auto_star. +Tactic Notation "applys" "*" constr(E0) constr(A1) constr(A2) constr(A3) := + applys E0 A1 A2 A3; auto_star. +Tactic Notation "applys" "*" constr(E0) constr(A1) constr(A2) constr(A3) constr(A4) := + applys E0 A1 A2 A3 A4; auto_star. +Tactic Notation "applys" "*" constr(E0) constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + applys E0 A1 A2 A3 A4 A5; auto_star. + +Tactic Notation "specializes" "*" hyp(H) := + specializes H; auto_star. +Tactic Notation "specializes" "~" hyp(H) constr(A1) := + specializes H A1; auto_star. +Tactic Notation "specializes" hyp(H) constr(A1) constr(A2) := + specializes H A1 A2; auto_star. +Tactic Notation "specializes" hyp(H) constr(A1) constr(A2) constr(A3) := + specializes H A1 A2 A3; auto_star. +Tactic Notation "specializes" hyp(H) constr(A1) constr(A2) constr(A3) constr(A4) := + specializes H A1 A2 A3 A4; auto_star. +Tactic Notation "specializes" hyp(H) constr(A1) constr(A2) constr(A3) constr(A4) constr(A5) := + specializes H A1 A2 A3 A4 A5; auto_star. + + +Tactic Notation "fapply" "*" constr(E) := + fapply E; auto_star. +Tactic Notation "sapply" "*" constr(E) := + sapply E; auto_star. + +Tactic Notation "logic" constr(E) := + logic_base E ltac:(fun _ => auto_star). + +Tactic Notation "intros_all" "*" := + intros_all; auto_star. + +Tactic Notation "unfolds" "*" := + unfolds; auto_star. +Tactic Notation "unfolds" "*" constr(F1) := + unfolds F1; auto_star. +Tactic Notation "unfolds" "*" constr(F1) "," constr(F2) := + unfolds F1, F2; auto_star. +Tactic Notation "unfolds" "*" constr(F1) "," constr(F2) "," constr(F3) := + unfolds F1, F2, F3; auto_star. +Tactic Notation "unfolds" "*" constr(F1) "," constr(F2) "," constr(F3) "," + constr(F4) := + unfolds F1, F2, F3, F4; auto_star. + +Tactic Notation "simple" "*" := + simpl; auto_star. +Tactic Notation "simple" "*" "in" hyp(H) := + simpl in H; auto_star. +Tactic Notation "simpls" "*" := + simpls; auto_star. +Tactic Notation "hnfs" "*" := + hnfs; auto_star. +Tactic Notation "hnfs" "*" "in" hyp(H) := + hnf in H; auto_star. +Tactic Notation "substs" "*" := + substs; auto_star. +Tactic Notation "intro_hyp" "*" hyp(H) := + subst_hyp H; auto_star. +Tactic Notation "intro_subst" "*" := + intro_subst; auto_star. +Tactic Notation "subst_eq" "*" constr(E) := + subst_eq E; auto_star. + +Tactic Notation "rewrite" "*" constr(E) := + rewrite E; auto_star. +Tactic Notation "rewrite" "*" "<-" constr(E) := + rewrite <- E; auto_star. +Tactic Notation "rewrite" "*" constr(E) "in" hyp(H) := + rewrite E in H; auto_star. +Tactic Notation "rewrite" "*" "<-" constr(E) "in" hyp(H) := + rewrite <- E in H; auto_star. + +Tactic Notation "rewrites" "*" constr(E) := + rewrites E; auto_star. +Tactic Notation "rewrites" "*" constr(E) "in" hyp(H):= + rewrites E in H; auto_star. +Tactic Notation "rewrites" "*" constr(E) "in" "*":= + rewrites E in *; auto_star. +Tactic Notation "rewrites" "*" "<-" constr(E) := + rewrites <- E; auto_star. +Tactic Notation "rewrites" "*" "<-" constr(E) "in" hyp(H):= + rewrites <- E in H; auto_star. +Tactic Notation "rewrites" "*" "<-" constr(E) "in" "*":= + rewrites <- E in *; auto_star. + +Tactic Notation "rewrite_all" "*" constr(E) := + rewrite_all E; auto_star. +Tactic Notation "rewrite_all" "*" "<-" constr(E) := + rewrite_all <- E; auto_star. +Tactic Notation "rewrite_all" "*" constr(E) "in" ident(H) := + rewrite_all E in H; auto_star. +Tactic Notation "rewrite_all" "*" "<-" constr(E) "in" ident(H) := + rewrite_all <- E in H; auto_star. +Tactic Notation "rewrite_all" "*" constr(E) "in" "*" := + rewrite_all E in *; auto_star. +Tactic Notation "rewrite_all" "*" "<-" constr(E) "in" "*" := + rewrite_all <- E in *; auto_star. + +Tactic Notation "asserts_rewrite" "*" constr(E) := + asserts_rewrite E; auto_star. +Tactic Notation "asserts_rewrite" "*" "<-" constr(E) := + asserts_rewrite <- E; auto_star. +Tactic Notation "asserts_rewrite" "*" constr(E) "in" hyp(H) := + asserts_rewrite E; auto_star. +Tactic Notation "asserts_rewrite" "*" "<-" constr(E) "in" hyp(H) := + asserts_rewrite <- E; auto_star. +Tactic Notation "asserts_rewrite" "*" constr(E) "in" "*" := + asserts_rewrite E in *; auto_tilde. +Tactic Notation "asserts_rewrite" "*" "<-" constr(E) "in" "*" := + asserts_rewrite <- E in *; auto_tilde. + +Tactic Notation "cuts_rewrite" "*" constr(E) := + cuts_rewrite E; auto_star. +Tactic Notation "cuts_rewrite" "*" "<-" constr(E) := + cuts_rewrite <- E; auto_star. +Tactic Notation "cuts_rewrite" "*" constr(E) "in" hyp(H) := + cuts_rewrite E in H; auto_star. +Tactic Notation "cuts_rewrite" "*" "<-" constr(E) "in" hyp(H) := + cuts_rewrite <- E in H; auto_star. + +Tactic Notation "erewrite" "*" constr(E) := + erewrite E; auto_star. + +Tactic Notation "fequal" "*" := + fequal; auto_star. +Tactic Notation "fequals" "*" := + fequals; auto_star. +Tactic Notation "pi_rewrite" "*" constr(E) := + pi_rewrite E; auto_star. +Tactic Notation "pi_rewrite" "*" constr(E) "in" hyp(H) := + pi_rewrite E in H; auto_star. + +Tactic Notation "invert" "*" hyp(H) := + invert H; auto_star. +Tactic Notation "inverts" "*" hyp(H) := + inverts H; auto_star. +Tactic Notation "inverts" "*" hyp(E) "as" := + inverts E as; auto_star. +Tactic Notation "injects" "*" hyp(H) := + injects H; auto_star. +Tactic Notation "inversions" "*" hyp(H) := + inversions H; auto_star. + +Tactic Notation "cases" "*" constr(E) "as" ident(H) := + cases E as H; auto_star. +Tactic Notation "cases" "*" constr(E) := + cases E; auto_star. +Tactic Notation "case_if" "*" := + case_if; auto_star. +Tactic Notation "case_ifs" "*" := + case_ifs; auto_star. +Tactic Notation "case_if" "*" "in" hyp(H) := + case_if in H; auto_star. +Tactic Notation "cases_if" "*" := + cases_if; auto_star. +Tactic Notation "cases_if" "*" "in" hyp(H) := + cases_if in H; auto_star. + Tactic Notation "destruct_if" "*" := + destruct_if; auto_star. +Tactic Notation "destruct_if" "*" "in" hyp(H) := + destruct_if in H; auto_star. +Tactic Notation "destruct_head_match" "*" := + destruct_head_match; auto_star. + +Tactic Notation "cases'" "*" constr(E) "as" ident(H) := + cases' E as H; auto_star. +Tactic Notation "cases'" "*" constr(E) := + cases' E; auto_star. +Tactic Notation "cases_if'" "*" "as" ident(H) := + cases_if' as H; auto_star. +Tactic Notation "cases_if'" "*" := + cases_if'; auto_star. + + +Tactic Notation "decides_equality" "*" := + decides_equality; auto_star. + +Tactic Notation "iff" "*" := + iff; auto_star. +Tactic Notation "iff" "*" simple_intropattern(I) := + iff I; auto_star. +Tactic Notation "splits" "*" := + splits; auto_star. +Tactic Notation "splits" "*" constr(N) := + splits N; auto_star. + +Tactic Notation "destructs" "*" constr(T) := + destructs T; auto_star. +Tactic Notation "destructs" "*" constr(N) constr(T) := + destructs N T; auto_star. + +Tactic Notation "branch" "*" constr(N) := + branch N; auto_star. +Tactic Notation "branch" "*" constr(K) "of" constr(N) := + branch K of N; auto_star. + +Tactic Notation "branches" "*" constr(T) := + branches T; auto_star. +Tactic Notation "branches" "*" constr(N) constr(T) := + branches N T; auto_star. + +Tactic Notation "exists" "*" := + exists; auto_star. +Tactic Notation "exists___" "*" := + exists___; auto_star. +Tactic Notation "exists" "*" constr(T1) := + exists T1; auto_star. +Tactic Notation "exists" "*" constr(T1) constr(T2) := + exists T1 T2; auto_star. +Tactic Notation "exists" "*" constr(T1) constr(T2) constr(T3) := + exists T1 T2 T3; auto_star. +Tactic Notation "exists" "*" constr(T1) constr(T2) constr(T3) constr(T4) := + exists T1 T2 T3 T4; auto_star. +Tactic Notation "exists" "*" constr(T1) constr(T2) constr(T3) constr(T4) + constr(T5) := + exists T1 T2 T3 T4 T5; auto_star. +Tactic Notation "exists" "*" constr(T1) constr(T2) constr(T3) constr(T4) + constr(T5) constr(T6) := + exists T1 T2 T3 T4 T5 T6; auto_star. + +Tactic Notation "exists" "*" constr(T1) "," constr(T2) := + exists T1 T2; auto_star. +Tactic Notation "exists" "*" constr(T1) "," constr(T2) "," constr(T3) := + exists T1 T2 T3; auto_star. +Tactic Notation "exists" "*" constr(T1) "," constr(T2) "," constr(T3) "," + constr(T4) := + exists T1 T2 T3 T4; auto_star. +Tactic Notation "exists" "*" constr(T1) "," constr(T2) "," constr(T3) "," + constr(T4) "," constr(T5) := + exists T1 T2 T3 T4 T5; auto_star. +Tactic Notation "exists" "*" constr(T1) "," constr(T2) "," constr(T3) "," + constr(T4) "," constr(T5) "," constr(T6) := + exists T1 T2 T3 T4 T5 T6; auto_star. + + + +(* ********************************************************************** *) +(** * Tactics to sort out the proof context *) + +(* ---------------------------------------------------------------------- *) +(** ** Hiding hypotheses *) + +(* Implementation *) + +Definition ltac_something (P:Type) (e:P) := e. + +Notation "'Something'" := + (@ltac_something _ _). + +Lemma ltac_something_eq : forall (e:Type), + e = (@ltac_something _ e). +Proof using. auto. Qed. + +Lemma ltac_something_hide : forall (e:Type), + e -> (@ltac_something _ e). +Proof using. auto. Qed. + +Lemma ltac_something_show : forall (e:Type), + (@ltac_something _ e) -> e. +Proof using. auto. Qed. + +(** [hide_def x] and [show_def x] can be used to hide/show + the body of the definition [x]. *) + +Tactic Notation "hide_def" hyp(x) := + let x' := constr:(x) in + let T := eval unfold x in x' in + change T with (@ltac_something _ T) in x. + +Tactic Notation "show_def" hyp(x) := + let x' := constr:(x) in + let U := eval unfold x in x' in + match U with @ltac_something _ ?T => + change U with T in x end. + +(** [show_def] unfolds [Something] in the goal *) + +Tactic Notation "show_def" := + unfold ltac_something. +Tactic Notation "show_def" "in" hyp(H) := + unfold ltac_something in H. +Tactic Notation "show_def" "in" "*" := + unfold ltac_something in *. + +(** [hide_defs] and [show_defs] applies to all definitions *) + +Tactic Notation "hide_defs" := + repeat match goal with H := ?T |- _ => + match T with + | @ltac_something _ _ => fail 1 + | _ => change T with (@ltac_something _ T) in H + end + end. + +Tactic Notation "show_defs" := + repeat match goal with H := (@ltac_something _ ?T) |- _ => + change (@ltac_something _ T) with T in H end. + + +(** [hide_hyp H] replaces the type of [H] with the notation [Something] + and [show_hyp H] reveals the type of the hypothesis. Note that the + hidden type of [H] remains convertible the real type of [H]. *) + +Tactic Notation "show_hyp" hyp(H) := + apply ltac_something_show in H. + +Tactic Notation "hide_hyp" hyp(H) := + apply ltac_something_hide in H. + +(** [hide_hyps] and [show_hyps] can be used to hide/show all hypotheses + of type [Prop]. *) + +Tactic Notation "show_hyps" := + repeat match goal with + H: @ltac_something _ _ |- _ => show_hyp H end. + +Tactic Notation "hide_hyps" := + repeat match goal with H: ?T |- _ => + match type of T with + | Prop => + match T with + | @ltac_something _ _ => fail 2 + | _ => hide_hyp H + end + | _ => fail 1 + end + end. + +(** [hide H] and [show H] automatically select between + [hide_hyp] or [hide_def], and [show_hyp] or [show_def]. + Similarly [hide_all] and [show_all] apply to all. *) + +Tactic Notation "hide" hyp(H) := + first [hide_def H | hide_hyp H]. + +Tactic Notation "show" hyp(H) := + first [show_def H | show_hyp H]. + +Tactic Notation "hide_all" := + hide_hyps; hide_defs. + +Tactic Notation "show_all" := + unfold ltac_something in *. + +(** [hide_term E] can be used to hide a term from the goal. + [show_term] or [show_term E] can be used to reveal it. + [hide_term E in H] can be used to specify an hypothesis. *) + +Tactic Notation "hide_term" constr(E) := + change E with (@ltac_something _ E). +Tactic Notation "show_term" constr(E) := + change (@ltac_something _ E) with E. +Tactic Notation "show_term" := + unfold ltac_something. + +Tactic Notation "hide_term" constr(E) "in" hyp(H) := + change E with (@ltac_something _ E) in H. +Tactic Notation "show_term" constr(E) "in" hyp(H) := + change (@ltac_something _ E) with E in H. +Tactic Notation "show_term" "in" hyp(H) := + unfold ltac_something in H. + +(** [show_unfold R] unfolds the definition of [R] and + reveals the hidden definition of R. --todo:test, + and implement using unfold simply *) + (* --TODO: change "unfolds" *) + +Tactic Notation "show_unfold" constr(R1) := + unfold R1; show_def. +Tactic Notation "show_unfold" constr(R1) "," constr(R2) := + unfold R1, R2; show_def. + +(* ---------------------------------------------------------------------- *) +(** ** Sorting hypotheses *) + +(** [sort] sorts out hypotheses from the context by moving all the + propositions (hypotheses of type Prop) to the bottom of the context. *) + +Ltac sort_tactic := + try match goal with H: ?T |- _ => + match type of T with Prop => + generalizes H; (try sort_tactic); intro + end end. + +Tactic Notation "sort" := + sort_tactic. + + +(* ---------------------------------------------------------------------- *) +(** ** Clearing hypotheses *) + +(** [clears X1 ... XN] is a variation on [clear] which clears + the variables [X1]..[XN] as well as all the hypotheses which + depend on them. Contrary to [clear], it never fails. *) + +Tactic Notation "clears" ident(X1) := + let rec doit _ := + match goal with + | H:context[X1] |- _ => clear H; try (doit tt) + | _ => clear X1 + end in doit tt. +Tactic Notation "clears" ident(X1) ident(X2) := + clears X1; clears X2. +Tactic Notation "clears" ident(X1) ident(X2) ident(X3) := + clears X1; clears X2; clears X3. +Tactic Notation "clears" ident(X1) ident(X2) ident(X3) ident(X4) := + clears X1; clears X2; clears X3; clears X4. +Tactic Notation "clears" ident(X1) ident(X2) ident(X3) ident(X4) + ident(X5) := + clears X1; clears X2; clears X3; clears X4; clears X5. +Tactic Notation "clears" ident(X1) ident(X2) ident(X3) ident(X4) + ident(X5) ident(X6) := + clears X1; clears X2; clears X3; clears X4; clears X5; clears X6. + +(** [clears] (without any argument) clears all the unused variables + from the context. In other words, it removes any variable + which is not a proposition (i.e. not of type Prop) and which + does not appear in another hypothesis nor in the goal. *) + (* --TODO: rename to clears_var ? *) + +Ltac clears_tactic := + match goal with H: ?T |- _ => + match type of T with + | Prop => generalizes H; (try clears_tactic); intro + | ?TT => clear H; (try clears_tactic) + | ?TT => generalizes H; (try clears_tactic); intro + end end. + +Tactic Notation "clears" := + clears_tactic. + +(** [clears_all] clears all the hypotheses from the context + that can be cleared. It leaves only the hypotheses that + are mentioned in the goal. *) + +Ltac clears_or_generalizes_all_core := + repeat match goal with H: _ |- _ => + first [ clear H | generalizes H] end. + +Tactic Notation "clears_all" := + generalize ltac_mark; + clears_or_generalizes_all_core; + intro_until_mark. + +(** [clears_but H1 H2 .. HN] clears all hypotheses except the + one that are mentioned and those that cannot be cleared. *) + +Ltac clears_but_core cont := + generalize ltac_mark; + cont tt; + clears_or_generalizes_all_core; + intro_until_mark. + +Tactic Notation "clears_but" := + clears_but_core ltac:(fun _ => idtac). +Tactic Notation "clears_but" ident(H1) := + clears_but_core ltac:(fun _ => gen H1). +Tactic Notation "clears_but" ident(H1) ident(H2) := + clears_but_core ltac:(fun _ => gen H1 H2). +Tactic Notation "clears_but" ident(H1) ident(H2) ident(H3) := + clears_but_core ltac:(fun _ => gen H1 H2 H3). +Tactic Notation "clears_but" ident(H1) ident(H2) ident(H3) ident(H4) := + clears_but_core ltac:(fun _ => gen H1 H2 H3 H4). +Tactic Notation "clears_but" ident(H1) ident(H2) ident(H3) ident(H4) ident(H5) := + clears_but_core ltac:(fun _ => gen H1 H2 H3 H4 H5). + +Lemma demo_clears_all_and_clears_but : + forall x y:nat, y < 2 -> x = x -> x >= 2 -> x < 3 -> True. +Proof using. + introv M1 M2 M3. dup 6. + (* [clears_all] clears all hypotheses. *) + clears_all. auto. + (* [clears_but H] clears all but [H] *) + clears_but M3. auto. + clears_but y. auto. + clears_but x. auto. + clears_but M2 M3. auto. + clears_but x y. auto. +Qed. + +(** [clears_last] clears the last hypothesis in the context. + [clears_last N] clears the last [N] hypotheses in the context. *) + +Tactic Notation "clears_last" := + match goal with H: ?T |- _ => clear H end. + +Ltac clears_last_base N := + match number_to_nat N with + | 0 => idtac + | S ?p => clears_last; clears_last_base p + end. + +Tactic Notation "clears_last" constr(N) := + clears_last_base N. + + +(* ********************************************************************** *) +(** * Tactics for development purposes *) + +(* ---------------------------------------------------------------------- *) +(** ** Skipping subgoals *) + +(** The [skip] tactic can be used at any time to admit the current + goal. Unlike [admit], it does not require ending the proof with + [Admitted] instead of [Qed]. It thus saves the pain of renaming [Qed] + into [Admitted] and vice-versa all the time. + + The implementation of [skip] relies on an axiom [False]. + To obtain a safe development, it suffices to replace [False] with [True] + in the statement of that axiom. + + Note that it is still necessary to instantiate all the existential + variables introduced by other tactics in order for [Qed] to be accepted. +*) + +(** To obtain a safe development, change to [skip_axiom : True] *) +Axiom skip_axiom : False. + +Ltac skip_with_axiom := + exfalso; apply skip_axiom. + +Tactic Notation "skip" := + skip_with_axiom. + +(** To use traditional [admit] instead of [skip] in the tactics defined below, + uncomment the following definition, to bind [skip] to [admit]. *) +(* +Tactic Notation "skip" := + admit. +*) + +(** [demo] is like [admit] but it documents the fact that admit is intended *) + +Tactic Notation "demo" := + skip. + +(** [admits H: T] adds an assumption named [H] of type [T] to the + current context, blindly assuming that it is true. + [admit: T] is another possible syntax. + Note that H may be an intro pattern. *) + +Tactic Notation "admits" simple_intropattern(I) ":" constr(T) := + asserts I: T; [ skip | ]. +Tactic Notation "admits" ":" constr(T) := + let H := fresh "TEMP" in admits H: T. +Tactic Notation "admits" "~" ":" constr(T) := + admits: T; auto_tilde. +Tactic Notation "admits" "*" ":" constr(T) := + admits: T; auto_star. + +(** [admit_cuts T] simply replaces the current goal with [T]. *) + +Tactic Notation "admit_cuts" constr(T) := + cuts: T; [ skip | ]. + +(** [admit_goal H] applies to any goal. It simply assumes + the current goal to be true. The assumption is named "H". + It is useful to set up proof by induction or coinduction. + Syntax [admit_goal] is also accepted.*) + +Tactic Notation "admit_goal" ident(H) := + match goal with |- ?G => admits H: G end. + +Tactic Notation "admit_goal" := + let IH := fresh "IH" in admit_goal IH. + +(** [admit_rewrite T] can be applied when [T] is an equality. + It blindly assumes this equality to be true, and rewrite it in + the goal. *) + +Tactic Notation "admit_rewrite" constr(T) := + let M := fresh "TEMP" in admits M: T; rewrite M; clear M. + +(** [admit_rewrite T in H] is similar as [admit_rewrite], except that + it rewrites in hypothesis [H]. *) + +Tactic Notation "admit_rewrite" constr(T) "in" hyp(H) := + let M := fresh "TEMP" in admits M: T; rewrite M in H; clear M. + +(** [admit_rewrites_all T] is similar as [admit_rewrite], except that + it rewrites everywhere (goal and all hypotheses). *) + +Tactic Notation "admit_rewrite_all" constr(T) := + let M := fresh "TEMP" in admits M: T; rewrite_all M; clear M. + +(** [forwards_nounfold_admit_sides_then E ltac:(fun K => ..)] + is like [forwards: E] but it provides the resulting term + to a continuation, under the name [K], and it admits + any side-condition produced by the instantiation of [E], + using the [skip] tactic. *) + +Inductive ltac_goal_to_discard := ltac_goal_to_discard_intro. + +Ltac forwards_nounfold_admit_sides_then S cont := + let MARK := fresh "TEMP" in + generalize ltac_goal_to_discard_intro; + intro MARK; + forwards_nounfold_then S ltac:(fun K => + clear MARK; + cont K); + match goal with + | MARK: ltac_goal_to_discard |- _ => skip + | _ => idtac + end. + +(** DEPRECATED -- FOR BACKWARD COMPATIBILITY *) + +Tactic Notation "skip" simple_intropattern(I) ":" constr(T) := + admits I: T. +Tactic Notation "skip" ":" constr(T) := + admits: T. +Tactic Notation "skip" "~" ":" constr(T) := + admits~:T. +Tactic Notation "skip" "*" ":" constr(T) := + admits*:T. + +Tactic Notation "skip" simple_intropattern(I1) + simple_intropattern(I2) ":" constr(T) := + skip [I1 I2]: T. +Tactic Notation "skip" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) ":" constr(T) := + skip [I1 [I2 I3]]: T. +Tactic Notation "skip" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) + simple_intropattern(I4) ":" constr(T) := + skip [I1 [I2 [I3 I4]]]: T. +Tactic Notation "skip" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) + simple_intropattern(I4) simple_intropattern(I5) ":" constr(T) := + skip [I1 [I2 [I3 [I4 I5]]]]: T. +Tactic Notation "skip" simple_intropattern(I1) + simple_intropattern(I2) simple_intropattern(I3) + simple_intropattern(I4) simple_intropattern(I5) + simple_intropattern(I6) ":" constr(T) := + skip [I1 [I2 [I3 [I4 [I5 I6]]]]]: T. + +Tactic Notation "skip_asserts" simple_intropattern(I) ":" constr(T) := + admits I: T. +Tactic Notation "skip_asserts" ":" constr(T) := + admits: T. +Tactic Notation "skip_cuts" constr(T) := + admit_cuts T. +Tactic Notation "skip_goal" ident(H) := + admit_goal H. +Tactic Notation "skip_goal" := + admit_goal. +Tactic Notation "skip_rewrite" constr(T) := + admit_rewrite T. +Tactic Notation "skip_rewrite" constr(T) "in" hyp(H) := + admit_rewrite T in H. +Tactic Notation "skip_rewrite_all" constr(T) := + admit_rewrite_all T. +Ltac forwards_nounfold_skip_sides_then S cont := + forwards_nounfold_admit_sides_then S cont. +Tactic Notation "skip_induction" constr(E) := + let IH := fresh "IH" in admit_goal IH; destruct E. +Tactic Notation "skip_induction" constr(E) "as" simple_intropattern(I) := + let IH := fresh "IH" in admit_goal IH; destruct E as I. + + +(* ********************************************************************** *) +(** * Compatibility with standard library *) + +(** The module [Program] contains definitions that conflict with the + current module. If you import [Program], either directly or indirectly + (e.g. through [Setoid] or [ZArith]), you will need to import the + compability definitions through the top-level command: + [Import LibTacticsCompatibility]. *) + +Module LibTacticsCompatibility. + Tactic Notation "apply" "*" constr(H) := + sapply H; auto_star. + Tactic Notation "subst" "*" := + subst; auto_star. +End LibTacticsCompatibility. + +Open Scope nat_scope. + + + + +(* ********************************************************************** *) +(** * Additional notations for Coq *) + +(* ---------------------------------------------------------------------- *) +(** ** N-ary Existentials --TODO: DEPRECATED, Coq now supports it. *) + +(** [exists T1 ... TN, P] is a shorthand for + [exists T1, ..., exists TN, P]. Note that + [Coq.Program.Syntax] already defines exists + for arity up to 4. *) + +Notation "'exists' x1 ',' P" := + (exists x1, P) + (at level 200, x1 ident, + right associativity) : type_scope. +Notation "'exists' x1 x2 ',' P" := + (exists x1, exists x2, P) + (at level 200, x1 ident, x2 ident, + right associativity) : type_scope. +Notation "'exists' x1 x2 x3 ',' P" := + (exists x1, exists x2, exists x3, P) + (at level 200, x1 ident, x2 ident, x3 ident, + right associativity) : type_scope. +Notation "'exists' x1 x2 x3 x4 ',' P" := + (exists x1, exists x2, exists x3, exists x4, P) + (at level 200, x1 ident, x2 ident, x3 ident, x4 ident, + right associativity) : type_scope. +Notation "'exists' x1 x2 x3 x4 x5 ',' P" := + (exists x1, exists x2, exists x3, exists x4, exists x5, P) + (at level 200, x1 ident, x2 ident, x3 ident, x4 ident, x5 ident, + right associativity) : type_scope. +Notation "'exists' x1 x2 x3 x4 x5 x6 ',' P" := + (exists x1, exists x2, exists x3, exists x4, exists x5, exists x6, P) + (at level 200, x1 ident, x2 ident, x3 ident, x4 ident, x5 ident, + x6 ident, + right associativity) : type_scope. +Notation "'exists' x1 x2 x3 x4 x5 x6 x7 ',' P" := + (exists x1, exists x2, exists x3, exists x4, exists x5, exists x6, + exists x7, P) + (at level 200, x1 ident, x2 ident, x3 ident, x4 ident, x5 ident, + x6 ident, x7 ident, + right associativity) : type_scope. +Notation "'exists' x1 x2 x3 x4 x5 x6 x7 x8 ',' P" := + (exists x1, exists x2, exists x3, exists x4, exists x5, exists x6, + exists x7, exists x8, P) + (at level 200, x1 ident, x2 ident, x3 ident, x4 ident, x5 ident, + x6 ident, x7 ident, x8 ident, + right associativity) : type_scope. +Notation "'exists' x1 x2 x3 x4 x5 x6 x7 x8 x9 ',' P" := + (exists x1, exists x2, exists x3, exists x4, exists x5, exists x6, + exists x7, exists x8, exists x9, P) + (at level 200, x1 ident, x2 ident, x3 ident, x4 ident, x5 ident, + x6 ident, x7 ident, x8 ident, x9 ident, + right associativity) : type_scope. +Notation "'exists' x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 ',' P" := + (exists x1, exists x2, exists x3, exists x4, exists x5, exists x6, + exists x7, exists x8, exists x9, exists x10, P) + (at level 200, x1 ident, x2 ident, x3 ident, x4 ident, x5 ident, + x6 ident, x7 ident, x8 ident, x9 ident, x10 ident, + right associativity) : type_scope. + + +(* ---------------------------------------------------------------------- *) +(** ** ['let] bindings (EXPERIMENTAL). *) + +(** The syntax ['let x := v in e] has the same meaning as [let x := v in e] + except that the binding is implemented using a beta-redex that is not + reduced automatically by [simpl]. The ['let] construct therefore makes + it possible to simplify or push to the context let-bindings one by one. *) + +(** Definition of ['let] *) + +Definition let_binding (A B:Type) (v:A) (K:A->B) := K v. + +Notation "''let' x ':=' v 'in' e" := (let_binding v (fun x => e)) + (at level 69, x ident, right associativity, + format "'[v' '[' ''let' x ':=' v 'in' ']' '/' '[' e ']' ']'") + : let_scope. + +Notation "''let' x ':' A ':=' v 'in' e" := (let_binding (v:A) (fun x:A => e)) + (at level 69, x ident, right associativity, + format "'[v' '[' ''let' x ':' A ':=' v 'in' ']' '/' '[' e ']' ']'") + : let_scope. + +Global Open Scope let_scope. + +Lemma let_binding_unfold : forall (A B:Type) (v:A) (K:A->B), + let_binding v K = K v. +Proof using. reflexivity. Qed. + +Ltac let_get_fresh_binding_name K := + match K with (fun x => _) => let y := fresh x in y end. + +(** [let_simpl] finds the first occurence of a ['let] binding and + substitutes it. *) + +Tactic Notation "let_simpl" "in" hyp(H) := + match type of H with context [ let_binding ?v ?K ] => + changes (let_binding v K) with (K v) in H + end. + +Tactic Notation "let_simpl" := + match goal with + | |- context [ let_binding ?v ?K ] => + changes (let_binding v K) with (K v) + | H: context [ let_binding ?v ?K ] |- _ => + let_simpl in H + end. + +Tactic Notation "let_simpl" constr(v) "in" hyp(H) := + repeat match type of H with context [ let_binding v ?K ] => + changes (let_binding v K) with (K v) in H + end. + +Tactic Notation "let_simpl" constr(v) := + repeat match goal with + | |- context [ let_binding v ?K ] => + changes (let_binding v K) with (K v) + | H: context [ let_binding v ?K ] |- _ => + let_simpl v in H + end. + +(** [let_name] finds the first occurence of a ['let] binding and + moves this binding to the proof context. *) + +Tactic Notation "let_name" "in" hyp(H) := + match type of H with context [ let_binding ?v ?K ] => + let x := let_get_fresh_binding_name K in + set_eq x: v in H; + let_simpl in H + end. + +Tactic Notation "let_name" "in" hyp(H) "as" ident(x) := + match type of H with context [ let_binding ?v ?K ] => + set_eq x: v in H; + let_simpl in H + end. + +Tactic Notation "let_name" := + match goal with + | |- context [ let_binding ?v ?K ] => + let x := let_get_fresh_binding_name K in + set_eq x: v; + let_simpl + | H: context [ let_binding ?v ?K ] |- _ => + let_name in H + end. + +Tactic Notation "let_name" "as" ident(x) := + match goal with + | |- context [ let_binding ?v ?K ] => + set_eq x: v; + let_simpl + | H: context [ let_binding ?v ?K ] |- _ => + let_name in H as x + end. + +(** [let_name_all] finds the first occurence of a ['let] binding, + moves this binding to the proof context, and further simplify + all the other ['let] bindings that are binding the same value. + (See LibFixDemos for a practical motivation.) *) + +Tactic Notation "let_name_all" "in" hyp(H) := + match type of H with context [ let_binding ?v ?K ] => + let x := let_get_fresh_binding_name K in + set_eq x: v in H; + let_simpl x in H + end. + +Tactic Notation "let_name_all" "in" hyp(H) "as" ident(x) := + match type of H with context [ let_binding ?v ?K ] => + set_eq x: v in H; + let_simpl x in H + end. + +Tactic Notation "let_name_all" := + match goal with + | |- context [ let_binding ?v ?K ] => + let x := let_get_fresh_binding_name K in + set_eq x: v; + let_simpl x + | H: context [ let_binding ?v ?K ] |- _ => + let_name_all in H + end. + +Tactic Notation "let_name_all" "as" ident(x) := + match goal with + | |- context [ let_binding ?v ?K ] => + set_eq x: v; + let_simpl x + | H: context [ let_binding ?v ?K ] |- _ => + let_name_all in H as x + end. + + +(* ---------------------------------------------------------------------- *) +(* Bugfix for [f_equal] and [fequals]; only supports up to arity 5 *) + +Section FuncEq. +Variables (A1 A2 A3 A4 A5 B : Type). + +Lemma args_eq_1 : forall (f:A1->B) x1 y1, + x1 = y1 -> + f x1 = f y1. +Proof using. intros. subst~. Qed. + +Lemma args_eq_2 : forall (f:A1->A2->B) x1 y1 x2 y2, + x1 = y1 -> x2 = y2 -> + f x1 x2 = f y1 y2. +Proof using. intros. subst~. Qed. + +Lemma args_eq_3 : forall (f:A1->A2->A3->B) x1 y1 x2 y2 x3 y3, + x1 = y1 -> x2 = y2 -> x3 = y3 -> + f x1 x2 x3 = f y1 y2 y3. +Proof using. intros. subst~. Qed. + +Lemma args_eq_4 : forall (f:A1->A2->A3->A4->B) x1 y1 x2 y2 x3 y3 x4 y4, + x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 -> + f x1 x2 x3 x4 = f y1 y2 y3 y4. +Proof using. intros. subst~. Qed. + +Lemma args_eq_5 : forall (f:A1->A2->A3->A4->A5->B) x1 y1 x2 y2 x3 y3 x4 y4 x5 y5, + x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 -> x5 = y5 -> + f x1 x2 x3 x4 x5 = f y1 y2 y3 y4 y5. +Proof using. intros. subst~. Qed. + +End FuncEq. + +Ltac f_equal_fixed := + try ( + first + [ apply args_eq_1 + | apply args_eq_2 + | apply args_eq_3 + | apply args_eq_4 + | apply args_eq_5 ]; + try reflexivity). + +Ltac fequal_base ::= + let go := f_equal_fixed; [ fequal_base | ] in + match goal with + | |- (_,_,_) = (_,_,_) => go + | |- (_,_,_,_) = (_,_,_,_) => go + | |- (_,_,_,_,_) = (_,_,_,_,_) => go + | |- (_,_,_,_,_,_) = (_,_,_,_,_,_) => go + | |- _ => f_equal_fixed + end. + + +(* ---------------------------------------------------------------------- *) +(* Bugfix for [autorewrite in *], which is currently inefficient *) + +(** Generalize all propositions into the goal. + Naive implementation: + + Ltac generalize_all_prop := + repeat match goal with H: ?T |- _ => + match type of T with Prop => + generalizes H + end end. + + The real implementation is careful to not generalized [ltac_Mark], + even though it is of type [Prop]. + TODO: investigate whether it would be sufficient to put [ltac_Mark] + in [Type] to obtain the desired behavior. *) + +Ltac generalize_all_prop := + repeat match goal with H: ?T |- _ => + try match T with ltac_Mark => fail 2 end; + match type of T with Prop => + generalizes H + end end. + +(** Work around for inefficiency bug of [autorewrite in *]. + Usage, e.g.: + [Tactic Notation "rew_list" "in" "*" := + autorewrite_in_star_patch + ltac:(fun tt => autorewrite with rew_list)]. *) + +Ltac autorewrite_in_star_patch cont := + generalize ltac_mark; + generalize_all_prop; + cont tt; + intro_until_mark. diff --git a/test/serlib/genarg/mbid.v b/test/serlib/genarg/mbid.v new file mode 100644 index 00000000..21ddbbbb --- /dev/null +++ b/test/serlib/genarg/mbid.v @@ -0,0 +1,52 @@ +(* + Test file for #150, provided by Clement Pit-Claudel. + + Note that the problem here is with serialization of Goals, not AST. + *) + +Require Export NumPrelude NZAxioms. +Require Import NZBase NZOrder NZAddOrder. + +(** In this file, we investigate the shape of domains satisfying + the [NZDomainSig] interface. In particular, we define a + translation from Peano numbers [nat] into NZ. +*) + +Local Notation "f ^ n" := (fun x => nat_rect _ x (fun _ => f) n). + +#[global] Instance nat_rect_wd n {A} (R:relation A) : + Proper (R==>(R==>R)==>R) (fun x f => nat_rect (fun _ => _) x (fun _ => f) n). +Proof. +intros x y eq_xy f g eq_fg; induction n; [assumption | now apply eq_fg]. +Qed. + +Module NZDomainProp (Import NZ:NZDomainSig'). +Include NZBaseProp NZ. + +(** * Relationship between points thanks to [succ] and [pred]. *) + +(** For any two points, one is an iterated successor of the other. *) + +Lemma itersucc_or_itersucc n m : exists k, n == (S^k) m \/ m == (S^k) n. +Proof. +revert n. +apply central_induction with (z:=m). + { intros x y eq_xy; apply ex_iff_morphism. + intros n; apply or_iff_morphism. + + split; intros; etransitivity; try eassumption; now symmetry. + + split; intros; (etransitivity; [eassumption|]); [|symmetry]; + (eapply nat_rect_wd; [eassumption|apply succ_wd]). + } +exists 0%nat. now left. +intros n. split; intros [k [L|R]]. +exists (Datatypes.S k). left. now apply succ_wd. +destruct k as [|k]. +simpl in R. exists 1%nat. left. now apply succ_wd. +rewrite nat_rect_succ_r in R. exists k. now right. +destruct k as [|k]; simpl in L. +exists 1%nat. now right. +apply succ_inj in L. exists k. now left. +exists (Datatypes.S k). right. now rewrite nat_rect_succ_r. +Qed. + +End NZDomainProp. diff --git a/test/serlib/genarg/move.v b/test/serlib/genarg/move.v new file mode 100644 index 00000000..27833d85 --- /dev/null +++ b/test/serlib/genarg/move.v @@ -0,0 +1,99 @@ +From Coq Require Import ssreflect ssrbool ssrfun. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Module Equality. + +Definition axiom T (e : rel T) := forall x y, reflect (x = y) (e x y). + +Structure mixin_of T := Mixin {op : rel T; _ : axiom op}. +Notation class_of := mixin_of (only parsing). + +Section ClassDef. + +Structure type := Pack {sort; _ : class_of sort}. +Local Coercion sort : type >-> Sortclass. +Variables (T : Type) (cT : type). + +Definition class := let: @Pack _ c := cT return class_of cT in c. + +Definition clone := fun c & cT -> T & phant_id (@Pack T c) cT => Pack c. + +End ClassDef. + +Definition eqType := Equality.type. +Coercion Equality.sort : Equality.type >-> Sortclass. +Notation EqType T m := (@Equality.Pack T m). + +Module Ordered. + +Section RawMixin. + +Structure mixin_of (T : eqType) := + Mixin {ordering : rel T; + _ : irreflexive ordering; + _ : transitive ordering; + }. +End RawMixin. + +Section ClassDef. + +Record class_of (T : Type) := Class { + base : Equality.class_of T; + mixin : mixin_of (Equality.Pack base)}. + +Local Coercion base : class_of >-> Equality.class_of. + +Structure type : Type := Pack {sort : Type; _ : class_of sort;}. +Local Coercion sort : type >-> Sortclass. + +Variables (T : Type) (cT : type). +Definition class := let: @Pack _ c as cT' := cT return class_of cT' in c. + +Definition pack b (m0 : mixin_of (EqType T b)) := + fun m & phant_id m0 m => Pack (@Class T b m). + +Definition eqType := Equality.Pack class. + +End ClassDef. + +Module Exports. +Coercion eqType : type >-> Equality.type. +Canonical Structure eqType. +Notation ordType := Ordered.type. +Definition ord T : rel (sort T) := (ordering (mixin (class T))). +End Exports. +End Ordered. +Export Ordered.Exports. + +Definition eq_op T := Equality.op (Equality.class T). + +Notation "x == y" := (eq_op x y) + (at level 70, no associativity) : bool_scope. + +Lemma eqP T : Equality.axiom (@eq_op T). +Proof. by case: T => ? []. Qed. +Arguments eqP {T x y}. + +Definition oleq (T : ordType) (t1 t2 : T) := ord t1 t2 || (t1 == t2). + +Prenex Implicits ord oleq. + +Section Lemmas. +Variable T : ordType. +Implicit Types x y : T. + +Variable trans : transitive (@ord T). + +Lemma otrans : transitive (@oleq T). +Proof. +move=>x y z /=. +case/orP; last by move/eqP=>->. +rewrite /oleq; move=>T1. +case/orP; first by move/(trans T1)=>->. +by move/eqP=><-; rewrite T1. +Qed. + +End Lemmas. diff --git a/test/serlib/genarg/now.v b/test/serlib/genarg/now.v new file mode 100644 index 00000000..dff3eba0 --- /dev/null +++ b/test/serlib/genarg/now.v @@ -0,0 +1,2 @@ +Lemma addnC n : n + 0 = n. +Proof. now induction n. Qed. diff --git a/test/serlib/genarg/primitives.v b/test/serlib/genarg/primitives.v new file mode 100644 index 00000000..80608368 --- /dev/null +++ b/test/serlib/genarg/primitives.v @@ -0,0 +1,11 @@ +Require Export CarryType. + +Primitive int := #int63_type. +Primitive lsl := #int63_lsl. + +Set Universe Polymorphism. + +Primitive array := #array_type. + +Primitive make : forall A, int -> A -> array A := #array_make. +Arguments make {_} _ _. diff --git a/test/serlib/genarg/rename.v b/test/serlib/genarg/rename.v new file mode 100644 index 00000000..c9607bf4 --- /dev/null +++ b/test/serlib/genarg/rename.v @@ -0,0 +1,10 @@ +Require Import ZArith. + +Open Scope Z_scope. + +Lemma Zplus0 : forall n, n + 0 = n. +Proof. +intros n. +rename n into m. +auto with zarith. +Qed. diff --git a/test/serlib/genarg/replace.v b/test/serlib/genarg/replace.v new file mode 100644 index 00000000..efa5f838 --- /dev/null +++ b/test/serlib/genarg/replace.v @@ -0,0 +1,89 @@ +Require Import ZArith Zquot. + +Record radix := { radix_val :> Z ; radix_prop : Zle_bool 2 radix_val = true }. + +Theorem Zpower_plus : + forall n k1 k2, (0 <= k1)%Z -> (0 <= k2)%Z -> + Zpower n (k1 + k2) = (Zpower n k1 * Zpower n k2)%Z. +Proof. +intros n k1 k2 H1 H2. +now apply Zpower_exp ; apply Z.le_ge. +Qed. + +Theorem Zpower_Zpower_nat : + forall b e, (0 <= e)%Z -> + Zpower b e = Zpower_nat b (Z.abs_nat e). +Proof. +intros b [|e|e] He. +apply refl_equal. +apply Zpower_pos_nat. +elim He. +apply refl_equal. +Qed. + +Theorem Zpower_nat_S : + forall b e, + Zpower_nat b (S e) = (b * Zpower_nat b e)%Z. +Proof. +intros b e. +rewrite (Zpower_nat_is_exp 1 e). +apply (f_equal (fun x => x * _)%Z). +apply Zmult_1_r. +Qed. + +Section Beta. + +Variable beta : radix. + +Theorem radix_gt_0 : (0 < beta)%Z. +Proof. +apply Z.lt_le_trans with 2%Z. +easy. +apply Zle_bool_imp_le. +apply beta. +Qed. + +Theorem Zpower_gt_0 : + forall p, + (0 <= p)%Z -> + (0 < Zpower beta p)%Z. +Proof. +intros p Hp. +rewrite Zpower_Zpower_nat with (1 := Hp). +induction (Z.abs_nat p). +easy. +rewrite Zpower_nat_S. +apply Zmult_lt_0_compat with (2 := IHn). +apply radix_gt_0. +Qed. + +Definition Zdigit n k := Z.rem (Z.quot n (Zpower beta k)) beta. + +Theorem Zdigit_ge_Zpower_pos : + forall e n, + (0 <= n < Zpower beta e)%Z -> + forall k, (e <= k)%Z -> Zdigit n k = Z0. +Proof. +intros e n Hn k Hk. +unfold Zdigit. +rewrite Z.quot_small. +apply Zrem_0_l. +split. +apply Hn. +apply Z.lt_le_trans with (1 := proj2 Hn). +replace k with (e + (k - e))%Z by ring. +rewrite Zpower_plus. +rewrite <- (Zmult_1_r (beta ^ e)) at 1. +apply Zmult_le_compat_l. +apply (Zlt_le_succ 0). +apply Zpower_gt_0. +now apply Zle_minus_le_0. +apply Zlt_le_weak. +now apply Z.le_lt_trans with n. +generalize (Z.le_lt_trans _ _ _ (proj1 Hn) (proj2 Hn)). +clear. +now destruct e as [|e|e]. +now apply Zle_minus_le_0. +Qed. + +End Beta. diff --git a/test/serlib/genarg/revert.v b/test/serlib/genarg/revert.v new file mode 100644 index 00000000..34b96753 --- /dev/null +++ b/test/serlib/genarg/revert.v @@ -0,0 +1,48 @@ +Require Import List. +Import ListNotations. +Require Import Sumbool. + +Ltac break_and := + repeat match goal with + | [H : _ /\ _ |- _ ] => destruct H + end. + +Ltac break_if := + match goal with + | [ |- context [ if ?X then _ else _ ] ] => + match type of X with + | sumbool _ _ => destruct X + | _ => destruct X eqn:? + end + end. + +Definition update2 {A B : Type} (A_eq_dec : forall x y : A, {x = y} + {x <> y}) (f : A -> A -> B) (x y : A) (v : B) := + fun x' y' => if sumbool_and _ _ _ _ (A_eq_dec x x') (A_eq_dec y y') then v else f x' y'. + +Fixpoint collate {A B : Type} (A_eq_dec : forall x y : A, {x = y} + {x <> y}) (from : A) (f : A -> A -> list B) (ms : list (A * B)) := + match ms with + | [] => f + | (to, m) :: ms' => collate A_eq_dec from (update2 A_eq_dec f from to (f from to ++ [m])) ms' + end. + +Section Update2. + Variables A B : Type. + Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}. + + Lemma collate_neq : + forall h n n' ns (f : A -> A -> list B), + h <> n -> + collate A_eq_dec h f ns n n' = f n n'. + Proof using. + intros. + revert f. + induction ns; intros; auto. + destruct a. + simpl in *. + rewrite IHns. + unfold update2. + break_if; auto. + break_and; subst. + intuition. + Qed. +End Update2. \ No newline at end of file diff --git a/test/serlib/genarg/setoid_rewrite.v b/test/serlib/genarg/setoid_rewrite.v new file mode 100644 index 00000000..71c0f846 --- /dev/null +++ b/test/serlib/genarg/setoid_rewrite.v @@ -0,0 +1,20 @@ +Require Setoid. +Require Import PeanoNat Bool List. +Require Import Lia. + +Section ReDun. + + Variable A : Type. + + Variable decA : forall (a b : A), {a = b}+{a <> b}. + + Theorem NoDup_count_occ' l: + NoDup l <-> (forall x:A, In x l -> count_occ decA l x = 1). + Proof. + rewrite (NoDup_count_occ decA). + setoid_rewrite (count_occ_In decA) at 1. + unfold gt, lt in *. + split; intros H x; specialize (H x); + set (n := count_occ decA l x) in *; clearbody n; lia. + Qed. +End ReDun. diff --git a/test/serlib/genarg/specialize.v b/test/serlib/genarg/specialize.v new file mode 100644 index 00000000..ca00e417 --- /dev/null +++ b/test/serlib/genarg/specialize.v @@ -0,0 +1,58 @@ +Require Import List. +Import ListNotations. + +Set Implicit Arguments. + +Ltac break_match := + match goal with + | [ |- context [ match ?X with _ => _ end ] ] => + match type of X with + | sumbool _ _ => destruct X + | _ => destruct X eqn:? + end + end. + +Ltac do_in_app := + match goal with + | [ H : In _ (_ ++ _) |- _ ] => apply in_app_iff in H + end. + +Section dedup. + Variable A : Type. + Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}. + + Fixpoint dedup (xs : list A) : list A := + match xs with + | [] => [] + | x :: xs => let tail := dedup xs in + if in_dec A_eq_dec x xs then + tail + else + x :: tail + end. + + Lemma dedup_app : forall (xs ys : list A), + (forall x y, In x xs -> In y ys -> x <> y) -> + dedup (xs ++ ys) = dedup xs ++ dedup ys. + Proof using. + intros. induction xs; simpl; auto. + repeat break_match. + - apply IHxs. + intros. + apply H; intuition. + - exfalso. + specialize (H a a). + apply H; intuition. + do_in_app. + intuition. + - exfalso. + apply n. + intuition. + - simpl. + f_equal. + apply IHxs. + intros. + apply H; intuition. + Qed. + +End dedup. \ No newline at end of file diff --git a/test/serlib/genarg/subst.v b/test/serlib/genarg/subst.v new file mode 100644 index 00000000..3619423b --- /dev/null +++ b/test/serlib/genarg/subst.v @@ -0,0 +1,77 @@ +Require Import List. +Import ListNotations. + +Set Implicit Arguments. + +Section assoc. + Variable K V : Type. + Variable K_eq_dec : forall k k' : K, {k = k'} + {k <> k'}. + + Fixpoint assoc (l : list (K * V)) (k : K) : option V := + match l with + | [] => None + | (k', v) :: l' => + if K_eq_dec k k' then + Some v + else + assoc l' k + end. + + Fixpoint assoc_set (l : list (K * V)) (k : K) (v : V) : list (K * V) := + match l with + | [] => [(k, v)] + | (k', v') :: l' => + if K_eq_dec k k' then + (k, v) :: l' + else + (k', v') :: (assoc_set l' k v) + end. + + Lemma get_set_same : + forall k v l, + assoc (assoc_set l k v) k = Some v. + Proof using. + induction l; intros; simpl. + - destruct (K_eq_dec _ _); simpl; subst; congruence. + - destruct a; repeat (destruct (K_eq_dec _ _); simpl; subst; try congruence). + Qed. + + Lemma get_set_diff : + forall k k' v l, + k <> k' -> + assoc (assoc_set l k v) k' = assoc l k'. + Proof using. + induction l; intros; simpl. + - destruct (K_eq_dec _ _); simpl; subst; congruence. + - destruct a. + repeat (destruct (K_eq_dec _ _); simpl; subst; try congruence). + rewrite IHl; auto. + Qed. + + Ltac assoc_rewrite := + match goal with + | [ |- context [assoc (assoc_set _ ?k0' _) ?k0 ] ] => + first [rewrite get_set_same with (k := k0) by auto | + rewrite get_set_diff with (k' := k0) by auto ] + end. + + Definition a_equiv (l1 : list (K * V)) l2 := + forall k,assoc l1 k = assoc l2 k. + + Lemma assoc_set_assoc_set_diff : + forall l (k : K) (v : V) k' v', + k <> k' -> + a_equiv (assoc_set (assoc_set l k v) k' v') + (assoc_set (assoc_set l k' v') k v). + Proof using. + unfold a_equiv. + intros. + destruct (K_eq_dec k0 k'); [subst k'; rewrite get_set_same with (k := k0)| + rewrite get_set_diff with (k' := k0) by auto]. + - now repeat assoc_rewrite. + - destruct (K_eq_dec k0 k); [subst k; rewrite get_set_same with (k := k0)| + rewrite get_set_diff with (k' := k0) by auto]. + + now repeat assoc_rewrite. + + now repeat assoc_rewrite. + Qed. +End assoc. \ No newline at end of file diff --git a/test/serlib/genarg/symmetry.v b/test/serlib/genarg/symmetry.v new file mode 100644 index 00000000..9384ad1e --- /dev/null +++ b/test/serlib/genarg/symmetry.v @@ -0,0 +1,18 @@ +Require Import List. +Import ListNotations. + +Set Implicit Arguments. + +Section list_util. + Variables A : Type. + + Lemma list_neq_cons : + forall (l : list A) x, + x :: l <> l. + Proof using. + intuition. + symmetry in H. + induction l; + now inversion H. + Qed. +End list_util. diff --git a/test/serlib/genarg/tactic_notation.v b/test/serlib/genarg/tactic_notation.v new file mode 100644 index 00000000..5b8d70c1 --- /dev/null +++ b/test/serlib/genarg/tactic_notation.v @@ -0,0 +1,30 @@ +Require ZArith.BinInt. + +Definition ltac_int_to_nat (x:BinInt.Z) : nat := + match x with + | BinInt.Z0 => 0%nat + | BinInt.Zpos p => BinPos.nat_of_P p + | BinInt.Zneg p => 0%nat + end. + +Ltac number_to_nat N := + match type of N with + | nat => constr:(N) + | BinInt.Z => let N' := constr:(ltac_int_to_nat N) in eval compute in N' + end. + +Lemma dup_lemma : forall P, P -> P -> P. +Proof using. auto. Qed. + +Ltac dup_tactic N := + match number_to_nat N with + | 0 => idtac + | S 0 => idtac + | S ?N' => apply dup_lemma; [ | dup_tactic N' ] + end. + +Tactic Notation "dup" constr(N) := + dup_tactic N. + +Tactic Notation "dup" := + dup 2. diff --git a/test/serlib/genarg/test_roundtrip.in b/test/serlib/genarg/test_roundtrip.in new file mode 100755 index 00000000..9f2b379f --- /dev/null +++ b/test/serlib/genarg/test_roundtrip.in @@ -0,0 +1,11 @@ +#!/usr/bin/env bash + +set -e + +FCC=../../../compiler/fcc.exe +FILE_IN="$1" +FILE_OUT="${FILE_IN%.v}.sexp" + +$FCC --display=quiet "$FILE_IN" +# $SERCOMP --input=vernac --mode=sexp --exn_on_opaque "$FILE_IN" > "$FILE_OUT" +# $SERCOMP --input=sexp --mode=check "$FILE_OUT" diff --git a/test/server/package-lock.json b/test/server/package-lock.json index 03162f2a..fc1fabe7 100644 --- a/test/server/package-lock.json +++ b/test/server/package-lock.json @@ -1253,11 +1253,13 @@ } }, "node_modules/braces": { - "version": "3.0.2", + "version": "3.0.3", + "resolved": "https://registry.npmjs.org/braces/-/braces-3.0.3.tgz", + "integrity": "sha512-yQbXgO/OSZVD2IsiLlro+7Hf6Q18EJrKSEsdoMzKePKXct3gvD8oLcOQdIzGupr5Fj+EDe8gO/lxc1BzfMpxvA==", "dev": true, "license": "MIT", "dependencies": { - "fill-range": "^7.0.1" + "fill-range": "^7.1.1" }, "engines": { "node": ">=8" @@ -1614,7 +1616,9 @@ } }, "node_modules/fill-range": { - "version": "7.0.1", + "version": "7.1.1", + "resolved": "https://registry.npmjs.org/fill-range/-/fill-range-7.1.1.tgz", + "integrity": "sha512-YsGpe3WHLK8ZYi4tWDg2Jy3ebRz2rXowDxnld4bkQB00cc/1Zw9AWnC0i9ztDJitivtQvaI9KaLyKrc+hBW0yg==", "dev": true, "license": "MIT", "dependencies": { @@ -1831,6 +1835,8 @@ }, "node_modules/is-number": { "version": "7.0.0", + "resolved": "https://registry.npmjs.org/is-number/-/is-number-7.0.0.tgz", + "integrity": "sha512-41Cifkg6e8TylSpdtTpeLVMqvSBEVzTttHvERD741+pnZ8ANv0004MRL43QKPDlK9cGvNp6NZWZUBlbGXYxxng==", "dev": true, "license": "MIT", "engines": { @@ -3096,6 +3102,8 @@ }, "node_modules/to-regex-range": { "version": "5.0.1", + "resolved": "https://registry.npmjs.org/to-regex-range/-/to-regex-range-5.0.1.tgz", + "integrity": "sha512-65P7iz6X5yEr1cwcgvQxbbIw7Uk3gOy5dIdtZ4rDveLqhrdJP+Li/Hx6tyK0NEb+2GCyneCMJiGqrADCSNk8sQ==", "dev": true, "license": "MIT", "dependencies": {