pax_global_header00006660000000000000000000000064151741166310014517gustar00rootroot0000000000000052 comment=0e084eec03bb22d74e4bb0d8ee7792b4dadfa705 arthuraa-deriving-0e084ee/000077500000000000000000000000001517411663100155475ustar00rootroot00000000000000arthuraa-deriving-0e084ee/.github/000077500000000000000000000000001517411663100171075ustar00rootroot00000000000000arthuraa-deriving-0e084ee/.github/workflows/000077500000000000000000000000001517411663100211445ustar00rootroot00000000000000arthuraa-deriving-0e084ee/.github/workflows/cachix-install-nix-action.yml000066400000000000000000000031651517411663100266460ustar00rootroot00000000000000name: Nix Flake actions on: pull_request: push: jobs: nix-matrix: runs-on: ubuntu-latest outputs: matrix: ${{ steps.set-matrix.outputs.matrix }} steps: - uses: actions/checkout@v4 - uses: cachix/install-nix-action@v30 - id: set-matrix name: Generate Nix Matrix run: | set -Eeu matrix="$(nix eval --json '.#githubActions.matrix')" echo "matrix=$matrix" >> "$GITHUB_OUTPUT" nix-build: name: ${{ matrix.name }} (${{ matrix.system }}) needs: nix-matrix runs-on: ${{ matrix.os }} strategy: # Don't cancel sibling matrix jobs on the first failure — we want # every platform to report independently and to upload its bench # artifacts even if another one is broken. fail-fast: false matrix: ${{fromJSON(needs.nix-matrix.outputs.matrix)}} steps: - uses: actions/checkout@v4 - uses: cachix/install-nix-action@v30 - uses: nix-community/cache-nix-action@v7 with: primary-key: nix-${{ matrix.system }}-${{ hashFiles('flake.lock') }} restore-prefixes-first-match: nix-${{ matrix.system }}- gc-max-store-size-linux: 2000000000 gc-max-store-size-macos: 2000000000 purge: true purge-created: 604800 purge-primary-key: never - run: nix build -L '.#${{ matrix.attr }}' - name: Upload bench artifacts if: success() uses: actions/upload-artifact@v4 with: name: bench-${{ matrix.name }}-${{ matrix.system }} path: result/share/deriving/bench/ if-no-files-found: warn arthuraa-deriving-0e084ee/.gitignore000066400000000000000000000003021517411663100175320ustar00rootroot00000000000000*.vo *.vok *.vos *.glob *.d *.aux CoqMakefile CoqMakefile.conf theories/tactics.v .dir-locals.el .direnv .envrc make_tactics make_tactics.cmo make_tactics.cmi bench/build/ bench/results/ result arthuraa-deriving-0e084ee/CHANGELOG.md000066400000000000000000000057171517411663100173720ustar00rootroot00000000000000# Changelog All notable changes to this project will be documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). ## [Unreleased] ### Added ### Changed ### Deprecated ### Removed ### Fixed ## [0.2.3] - 2026-04-28 ### Added - Performance benchmarks (`bench/`) with gnuplot visualization. - CI now tests Coq 8.17 through Rocq 9.1 on multiple platforms. - `CONTRIBUTING.md` with testing instructions. ### Changed - Switched from CircleCI to GitHub Actions. ### Fixed - Adapt to https://github.com/rocq-prover/rocq/pull/21611, https://github.com/math-comp/math-comp/pull/1545. - Fix inlining of mutual recursors in `[indDef for ...]`. The destructor stored in `Ind.Def.case` for mutual inductive types contained unreduced calls to the per-type recursors (e.g. `M0_rect ... (M0A n)`), because `eval hnf` refused to delta-unfold a recursor whose structurally recursive argument was not yet supplied. Replacing `eval hnf` with `eval red` (with `hnf` as fallback) in `unwind_recursor` inlines the underlying fix, so the destructor becomes a clean pattern-match. This gives a ~1.6-1.8x speedup on `deriving_compute` simplification for mutual types. ## [0.2.2] - 2025-04-17 ### Fixed - Add explicit import of `Coq.Setoid`, for compatibility with MathComp 2.4.0. ## [0.2.1] - 2024-12-02 ### Changed - Use new display type for `orderType`, as in MathComp 2.3.0. The generated instances now use the default display. ### Fixed - Simplify the type of derived isFinite instances to avoid a non-forgetful inheritance warning. ## [0.2.0] - 2023-09-22 ### Changed - Make Deriving compatible with Hierarchy Builder and MathComp 2.0.0. - Following the changes of terminology in MathComp, the syntax for deriving the base mixins has now the form `[derive [] for ]`, where + `` is one of `red`, `nored` or `lazy`. + `` is one of `hasDecEq`, `hasChoice`, `isCountable`, `isFinite` or `isOrder`. ### Deprecated - The derivation forms `[derive ...]` that mention the old MathComp mixin names `eqMixin`, `choiceMixin`, `countMixin`, `finMixin` and `orderMixin` are deprecated. Use the new names for those mixins, as explained in the previous section. ## [0.1.1] - 2023-03-10 ### Fixed - Add `global` locality annotations to comply with newer versions of Coq ## [0.1.0] - 2020-02-24 ### Added - First version supporting inductive types. [Unreleased]: https://github.com/arthuraa/deriving/compare/v0.2.3...HEAD [0.2.3]: https://github.com/arthuraa/deriving/releases/tag/v0.2.3 [0.2.2]: https://github.com/arthuraa/deriving/releases/tag/v0.2.2 [0.2.1]: https://github.com/arthuraa/deriving/releases/tag/v0.2.1 [0.2.0]: https://github.com/arthuraa/deriving/releases/tag/v0.2.0 [0.1.1]: https://github.com/arthuraa/deriving/releases/tag/v0.1.1 [0.1.0]: https://github.com/arthuraa/deriving/releases/tag/v0.1.0 arthuraa-deriving-0e084ee/CLAUDE.md000066400000000000000000000077001517411663100170320ustar00rootroot00000000000000# CLAUDE.md This file provides guidance to Claude Code (claude.ai/code) when working with code in this repository. ## Project Deriving is a Coq library that automatically derives instances of MathComp classes (`eqType`, `choiceType`, `countType`, `finType`, `orderType`) for inductive data types, analogous to Haskell's `deriving`. It targets Coq 8.17–Rocq 9.1 with MathComp ssreflect 2.2–2.5. ## Build Commands ```bash make # Build the library (generates CoqMakefile via coq_makefile, then compiles) make test # Compile test files in tests/ make clean # Clean build artifacts including generated tactics.v make install # Install via opam ``` Alternative: `nix build` or `nix develop` (provides dev shell with coq-lsp). ## Build System - `Makefile` generates `CoqMakefile` from `_CoqProject` using `coq_makefile`, then delegates to it. - `CoqMakefile.local` adds custom rules: generating `theories/tactics.v` and compiling tests. - `theories/tactics.v` is **auto-generated** — do not edit it directly. It is produced by `ocaml make_tactics.ml` which scans `theories/base.v` and `theories/ind.v` for `Hint Unfold` directives and emits `Declare Reduction` forms. ## Architecture The library namespace is `deriving` (mapped from `theories/` via `-Q theories deriving` in `_CoqProject`). ### Core modules (theories/) - **base.v** — Foundational utilities: type equality/casting primitives, transport lemmas, the `deriving` hint database, and unfold hints consumed by `make_tactics.ml`. - **ind.v** — Inductive type infrastructure: `fun_split` for decomposing function types, `lift_class` for lifting type classes through inductive parameters, polymorphic type handling. - **tactics.v** — (generated) `deriving_compute` and `deriving_lazy` reduction tactics built from the unfold hints in base.v and ind.v. - **infer.v** — Notations for defining `IndType` instances: `[indDef for rect]` and `[infer indType of T ...]`. - **instances.v** — Pre-built `IndType` + derived instances for standard types (unit, bool, nat, option, sum, prod, seq, comparison, positive, N, Z, ascii, string). - **compat.v** — MathComp version compatibility shim (handles `Order.disp_t` differences). - **deriving.v** — Convenience re-export of all public modules. ### Instance derivation modules (theories/instances/) - **eqtype.v** — Derives `hasDecEq` (decidable equality). - **tree_of_ind.v** — Converts inductive types to decision trees; core infrastructure used by other derivations. - **fintype.v** — Derives `isFinite` (requires non-recursive types with finType parameters). - **order.v** — Derives `isOrder` (lexicographic total order on constructors then arguments). ### Derivation workflow ```coq (* 1. Define type *) Inductive foo := Foo1 of nat | Foo2 of foo & nat. (* 2. Register IndType *) Definition foo_indDef := [indDef for foo_rect]. Canonical foo_indType := IndType foo foo_indDef. (* 3. Derive and register instances *) Definition foo_hasDecEq := [derive hasDecEq for foo]. HB.instance Definition _ := foo_hasDecEq. ``` Derivation flags: `[derive ...]` (cbv simplification), `[derive lazy ...]` (lazy eval), `[derive nored ...]` (no simplification — use for large types, keep opaque with `Qed`). ### Special cases - **Records**: Coq doesn't auto-generate induction principles for records. Add `Scheme T_rect := Induction for T Sort Type.` first. - **Mutually recursive types**: Use `Combined Scheme` to produce a joint recursor. - **Nested inductive types**: Requires a hand-written recursor. ## Tests Test files in `tests/` serve as both regression tests and usage examples: `syntax.v` (mutual recursion, `nored`), `tree.v`, `mutual.v`, `nested.v`, `three.v` (three-way mutual), `records.v`. ## Style Guidelines - Keep lines as close to 80 characters as possible, but never above 80. - Use ssreflect tactics by default. ## CI GitHub Actions with Nix (`nix build`) across x86_64-linux, aarch64-linux, aarch64-darwin, x86_64-darwin. Caching via Cachix. arthuraa-deriving-0e084ee/CONTRIBUTING.md000066400000000000000000000034151517411663100200030ustar00rootroot00000000000000# Contributing ## Running the tests Run `make test` from the repo root (inside `nix develop` if you use the flake) to build the library and run the entire test suite. There are two kinds of tests: - **End-to-end functionality tests** under `tests/*.v`. Each file is a small Rocq development that exercises the derivation machinery on a particular shape of inductive type (mutual recursion, records, nested types, `nored` mode, etc.) and acts as both a regression test and a usage example. - **Performance benchmarks** under `bench/`. These measure how long the derivation tactics take on synthetic inductive types of varying shapes. ## How the benchmarks work Each benchmark sweep (e.g. `types`, `ctors`, `rec`) is described by a plain CSV file at `bench/.csv`. Each row lists the parameters that should be passed to `bench/gen_bench.ml` to produce one synthetic Rocq file (number of mutually inductive types, number of constructors per type, number of recursive and nonrecursive arguments, etc.). `bench/gen_mk.awk` reads those CSVs and emits a make fragment with one `.v` recipe per row plus the dependencies that wire each .v file to several `.out` files — one per repetition. The number of repetitions is set once in `bench/bench.mk` via `BENCH_REPS`, so we can take a median and smooth out noise; `make -j` parallelises the runs across cores. The sweeps cover the factors we care about for derivation performance: number of mutually inductive types, number of constructors, number of recursive arguments per constructor, number of nonrecursive arguments, and the combination of both kinds of arguments. Each sweep produces one summary CSV and one PNG plot under `bench/results/latest/`, so you end up with one graph per factor showing how each derivation step scales. arthuraa-deriving-0e084ee/CoqMakefile.local000066400000000000000000000013561517411663100207500ustar00rootroot00000000000000TESTVFILES=$(wildcard tests/*.v) TESTVOFILES=$(TESTVFILES:.v=.vo) UNFOLDFILES = theories/ind.v theories/base.v include bench/bench.mk theories/tactics.v: make_tactics.ml $(UNFOLDFILES) ocaml -I +str str.cma make_tactics.ml $(UNFOLDFILES) > theories/tactics.v test: $(TESTVOFILES) .PHONY: test .CoqMakefile.test.d: $(TESTVFILES) $(SHOW)'COQDEP TESTVFILES' $(HIDE)$(COQDEP) -vos -dyndep var $(COQMF_COQLIBS_NOML) $^ $(redir_if_ok) -include .CoqMakefile.test.d $(TESTVOFILES): %.vo: %.v $(SHOW)TEST $< $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< $(TIMING_EXTRA) clean:: $(HIDE)rm -f $(TESTVOFILES) $(HIDE)rm -f .CoqMakefile.test.d $(HIDE)rm -f theories/tactics.v # Local Variables: # mode: Makefile # End: arthuraa-deriving-0e084ee/LICENSE000066400000000000000000000020501517411663100165510ustar00rootroot00000000000000Copyright 2019 Arthur Azevedo de Amorim Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. arthuraa-deriving-0e084ee/Makefile000066400000000000000000000013261517411663100172110ustar00rootroot00000000000000# KNOWNTARGETS will not be passed along to CoqMakefile KNOWNTARGETS := CoqMakefile # KNOWNFILES will not get implicit targets from the final rule, and so depending on them won’t invoke the submake # Warning: These files get declared as PHONY, so any targets depending on them always get rebuilt KNOWNFILES := Makefile _CoqProject .DEFAULT_GOAL := invoke-coqmakefile CoqMakefile: Makefile _CoqProject $(COQBIN)coq_makefile -f _CoqProject -o CoqMakefile invoke-coqmakefile: CoqMakefile $(MAKE) --no-print-directory -f CoqMakefile $(filter-out $(KNOWNTARGETS),$(MAKECMDGOALS)) .PHONY: invoke-coqmakefile $(KNOWNFILES) # This should be the last rule, to handle any targets not declared above %: invoke-coqmakefile @true arthuraa-deriving-0e084ee/README.md000066400000000000000000000072601517411663100170330ustar00rootroot00000000000000# Deriving ─ Generic instances for Coq inductive types [![Nix Flake actions](https://github.com/arthuraa/deriving/actions/workflows/cachix-install-nix-action.yml/badge.svg)](https://github.com/arthuraa/deriving/actions/workflows/cachix-install-nix-action.yml) The Deriving library builds instances of basic MathComp classes for inductive data types with little boilerplate, akin to Haskell's `deriving` functionality. To define an `eqType` instance for a type `foo`, just write: From HB Require Import structures. From mathcomp Require Import ssreflect ssrnat eqtype. From deriving Require Import deriving. Inductive foo := Foo1 of nat | Foo2 of foo & nat. (* foo_rect is the recursor automatically generated by Coq *) Definition foo_indDef := [indDef for foo_rect]. Canonical foo_indType := IndType foo foo_indDef. Definition foo_hasDecEq := [derive hasDecEq for foo]. HB.instance Definition _ := foo_hasDecEq. ## Supported types and limitations Besides simple definitions such as the one above, Deriving can handle the following features: - Types with uniform parameters (e.g. `list`). - Mutually inductive types (by using the recursor generated by `Combined Scheme` command). - Nested inductive types (if you write your own recursor). Check the `tests/` directory for detailed examples. The following features are still not supported: - Types with non-uniform parameters (e.g. `Vector.t`). - Constructors with dependent types (e.g. `C : forall n : nat, P n -> T`). - Coinductive types. ## Predefined instances Besides `eqType`, there are predefined generic instances for `choiceType`, `countType`, `finType` and `orderType`. To use them, you must ensure that every non-recursive argument of the type is _also an instance of the class_; otherwise, you'll get an ugly, uninformative error message. For `finType`, you must additionally ensure that the type does not have recursive occurrences. You can also define instances for your own classes inside of Coq, without resorting to OCaml code. This feature is not documented yet, but you can refer to the definition of the instances provided by Deriving in `theories/instances`. Or drop me a line! ## Record instances Coq does not generate induction principles for record types by default. If you want to derive an instance for a record type, you need to generate the induction principle by hand: Record foo := (* ... *) Scheme foo_rect := Induction for foo Sort Type. Check the tests for [an example](tests/records.v). ## Simplification and performance issues It is useful for instances of certain classes to have good reduction behavior (e.g. `eqType`). By default, Deriving attempts to simplify the derived instances as much as possible, to make them more similar to hand-written code. However, this process can be too slow for large definitions, so it can be disabled with the `nored` flag: Definition large_type_hasDecEq : Equality.mixin_of large_type. Proof. exact [derive nored hasDecEq for large_type]. Qed. In such cases, it is a good idea to keep the instance opaque (e.g. defined with `Qed`) to avoid slowdown. ## Requirements Deriving has been tested against the following dependencies: - Coq 8.17 -- Rocq 9.1 - `coq-mathcomp-ssreflect` 2.2.0 -- 2.5.0 ## Installation Deriving can be installed through the [`released`](https://coq.inria.fr/opam/released/README.md) repository: ```shell opam repo add coq-released https://coq.inria.fr/opam/released opam install coq-deriving ``` Alternatively, you can compile Deriving from source: ```shell make && make install ``` ## Citing If you want to cite Deriving, you can refer to its [Zenodo page][1]. [1]: https://zenodo.org/record/7065501#.YxuE-9LMKEC arthuraa-deriving-0e084ee/TODO.org000066400000000000000000000006621517411663100170310ustar00rootroot00000000000000* Documentation * Clean up code * Ensure equality and order operations are simplified properly * Check why it is not possible to derive the mixin directly in the instance E.g. this does not work: HB.instance Definition _ := [derive eqMixin for foo]. * Find a better way of writing packing functions (cf. infer.v and the derive notation in eqtype.v) * By default, [derive nored eqMixin for ...] does not simplify the type of the mixin arthuraa-deriving-0e084ee/_CoqProject000066400000000000000000000007111517411663100177010ustar00rootroot00000000000000-Q theories deriving -arg -w -arg -notation-overridden -arg -w -arg -non-reversible-notation -arg -w -arg -ssr-search-moved -arg -w -arg -redundant-canonical-projection -arg -w -arg -projection-no-head-constant theories/base.v theories/ind.v theories/tactics.v theories/infer.v theories/instances.v theories/compat.v theories/deriving.v theories/instances/eqtype.v theories/instances/tree_of_ind.v theories/instances/fintype.v theories/instances/order.v arthuraa-deriving-0e084ee/bench/000077500000000000000000000000001517411663100166265ustar00rootroot00000000000000arthuraa-deriving-0e084ee/bench/README.md000066400000000000000000000075271517411663100201200ustar00rootroot00000000000000# Benchmarks This directory holds the performance benchmarks for the derivation tactics. They run as part of `make test` and produce one CSV plus one PNG per sweep under `bench/results/latest/`. ## Sweeps A *sweep* varies one factor that we expect to affect derivation cost and holds the rest fixed. The five sweeps currently defined are: | sweep | x-axis | |----------|-------------------------------------------------| | `types` | number of mutually inductive types | | `ctors` | number of constructors per type | | `rec` | recursive arguments per constructor | | `nonrec` | nonrecursive arguments per constructor | | `args` | both kinds of arguments together (rec = nonrec) | Each sweep is described by a plain CSV file at `bench/.csv`. The header lists `value` (the x-axis) followed by one column per `gen_bench.ml` flag; every row becomes one synthetic Rocq file with those parameters. Adding a data point is a one-line edit; adding a new sweep is a new CSV plus an entry in `BENCH_DIMS` (and an x-axis label in `bench/plot.ml`). ## Pipeline ``` bench/.csv ──▶ gen_mk.awk ──▶ bench/build/bench-deps.mk │ ▼ gen_bench.ml ──▶ build//v.v │ ▼ rocq c ──▶ build//v-.out │ ▼ summarize ──▶ results/latest/.csv │ ▼ plot ──▶ results/latest/.png ``` `bench/gen_mk.awk` reads every `bench/.csv` and emits `bench/build/bench-deps.mk`, an auto-generated make fragment that contains, for each row, a `.v` recipe and per-rep `.out`→`.v` dependencies. `bench/bench.mk` (the hand-written companion) provides the small number of generic pattern rules that drive the rest of the pipeline: - `%.v` — generated by `gen_bench.ml` from the CSV row. - `%.out` — captured stdout of `rocq c` on the matching `.v`. - `summarize.ml` — small OCaml script (run under the bytecode interpreter) that parses a batch of `.out` files into a long-form summary CSV. - `plot.ml` — small OCaml script that reads a summary CSV, takes the median across reps for each `(value, derivation step)`, and shells out to `gnuplot` to render the PNG. Each benchmark is run several times (`BENCH_REPS` in `bench/bench.mk`) so that `plot` can take the median and smooth out noise. Because every `.out` file is its own make target, `make -j` parallelises the runs across cores for free. ## Files | file | role | |------------------------|---------------------------------------------------------| | `.csv` | sweep configuration (one row per data point) | | `gen_bench.ml` | generates a synthetic `.v` file from CLI flags | | `gen_mk.awk` | turns the sweep CSVs into `build/bench-deps.mk` | | `bench.mk` | hand-written make rules driving the whole pipeline | | `summarize.ml` | aggregates per-run `.out` files into one summary CSV | | `plot.ml` | renders one summary CSV into a PNG via `gnuplot` | | `build/` | gitignored; intermediate `.v`, `.out`, compiled tools | | `results/latest/` | gitignored; final summary CSVs and PNGs | arthuraa-deriving-0e084ee/bench/args.csv000066400000000000000000000001171517411663100202760ustar00rootroot00000000000000value,types,ctors,rec,nonrec 1,1,2,1,1 2,1,2,2,2 3,1,2,3,3 4,1,2,4,4 5,1,2,5,5 arthuraa-deriving-0e084ee/bench/bench.mk000066400000000000000000000045401517411663100202410ustar00rootroot00000000000000# bench/bench.mk — Performance-benchmark rules. See bench/README.md # for an overview of how the pipeline fits together. BENCH_DIMS = types nonrec rec args ctors BENCH_REPS = 3 BENCH_BUILD = bench/build BENCH_RESULTS = bench/results/latest BENCH_CSVS = $(BENCH_DIMS:%=bench/%.csv) BENCH_SUMMARIES = $(BENCH_DIMS:%=$(BENCH_RESULTS)/%.csv) BENCH_PNGS = $(BENCH_SUMMARIES:.csv=.png) # We run the OCaml helper scripts under the bytecode interpreter. The csv # library lives outside the stdlib, so feed it via -I + csv.cma; unix.cma is in # the stdlib and needs no extra path. BENCH_OCAML = ocaml -I $(shell ocamlfind query csv) csv.cma bench: $(BENCH_PNGS) .PHONY: bench test: bench $(BENCH_BUILD)/bench-deps.mk: $(BENCH_CSVS) bench/gen_mk.awk $(SHOW)'BENCH-DEPS $@' $(HIDE)mkdir -p $(@D) $(HIDE)awk -v reps='$(BENCH_REPS)' \ -v build='$(BENCH_BUILD)' \ -v results='$(BENCH_RESULTS)' \ -f bench/gen_mk.awk $(BENCH_CSVS) > $@ -include $(BENCH_BUILD)/bench-deps.mk # The .v recipes are supplied by bench-deps.mk. # Generic .out rule: run the .v file injected as a prerequisite by # bench-deps.mk through coqtop in batch mode. Depend on the library VO files # (not TESTVOFILES) so only the theories are rebuilt before a bench. Prereqs # expand at rule-read time so we can't reference VOFILES here (it's defined # later in CoqMakefile); $(VFILES) is set by `include CoqMakefile.conf` before # CoqMakefile.local is read. # # We use $(COQTOP) -batch rather than $(COQC) because a single .v file is # compiled once per repetition: three parallel $(COQC) invocations racing on # the same .vo/.vos/.vok/.glob output paths caused intermittent "Uncaught # exception End_of_file" anomalies in CI. coqtop -batch runs the file for # side effects without touching any output file. $(BENCH_BUILD)/%.out: $(VFILES:.v=.vo) $(SHOW)'BENCH $(filter %.v,$^)' $(HIDE)mkdir -p $(@D) $(HIDE)$(COQTOP) -batch $(COQDEBUG) $(COQFLAGS) $(COQLIBS) \ -load-vernac-source $(basename $(filter %.v,$^)) > $@ $(BENCH_RESULTS)/%.csv: bench/summarize.ml $(SHOW)'SUMMARIZE $@' $(HIDE)mkdir -p $(@D) $(HIDE)$(BENCH_OCAML) bench/summarize.ml -dim $* \ $(filter %.out,$^) > $@ $(BENCH_RESULTS)/%.png: $(BENCH_RESULTS)/%.csv bench/plot.ml $(SHOW)'PLOT $@' $(HIDE)$(BENCH_OCAML) unix.cma bench/plot.ml $< $@ clean:: $(HIDE)rm -rf $(BENCH_BUILD) $(BENCH_RESULTS) arthuraa-deriving-0e084ee/bench/ctors.csv000066400000000000000000000002031517411663100204700ustar00rootroot00000000000000value,types,ctors,rec,nonrec 1,1,1,1,1 2,1,2,1,1 3,1,3,1,1 4,1,4,1,1 5,1,5,1,1 6,1,6,1,1 7,1,7,1,1 8,1,8,1,1 9,1,9,1,1 10,1,10,1,1 arthuraa-deriving-0e084ee/bench/gen_bench.ml000066400000000000000000000143311517411663100210720ustar00rootroot00000000000000(* gen_bench.ml — Generate Rocq test files for benchmarking deriving. Usage: ocaml gen_bench.ml [options] Options: -types N number of mutually inductive types (default 1) -ctors N constructors per type (default 3) -rec N recursive arguments per constructor (default 1) -nonrec N nonrecursive arguments per constructor (default 1) -nonrec-type T type of nonrecursive arguments (default nat) -seed N random seed (default 0) -o FILE output file (default stdout) The first constructor of each type always takes 0 recursive arguments so the type is inhabited. *) let n_types = ref 1 let n_ctors = ref 3 let n_rec = ref 1 let n_nonrec = ref 1 let nonrec_type = ref "nat" let seed = ref 0 let output = ref "" let speclist = [ "-types", Arg.Set_int n_types, "N number of mutually inductive types"; "-ctors", Arg.Set_int n_ctors, "N constructors per type"; "-rec", Arg.Set_int n_rec, "N recursive arguments per constructor"; "-nonrec", Arg.Set_int n_nonrec, "N nonrecursive arguments per constructor"; "-nonrec-type", Arg.Set_string nonrec_type,"T type of nonrecursive arguments"; "-seed", Arg.Set_int seed, "N random seed"; "-o", Arg.Set_string output, "FILE output file (default stdout)"; ] let usage = "gen_bench.ml [options]" let () = Arg.parse speclist (fun a -> raise (Arg.Bad ("unexpected arg " ^ a))) usage; if !n_types < 1 then begin prerr_endline "gen_bench: -types must be >= 1"; exit 1 end; Random.init !seed; let buf = Buffer.create 4096 in let pf fmt = Printf.ksprintf (Buffer.add_string buf) fmt in let type_name i = Printf.sprintf "T%d" i in let ctor_name i j = Printf.sprintf "C%d_%d" i j in let mutual = !n_types > 1 in (* Header *) pf "(* Auto-generated by bench/gen_bench.ml. Do not edit. *)\n"; pf "(* types=%d ctors=%d rec=%d nonrec=%d nonrec-type=%s seed=%d *)\n\n" !n_types !n_ctors !n_rec !n_nonrec !nonrec_type !seed; pf "From HB Require Import structures.\n"; pf "From mathcomp Require Import\n"; pf " ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype finset order.\n"; pf "Set SsrOldRewriteGoalsOrder.\n\n"; pf "From deriving Require Import deriving.\n"; pf "From deriving Require Import instances.eqtype instances.order.\n\n"; pf "Set Implicit Arguments.\n"; pf "Unset Strict Implicit.\n"; pf "Unset Printing Implicit Defensive.\n\n"; (* Inductive declaration *) if mutual then pf "Unset Elimination Schemes.\n"; for i = 0 to !n_types - 1 do let kw = if i = 0 then "Inductive" else "with" in pf "%s %s :=" kw (type_name i); if !n_ctors = 0 then () else begin pf "\n"; for j = 0 to !n_ctors - 1 do let n_rec_this = if j = 0 then 0 else !n_rec in let nonrec_args = List.init !n_nonrec (fun _ -> !nonrec_type) in let rec_args = List.init n_rec_this (fun _ -> type_name (Random.int !n_types)) in let args = nonrec_args @ rec_args in pf "| %s" (ctor_name i j); (match args with | [] -> () | _ -> pf " of %s" (String.concat " & " args)); if j < !n_ctors - 1 then pf "\n" done end; if i < !n_types - 1 then pf "\n" done; pf ".\n"; if mutual then pf "Set Elimination Schemes.\n"; pf "\n"; (* Recursors *) let rect_name i = Printf.sprintf "%s_rect" (type_name i) in let combined_name = "T_combined_rect" in let main_rect = if mutual then combined_name else rect_name 0 in if mutual then begin for i = 0 to !n_types - 1 do let kw = if i = 0 then "Scheme" else "with " in pf "%s %s := Induction for %s Sort Type%s\n" kw (rect_name i) (type_name i) (if i = !n_types - 1 then "." else "") done; pf "Combined Scheme %s from" combined_name; for i = 0 to !n_types - 1 do pf "%s %s" (if i = 0 then "" else ",") (rect_name i) done; pf ".\n\n" end; let say msg = pf "Goal True. idtac \"BENCH: %s\". Abort.\n" msg in (* indDef + IndType *) say "indDef"; pf "Time Definition T_indDef := [indDef for %s].\n" main_rect; for i = 0 to !n_types - 1 do let t = type_name i in say (Printf.sprintf "IndType %s" t); pf "Time Canonical %s_indType := IndType %s T_indDef.\n" t t done; pf "\n"; (* nored hasDecEq + simplified hasDecEq for each type *) for i = 0 to !n_types - 1 do let t = type_name i in say (Printf.sprintf "nored hasDecEq %s" t); pf "Time Definition %s_hasDecEq_nored : hasDecEq %s :=\n" t t; pf " [derive nored hasDecEq for %s].\n" t; say (Printf.sprintf "simpl hasDecEq %s" t); pf "Time Definition %s_hasDecEq : hasDecEq %s :=\n" t t; pf " ltac:(simpl_hasDecEq %s %s_hasDecEq_nored).\n" t t; pf "HB.instance Definition _ := %s_hasDecEq.\n\n" t done; (* hasChoice for each type. There is no nored form: the derivation piggybacks on tree_of_coq_indK via Choice.copy/pcan_type. *) for i = 0 to !n_types - 1 do let t = type_name i in say (Printf.sprintf "hasChoice %s" t); pf "Time Definition %s_hasChoice := [derive hasChoice for %s].\n" t t; pf "HB.instance Definition _ := %s_hasChoice.\n\n" t done; (* isCountable, same shape as hasChoice. *) for i = 0 to !n_types - 1 do let t = type_name i in say (Printf.sprintf "isCountable %s" t); pf "Time Definition %s_isCountable := [derive isCountable for %s].\n" t t; pf "HB.instance Definition _ := %s_isCountable.\n\n" t done; (* nored isOrder + simplified isOrder, mirroring hasDecEq. *) for i = 0 to !n_types - 1 do let t = type_name i in say (Printf.sprintf "nored isOrder %s" t); pf "Time Definition %s_isOrder_nored\n" t; pf " : Order.isOrder Order.default_display %s :=\n" t; pf " [derive nored isOrder for %s].\n" t; say (Printf.sprintf "simpl isOrder %s" t); pf "Time Definition %s_isOrder\n" t; pf " : Order.isOrder Order.default_display %s :=\n" t; pf " ltac:(simpl_isOrder %s %s_isOrder_nored).\n" t t; pf "HB.instance Definition _ := %s_isOrder.\n\n" t done; let out = Buffer.contents buf in if !output = "" then print_string out else begin let oc = open_out !output in output_string oc out; close_out oc end arthuraa-deriving-0e084ee/bench/gen_mk.awk000066400000000000000000000040221517411663100205700ustar00rootroot00000000000000# gen_mk.awk — Turn benchmark configuration CSVs into a make fragment. # # Invoke as: # awk -v reps=3 -v build='bench/build' -v results='bench/results/latest' \ # -f bench/gen_mk.awk bench/types.csv bench/nonrec.csv ... # # `reps` is the number of repetitions per benchmark; the resulting # .out files use 0..reps-1 as their index suffix. # # For each row in .csv we emit: # - a .v target with a gen_bench.ml recipe, # - explicit dependency lines linking the matching .out files # back to the .v file, so the generic %.out pattern rule in # CoqMakefile.local can pick them up, # - a dependency line adding each .out to the per-dimension summary # CSV target. BEGIN { if (reps == "") reps = 1 if (build == "") build = "bench/build" if (results == "") results = "bench/results/latest" print "# Auto-generated by bench/gen_mk.awk — do not edit." } FNR == 1 { # Extract dimension name from the file path: strip dir and .csv. dim = FILENAME sub(/.*\//, "", dim) sub(/\.csv$/, "", dim) nfields = split($0, header, ",") next } { nrow = split($0, row, ",") if (nrow == 0 || row[1] == "") next value = row[1] # Prefix with "v" so the resulting filename is a valid Rocq module # name (they can't start with a digit). vfile = build "/" dim "/v" value ".v" # gen_bench.ml CLI: column names (after `value`) map to -. cmd = "ocaml bench/gen_bench.ml" for (i = 2; i <= nfields; i++) { cmd = cmd " -" header[i] " " row[i] } cmd = cmd " -o $@" # .v recipe. printf "%s: bench/gen_bench.ml\n", vfile printf "\t$(SHOW)'GEN-BENCH %s'\n", vfile printf "\t$(HIDE)mkdir -p $(@D)\n" printf "\t$(HIDE)%s\n", cmd # Per-rep .out → .v dependency + summary rollup. outs = "" for (rep = 0; rep < reps; rep++) { out = build "/" dim "/v" value "-" rep ".out" outs = (outs == "" ? out : outs " " out) } printf "%s: %s\n", outs, vfile printf "%s/%s.csv: %s\n", results, dim, outs } arthuraa-deriving-0e084ee/bench/nonrec.csv000066400000000000000000000002031517411663100206220ustar00rootroot00000000000000value,types,ctors,rec,nonrec 1,1,2,1,1 2,1,2,1,2 3,1,2,1,3 4,1,2,1,4 5,1,2,1,5 6,1,2,1,6 7,1,2,1,7 8,1,2,1,8 9,1,2,1,9 10,1,2,1,10 arthuraa-deriving-0e084ee/bench/plot.ml000066400000000000000000000133761517411663100201500ustar00rootroot00000000000000(* plot.ml — Aggregate one long-form summary CSV and draw a PNG. Invoked by the bench/bench.mk %.png recipe: ocaml -I $(ocamlfind query csv) csv.cma unix.cma \ bench/plot.ml The summary CSV is in the format emitted by bench/summarize.ml: columns `dimension,value,rep,step,seconds`, one row per `Time Definition` transaction. Step labels like "simpl hasDecEq T0" carry a trailing per-type " T" suffix which we strip so multi-type sweeps collapse to a single line per derivation step. For each (value, rep, step) we sum across types to show total work, then take the median across reps so the final plot has one point per (value, step). The aggregated table is dumped to a sibling .dat file and fed to gnuplot as wide-format columns. *) let dim_xlabels = [ "types", "number of mutually inductive types"; "nonrec", "nonrecursive arguments per constructor"; "rec", "recursive arguments per constructor"; "args", "arguments per constructor (rec = nonrec)"; "ctors", "constructors per type"; ] let step_order = [ "indDef"; "IndType"; "nored hasDecEq"; "simpl hasDecEq"; "hasChoice"; "isCountable"; "nored isOrder"; "simpl isOrder"; ] (* Strip a trailing " T" suffix from a step label. *) let base_step step = let n = String.length step in let rec digits_from i = if i >= n then true else if step.[i] >= '0' && step.[i] <= '9' then digits_from (i + 1) else false in let rec scan i = if i + 2 > n then step else if step.[i] = ' ' && step.[i + 1] = 'T' && i + 2 < n && digits_from (i + 2) then String.sub step 0 i else scan (i + 1) in scan 0 let median xs = let a = Array.of_list xs in Array.sort compare a; let n = Array.length a in if n = 0 then nan else if n mod 2 = 1 then a.(n / 2) else (a.(n / 2 - 1) +. a.(n / 2)) /. 2.0 let load_sums path = let rows = Csv.load path in match rows with | [] -> failwith ("empty CSV: " ^ path) | header :: rows -> let idx name = let rec find i = function | [] -> failwith ("missing column: " ^ name) | c :: _ when c = name -> i | _ :: rest -> find (i + 1) rest in find 0 header in let i_val = idx "value" in let i_rep = idx "rep" in let i_step = idx "step" in let i_secs = idx "seconds" in (* (value, rep, base_step) -> total seconds across types *) let sums = Hashtbl.create 128 in List.iter (fun row -> let row = Array.of_list row in if Array.length row > i_secs then begin let v = int_of_string row.(i_val) in let r = int_of_string row.(i_rep) in let step = base_step row.(i_step) in let secs = float_of_string row.(i_secs) in let key = (v, r, step) in let prev = try Hashtbl.find sums key with Not_found -> 0.0 in Hashtbl.replace sums key (prev +. secs) end ) rows; sums let group_by_step sums = let by_step = Hashtbl.create 16 in Hashtbl.iter (fun (v, _rep, step) s -> let vmap = match Hashtbl.find_opt by_step step with | Some m -> m | None -> let m = Hashtbl.create 16 in Hashtbl.add by_step step m; m in let prev = try Hashtbl.find vmap v with Not_found -> [] in Hashtbl.replace vmap v (s :: prev) ) sums; by_step let sorted_values by_step = let s = ref [] in Hashtbl.iter (fun _step vmap -> Hashtbl.iter (fun v _ -> if not (List.mem v !s) then s := v :: !s ) vmap ) by_step; List.sort compare !s let ordered_steps by_step = let known = List.filter (fun s -> Hashtbl.mem by_step s) step_order in let extras = Hashtbl.fold (fun k _ acc -> if List.mem k step_order then acc else k :: acc ) by_step [] in known @ List.sort compare extras let write_dat path values steps by_step = let oc = open_out path in output_string oc "# value"; List.iter (fun s -> output_char oc ' '; String.iter (fun c -> output_char oc (if c = ' ' then '_' else c) ) s ) steps; output_char oc '\n'; List.iter (fun v -> Printf.fprintf oc "%d" v; List.iter (fun s -> let vmap = Hashtbl.find by_step s in match Hashtbl.find_opt vmap v with | Some xs -> Printf.fprintf oc " %.6f" (median xs) | None -> output_string oc " NaN" ) steps; output_char oc '\n' ) values; close_out oc let run_gnuplot ~dat ~png ~title ~xlabel steps = let ic, oc = Unix.open_process "gnuplot" in let p fmt = Printf.fprintf oc fmt in p "set terminal pngcairo size 900,600 enhanced font 'sans,11'\n"; p "set output '%s'\n" png; p "set title 'deriving timings vs %s'\n" title; p "set xlabel '%s'\n" xlabel; p "set ylabel 'seconds (median over reps)'\n"; p "set key outside right top\n"; p "set grid\n"; p "set logscale y\n"; p "set yrange [0.001:*]\n"; p "plot "; List.iteri (fun i step -> if i > 0 then p ", "; p "'%s' using 1:%d with linespoints title '%s'" dat (i + 2) step ) steps; p "\n"; close_out oc; (try while true do ignore (input_line ic) done with End_of_file -> ()); ignore (Unix.close_process (ic, oc)) let () = let csv_path, png_path = match Sys.argv with | [| _; a; b |] -> a, b | _ -> prerr_endline "usage: plot.ml "; exit 2 in let dim = Filename.chop_extension (Filename.basename csv_path) in let xlabel = try List.assoc dim dim_xlabels with Not_found -> dim in let dat_path = Filename.concat (Filename.dirname png_path) (dim ^ ".dat") in let sums = load_sums csv_path in let by_step = group_by_step sums in let values = sorted_values by_step in let steps = ordered_steps by_step in write_dat dat_path values steps by_step; run_gnuplot ~dat:dat_path ~png:png_path ~title:xlabel ~xlabel steps; Printf.printf "wrote %s\n" png_path arthuraa-deriving-0e084ee/bench/rec.csv000066400000000000000000000002031517411663100201070ustar00rootroot00000000000000value,types,ctors,rec,nonrec 1,1,2,1,1 2,1,2,2,1 3,1,2,3,1 4,1,2,4,1 5,1,2,5,1 6,1,2,6,1 7,1,2,7,1 8,1,2,8,1 9,1,2,9,1 10,1,2,10,1 arthuraa-deriving-0e084ee/bench/summarize.ml000066400000000000000000000062031517411663100211750ustar00rootroot00000000000000(* summarize.ml — Turn a batch of coqc .out files into a long-form CSV. Invoked by the bench/bench.mk %.csv summary rule: ocaml -I $(ocamlfind query csv) csv.cma bench/summarize.ml \ -dim //-.out ... Each input file is the captured stdout of a single coqc invocation on a benchmark .v file; gen_bench.ml sprinkles `idtac "BENCH: ..."` commands before each `Time Definition`, so the output looks like: BENCH: simpl hasDecEq T0 Finished transaction in 0.123 secs (0.120u,0.003s) ... We pair each BENCH label with the next `Finished transaction in X` line and emit one CSV row per pair. Value and rep are recovered from the filename stem, e.g. `bench/build/types/3-1.out` → value=3, rep=1. *) let dim = ref "" let files = ref [] let has_prefix s p = String.length s >= String.length p && String.sub s 0 (String.length p) = p let strip_prefix s p = String.sub s (String.length p) (String.length s - String.length p) let read_lines path = let ic = open_in path in let rec loop acc = match input_line ic with | line -> loop (line :: acc) | exception End_of_file -> close_in ic; List.rev acc in loop [] let parse_output lines = let label = ref None in let acc = ref [] in List.iter (fun raw -> let line = String.trim raw in if has_prefix line "BENCH: " then label := Some (strip_prefix line "BENCH: ") else if has_prefix line "Finished transaction in " then begin let rest = strip_prefix line "Finished transaction in " in match String.index_opt rest ' ' with | None -> () | Some i -> (try let t = float_of_string (String.sub rest 0 i) in (match !label with | Some l -> acc := (l, t) :: !acc; label := None | None -> ()) with _ -> ()) end ) lines; List.rev !acc (* Recover (value, rep) from "/v-.out". The leading "v" is a prefix added by gen_mk.awk so the file name is a legal Rocq module identifier. *) let parse_stem path = let base = Filename.chop_extension (Filename.basename path) in let base = if String.length base > 0 && base.[0] = 'v' then String.sub base 1 (String.length base - 1) else base in match String.index_opt base '-' with | None -> failwith ("bad .out filename: " ^ path) | Some i -> let value = String.sub base 0 i in let rep = String.sub base (i + 1) (String.length base - i - 1) in (value, rep) let () = Arg.parse [ "-dim", Arg.Set_string dim, "NAME dimension label emitted in the CSV" ] (fun f -> files := f :: !files) "summarize.ml -dim NAME FILE.out ..."; if !dim = "" then (prerr_endline "summarize.ml: -dim is required"; exit 2); let files = List.rev !files in let rows = ref [ [ "dimension"; "value"; "rep"; "step"; "seconds" ] ] in List.iter (fun path -> let value, rep = parse_stem path in let pairs = parse_output (read_lines path) in List.iter (fun (step, secs) -> rows := [ !dim; value; rep; step; Printf.sprintf "%.6f" secs ] :: !rows ) pairs ) files; Csv.output_all (Csv.to_channel stdout) (List.rev !rows) arthuraa-deriving-0e084ee/bench/types.csv000066400000000000000000000001171517411663100205060ustar00rootroot00000000000000value,types,ctors,rec,nonrec 1,1,2,1,1 2,2,2,1,1 3,3,2,1,1 4,4,2,1,1 5,5,2,1,1 arthuraa-deriving-0e084ee/coq-deriving.opam000066400000000000000000000020111517411663100210060ustar00rootroot00000000000000opam-version: "2.0" name: "coq-deriving" version: "dev" maintainer: "Arthur Azevedo de Amorim " homepage: "https://github.com/arthuraa/deriving" bug-reports: "https://github.com/arthuraa/deriving/issues" dev-repo: "git+https://github.com/arthuraa/deriving.git" license: "MIT" build: [ make "-j" "%{jobs}%" "test" {with-test} ] install: [ make "install" ] depends: [ "coq" { (>= "8.17" & < "9.2~") | (= "dev") } "coq-mathcomp-ssreflect" {>= "2.0" | (= "dev")} ] tags: [ "keyword:generic programming" "category:Computer Science/Data Types and Data Structures" "logpath:deriving" ] authors: [ "Arthur Azevedo de Amorim" ] synopsis: "Generic instances of MathComp classes" description: """ Deriving provides generic instances of MathComp classes for inductive data types. It includes native support for eqType, choiceType, countType and finType instances, and it allows users to define their own instances for other classes. """ url { src: "git+https://github.com/arthuraa/deriving.git#master" } arthuraa-deriving-0e084ee/flake.lock000066400000000000000000000041001517411663100174760ustar00rootroot00000000000000{ "nodes": { "flake-parts": { "inputs": { "nixpkgs-lib": "nixpkgs-lib" }, "locked": { "lastModified": 1765835352, "narHash": "sha256-XswHlK/Qtjasvhd1nOa1e8MgZ8GS//jBoTqWtrS1Giw=", "owner": "hercules-ci", "repo": "flake-parts", "rev": "a34fae9c08a15ad73f295041fec82323541400a9", "type": "github" }, "original": { "owner": "hercules-ci", "repo": "flake-parts", "type": "github" } }, "nix-github-actions": { "inputs": { "nixpkgs": [ "nixpkgs" ] }, "locked": { "lastModified": 1737420293, "narHash": "sha256-F1G5ifvqTpJq7fdkT34e/Jy9VCyzd5XfJ9TO8fHhJWE=", "owner": "nix-community", "repo": "nix-github-actions", "rev": "f4158fa080ef4503c8f4c820967d946c2af31ec9", "type": "github" }, "original": { "owner": "nix-community", "repo": "nix-github-actions", "type": "github" } }, "nixpkgs": { "locked": { "lastModified": 1776548001, "narHash": "sha256-ZSK0NL4a1BwVbbTBoSnWgbJy9HeZFXLYQizjb2DPF24=", "owner": "NixOS", "repo": "nixpkgs", "rev": "b12141ef619e0a9c1c84dc8c684040326f27cdcc", "type": "github" }, "original": { "owner": "NixOS", "ref": "nixos-unstable", "repo": "nixpkgs", "type": "github" } }, "nixpkgs-lib": { "locked": { "lastModified": 1765674936, "narHash": "sha256-k00uTP4JNfmejrCLJOwdObYC9jHRrr/5M/a/8L2EIdo=", "owner": "nix-community", "repo": "nixpkgs.lib", "rev": "2075416fcb47225d9b68ac469a5c4801a9c4dd85", "type": "github" }, "original": { "owner": "nix-community", "repo": "nixpkgs.lib", "type": "github" } }, "root": { "inputs": { "flake-parts": "flake-parts", "nix-github-actions": "nix-github-actions", "nixpkgs": "nixpkgs" } } }, "root": "root", "version": 7 } arthuraa-deriving-0e084ee/flake.nix000066400000000000000000000117551517411663100173620ustar00rootroot00000000000000{ description = '' Deriving provides generic instances of MathComp classes for inductive data types. It includes native support for eqType, choiceType, countType and finType instances, and it allows users to define their own instances for other classes. ''; inputs = { flake-parts.url = "github:hercules-ci/flake-parts"; nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable"; nix-github-actions.url = "github:nix-community/nix-github-actions"; nix-github-actions.inputs.nixpkgs.follows = "nixpkgs"; }; outputs = inputs@{ self, flake-parts, nixpkgs, nix-github-actions, ... }: let # Coq/Rocq package sets we test against. The first entry is exposed as # packages.default / checks.default. Used by the overlay (to decide what # to override) and by perSystem (to populate packages and checks). coqVersions = [ "9_1" "9_0" "8_20" "8_19" "8_18" "8_17" ]; defaultVersion = builtins.head coqVersions; in flake-parts.lib.mkFlake { inherit inputs; } { imports = [ # To import a flake module # 1. Add foo to inputs # 2. Add foo as a parameter to the outputs function # 3. Add here: foo.flakeModule ]; systems = [ "x86_64-linux" "aarch64-linux" "aarch64-darwin" "x86_64-darwin" ]; perSystem = { config, self', inputs', pkgs, system, ... }: { _module.args.pkgs = import self.inputs.nixpkgs { inherit system; overlays = [ self.overlays.default ]; config = { }; }; devShells.default = pkgs.mkShell { propagatedBuildInputs = [ pkgs.coqPackages.coq-lsp ]; inputsFrom = [ self'.checks.default ]; }; packages = let packagesByVersion = nixpkgs.lib.listToAttrs (map (coqVersion: { name = coqVersion; value = pkgs."coqPackages_${coqVersion}".deriving; }) coqVersions); in packagesByVersion // { default = packagesByVersion.${defaultVersion}; }; checks = builtins.mapAttrs (set: package: package.overrideAttrs { doCheck = true; }) self'.packages; }; flake = { # The usual flake attributes can be defined here, including system- # agnostic ones like nixosModule and system-enumerating ones, although # those are more easily expressed in perSystem. githubActions = nix-github-actions.lib.mkGithubMatrix { checks = # Drop the "default" check — it is an alias for one of # the versioned checks, and including it would build # the same derivation twice in CI. builtins.mapAttrs (_: checks: builtins.removeAttrs checks [ "default" ]) (nixpkgs.lib.getAttrs [ "x86_64-linux" "aarch64-linux" "aarch64-darwin" ] self.checks); }; overlays.default = final: prev: let overrideDeriving = coqPackages: coqPackages.overrideScope (final': prev': { deriving = prev'.lib.overrideCoqDerivation { version = ./.; checkTarget = "test"; checkFlags = [ "VERBOSE=" ]; # The nixpkgs coq setup hook sets COQPATH for dependency # lookup, but rocq 9.0+ warns that COQPATH is deprecated in # favour of ROCQPATH. Translate once, before any phase runs, # to silence the warning. Older versions still need COQPATH, # so this is a no-op there. preConfigure = prev.lib.optionalString (prev.lib.versionAtLeast prev'.coq.coq-version "9.0") '' if [ -n "''${COQPATH-}" ]; then export ROCQPATH="$COQPATH" unset COQPATH fi ''; nativeCheckInputs = [ final.gnuplot final'.coq.ocamlPackages.findlib final'.coq.ocamlPackages.csv ]; # When the check phase ran, copy the bench artifacts into $out # so CI can upload them. Guarded so the non-check build # (packages.default) is unaffected. postInstall = '' if [ -d bench/results/latest ]; then mkdir -p $out/share/deriving/bench cp -r bench/results/latest/. $out/share/deriving/bench/ fi ''; } prev'.deriving; }); in nixpkgs.lib.listToAttrs (map (coqVersion: { name = "coqPackages_${coqVersion}"; value = overrideDeriving prev."coqPackages_${coqVersion}";}) coqVersions); }; }; } arthuraa-deriving-0e084ee/make_tactics.ml000066400000000000000000000016671517411663100205420ustar00rootroot00000000000000let re = Str.regexp "Hint Unfold \\([^ ]+\\) : deriving." let read_file acc file = let ic = open_in file in let rec loop acc = try let s = input_line ic in let acc = if Str.string_match re s 0 then Str.replace_matched "\\1" s :: acc else acc in loop acc with End_of_file -> close_in ic; acc in loop acc let read_files files = List.rev @@ Array.fold_left read_file [] files let print_db prefix db = Printf.printf " %s [" prefix; List.iter (Printf.printf " %s\n") db; print_endline "]." let _ = print_endline "From mathcomp Require Import ssreflect ssrfun."; print_endline "From deriving Require Import base ind."; print_endline "Declare Reduction deriving_compute :="; let db = read_files Sys.argv in print_db "cbv" db; print_endline "Declare Reduction deriving_lazy :="; print_db "lazy" db; print_endline "Ltac deriving_compute :="; print_db "cbv" db arthuraa-deriving-0e084ee/tests/000077500000000000000000000000001517411663100167115ustar00rootroot00000000000000arthuraa-deriving-0e084ee/tests/mutual.v000066400000000000000000000042441517411663100204130ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype finset order. Set SsrOldRewriteGoalsOrder. (* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) From deriving Require Import deriving. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Unset Elimination Schemes. Inductive foo := | Foo1 of nat | Foo2 of bool & bar with bar := | Bar1 of foo & foo | Bar2 of nat & foo with baz := | Baz of foo & baz. Set Elimination Schemes. Scheme foo_rect := Induction for foo Sort Type with bar_rect := Induction for bar Sort Type with baz_rect := Induction for baz Sort Type. Combined Scheme foo_bar_baz_rect from foo_rect, bar_rect, baz_rect. Definition foo_bar_baz_indDef := [indDef for foo_bar_baz_rect]. Canonical foo_indType := IndType foo foo_bar_baz_indDef. Canonical bar_indType := IndType bar foo_bar_baz_indDef. Canonical baz_indType := IndType baz foo_bar_baz_indDef. Definition foo_hasDecEq := [derive hasDecEq for foo]. HB.instance Definition _ := foo_hasDecEq. Definition bar_hasDecEq := [derive hasDecEq for bar]. HB.instance Definition _ := bar_hasDecEq. Definition baz_hasDecEq := [derive hasDecEq for baz]. HB.instance Definition _ := baz_hasDecEq. Definition foo_hasChoice := [derive hasChoice for foo]. HB.instance Definition _ := foo_hasChoice. Definition bar_hasChoice := [derive hasChoice for bar]. HB.instance Definition _ := bar_hasChoice. Definition baz_hasChoice := [derive hasChoice for baz]. HB.instance Definition _ := baz_hasChoice. Definition foo_isCountable := [derive isCountable for foo]. HB.instance Definition _ := foo_isCountable. Definition bar_isCountable := [derive isCountable for bar]. HB.instance Definition _ := bar_isCountable. Definition baz_isCountable := [derive isCountable for baz]. HB.instance Definition _ := baz_isCountable. Definition foo_isOrder := [derive isOrder for foo]. HB.instance Definition _ := foo_isOrder. Definition bar_isOrder := [derive isOrder for bar]. HB.instance Definition _ := bar_isOrder. Definition baz_isOrder := [derive isOrder for baz]. HB.instance Definition _ := baz_isOrder. arthuraa-deriving-0e084ee/tests/nested.v000066400000000000000000000035621517411663100203700ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype finset order. Set SsrOldRewriteGoalsOrder. (* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) From deriving Require Import deriving. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Unset Elimination Schemes. Inductive rose := Rose of seq rose. Set Elimination Schemes. Definition rose_rect (P1 : rose -> Type) (P2 : seq rose -> Type) (HR : forall rs, P2 rs -> P1 (Rose rs)) (HN : P2 [::]) (HC : forall r, P1 r -> forall rs, P2 rs -> P2 (r :: rs)) : forall r, P1 r := fix rose_rect r := let fix seq_rose_rect rs : P2 rs := match rs with | [::] => HN | r :: rs => HC r (rose_rect r) rs (seq_rose_rect rs) end in match r with Rose rs => HR rs (seq_rose_rect rs) end. Definition seq_rose_rect (P1 : rose -> Type) (P2 : seq rose -> Type) (HR : forall rs, P2 rs -> P1 (Rose rs)) (HN : P2 [::]) (HC : forall r, P1 r -> forall rs, P2 rs -> P2 (r :: rs)) : forall rs, P2 rs := fix seq_rose_rect rs : P2 rs := match rs with | [::] => HN | r :: rs => HC r (rose_rect HR HN HC r) rs (seq_rose_rect rs) end. Combined Scheme rose_seq_rose_rect from rose_rect, seq_rose_rect. Definition rose_seq_rose_indDef := [indDef for rose_seq_rose_rect]. Canonical rose_indType := IndType rose rose_seq_rose_indDef. Definition rose_hasDecEq := [derive hasDecEq for rose]. HB.instance Definition _ := rose_hasDecEq. Definition rose_hasChoice := [derive hasChoice for rose]. HB.instance Definition _ := rose_hasChoice. Definition rose_isCountable := [derive isCountable for rose]. HB.instance Definition _ := rose_isCountable. Definition rose_isOrder := [derive isOrder for rose]. HB.instance Definition _ := rose_isOrder. arthuraa-deriving-0e084ee/tests/records.v000066400000000000000000000015041517411663100205410ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import all_ssreflect. From deriving Require Import deriving. Set SsrOldRewriteGoalsOrder. (* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) Record foo := Foo { foo1 : nat; foo2 : bool }. Scheme foo_rect := Induction for foo Sort Type. Definition foo_indDef := [indDef for foo_rect]. Canonical foo_indType := IndType foo foo_indDef. Definition foo_hasDecEq := [derive hasDecEq for foo]. HB.instance Definition _ := foo_hasDecEq. Definition foo_hasChoice := [derive hasChoice for foo]. HB.instance Definition _ := foo_hasChoice. Definition foo_isCountable := [derive isCountable for foo]. HB.instance Definition _ := foo_isCountable. Definition foo_isOrder := [derive isOrder for foo]. HB.instance Definition _ := foo_isOrder. arthuraa-deriving-0e084ee/tests/syntax.v000066400000000000000000000124401517411663100204270ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype finset order. Set SsrOldRewriteGoalsOrder. (* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) From deriving Require Import deriving. Require Import Coq.Strings.String. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. (* An example of syntax trees for a lambda calculus. Adapted from Iris's heap lang (https://gitlab.mpi-sws.org/iris/iris/blob/master/theories/heap_lang/lang.v). *) Inductive base_lit : Set := | LitInt (n : nat) | LitBool (b : bool) | LitUnit | LitPoison | LitLoc (l : nat) | LitProphecy (p: nat). Definition base_lit_indDef := [indDef for base_lit_rect]. Canonical base_lit_indType := IndType base_lit base_lit_indDef. Definition base_lit_hasDecEq := [derive lazy hasDecEq for base_lit]. HB.instance Definition _ := base_lit_hasDecEq. Definition base_lit_hasChoice := [derive hasChoice for base_lit]. HB.instance Definition _ := base_lit_hasChoice. Definition base_lit_isCountable := [derive isCountable for base_lit]. HB.instance Definition _ := base_lit_isCountable. Definition base_lit_isOrder := [derive isOrder for base_lit]. HB.instance Definition _ := base_lit_isOrder. Inductive un_op : Set := | NegOp | MinusUnOp. Definition un_op_indDef := [indDef for un_op_rect]. Canonical un_op_indType := IndType un_op un_op_indDef. Definition un_op_hasDecEq := [derive hasDecEq for un_op]. HB.instance Definition _ := un_op_hasDecEq. Definition un_op_hasChoice := [derive hasChoice for un_op]. HB.instance Definition _ := un_op_hasChoice. Definition un_op_isCountable := [derive isCountable for un_op]. HB.instance Definition _ := un_op_isCountable. Definition un_op_isFinite := [derive isFinite for un_op]. HB.instance Definition _ := un_op_isFinite. Definition un_op_isOrder := [derive isOrder for un_op]. HB.instance Definition _ := un_op_isOrder. Inductive bin_op : Set := | PlusOp | MinusOp | MultOp | QuotOp | RemOp | AndOp | OrOp | XorOp | ShiftLOp | ShiftROp | LeOp | LtOp | EqOp | OffsetOp. Definition bin_op_indDef := [indDef for bin_op_rect]. Canonical bin_op_indType := IndType bin_op bin_op_indDef. Definition bin_op_hasDecEq := [derive hasDecEq for bin_op]. HB.instance Definition _ := bin_op_hasDecEq. Definition bin_op_hasChoice := [derive hasChoice for bin_op]. HB.instance Definition _ := bin_op_hasChoice. Definition bin_op_isCountable := [derive isCountable for bin_op]. HB.instance Definition _ := bin_op_isCountable. Definition bin_op_isFinite := [derive isFinite for bin_op]. HB.instance Definition _ := bin_op_isFinite. Definition bin_op_isOrder := [derive isOrder for bin_op]. HB.instance Definition _ := bin_op_isOrder. Unset Elimination Schemes. Inductive expr := (* Values *) | Val (v : val) (* Base lambda calculus *) | Var (x : string) | Rec (f x : string) (e : expr) | App (e1 e2 : expr) (* Base types and their operations *) | UnOp (op : un_op) (e : expr) | BinOp (op : bin_op) (e1 e2 : expr) | If (e0 e1 e2 : expr) (* Products *) | Pair (e1 e2 : expr) | Fst (e : expr) | Snd (e : expr) (* Sums *) | InjL (e : expr) | InjR (e : expr) | Case (e0 : expr) (e1 : expr) (e2 : expr) (* Concurrency *) | Fork (e : expr) (* Heap *) | AllocN (e1 e2 : expr) (* array length (positive number), initial value *) | Free (e : expr) | Load (e : expr) | Store (e1 : expr) (e2 : expr) | CmpXchg (e0 : expr) (e1 : expr) (e2 : expr) (* Compare-exchange *) | FAA (e1 : expr) (e2 : expr) (* Fetch-and-add *) (* Prophecy *) | NewProph | Resolve (e0 : expr) (e1 : expr) (e2 : expr) (* wrapped expr, proph, val *) with val := | LitV (l : base_lit) | RecV (f x : string) (e : expr) | PairV (v1 v2 : val) | InjLV (v : val) | InjRV (v : val). Set Elimination Schemes. Scheme expr_rect := Induction for expr Sort Type with val_rect := Induction for val Sort Type. Combined Scheme expr_val_rect from expr_rect, val_rect. Definition expr_val_indDef := [indDef for expr_val_rect]. Canonical expr_indType := IndType expr expr_val_indDef. Canonical val_indType := IndType val expr_val_indDef. (* FIXME: can we make these definitions transparent? *) Definition expr_hasDecEq : Equality.mixin_of expr. Proof. exact: [derive nored hasDecEq for expr]. Qed. HB.instance Definition _ := expr_hasDecEq. (* FIXME: can we make these definitions transparent? *) Definition val_hasDecEq : Equality.mixin_of val. Proof. exact: [derive nored hasDecEq for val]. Qed. HB.instance Definition _ := val_hasDecEq. Definition expr_hasChoice := [derive hasChoice for expr]. HB.instance Definition _ := expr_hasChoice. Definition val_hasChoice := [derive hasChoice for val]. HB.instance Definition _ := val_hasChoice. Definition expr_isCountable := [derive isCountable for expr]. HB.instance Definition _ := expr_isCountable. Definition val_isCountable := [derive isCountable for val]. HB.instance Definition _ := val_isCountable. Definition expr_isOrder : Order.isOrder Order.default_display expr. Proof. exact: [derive nored isOrder for expr]. Qed. HB.instance Definition _ := expr_isOrder. Definition val_isOrder : Order.isOrder Order.default_display val. Proof. exact: [derive nored isOrder for val]. Qed. HB.instance Definition _ := val_isOrder. arthuraa-deriving-0e084ee/tests/three.v000066400000000000000000000021051517411663100202050ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype finset order. Set SsrOldRewriteGoalsOrder. (* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) From deriving Require Import deriving. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Inductive three := A of bool & bool | B | C. Definition three_indDef := [indDef for three_rect]. Canonical three_indType := Eval hnf in IndType three three_indDef. Definition three_hasDecEq := [derive hasDecEq for three]. HB.instance Definition _ := three_hasDecEq. Definition three_hasChoice := [derive hasChoice for three]. HB.instance Definition _ := three_hasChoice. Definition three_isCountable := [derive isCountable for three]. HB.instance Definition _ := three_isCountable. Definition three_isFinite := [derive isFinite for three]. HB.instance Definition _ := three_isFinite. Definition three_isOrder := [derive isOrder for three]. HB.instance Definition _ := three_isOrder. arthuraa-deriving-0e084ee/tests/tree.v000066400000000000000000000021661517411663100200440ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype finset order. Set SsrOldRewriteGoalsOrder. (* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) From deriving Require Import deriving. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Inductive tree (T : Type) := | Leaf of {set 'I_10} | Node of T & tree T & tree T. Arguments Leaf {_} _. Definition tree_indDef T := [indDef for @tree_rect T]. Canonical tree_indType T := Eval hnf in IndType (tree T) (tree_indDef T). Section TreeEqType. Variable T : eqType. Definition tree_hasDecEq := [derive hasDecEq for tree T]. HB.instance Definition _ := tree_hasDecEq. End TreeEqType. Section TreeChoiceType. Variable T : choiceType. Definition tree_hasChoice := [derive hasChoice for tree T]. HB.instance Definition _ := tree_hasChoice. End TreeChoiceType. Section TreeCountType. Variable T : countType. Definition tree_isCountable := [derive isCountable for tree T]. HB.instance Definition _ := tree_isCountable. End TreeCountType. arthuraa-deriving-0e084ee/theories/000077500000000000000000000000001517411663100173715ustar00rootroot00000000000000arthuraa-deriving-0e084ee/theories/base.v000066400000000000000000001113421517411663100204740ustar00rootroot00000000000000From Coq Require Import Setoid. From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype order. Set SsrOldRewriteGoalsOrder. (* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Set Primitive Projections. (* Backwards compatibility for hint locality attributes *) Set Warnings "-unsupported-attributes". Declare Scope deriving_scope. Delimit Scope deriving_scope with deriving. Open Scope deriving_scope. Create HintDb deriving. Notation "f \o g" := (fun x => f (g x)) (only parsing) : deriving_scope. Section EqEqType. Variable (T : eqType) (x y : T). Definition eq_eqb (p q : x = y :> T) := true. Lemma eq_eqbP : Equality.axiom eq_eqb. Proof. move=> p q; apply: ReflectT; apply: eq_irrelevance. Qed. HB.instance Definition _ := hasDecEq.Build (x = y) eq_eqbP. End EqEqType. Definition cast T (P : T -> Type) x y (e : x = y) : P x -> P y := match e with erefl => id end. Arguments cast {_} _ {_ _} _. #[global] Hint Unfold cast : deriving. Notation "e1 * e2" := (etrans e1 e2) : deriving_scope. Notation "e ^-1" := (esym e) : deriving_scope. (* We redefine some constants of the standard library here to avoid problems with universe inconsistency and opacity. *) Definition castK T (P : T -> Type) x y (e : x = y) : cancel (cast P e) (cast P e^-1) := match e with erefl => fun _ => erefl end. Definition castKV T (P : T -> Type) x y (e : x = y) : cancel (cast P e^-1) (cast P e) := match e with erefl => fun _ => erefl end. Definition congr1 T S (f : T -> S) x y (e : x = y) : f x = f y := match e with erefl => erefl end. Definition congr1V T S (f : T -> S) x y (e : x = y) : (congr1 f e)^-1 = congr1 f e^-1 := match e with erefl => erefl end. Definition etransV T (x y z : T) (p : x = y) (q : y = z) : (p * q)^-1 = q^-1 * p^-1 := match p in _ = y return forall q : y = z, (p * q)^-1 = q^-1 * p^-1 with | erefl => fun q => match q with erefl => erefl end end q. Definition etrans1p T (x y : T) (p : x = y) : erefl * p = p := match p with erefl => erefl end. Definition etransVp T (x y : T) (p : x = y) : p^-1 * p = erefl := match p with erefl => erefl end. Definition etranspV T (x y : T) (p : x = y) : p * p^-1 = erefl := match p with erefl => erefl end. Definition congr2 T1 T2 S (f : T1 -> T2 -> S) x1 y1 x2 y2 (e1 : x1 = y1) (e2 : x2 = y2) : f x1 x2 = f y1 y2 := congr1 (f x1) e2 * congr1 (fun a => f a y2) e1. Definition castCE T S (x y : T) (p : x = y) a : cast (fun=> S) p a = a := match p with erefl => erefl end. Definition castFE T (P Q : T -> Type) x y (p : x = y) : forall f a, cast (fun x => P x -> Q x) p f a = cast Q p (f (cast P p^-1 a)) := match p with erefl => fun f a => erefl end. Definition cast_idE T (P : T -> Type) x y (p : x = y) : cast id (congr1 P p) = cast P p := match p with erefl => erefl end. Definition castD T (P : T -> Type) x y z (p : x = y) (q : y = z) : forall a, cast P (p * q) a = cast P q (cast P p a) := match q with erefl => fun a => erefl end. #[global] Hint Unfold Logic.eq_sym : deriving. #[global] Hint Unfold Logic.eq_trans : deriving. #[global] Hint Unfold etrans : deriving. #[global] Hint Unfold esym : deriving. #[global] Hint Unfold congr1 : deriving. #[global] Hint Unfold f_equal : deriving. #[global] Hint Unfold fst : deriving. #[global] Hint Unfold snd : deriving. (** An alternative to the standard prod type, to avoid name clashes and universe issues. *) Set Universe Polymorphism. Record cell T S := Cell { hd : T; tl : S }. Arguments Cell {_ _}. Arguments hd {_ _}. Arguments tl {_ _}. #[global] Hint Unfold hd : deriving. #[global] Hint Unfold tl : deriving. Notation "x ::: y" := (Cell x y) (at level 60) : deriving_scope. Module PolyType. Record sig T (P : T -> Prop) := exist { sval : T; svalP : P sval }. Arguments exist {T} P sval svalP. Notation "{ x | P }" := (sig (fun x => P)) : type_scope. Notation "{ x : T | P }" := (sig (fun x : T => P)) : type_scope. Inductive seq T := nil | cons of T & seq T. Arguments nil {_}. Infix "::" := cons : deriving_scope. Notation "[ :: ]" := nil : deriving_scope. Notation "[ :: x1 ]" := (cons x1 nil) : deriving_scope. Fixpoint list_of_seq T (xs : seq T) : seq.seq T := if xs is x :: xs then (x :: list_of_seq xs)%SEQ else [::]%SEQ. Fixpoint seq_of_list T (xs : seq.seq T) : seq T := if xs is (x :: xs)%SEQ then x :: seq_of_list xs else [::]. Lemma list_of_seqK T : cancel (@list_of_seq T) (@seq_of_list T). Proof. by elim=> //= ?? ->. Qed. Lemma seq_of_listK T : cancel (@seq_of_list T) (@list_of_seq T). Proof. by elim=> //= ?? ->. Qed. Fixpoint size T (xs : seq T) := if xs is x :: xs then (size xs).+1 else 0. Definition map T S (f : T -> S) := fix map xs := if xs is x :: xs then f x :: map xs else [::]. Definition foldr T S (f : T -> S -> S) (x : S) := fix foldr xs := if xs is x' :: xs then f x' (foldr xs) else x. Definition sumn := foldr addn 0. Fixpoint cat T (xs ys : seq T) := if xs is x :: xs then x :: cat xs ys else ys. Infix "++" := cat : deriving_scope. Definition flatten T (xxs : seq (seq T)) : seq T := foldr (@cat T) [::] xxs. Lemma seq_of_list_map T S (f : T -> S) (xs : seq.seq T) : seq_of_list (seq.map f xs) = map f (seq_of_list xs). Proof. by elim: xs=> //= x xs ->. Qed. Lemma list_of_seq_map T S (f : T -> S) (xs : seq T) : list_of_seq (map f xs) = seq.map f (list_of_seq xs). Proof. by elim: xs=> //= x xs ->. Qed. Fixpoint all T (P : T -> bool) (xs : seq T) := if xs is x :: xs then P x && all P xs else true. End PolyType. Import PolyType. #[global] Hint Unfold PolyType.sval : deriving. #[global] Hint Unfold PolyType.svalP : deriving. #[global] Hint Unfold PolyType.list_of_seq : deriving. #[global] Hint Unfold PolyType.seq_of_list : deriving. #[global] Hint Unfold PolyType.size : deriving. #[global] Hint Unfold PolyType.map : deriving. #[global] Hint Unfold PolyType.foldr : deriving. #[global] Hint Unfold PolyType.sumn : deriving. #[global] Hint Unfold PolyType.cat : deriving. #[global] Hint Unfold PolyType.flatten : deriving. #[global] Hint Unfold PolyType.all : deriving. Fixpoint fin n := if n is n.+1 then option (fin n) else void. #[global] Hint Unfold fin : deriving. Fixpoint all_fin n : (fin n -> Prop) -> Prop := match n with | 0 => fun P => True | n.+1 => fun P => P None /\ @all_fin n (fun i => P (Some i)) end. #[global] Hint Unfold all_fin : deriving. Lemma all_finP n (P : fin n -> Prop) : all_fin P <-> (forall i, P i). Proof. split; elim: n P=> [|n IH] P //=. - case=> ? H [i|] //; exact: (IH (fun i => P (Some i))). - by move=> H; split; [exact: (H None)|apply: IH; eauto]. Qed. Fixpoint all_finb n : (fin n -> bool) -> bool := match n with | 0 => fun f => true | n.+1 => fun f => f None && @all_finb n (fun i => f (Some i)) end. #[global] Hint Unfold all_finb : deriving. Fixpoint nth_fin T (xs : seq T) : fin (size xs) -> T := match xs with | [::] => fun n => match n with end | x :: xs => fun n => if n is Some n then nth_fin n else x end. #[global] Hint Unfold nth_fin : deriving. Definition fnth T S (f : T -> S) (xs : seq T) (i : fin (size xs)) : S := f (nth_fin i). Arguments fnth {T S} f xs i. #[global] Hint Unfold fnth : deriving. Definition fcons n T (x : T) (f : fin n -> T) : fin n.+1 -> T := fun i => if i is Some i then f i else x. #[global] Hint Unfold fcons : deriving. Definition fnil T : fin 0 -> T := fun i => match i with end. #[global] Hint Unfold fnil : deriving. Fixpoint leq_fin n : forall i j : fin n, (i = j) + bool := match n with | 0 => fun i => match i with end | n.+1 => fun i => match i return forall j, (i = j) + bool with | None => fun j => if j is None then inl erefl else inr true | Some i' => fun j => if j is Some j' then match leq_fin i' j' with | inl e => inl (congr1 Some e) | inr b => inr b end else inr false end end. #[global] Hint Unfold leq_fin : deriving. Fixpoint leq_finii n : forall i : fin n, @leq_fin n i i = inl erefl := match n return forall i : fin n, leq_fin i i = inl erefl with | 0 => fun i => match i with end | n.+1 => fun i => match i return @leq_fin n.+1 i i = inl erefl with | None => erefl | Some i => congr1 (fun r => match r with | inl e => inl (congr1 Some e) | inr b => inr b end) (@leq_finii n i) end end. #[global] Hint Unfold leq_finii : deriving. Fixpoint nat_of_fin n : fin n -> nat := match n with | 0 => fun i => match i with end | n.+1 => fun i => if i is Some i then (nat_of_fin i).+1 else 0 end. #[global] Hint Unfold nat_of_fin : deriving. Fixpoint finW n : forall (m : fin n), fin (nat_of_fin m) -> fin n := match n with | 0 => fun m => match m with end | n.+1 => fun m => match m with | None => fun i => match i with end | Some m => fun i => match i with | None => None | Some i => Some (@finW n m i) end end end. #[global] Hint Unfold finW : deriving. Lemma leq_nat_of_fin n (i j : fin n) : (nat_of_fin i <= nat_of_fin j) = if leq_fin i j is inr b then b else true. Proof. elim: n i j=> [[]|n IH] /= [i|] [j|] //. by rewrite ltnS IH; case: (leq_fin i j). Qed. Lemma nat_of_fin_inj n : injective (@nat_of_fin n). Proof. by elim: n=> [[]|n IH] /= [i|] [j|] // [/IH ->]. Qed. Fixpoint fin_of_nat n m : option (fin n) := match n with | 0 => None | n.+1 => if m is m.+1 then if fin_of_nat n m is Some i then Some (Some i) else None else Some None end. #[global] Hint Unfold fin_of_nat : deriving. Lemma nat_of_finK n : pcancel (@nat_of_fin n) (@fin_of_nat n). Proof. by elim: n=> [[]|n IH /= [i|]] //=; rewrite IH. Qed. Lemma leq_fin_swap n (i j : fin n) : leq_fin i j = match leq_fin j i with | inl e => inl (esym e) | inr b => inr (~~ b) end. Proof. move: (leq_nat_of_fin i j) (leq_nat_of_fin j i). case: ltngtP=> [||/nat_of_fin_inj ->]; last by rewrite leq_finii. - case: (leq_fin j i)=> // [] [] //=. case: (leq_fin i j)=> [e|b _ <- //]. by rewrite {1}e ltnn. - case: (leq_fin i j)=> // _ ji <-. case: (leq_fin j i) ji => [e|b _ <- //]. by rewrite {1}e ltnn. Qed. Fixpoint enum_fin n : seq (fin n) := match n with | 0 => [::] | n.+1 => None :: map Some (enum_fin n) end. #[global] Hint Unfold enum_fin : deriving. Fixpoint size_map T S (f : T -> S) (s : seq T) : size (map f s) = size s := match s with | [::] => erefl | i :: s => congr1 succn (size_map f s) end. Fixpoint size_enum_fin n : size (enum_fin n) = n := match n with | 0 => erefl | n.+1 => congr1 succn (size_map Some (enum_fin n) * size_enum_fin n) end. Fixpoint sum_of_fin n m : fin (n + m) -> fin n + fin m := match n with | 0 => inr | n.+1 => fun i => match i with | None => inl None | Some i => match @sum_of_fin n m i with | inl j => inl (Some j) | inr j => inr j end end end. #[global] Hint Unfold sum_of_fin : deriving. Arguments sum_of_fin : clear implicits. Fixpoint fin_of_sumL n m : fin n -> fin (n + m) := match n return fin n -> fin (n + m) with | 0 => fun i => match i with end | n.+1 => fun i => match i with | None => None | Some i => Some (@fin_of_sumL n m i) end end. #[global] Hint Unfold fin_of_sumL : deriving. Arguments fin_of_sumL : clear implicits. Fixpoint fin_of_sumR n m : fin m -> fin (n + m) := match n with | 0 => id | n.+1 => fun i => Some (@fin_of_sumR n m i) end. #[global] Hint Unfold fin_of_sumR : deriving. Arguments fin_of_sumR : clear implicits. Definition fin_of_sum n m (i : fin n + fin m) : fin (n + m) := match i with | inl i => fin_of_sumL n m i | inr i => fin_of_sumR n m i end. #[global] Hint Unfold fin_of_sum : deriving. Arguments fin_of_sum : clear implicits. Lemma sum_of_finK n m : cancel (sum_of_fin n m) (fin_of_sum n m). Proof. elim: n=> [|n IH] //= [i|] //=. by case: (sum_of_fin n m i) (IH i)=> //= ? ->. Qed. Lemma fin_of_sumK n m : cancel (fin_of_sum n m) (sum_of_fin n m). Proof. case=> i /=; elim: n i => [|n IH] //=. - by case=> [i|] //=; rewrite IH. - by move=> i; rewrite IH. Qed. Fixpoint sumn_fin n : (fin n -> nat) -> nat := match n with | 0 => fun _ => 0 | n.+1 => fun ns => ns None + sumn_fin (fun i => ns (Some i)) end. Fixpoint tag_of_fin n : forall (m : fin n -> nat), fin (sumn_fin m) -> {i : fin n & fin (m i)} := match n return forall (m : fin n -> nat), fin (sumn_fin m) -> {i : fin n & fin (m i)} with | 0 => fun _ (i : fin 0) => match i with end | n.+1 => fun m (i : fin (sumn_fin m)) => match sum_of_fin (m None) (sumn_fin (fun j => m (Some j))) i with | inl j => @Tagged _ None (fun i => fin (m i)) j | inr j => let p := tag_of_fin j in @Tagged _ (Some (tag p)) (fun i => fin (m i)) (tagged p) end end. #[global] Hint Unfold tag_of_fin : deriving. Arguments tag_of_fin {n} _ _. Fixpoint fin_of_tag' n : forall (m : fin n -> nat) (i : fin n), fin (m i) -> fin (sumn_fin m) := match n with | 0 => fun m i => match i with end | n.+1 => fun m i j => let ij := match i return fin (m i) -> _ with | None => fun j => inl j | Some i => fun j => inr (fin_of_tag' j) end j in fin_of_sum _ _ ij end. #[global] Hint Unfold fin_of_tag' : deriving. Arguments fin_of_tag' {n} _ _ _. Definition fin_of_tag n m (p : {i : fin n & fin (m i)}) := @fin_of_tag' n m (tag p) (tagged p). #[global] Hint Unfold fin_of_tag : deriving. Lemma tag_of_finK n m : cancel (@tag_of_fin n m) (@fin_of_tag n m). Proof. rewrite /fin_of_tag; elim: n m => [m []|n IH m x] /=. rewrite -[RHS](sum_of_finK x) /=. by case: (sum_of_fin _ _ x) => {}x //=; rewrite IH. Qed. Lemma fin_of_tagK n m : cancel (@fin_of_tag n m) (@tag_of_fin n m). Proof. rewrite /fin_of_tag; case=> i j /=. elim: n m i j => [m []|n IH m i j /=]. by rewrite fin_of_sumK; case: i j => [i|] j; rewrite ?IH. Qed. Definition map_fin (n : nat) T (f : fin n -> T) : seq T := map f (enum_fin n). Definition cast_fin n m (e : n = m) : forall (i : fin n.+1), cast fin (congr1 succn e) i = if i is Some j then Some (cast fin e j) else None := match e with | erefl => fun i => if i is None then erefl else erefl end. Unset Universe Polymorphism. Fixpoint fin_eqClass n : Equality (fin n) := match n return Equality (fin n) with | 0 => Equality.on void | n.+1 => Equality.on (option (HB.pack_for Equality.type (fin n) (fin_eqClass n))) end. Fixpoint fin_choiceClass n : Choice (fin n) := match n with | 0 => Choice.on void | n.+1 => Choice.on (option (HB.pack_for Choice.type (fin n) (fin_choiceClass n))) end. Fixpoint fin_countClass n : Countable (fin n) := match n with | 0 => Countable.on void | n.+1 => Countable.on (option (HB.pack_for Countable.type (fin n) (fin_countClass n))) end. Section FinInstances. Variable n : nat. HB.instance Definition _ := fin_eqClass n. HB.instance Definition _ := fin_choiceClass n. HB.instance Definition _ := fin_countClass n. End FinInstances. Set Universe Polymorphism. Section Ilist. Variables (T : Type). Definition ilist n := iter n (cell T) unit. Fixpoint inth n : ilist n -> fin n -> T := match n return ilist n -> fin n -> T with | 0 => fun l (i : void) => match i with end | n.+1 => fun l i => if i is Some j then inth l.(tl) j else l.(hd) end. Fixpoint ilist_of_fun n : forall (f : fin n -> T), ilist n := match n with | 0 => fun _ => tt | n.+1 => fun f => f None ::: ilist_of_fun (fun i => f (Some i)) end. Fixpoint inth_of_fun n : forall (f : fin n -> T) (i : fin n), inth (ilist_of_fun f) i = f i := match n with | 0 => fun f i => match i with end | n.+1 => fun f i => if i is Some j then inth_of_fun (fun j => f (Some j)) j else erefl end. Fixpoint ilist_of_seq s : ilist (size s) := match s with | [::] => tt | x :: s => x ::: ilist_of_seq s end. Fixpoint seq_of_ilist n : ilist n -> seq T := match n with | 0 => fun l => [::] | n.+1 => fun l => l.(hd) :: seq_of_ilist l.(tl) end. Fixpoint size_seq_of_ilist n : forall (xs : ilist n), size (seq_of_ilist xs) = n := match n with | 0 => fun xs => erefl | n.+1 => fun xs => congr1 succn (size_seq_of_ilist xs.(tl)) end. End Ilist. #[global] Hint Unfold ilist : deriving. #[global] Hint Unfold inth : deriving. #[global] Hint Unfold ilist_of_fun : deriving. #[global] Hint Unfold inth_of_fun : deriving. #[global] Hint Unfold ilist_of_seq : deriving. #[global] Hint Unfold seq_of_ilist : deriving. Fixpoint imap T S (f : T -> S) n : ilist T n -> ilist S n := match n with | 0 => fun l => tt | n.+1 => fun l => f l.(hd) ::: imap f l.(tl) end. #[global] Hint Unfold imap : deriving. Lemma imap_eq (T S : Type) (f g : T -> S) : f =1 g -> forall n, @imap _ _ f n =1 @imap _ _ g n. Proof. by move=> efg; elim=> [[]|n IH] // [x l] /=; rewrite efg IH. Qed. Lemma imap1 (T: Type) n (l : ilist T n) : imap id l = l. Proof. by elim: n l=> /= [[]|n IH] // [x l] /=; rewrite IH. Qed. Lemma imap_comp (T S R : Type) (f : T -> S) (g : S -> R) n (l : ilist T n) : imap g (imap f l) = imap (g \o f) l. Proof. by elim: n l=> [[]|n IH] //= [x l] /=; rewrite IH. Qed. Fixpoint izip T S n : ilist T n -> ilist S n -> ilist (T * S) n := match n with | 0 => fun xs ys => tt | n.+1 => fun xs ys => (xs.(hd), ys.(hd)) ::: izip xs.(tl) ys.(tl) end. Section Hsum. Fixpoint hsum n : (fin n -> Type) -> Type := match n with | 0 => fun T_ => void | n.+1 => fun T_ => (T_ None + hsum (fun i => T_ (Some i)))%type end. Definition hsum' I (T_ : I -> Type) (xs : seq I) := hsum (fnth T_ xs). Fixpoint hin n : forall (T_ : fin n -> Type) i, T_ i -> hsum T_ := match n with | 0 => fun T_ i => match i with end | n.+1 => fun T_ i => match i with | Some j => fun x => inr (@hin _ (fun i => T_ (Some i)) j x) | None => fun x => inl x end end. Fixpoint hcase S n : forall (T_ : fin n -> Type), (forall i, T_ i -> S) -> hsum T_ -> S := match n with | 0 => fun T_ f x => match x with end | n.+1 => fun T_ f x => match x with | inl x => f None x | inr x => hcase (fun i x => f (Some i) x) x end end. Lemma hcaseE S n (T_ : fin n -> Type) (f : forall i, T_ i -> S) (i : fin n) (x : T_ i) : hcase f (hin x) = f i x. Proof. by elim: n T_ f i x=> [_ _ []|n IH] T_ f /= [i|//] x /=; rewrite IH. Qed. Definition hproj n (T_ : fin n -> Type) i : hsum T_ -> option (T_ i) := hcase (fun j x => if leq_fin j i is inl e then Some (cast T_ e x) else None). Lemma hinK n (T_ : fin n -> Type) i : pcancel (@hin n T_ i) (@hproj n T_ i). Proof. by move=> x; rewrite /hproj hcaseE leq_finii. Qed. End Hsum. #[global] Hint Unfold hsum : deriving. #[global] Hint Unfold hsum' : deriving. #[global] Hint Unfold hin : deriving. #[global] Hint Unfold hcase : deriving. #[global] Hint Unfold hproj : deriving. Section Hlist. Fixpoint hlist n : (fin n -> Type) -> Type := match n with | 0 => fun T_ => unit | n.+1 => fun T_ => cell (T_ None) (hlist (fun i => T_ (Some i))) end. Definition hlist' I (T_ : I -> Type) (xs : seq I) := hlist (fnth T_ xs). Identity Coercion hlist_of_hlist' : hlist' >-> hlist. Definition hlist2 n (m : fin n -> nat) (T : forall i, fin (m i) -> Type) := hlist (fun i => hlist (T i)). Identity Coercion hlist_of_hlist2 : hlist2 >-> hlist. Fixpoint hfun n : (fin n -> Type) -> Type -> Type := match n with | 0 => fun T_ S => S | n.+1 => fun T_ S => T_ None -> hfun (fun i => T_ (Some i)) S end. Definition hfun' I (T_ : I -> Type) (xs : seq I) S := hfun (fnth T_ xs) S. Identity Coercion hfun_of_hfun' : hfun' >-> hfun. Fixpoint happ n : forall (T_ : fin n -> Type) S, hfun T_ S -> hlist T_ -> S := match n with | 0 => fun T_ S f xs => f | n.+1 => fun T_ S f xs => happ (f xs.(hd)) xs.(tl) end. Coercion happ : hfun >-> Funclass. Fixpoint hcurry n : forall (T_ : fin n -> Type) S, (hlist T_ -> S) -> hfun T_ S := match n with | 0 => fun T_ S f => f tt | n.+1 => fun T_ S f => fun x => hcurry (fun xs => f (x ::: xs)) end. Lemma hcurryK n (T_ : fin n -> Type) S (f : hlist T_ -> S) xs : happ (hcurry f) xs = f xs. Proof. by elim: n T_ S f xs=> [??? [] //|n IH] /= ? /= ??[??]; rewrite IH. Qed. Fixpoint hfun2 n : forall (m : fin n -> nat) (T : forall i, fin (m i) -> Type) (S : Type), Type := match n with | 0 => fun m T S => S | n.+1 => fun m T S => @hfun (m None) (T None) (@hfun2 n _ (fun i => T (Some i)) S) end. Fixpoint happ2 n : forall (m : fin n -> nat) (T : forall i, fin (m i) -> Type) S, hfun2 T S -> hlist2 T -> S := match n with | 0 => fun m T S f xs => f | n.+1 => fun m T S f xs => @happ2 n _ (fun i => T (Some i)) S (f xs.(hd)) xs.(tl) end. Coercion happ2 : hfun2 >-> Funclass. Fixpoint hcurry2 n : forall (m : fin n -> nat) (T : forall i, fin (m i) -> Type) S, (hlist2 T -> S) -> hfun2 T S := match n with | 0 => fun m T S f => f tt | n.+1 => fun m T S f => hcurry (fun x => @hcurry2 n _ (fun i => T (Some i)) S (fun xs => f (x ::: xs))) end. Fixpoint hdfun n : forall (T : fin n -> Type), (hlist T -> Type) -> Type := match n with | 0 => fun T P => P tt | n.+1 => fun T P => forall (x : T None), @hdfun n (fun i => T (Some i)) (fun xs => P (x ::: xs)) end. Fixpoint hdapp n : forall (T : fin n -> Type) (P : hlist T -> Type), hdfun P -> forall x : hlist T, P x := match n with | 0 => fun T P f x => match x with tt => f end | n.+1 => fun T P f x => match x with Cell x xs => @hdapp n _ _ (f x) xs end end. Fixpoint hnth n : forall (T_ : fin n -> Type), hlist T_ -> forall i, T_ i := match n with | 0 => fun T_ xs i => match i with end | n.+1 => fun T_ xs i => match i with | Some j => hnth xs.(tl) j | None => xs.(hd) end end. Coercion hnth : hlist >-> Funclass. Fixpoint seq_of_hlist n S : forall (T_ : fin n -> Type), (forall i, T_ i -> S) -> hlist T_ -> seq S := match n with | 0 => fun T_ f xs => [::] | n.+1 => fun T_ f xs => f None xs.(hd) :: seq_of_hlist (fun i => f (Some i)) xs.(tl) end. Fixpoint hlist_of_seq n S : forall (T_ : fin n -> Type), (forall i, S -> option (T_ i)) -> seq S -> option (hlist T_) := match n with | 0 => fun T_ f xs => Some tt | n.+1 => fun T_ f xs => match xs with | [::] => None | x :: xs => match f None x, hlist_of_seq (fun i => f (Some i)) xs with | Some y, Some ys => Some (y ::: ys) | _, _ => None end end end. Lemma seq_of_hlistK n S (T_ : fin n -> Type) (f : forall i, T_ i -> S) (g : forall i, S -> option (T_ i)) : (forall i, pcancel (f i) (g i)) -> pcancel (seq_of_hlist f) (hlist_of_seq g). Proof. elim: n T_ f g=> [???? []|n IH] //= ? /= f g fK [??] /=. by rewrite fK IH // => i ?; rewrite fK. Qed. Lemma hlist_of_seq_map n S R (T_ : fin n -> Type) (f : forall i, R -> option (T_ i)) (g : S -> R) (xs : seq S) : hlist_of_seq f (map g xs) = hlist_of_seq (fun i x => f i (g x)) xs. Proof. elim: n T_ f xs=> [??|n IH] //= ? f [] //= x xs. by case: (f None (g x))=> //= ?; rewrite IH. Qed. Fixpoint hlist_of_fun n : forall (T_ : fin n -> Type) (f : forall i, T_ i), hlist T_ := match n with | 0 => fun T_ f => tt | n.+1 => fun T_ f => f None ::: hlist_of_fun (fun i => f (Some i)) end. Lemma hnth_of_fun n T_ f i : @hlist_of_fun n T_ f i = f i. Proof. by elim: n T_ f i=> [?? []|n IH] T_ f /= [i|] //=; rewrite IH. Qed. Fixpoint all_hlist n : forall T_, (@hlist n T_ -> Prop) -> Prop := match n with | 0 => fun T_ P => P tt | n.+1 => fun T_ P => forall x, all_hlist (fun xs => P (x ::: xs)) end. Lemma all_hlistP n T_ P : @all_hlist n T_ P <-> (forall xs, P xs). Proof. elim: n T_ P=> /= [??|n IH T_ P /=]. split; last exact; by move=> ? []. split. - by move=> H [x xs]; move/(_ x)/IH in H. - by move=> H x; apply/IH=> ?. Qed. Fixpoint all_hlist2 n : forall (m : fin n -> nat) (T : forall i, fin (m i) -> Type), (hlist2 T -> Prop) -> Prop := match n with | 0 => fun m T P => P tt | n.+1 => fun m T P => all_hlist (fun x => @all_hlist2 n _ (fun i => T (Some i)) (fun xs => P (x ::: xs))) end. Lemma all_hlist2P n m (T : forall i, fin (m i) -> Type) P : @all_hlist2 n m T P <-> (forall xs, P xs). Proof. elim: n m T P => /= [???|n IH m T P /=]. split; last exact; by move=> ? []. rewrite all_hlistP; split. - move=> H [x xs]. by move/(_ x): H; rewrite IH; apply. - by move=> H x; apply/IH=> ?. Qed. Fixpoint hfold S n : forall (T_ : fin n -> Type), (forall i : fin n, T_ i -> S -> S) -> S -> hlist T_ -> S := match n with | 0 => fun _ _ a _ => a | n.+1 => fun T_ f a l => f None l.(hd) (hfold (fun i => f (Some i)) a l.(tl)) end. End Hlist. #[global] Hint Unfold hlist : deriving. #[global] Hint Unfold hlist' : deriving. #[global] Hint Unfold hlist2 : deriving. #[global] Hint Unfold hfun : deriving. #[global] Hint Unfold hfun' : deriving. #[global] Hint Unfold happ : deriving. #[global] Hint Unfold hcurry : deriving. #[global] Hint Unfold hfun2 : deriving. #[global] Hint Unfold happ2 : deriving. #[global] Hint Unfold hcurry2 : deriving. #[global] Hint Unfold hdfun : deriving. #[global] Hint Unfold hdapp : deriving. #[global] Hint Unfold hnth : deriving. #[global] Hint Unfold seq_of_hlist : deriving. #[global] Hint Unfold hlist_of_seq : deriving. #[global] Hint Unfold hlist_of_fun : deriving. #[global] Hint Unfold all_hlist : deriving. #[global] Hint Unfold all_hlist2 : deriving. #[global] Hint Unfold hfold : deriving. Fixpoint hmap n : forall (T_ S_ : fin n -> Type) (f : forall i, T_ i -> S_ i), hlist T_ -> hlist S_ := match n with | 0 => fun _ _ _ _ => tt | n.+1 => fun _ _ f xs => f None xs.(hd) ::: hmap (fun j => f (Some j)) xs.(tl) end. #[global] Hint Unfold hmap : deriving. Definition hmap2 n (m : fin n -> nat) (T S : forall i, fin (m i) -> Type) (f : forall i j, T i j -> S i j) : hlist2 T -> hlist2 S := hmap (fun i => hmap (fun j => f i j)). #[global] Hint Unfold hmap2 : deriving. Definition hmap' I T_ S_ (f : forall i : I, T_ i -> S_ i) xs : hlist' T_ xs -> hlist' S_ xs := hmap (fun i : fin (size xs) => f (nth_fin i)). #[global] Hint Unfold hmap' : deriving. Lemma hmap_eq n (T_ S_ : fin n -> Type) (f g : forall i, T_ i -> S_ i) : (forall i, f i =1 g i) -> @hmap _ _ _ f =1 @hmap _ _ _ g. Proof. elim: n T_ S_ f g=> [//|n IH] /= T_ S_ /= f g efg [x xs]. by rewrite efg (IH _ _ _ _ (fun j => efg (Some j))). Qed. Lemma hmap1 n (T_ : fin n -> Type) (xs : hlist T_) : hmap (fun i => id) xs = xs. Proof. by elim: n T_ xs=> [_ [] //|n IH] /= T_ [x xs] /=; rewrite IH. Qed. Lemma hmap_comp n (T_ S_ R_ : fin n -> Type) (f : forall i, T_ i -> S_ i) (g : forall i, S_ i -> R_ i) (xs : hlist T_) : hmap g (hmap f xs) = hmap (fun i => g i \o f i) xs. Proof. by elim: n T_ S_ R_ f g xs=> //= n IH ??? /= ?? [??] /=; rewrite IH. Qed. Fixpoint hpmap n : forall (T_ S_ : fin n -> Type), (forall i, T_ i -> option (S_ i)) -> hlist T_ -> option (hlist S_) := match n with | 0 => fun _ _ _ _ => Some tt | n.+1 => fun _ _ f xs => if hpmap (fun i => f (Some i)) xs.(tl) is Some xs' then if f None xs.(hd) is Some x then Some (x ::: xs') else None else None end. Lemma hmap_pK n (T_ S_ : fin n -> Type) (f : forall i, T_ i -> S_ i) (g : forall i, S_ i -> option (T_ i)) : (forall i, pcancel (f i) (g i)) -> pcancel (hmap f) (hpmap g). Proof. elim: n T_ S_ f g=> [????? [] //|n IH] /= ?? /= f g fgK [x xs] /=. rewrite fgK /= IH // => i; exact: (fgK (Some i)). Qed. Lemma hnth_hmap n (T_ S_ : fin n -> Type) (f : forall i, T_ i -> S_ i) : forall (xs : hlist T_) i, hmap f xs i = f _ (xs i). Proof. elim: n T_ S_ f=> [//|/= n IH] T_ S_ /= f [x xs] [i|//]. by rewrite IH. Qed. Fixpoint hzip n : forall (T_ S_ : fin n -> Type), hlist T_ -> hlist S_ -> hlist (fun i => T_ i * S_ i)%type := match n with | 0 => fun T_ S_ xs ys => tt | n.+1 => fun T_ S_ xs ys => (xs.(hd), ys.(hd)) ::: hzip xs.(tl) ys.(tl) end. #[global] Hint Unfold hzip : deriving. Fixpoint hlist_eq n : forall (T_ S_ : fin n -> Type) (e : forall i, T_ i = S_ i), hlist T_ = hlist S_ := match n with | 0 => fun T_ S_ e => erefl | n.+1 => fun T_ S_ e => congr2 cell (e None) (hlist_eq (fun i => e (Some i))) end. #[global] Hint Unfold hlist_eq : deriving. Lemma hlist_eq_hmap n T_ S_ e xs : cast id (@hlist_eq n T_ S_ e) xs = hmap (fun i => cast id (e i)) xs. Proof. elim: n T_ S_ e xs=> [??? []|n IH] //= T_ S_ e [x xs] /=. rewrite /congr2. case: _ / (e None) x=> /= x; rewrite -IH. by case: _ / (hlist_eq _) xs. Qed. Lemma hlist_eqV n (T_ S_ : fin n -> Type) e : (@hlist_eq n T_ S_ e)^-1 = hlist_eq (fun i => (e i)^-1). Proof. elim: n T_ S_ e=> //= n IH T_ S_ e. by rewrite /congr2; case: _ / (e None)=> /=; rewrite -IH congr1V. Qed. Fixpoint hfun_eq n : forall (T_ S_ : fin n -> Type) (e : forall i, T_ i = S_ i) R, hfun T_ R = hfun S_ R := match n with | 0 => fun T_ S_ e R => erefl | n.+1 => fun T_ S_ e R => congr2 (fun X Y => X -> Y) (e None) (hfun_eq (fun i => e (Some i)) R) end. #[global] Hint Unfold hfun_eq : deriving. Lemma hfun_eqV n T_ S_ e R : (@hfun_eq n T_ S_ e R)^-1 = hfun_eq (fun i => (e i)^-1) R. Proof. elim: n T_ S_ e=> //= n IH T_ S_ e; rewrite /congr2 /=. by case: _ / (e None)=> /=; rewrite -IH congr1V. Qed. Lemma happ_eq n T_ S_ e R f xs : happ (cast id (@hfun_eq n T_ S_ e R) f) xs = happ f (cast id (hlist_eq e)^-1 xs). Proof. elim: n T_ S_ e f xs=> [|n IH] //= T_ S_ e f [x xs] /=. rewrite /congr2; case: _ / (e None) x=> x /=. transitivity (happ (cast id (hfun_eq (fun i => e (Some i)) R) (f x)) xs). by congr (happ _ xs); case: _ / (hfun_eq _ R) f=> f. rewrite {}IH; congr (happ (f _) _); by case: _ / (hlist_eq _) xs. Qed. Arguments fnth T S f xs i /. Unset Universe Polymorphism. Section ProdCell. Variables T S : Type. Definition prod_of_cell (x : cell T S) := (x.(hd), x.(tl)). Definition cell_of_prod (x : T * S) := Cell x.1 x.2. Lemma prod_of_cellK : cancel prod_of_cell cell_of_prod. Proof. by case. Qed. Lemma cell_of_prodK : cancel cell_of_prod prod_of_cell. Proof. by case. Qed. End ProdCell. Unset Universe Polymorphism. Section CellEqType. Variables T S : eqType. HB.instance Definition _ := Equality.copy (cell T S) (can_type (@prod_of_cellK T S)). End CellEqType. Section CellChoiceType. Variables T S : choiceType. HB.instance Definition _ := Choice.copy (cell T S) (can_type (@prod_of_cellK T S)). End CellChoiceType. Section CellCountType. Variables T S : countType. HB.instance Definition _ := Countable.copy (cell T S) (can_type (@prod_of_cellK T S)). End CellCountType. Section CellFinType. Variables T S : finType. HB.instance Definition _ := Finite.copy (cell T S) (can_type (@prod_of_cellK T S)). End CellFinType. Section HeterogeneousInstances. Variables (K : Type) (sort : K -> Type). Local Coercion sort : K >-> Sortclass. Variables (sum_K : K -> K -> K). Variables (sum_KP : forall sT sS, sort (sum_K sT sS) = (sort sT + sort sS)%type). Variables (void_K : K). Variables (void_KP : sort void_K = void). Fixpoint hsum_lift_loop n : forall (T_ : fin n -> K), {sT | sort sT = hsum T_} := match n with | 0 => fun T_ => exist _ void_K void_KP | n.+1 => fun T_ => let sT := hsum_lift_loop (fun j => T_ (Some j)) in exist _ (sum_K (T_ None) (sval sT)) (sum_KP (T_ None) (sval sT) * congr1 (sum (T_ None)) (svalP sT)) end. Variables (cell_K : K -> K -> K). Variables (cell_KP : forall sT sS, sort (cell_K sT sS) = cell (sort sT) (sort sS)). Variables (unit_K : K). Variables (unit_KP : sort unit_K = unit). Fixpoint hlist_lift_loop n : forall (T_ : fin n -> K), {sT | sort sT = hlist T_} := match n with | 0 => fun T_ => exist _ unit_K unit_KP | n.+1 => fun T_ => let sT := hlist_lift_loop (fun j => T_ (Some j)) in exist _ (cell_K (T_ None) (sval sT)) (cell_KP (T_ None) (sval sT) * congr1 (cell (T_ None)) (svalP sT)) end. Variables (arr_K : K -> K -> K). Variables (arr_KP : forall sT sS, sort (arr_K sT sS) = (sort sT -> sort sS)). Fixpoint hfun_lift_loop n : forall (T_ : fin n -> K) (sS : K) , {sT | sort sT = hfun T_ sS} := match n return forall (T_ : fin n -> K) (sS : K) , {sT | sort sT = hfun T_ sS} with | 0 => fun T_ sS => exist _ sS erefl | n.+1 => fun T_ sS => let sT := hfun_lift_loop (fun j => T_ (Some j)) sS in exist _ (arr_K (T_ None) (sval sT)) (arr_KP (T_ None) (sval sT) * congr1 (fun S => T_ None -> S) (svalP sT)) end. End HeterogeneousInstances. Definition hsum_lift K sort n T_ sum_K sum_KP void_K void_KP := @hsum_lift_loop K sort sum_K sum_KP void_K void_KP n T_. Arguments hsum_lift {K} sort {n} _ _ _ _ _. Definition hlist_lift K sort n T_ cell_K cell_KP unit_K unit_KP := @hlist_lift_loop K sort cell_K cell_KP unit_K unit_KP n T_. Arguments hlist_lift {K} sort {n} _ _ _ _ _. Definition hfun_lift K sort n T_ arr_K arr_KP S := @hlist_lift_loop K sort arr_K arr_KP n T_ S. Arguments hfun_lift {K} sort {n} _ _ _ S. Section HSumEqType. Variables (n : nat) (T_ : fin n -> eqType). Definition hsum_eqType := let sum_eqType := fun A B : eqType => Equality.clone (A + B)%type _ in let void_eqType := Equality.clone void _ in let lift := hsum_lift Equality.sort T_ sum_eqType (fun _ _ => erefl) void_eqType erefl in cast (fun A => Equality A) (svalP lift) (Equality.class (sval lift)). HB.instance Definition _ := hsum_eqType. End HSumEqType. Section HSumChoiceType. Variables (n : nat) (T_ : fin n -> choiceType). Definition hsum_choiceType := let sum_choiceType := fun A B : choiceType => Choice.clone (A + B)%type _ in let void_choiceType := Choice.clone void _ in let lift := hsum_lift Choice.sort T_ sum_choiceType (fun _ _ => erefl) void_choiceType erefl in cast (fun A => Choice A) (svalP lift) (Choice.class (sval lift)). HB.instance Definition _ := hsum_choiceType. End HSumChoiceType. Section HSumCountType. Variables (n : nat) (T_ : fin n -> countType). Definition hsum_countType := let sum_countType := fun A B : countType => Countable.clone (A + B)%type _ in let void_countType := Countable.clone void _ in let lift := hsum_lift Countable.sort T_ sum_countType (fun _ _ => erefl) void_countType erefl in cast (fun A => Countable A) (svalP lift) (Countable.class (sval lift)). HB.instance Definition _ := hsum_countType. End HSumCountType. Section HListEqType. Variables (n : nat) (T_ : fin n -> eqType). Definition hlist_eqType := let cell_eqType := fun A B : eqType => Equality.clone (cell A B)%type _ in let unit_eqType := Equality.clone unit _ in let lift := hlist_lift Equality.sort T_ cell_eqType (fun _ _ => erefl) unit_eqType erefl in cast (fun A => Equality A) (svalP lift) (Equality.class (sval lift)). HB.instance Definition _ := hlist_eqType. End HListEqType. Section HListChoiceType. Variables (n : nat) (T_ : fin n -> choiceType). Definition hlist_choiceType := let cell_choiceType := fun A B : choiceType => Choice.clone (cell A B)%type _ in let unit_choiceType := Choice.clone unit _ in let lift := hlist_lift Choice.sort T_ cell_choiceType (fun _ _ => erefl) unit_choiceType erefl in cast (fun A => Choice A) (svalP lift) (Choice.class (sval lift)). HB.instance Definition _ := hlist_choiceType. End HListChoiceType. Section HListCountType. Variables (n : nat) (T_ : fin n -> countType). Definition hlist_countType := let cell_countType := fun A B : countType => Countable.clone (cell A B)%type _ in let unit_countType := Countable.clone unit _ in let lift := hlist_lift Countable.sort T_ cell_countType (fun _ _ => erefl) unit_countType erefl in cast (fun A => Countable A) (svalP lift) (Countable.class (sval lift)). HB.instance Definition _ := hlist_countType. End HListCountType. Set Universe Polymorphism. Fixpoint hlist1' m : (fin m.+1 -> Type) -> Type := match m with | 0 => fun X => X None | m.+1 => fun X => X None * hlist1' (fun i => X (Some i)) end%type. #[global] Hint Unfold hlist1' : deriving. Fixpoint hnth1' m : forall T, @hlist1' m T -> forall i : fin m.+1, T i := match m with | 0 => fun T l i => if i isn't Some i then l else match i with end | m.+1 => fun T l i => if i isn't Some i then l.1 else @hnth1' m _ l.2 i end. #[global] Hint Unfold hnth1' : deriving. Definition hlist1 m := match m return (fin m -> Type) -> Type with | 0 => fun _ => unit | n.+1 => fun X => hlist1' X end. #[global] Hint Unfold hlist1 : deriving. Definition hnth1 m := match m return forall (T : fin m -> Type) (l : hlist1 T) i, T i with | 0 => fun _ _ i => match i with end | n.+1 => fun X l i => hnth1' l i end. Coercion hnth1 : hlist1 >-> Funclass. #[global] Hint Unfold hnth1 : deriving. arthuraa-deriving-0e084ee/theories/compat.v000066400000000000000000000013321517411663100210420ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype order. Set SsrOldRewriteGoalsOrder. (* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Set Primitive Projections. (* Compatibility layer for Order.disp_t introduced in MathComp 2.3 *) (* TODO: remove when we drop the support for MathComp 2.2 *) Module Order. Import Order. Definition disp_t : Set. Proof. exact: disp_t || exact: unit. Defined. Definition default_display : disp_t. Proof. exact: tt || exact: Disp tt tt. Defined. End Order. arthuraa-deriving-0e084ee/theories/deriving.v000066400000000000000000000001011517411663100213570ustar00rootroot00000000000000From deriving Require Export ind tactics infer instances compat. arthuraa-deriving-0e084ee/theories/ind.v000066400000000000000000001000551517411663100203330ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype. Set SsrOldRewriteGoalsOrder. (* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) From deriving Require Import base. From Coq Require Import ZArith NArith String Ascii. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. (* Backwards compatibility for hint locality attributes *) Set Warnings "-unsupported-attributes". Open Scope deriving_scope. Record fun_split n (R : Type) (T : R) (Ts : fin n -> R) := FunSplit { fs_fun :> fin n.+1 -> R; _ : T = fs_fun None; _ : forall i, Ts i = fs_fun (Some i); }. Definition fsE1 n R T Ts (TTs : @fun_split n R T Ts) : T = TTs None := let: FunSplit _ e _ := TTs in e. Definition fsE2 n R T Ts (TTs : @fun_split n R T Ts) : forall i, Ts i = TTs (Some i) := let: FunSplit _ _ e := TTs in e. Canonical fun_split1 n R (TTs : fin n.+1 -> R) := @FunSplit n R (TTs None) (fun i => TTs (Some i)) TTs erefl (fun=> erefl). #[global] Hint Unfold fs_fun : deriving. #[global] Hint Unfold fsE1 : deriving. #[global] Hint Unfold fsE2 : deriving. #[global] Hint Unfold fun_split1 : deriving. Section LiftClass. Import PolyType. Variables (K : Type) (sort : K -> Type). Definition eq_class X := {sX : K | sort sX = X}. Record tagged_sort n := TaggedSort { untag_sort :> fin n -> Type; }. Definition ts_nil_tag n Ts := @TaggedSort n Ts. Canonical ts_cons_tag n Ts := @ts_nil_tag n Ts. Record lift_class n := LiftClass { lift_class_sort :> tagged_sort n; _ : forall i, eq_class (lift_class_sort i); }. Definition lift_class_class n (sTs : lift_class n) := let: LiftClass _ cTs := sTs return forall i, eq_class (sTs i) in cTs. Canonical nil_lift_class f := @LiftClass 0 (ts_nil_tag f) (fun i => match i with end). Canonical cons_lift_class n (sT : K) (f : lift_class n) (g : fun_split (sort sT) f) := @LiftClass n.+1 (ts_cons_tag g) (fun i => match i with | None => cast eq_class (fsE1 g) (exist _ sT erefl) | Some i => cast eq_class (fsE2 g i) (lift_class_class f i) end). Definition lift_class_proj n cK (class : forall sT, cK (sort sT)) (sTs : lift_class n) (i : fin n) : cK (sTs i) := cast cK (svalP (lift_class_class sTs i)) (class _). End LiftClass. #[global] Hint Unfold eq_class : deriving. #[global] Hint Unfold untag_sort : deriving. #[global] Hint Unfold ts_nil_tag : deriving. #[global] Hint Unfold ts_cons_tag : deriving. #[global] Hint Unfold lift_class_sort : deriving. #[global] Hint Unfold lift_class_class : deriving. #[global] Hint Unfold nil_lift_class : deriving. #[global] Hint Unfold cons_lift_class : deriving. #[global] Hint Unfold lift_class_proj : deriving. Arguments lift_class_proj {K sort n cK} class sTs i. Notation "T -F> S" := (forall i, T i -> S i) (at level 30, only parsing, no associativity) : deriving_scope. Notation "T *F S" := (fun i => T i * S i)%type (at level 20, only parsing, no associativity) : deriving_scope. Set Universe Polymorphism. Section Signature. Import PolyType. Variable n : nat. Implicit Types (T S : fin n -> Type). Variant arg := NonRec of Type | Rec of fin n. Definition type_of_arg T (A : arg) : Type := match A with | NonRec X => X | Rec i => T i end. Definition type_of_arg_map T S (f : T -F> S) A : type_of_arg T A -> type_of_arg S A := match A with | NonRec X => id | Rec i => f i end. Definition is_rec A := if A is Rec _ then true else false. Definition arity := seq arg. Definition signature := seq arity. Definition declaration := fin n -> signature. Identity Coercion seq_of_arity : arity >-> seq. Identity Coercion seq_of_sig : signature >-> seq. Definition empty_decl : declaration := fun _ => [::]. Definition add_arity (D : declaration) i As : declaration := fun j => if leq_fin i j is inl _ then As :: D i else D j. Definition add_arity_ind (P : fin n -> signature -> Type) D i As j : P i (As :: D i) -> P j (D j) -> P j (add_arity D i As j) := fun H1 H2 => match leq_fin i j as X return P j (if X is inl _ then As :: D i else D j) with | inl e => cast (fun k => P k (As :: D i)) e H1 | inr _ => H2 end. Variables (K : Type) (sort : K -> Type). Definition arg_class A := if A is NonRec T then eq_class sort T else unit. Record arg_inst := ArgInst { arg_inst_sort :> arg; arg_inst_class : arg_class arg_inst_sort }. Arguments ArgInst : clear implicits. Definition arity_class (As : arity) := hlist' arg_class As. Record arity_inst := ArityInst { arity_inst_sort :> arity; arity_inst_class : arity_class arity_inst_sort; }. Arguments ArityInst : clear implicits. Definition sig_class (Σ : signature) := hlist' arity_class Σ. Record sig_inst := SigInst { sig_inst_sort :> signature; sig_inst_class : sig_class sig_inst_sort; }. Arguments SigInst : clear implicits. Record tagged_decl k := TaggedDecl { untag_decl :> fin k -> signature; }. Record decl_inst k := DeclInst { decl_inst_sort :> tagged_decl k; _ : forall i, sig_class (decl_inst_sort i) }. Arguments DeclInst : clear implicits. Definition decl_inst_class k (d : decl_inst k) : forall i, sig_class (@decl_inst_sort k d i) := let: DeclInst _ d := d in d. Implicit Types (A : arg) (As : arity) (Σ : signature). Implicit Types (Ai : arg_inst) (Asi : arity_inst) (Σi : sig_inst). Canonical NonRec_arg_inst sX := ArgInst (NonRec (sort sX)) (exist _ sX erefl). Canonical Rec_arg_inst i := ArgInst (Rec i) tt. Canonical nth_fin_arg_inst Asi (i : fin (size Asi)) := ArgInst (nth_fin i) (arity_inst_class Asi i). Canonical nil_arity_inst := ArityInst nil tt. Canonical cons_arity_inst Ai Asi := ArityInst (arg_inst_sort Ai :: arity_inst_sort Asi) (arg_inst_class Ai ::: arity_inst_class Asi). Canonical nth_fin_arity_inst Σi (i : fin (size Σi)) := ArityInst (nth_fin i) (sig_inst_class Σi i). Canonical nil_sig_inst := SigInst nil tt. Canonical cons_sig_inst Asi Σi := SigInst (arity_inst_sort Asi :: sig_inst_sort Σi) (arity_inst_class Asi ::: sig_inst_class Σi). Definition nil_decl_tag k (D : fin k -> signature) := TaggedDecl D. Canonical cons_decl_tag k (D : fin k -> signature) := nil_decl_tag D. Canonical nil_decl_inst f := DeclInst 0 (nil_decl_tag f) (fun i => match i with end). Canonical cons_decl_inst k Σi Di (D : fun_split (sig_inst_sort Σi) (untag_decl (@decl_inst_sort k Di))) := DeclInst k.+1 (cons_decl_tag (fs_fun D)) (fun i => match i with | None => cast sig_class (fsE1 D) (sig_inst_class Σi) | Some i => cast sig_class (fsE2 D i) (@decl_inst_class k Di i) end). Definition arity_rec (P : arity -> Type) (Pnil : P [::]) (PNonRec : forall (sX : K) (As : arity), P As -> P (NonRec (sort sX) :: As)) (PRec : forall i (As : arity), P As -> P (Rec i :: As)) := fix arity_rec As : arity_class As -> P As := match As with | [::] => fun cAs => Pnil | NonRec X :: As => fun cAs => cast (fun X => P (NonRec X :: As)) (svalP cAs.(hd)) (PNonRec (sval cAs.(hd)) As (arity_rec As cAs.(tl))) | Rec i :: As => fun cAs => PRec i As (arity_rec As cAs.(tl)) end. Lemma arity_ind (P : forall As, hlist' arg_class As -> Type) (Pnil : P [::] tt) (PNonRec : forall sX As cAs, P As cAs -> P (NonRec (sort sX) :: As) (exist _ sX erefl ::: cAs)) (PRec : forall i As cAs, P As cAs -> P (Rec i :: As) (tt ::: cAs)) As cAs : P As cAs. Proof. elim: As cAs=> [|[X|i] As IH] => /= [[]|[[xS e] cAs]|[[] cAs]] //. by case: X / e cAs => ?; apply: PNonRec. by apply: PRec. Qed. End Signature. #[global] Hint Unfold type_of_arg : deriving. #[global] Hint Unfold type_of_arg_map : deriving. #[global] Hint Unfold is_rec : deriving. #[global] Hint Unfold arity : deriving. #[global] Hint Unfold signature : deriving. #[global] Hint Unfold declaration : deriving. #[global] Hint Unfold empty_decl : deriving. #[global] Hint Unfold add_arity : deriving. #[global] Hint Unfold add_arity_ind : deriving. #[global] Hint Unfold arg_class : deriving. #[global] Hint Unfold arg_inst_sort : deriving. #[global] Hint Unfold arg_inst_class : deriving. #[global] Hint Unfold arity_class : deriving. #[global] Hint Unfold arity_inst_sort : deriving. #[global] Hint Unfold arity_inst_class : deriving. #[global] Hint Unfold sig_class : deriving. #[global] Hint Unfold sig_inst_sort : deriving. #[global] Hint Unfold sig_inst_class : deriving. #[global] Hint Unfold untag_decl : deriving. #[global] Hint Unfold decl_inst_sort : deriving. #[global] Hint Unfold decl_inst_class : deriving. #[global] Hint Unfold NonRec_arg_inst : deriving. #[global] Hint Unfold Rec_arg_inst : deriving. #[global] Hint Unfold nth_fin_arg_inst : deriving. #[global] Hint Unfold nil_arity_inst : deriving. #[global] Hint Unfold cons_arity_inst : deriving. #[global] Hint Unfold nil_sig_inst : deriving. #[global] Hint Unfold cons_sig_inst : deriving. #[global] Hint Unfold nil_decl_tag : deriving. #[global] Hint Unfold cons_decl_tag : deriving. #[global] Hint Unfold nil_decl_inst : deriving. #[global] Hint Unfold cons_decl_inst : deriving. #[global] Hint Unfold arity_rec : deriving. Definition arg_class_map n K1 K2 (sort1 : K1 -> Type) (sort2 : K2 -> Type) (f : K1 -> K2) (p : forall cT, sort2 (f cT) = sort1 cT) (A : arg n) : arg_class sort1 A -> arg_class sort2 A := match A with | NonRec T => fun cT => PolyType.exist _ (f (PolyType.sval cT)) (p (PolyType.sval cT) * PolyType.svalP cT) | Rec i => fun _ => tt end. #[global] Hint Unfold arg_class_map : deriving. Definition pack_decl_inst n (D : declaration n) (Di : decl_inst n Equality.sort n) & phant_id D (untag_decl (decl_inst_sort Di)) := Di. Unset Universe Polymorphism. Arguments add_arity_ind {n} P D i As j H1 H2. Arguments empty_decl {n}. Arguments arity_rec {n K} _ _ _ _ _. Module Ind. Section Basic. Variable n : nat. Implicit Types (A : arg n) (As : arity n) (Σ : signature n). Implicit Types (D : declaration n). Implicit Types (T S : fin n -> Type). Import PolyType. Definition Cidx D i := fin (size (D i)). Arguments Cidx : clear implicits. Definition args D T i (j : Cidx D i) : Type := hlist' (type_of_arg T) (nth_fin j). Definition args_map D T S (f : T -F> S) i j (xs : @args D T i j) : args S j := hmap' (type_of_arg_map f) xs. Definition constructors D T := forall (Ti : fin n) (Ci : Cidx D Ti), hfun' (type_of_arg T) (nth_fin Ci) (T Ti). Definition empty_cons T : constructors empty_decl T := fun Ti Ci => match Ci with end. Definition add_cons D T (Cs : constructors D T) Ti As (C : hfun' (type_of_arg T) As (T Ti)) : constructors (add_arity D Ti As) T := fun Ti' => add_arity_ind (fun Ti' Σ => forall Ci : fin (size Σ), hfun' (type_of_arg T) (nth_fin Ci) (T Ti')) D Ti As Ti' (fun Ci => if Ci is Some Ci then Cs Ti Ci else C) (Cs Ti'). Fixpoint rec_branch' T S i As : Type := match As with | NonRec X :: As => X -> rec_branch' T S i As | Rec j :: As => T j -> S j -> rec_branch' T S i As | [::] => S i end. Definition rec_branch D T S i (j : Cidx D i) : Type := rec_branch' T S i (nth_fin j). Definition recursor D T := forall S, hfun2 (@rec_branch D T S) (hlist1 (fun i => T i -> S i)). Fixpoint rec_branch'_of_hfun' T S i As : hfun' (type_of_arg (T *F S)) As (S i) -> rec_branch' T S i As := match As with | NonRec R :: As => fun f x => rec_branch'_of_hfun' (f x) | Rec j :: As => fun f x y => rec_branch'_of_hfun' (f (x, y)) | [::] => fun f => f end. Fixpoint hfun'_of_rec_branch' T S i As : rec_branch' T S i As -> hfun' (type_of_arg (T *F S)) As (S i) := match As with | NonRec R :: As => fun f x => hfun'_of_rec_branch' (f x) | Rec j :: As => fun f p => hfun'_of_rec_branch' (f p.1 p.2) | [::] => fun f => f end. Coercion hfun'_of_rec_branch' : rec_branch' >-> hfun'. Lemma rec_branch_of_hfunK T S i As f xs : @rec_branch'_of_hfun' T S i As f xs = f xs. Proof. by elim: As f xs => [|[R|j] As IH] f //= [[x y] xs]. Qed. Definition recursor_eq D T (Cs : constructors D T) (r : recursor D T) := forall S, all_hlist2 (fun bs : hlist2 (rec_branch T S) => all_fin (fun i : fin n => all_fin (fun j : Cidx D i => all_hlist (fun xs : args T j => r S bs _ (Cs i j xs) = bs i j (args_map (fun k x => (x, r S bs k x)) xs))))). Definition des_branch D T S i (j : Cidx D i) := hfun' (type_of_arg T) (nth_fin j) (S i). Definition destructor D T := forall S, hfun2 (@des_branch D T S) (hlist1 (fun i => T i -> S i)). Definition destructor_eq D T (Cs : constructors D T) (d : destructor D T) := forall S, all_hlist2 (fun bs : hlist2 (des_branch T S) => all_fin (fun i : fin n => all_fin (fun j : Cidx D i => all_hlist (fun xs : args T j => d S bs _ (Cs i j xs) = bs i j xs)))). Definition rec_of_des_branch D T S i (j : Cidx D i) (b : des_branch T S j) : rec_branch T S j := rec_branch'_of_hfun' (hcurry (fun xs => b (args_map (fun _ => fst) xs))). Definition destructor_of_recursor D T (r : recursor D T) : destructor D T := fun S => hcurry2 (fun bs : hlist2 (@des_branch D T S) => r S (hmap2 (@rec_of_des_branch D T S) bs)). Fixpoint ind_branch' T (P : forall i, T i -> Type) i As : hfun' (type_of_arg T) As (T i) -> Type := match As with | NonRec R :: As => fun C => forall x : R, ind_branch' P (C x) | Rec j :: As => fun C => forall x : T j, P j x -> ind_branch' P (C x) | [::] => fun C => P i C end. Definition ind_branch D T P (Cs : constructors D T) i (j : Cidx D i) := @ind_branch' T P i (nth_fin j) (Cs i j). Definition induction D T (Cs : constructors D T) := @hdfun n (fun i => T i -> Type) (fun P : hlist (fun i => T i -> Type) => hfun2 (@ind_branch D T P Cs) (hlist1 (fun i => forall x, P i x))). End Basic. Module Def. Set Primitive Projections. Record class_of n sorts (decl : declaration n) := Class { Cons : constructors decl sorts; rec : recursor decl sorts; case : destructor decl sorts; recE : recursor_eq Cons rec; caseE : destructor_eq Cons case; indP : induction Cons; }. Record type := Pack { n : nat; sorts : fin n -> Type; decl : declaration n; class : class_of sorts decl; }. Unset Primitive Projections. End Def. Section ClassDef. Set Primitive Projections. Record mixin_of T := Mixin { def : Def.type; idx : fin (Def.n def); idxE : T = Def.sorts idx; }. Unset Primitive Projections. Record type := Pack {sort : Type; _ : mixin_of sort}. Local Coercion sort : type >-> Sortclass. Local Notation class_of := mixin_of. Variables (T : Type) (cT : type). Definition class := let: Pack _ c as cT' := cT return class_of cT' in c. Definition clone n Ts D cTs i iE := let sTs := @Mixin T (@Def.Pack n Ts D cTs) i iE in fun & phant_id class sTs => @Pack T sTs. Let xT := let: Pack T _ := cT in T. Notation xclass := (class : class_of xT). End ClassDef. Notation class_of := mixin_of. Module Exports. Identity Coercion hdfun_of_induction : induction >-> hdfun. Coercion Def.sorts : Def.type >-> Funclass. Coercion Def.class : Def.type >-> Def.class_of. Notation indDef := Def.type. Notation IndDef := Def.Pack. Coercion sort : type >-> Sortclass. Coercion class : type >-> class_of. Coercion def : class_of >-> indDef. Notation indType := type. Notation "[ 'indType' 'of' T ]" := (@clone T _ _ _ _ _ _ _ id) (at level 0, format "[ 'indType' 'of' T ]") : form_scope. End Exports. End Ind. Export Ind.Exports. Arguments Ind.Def.decl : clear implicits. Class find_idx n (Ts : fin n -> Type) (T : Type) i (e : T = Ts i) := make_find_idx { }. Arguments find_idx : clear implicits. Arguments make_find_idx {_ _ _ _ _}. Definition find_idx_here n (Ts : fin n.+1 -> Type) : find_idx n.+1 Ts (Ts None) None erefl := make_find_idx. Definition find_idx_there n (Ts : fin n.+1 -> Type) T i e (_ : find_idx n (fun i => Ts (Some i)) T i e) : find_idx n.+1 Ts T (Some i) e := make_find_idx. #[global] Hint Extern 1 (find_idx ?m ?Ts ?T _ _) => match eval hnf in m with | ?n.+1 => eapply (@find_idx_here n Ts) end : typeclass_instances. #[global] Hint Extern 2 (find_idx ?m ?Ts ?T _ _) => match eval hnf in m with | ?n.+1 => eapply (@find_idx_there n Ts) end : typeclass_instances. Definition pack_indType T (Ts : indDef) i e & find_idx (Ind.Def.n Ts) Ts T i e := Ind.Pack (@Ind.Mixin T Ts i e). Notation IndType T Ts := (@pack_indType T Ts _ _ _). #[global] Hint Unfold Ind.Cidx : deriving. #[global] Hint Unfold Ind.args : deriving. #[global] Hint Unfold Ind.args_map : deriving. #[global] Hint Unfold Ind.constructors : deriving. #[global] Hint Unfold Ind.empty_cons : deriving. #[global] Hint Unfold Ind.add_cons : deriving. #[global] Hint Unfold Ind.rec_branch' : deriving. #[global] Hint Unfold Ind.rec_branch : deriving. #[global] Hint Unfold Ind.recursor : deriving. #[global] Hint Unfold Ind.rec_branch'_of_hfun' : deriving. #[global] Hint Unfold Ind.hfun'_of_rec_branch' : deriving. #[global] Hint Unfold Ind.recursor_eq : deriving. #[global] Hint Unfold Ind.des_branch : deriving. #[global] Hint Unfold Ind.destructor : deriving. #[global] Hint Unfold Ind.destructor_eq : deriving. #[global] Hint Unfold Ind.rec_of_des_branch : deriving. #[global] Hint Unfold Ind.destructor_of_recursor : deriving. #[global] Hint Unfold Ind.ind_branch' : deriving. #[global] Hint Unfold Ind.ind_branch : deriving. #[global] Hint Unfold Ind.induction : deriving. #[global] Hint Unfold Ind.Def.Cons : deriving. #[global] Hint Unfold Ind.Def.rec : deriving. #[global] Hint Unfold Ind.Def.case : deriving. #[global] Hint Unfold Ind.Def.n : deriving. #[global] Hint Unfold Ind.Def.sorts : deriving. #[global] Hint Unfold Ind.Def.decl : deriving. #[global] Hint Unfold Ind.Def.class : deriving. #[global] Hint Unfold Ind.class : deriving. #[global] Hint Unfold Ind.def : deriving. #[global] Hint Unfold Ind.idx : deriving. #[global] Hint Unfold Ind.idxE : deriving. #[global] Hint Unfold Ind.sort : deriving. #[global] Hint Unfold Ind.clone : deriving. #[global] Hint Unfold find_idx_here : deriving. #[global] Hint Unfold find_idx_there : deriving. #[global] Hint Unfold pack_indType : deriving. Module IndF. Section FunctorDef. Variables (n : nat) (D : declaration n). Implicit Types (T S : fin n -> Type). Notation size := PolyType.size. Record fobj T (i : fin n) := Cons { constr : Ind.Cidx D i; args : hlist' (type_of_arg T) (nth_fin constr) }. Arguments Cons {_ i} _ _. Local Notation F := fobj. Definition fmap T S (f : T -F> S) i (x : F T i) : F S i := Cons (constr x) (hmap' (type_of_arg_map f) (args x)). Lemma fmap_eq T S (f g : T -F> S) : (forall i x, f i x = g i x) -> (forall i (x : F T i), fmap f x = fmap g x). Proof. move=> e i [j args]; congr Cons; apply: hmap_eq => /= k. by case: (nth_fin k). Qed. Lemma fmap1 T i : @fmap T T (fun _ => id) i =1 id. Proof. move=> [j args] /=; congr Cons; rewrite -[RHS]hmap1. by apply: hmap_eq=> /= k; case: (nth_fin k). Qed. Lemma fmap_comp T S R (f : T -F> S) (g : S -F> R) i : @fmap _ _ (fun j x => g j (f j x)) i =1 @fmap _ _ g i \o @fmap _ _ f i. Proof. move=> [j args] /=; congr Cons; rewrite /= /hmap' hmap_comp. by apply: hmap_eq=> /= k; case: (nth_fin k). Qed. Lemma inj T (i : fin n) (j : Ind.Cidx D i) (a b : hlist' (type_of_arg T) (nth_fin j)) : Cons j a = Cons j b -> a = b. Proof. pose get x := if leq_fin (constr x) j is inl e then cast (fun j : Ind.Cidx D i => hlist' (type_of_arg T) (nth_fin j)) e (args x) else a. by move=> /(congr1 get); rewrite /get /= leq_finii /=. Qed. End FunctorDef. Section TypeDef. Variable (T : indDef). Notation D := (Ind.Def.decl T). Notation F := (@fobj _ D). Arguments Cons {n D T i} _ _. Definition Roll i (x : F T i) : T i := @Ind.Def.Cons _ _ _ T i (constr x) (args x). Definition rec_branches_of_fun S (body : F (T *F S) -F> S) : hlist2 (@Ind.rec_branch _ D T S) := hlist_of_fun (fun i => hlist_of_fun (fun j : Ind.Cidx D i => Ind.rec_branch'_of_hfun' (hcurry (fun l => body i (Cons j l))))). Definition rec S (body : F (T *F S) -F> S) := @Ind.Def.rec _ _ _ T S (rec_branches_of_fun body). Definition lift_type R i : fin (Ind.Def.n T) -> Type := fun j => if leq_fin i j is inl e then R else unit. Definition lift_typeE R i : lift_type R i i = R := congr1 (fun r => if r is inl e then R else unit) (leq_finii i). Definition lift_type_of R i j (f : i = j -> R) : lift_type R i j := match leq_fin i j as r return if r is inl e then R else unit with | inl e => f e | inr _ => tt end. Definition des_branches_of_fun i R (body : F T i -> R) : hlist2 (@Ind.des_branch _ D T (lift_type R i)) := hlist_of_fun (fun i' => hlist_of_fun (fun j : Ind.Cidx D i' => hcurry (fun l => @lift_type_of R i i' (fun e => body (cast (F T) e^-1 (Cons j l)))))). Definition case i R (body : F T i -> R) x := cast id (lift_typeE R i) (@Ind.Def.case _ _ _ T _ (des_branches_of_fun body) i x). Lemma recE S f i (a : F T i) : @rec S f i (Roll a) = f i (fmap (fun j (x : T j) => (x, rec f j x)) a). Proof. case: a=> [j args]; have := Ind.Def.recE T S. move/all_hlist2P/(_ (rec_branches_of_fun f)). move/all_finP/(_ i). move/all_finP/(_ j). move/all_hlistP/(_ args). rewrite /rec_branches_of_fun hnth_of_fun. rewrite /rec /Roll => -> /=. by rewrite /= hnth_of_fun Ind.rec_branch_of_hfunK hcurryK. Qed. Lemma caseE i R f (a : F T i) : case f (Roll a) = f a :> R. Proof. case: a => [j args]; have := Ind.Def.caseE T (lift_type R i). move/all_hlist2P/(_ (des_branches_of_fun f)). move/all_finP/(_ i). move/all_finP/(_ j). move/all_hlistP/(_ args). rewrite /des_branches_of_fun hnth_of_fun. rewrite /case /Roll => -> /=. rewrite /lift_type /lift_typeE /lift_type_of hnth_of_fun hcurryK /=. case: (leq_fin i i) (leq_finii i)=> // e. rewrite (eq_axiomK e) => {}e. by rewrite (eq_axiomK e) /=. Qed. Lemma indP P : (forall i (a : F (fun j => {x & P j x}) i), P i (Roll (fmap (fun _ => tag) a))) -> forall i x, P i x. Proof. move=> IH. pose Q := hlist_of_fun P. pose Q_of_P i a : P i a -> Q i a := cast id (congr1 (fun F => F a) (hnth_of_fun P i))^-1. pose P_of_Q i a : Q i a -> P i a := cast id (congr1 (fun F => F a) (hnth_of_fun P i)). pose TP_of_TQ i x := Tagged (P i) (P_of_Q i (tag x) (tagged x)). have Q_of_PK i a : cancel (Q_of_P i a) (P_of_Q i a) := castKV _. have P_of_QK i a : cancel (P_of_Q i a) (Q_of_P i a) := castK _. have {}IH i (a : F (fun j => {x & Q j x}) i) : Q i (Roll (fmap (fun _ => tag) a)). rewrite (_ : fmap _ a = fmap (fun _ => tag) (fmap TP_of_TQ a)); last first. by rewrite -[RHS]fmap_comp; apply: fmap_eq=> ? []. by apply: (Q_of_P); apply: IH. move=> i x {P_of_QK Q_of_PK Q_of_P TP_of_TQ}; apply: P_of_Q. move: {P} Q IH i x. rewrite /Roll; case: (T) => n S D [/= Cs _ _ _ _ indP] P. have {}indP : (forall i j, Ind.ind_branch' P (Cs i j)) -> (forall i x, P i x). move=> hyps i x. pose bs : hlist2 (Ind.ind_branch P Cs) := hlist_of_fun (fun i => hlist_of_fun (fun j => hyps i j)). exact: (hdapp indP P bs i x). move=> hyps; apply: indP=> i j. have {}hyps: forall args : hlist' (type_of_arg (fun k => {x & P k x})) (nth_fin j), P i (Cs i j (hmap' (type_of_arg_map (fun _ => tag)) args)). by move=> args; move: (hyps i (Cons j args)). move: (Cs i j) hyps; rewrite /fnth. elim: (nth_fin j)=> [|[R|k] As IH] /=. - by move=> C /(_ tt). - move=> C hyps x; apply: IH=> args; exact: (hyps (x ::: args)). - move=> constr hyps x H; apply: IH=> args. exact: (hyps (existT _ x H ::: args)). Qed. Definition unroll i := @case i _ id. Lemma RollK i : cancel (@Roll i) (@unroll i). Proof. by move=> x; rewrite /unroll caseE. Qed. Lemma Roll_inj i : injective (@Roll i). Proof. exact: can_inj (@RollK i). Qed. Lemma unrollK i : cancel (@unroll i) (@Roll i). Proof. by elim/indP: i / => i a; rewrite RollK. Qed. Lemma unroll_inj i : injective (@unroll i). Proof. exact: can_inj (@unrollK i). Qed. End TypeDef. End IndF. #[global] Hint Unfold IndF.constr : deriving. #[global] Hint Unfold IndF.args : deriving. #[global] Hint Unfold IndF.fmap : deriving. #[global] Hint Unfold IndF.Roll : deriving. #[global] Hint Unfold IndF.rec_branches_of_fun : deriving. #[global] Hint Unfold IndF.rec : deriving. #[global] Hint Unfold IndF.lift_type : deriving. #[global] Hint Unfold IndF.lift_typeE : deriving. #[global] Hint Unfold IndF.lift_type_of : deriving. #[global] Hint Unfold IndF.des_branches_of_fun : deriving. #[global] Hint Unfold IndF.case : deriving. #[global] Hint Unfold IndF.unroll : deriving. Section InferInstances. Import PolyType. Class infer_arity n (T : fin n -> Type) (P : forall i, T i -> Type) (branchT : Type) (As : arity n) (i : fin n) (C : hfun' (type_of_arg T) As (T i)) : Type. Arguments infer_arity : clear implicits. Instance infer_arity_end n T P i (x : T i) : infer_arity n T P (P i x) [::] i x. Defined. Instance infer_arity_rec n Ts P j (branchT : Ts j -> Type) i (As : arity n) (C : Ts j -> hfun' (type_of_arg Ts) As (Ts i)) (_ : forall x, infer_arity n Ts P (branchT x) As i (C x)) : infer_arity n Ts P (forall x, P j x -> branchT x) (Rec j :: As) i C. Defined. Instance infer_arity_nonrec n T P S (branchT : S -> Type) i As (C : S -> hfun' (type_of_arg T) As (T i)) (_ : forall x, infer_arity n T P (branchT x) As i (C x)) : infer_arity n T P (forall x, branchT x) (NonRec n S :: As) i C. Defined. Class infer_decl n T (P : forall i, T i -> Type) (elimT : Type) (D : declaration n) (Cs : Ind.constructors D T) : Type. Arguments infer_decl : clear implicits. Global Instance infer_decl_end n T P : infer_decl n T P (hlist1 (fun i => forall (x : T i), P i x)) empty_decl (@Ind.empty_cons _ _). Defined. Global Instance infer_decl_cons n T P (branchT : Type) Ti As C (_ : infer_arity n T P branchT As Ti C) (elimT : Type) D Cs (_ : infer_decl n T P elimT D Cs) : infer_decl n T P (branchT -> elimT) (add_arity D Ti As) (Ind.add_cons Cs C). Defined. Class read_rect (rectT : Type) (rect : rectT) (n : nat) (Ts : fin n -> Type) (rectT' : (forall i, Ts i -> Type) -> Type) (rect' : forall Ps, rectT' Ps). Arguments read_rect : clear implicits. Global Instance read_rect_type (T : Type) (rectT : (T -> Type) -> Type) (rect : forall P, rectT P) n Ts rectT' rect' (_ : forall P, read_rect (rectT P) (rect P) n Ts (rectT' P) (rect' P)) : read_rect (forall P, rectT P) rect n.+1 (fcons T Ts) (fun Ps => rectT' (Ps None) (fun i => Ps (Some i))) (fun Ps => rect' (Ps None) (fun i => Ps (Some i))) | 1. Defined. Global Instance read_rect_done rectT rect : read_rect rectT rect 0 (fnil Type) (fun _ => rectT) (fun _ => rect) | 2. Defined. Class bless_rect n Ts (D : declaration n) (Cs : Ind.constructors D Ts) (rectT : (forall i, Ts i -> Type) -> Type) (rect : forall P, rectT P) (rect' : Ind.recursor D Ts). Arguments bless_rect : clear implicits. Class infer_ind rectT (rect : rectT) n Ts (D : declaration n) (Cs : Ind.constructors D Ts) (rectT' : (forall i, Ts i -> Type) -> Type) (rect' : forall P, rectT' P) (rect'' : Ind.recursor D Ts). Arguments infer_ind : clear implicits. Global Instance do_infer_ind rectT rect n Ts rectT' rect' (_ : read_rect rectT rect n Ts rectT' rect') D Cs (_ : forall P, infer_decl n Ts P (rectT' P) D Cs) rect'' (_ : bless_rect n Ts D Cs rectT' rect' rect'') : infer_ind rectT rect n Ts D Cs rectT' rect' rect''. Defined. End InferInstances. Arguments infer_arity : clear implicits. Arguments infer_decl : clear implicits. Arguments read_rect : clear implicits. Arguments bless_rect : clear implicits. Arguments infer_ind : clear implicits. #[global] Hint Unfold infer_arity_end : deriving. #[global] Hint Unfold infer_arity_rec : deriving. #[global] Hint Unfold infer_arity_nonrec : deriving. #[global] Hint Unfold infer_decl_end : deriving. #[global] Hint Unfold infer_decl_cons : deriving. #[global] Hint Unfold read_rect_type : deriving. #[global] Hint Unfold read_rect_done : deriving. #[global] Hint Unfold do_infer_ind : deriving. Ltac infer_arity := cbv beta; match goal with | |- infer_arity ?n ?Ts ?Ps (?Ps ?i ?x) _ _ _ => exact (@infer_arity_end n Ts Ps i x) | |- infer_arity ?n ?Ts ?Ps (forall x, ?Ps ?j x -> @?branchT x) _ _ _ => eapply (@infer_arity_rec n Ts Ps j branchT) | |- infer_arity ?n ?Ts ?Ps (forall x : ?S, @?branchT x) _ _ _ => eapply (@infer_arity_nonrec n Ts Ps S branchT) end. #[global] Hint Extern 0 (infer_arity _ _ _ _ _ _ _) => infer_arity : typeclass_instances. Ltac infer_decl := cbv beta; match goal with | |- infer_decl ?n ?Ts ?Ps (?branchT -> ?rectT) _ _ => eapply (@infer_decl_cons n Ts Ps branchT _ _ _ _ rectT) | |- infer_decl ?n ?Ts ?Ps _ _ _ => eapply (@infer_decl_end n Ts Ps) end. #[global] Hint Extern 0 (infer_decl _ _ _ _ _ _) => infer_decl : typeclass_instances. Ltac bless_rect := cbv beta; match goal with | |- bless_rect ?n ?Ts ?D ?Cs ?rectT ?rect _ => exact (@Build_bless_rect n Ts D Cs rectT rect (fun P => rect (fun i _ => P i))) end. #[global] Hint Extern 0 (bless_rect _ _ _ _ _ _ _) => bless_rect : typeclass_instances. Module IndEqType. Record type := Pack { n : nat; sorts : fin n -> Type; decl : declaration n; eq_class : forall i, Equality (sorts i); ind_class : Ind.Def.class_of sorts decl; }. Definition indDef T := Ind.Def.Pack (ind_class T). Module Import Exports. Notation indEqType := type. Notation IndEqType := Pack. Coercion sorts : type >-> Funclass. Coercion indDef : type >-> Ind.Def.type. Canonical indDef. End Exports. End IndEqType. Export IndEqType.Exports. Section IndEqTypeInstances. Variables (T : indEqType) (i : fin (IndEqType.n T)). HB.instance Definition indEqType_eqType := IndEqType.eq_class i. End IndEqTypeInstances. #[global] Hint Unfold IndEqType.n : deriving. #[global] Hint Unfold IndEqType.sorts : deriving. #[global] Hint Unfold IndEqType.decl : deriving. #[global] Hint Unfold IndEqType.eq_class : deriving. #[global] Hint Unfold IndEqType.ind_class : deriving. #[global] Hint Unfold IndEqType.indDef : deriving. Module IndChoiceType. Record type := Pack { n : nat; sorts : fin n -> Type; decl : declaration n; choice_class : forall i, Choice (sorts i); ind_class : Ind.Def.class_of sorts decl; }. Definition indDef T := Ind.Def.Pack (ind_class T). Module Import Exports. Notation indChoiceType := type. Notation IndChoiceType := Pack. Coercion sorts : type >-> Funclass. Coercion indDef : type >-> Ind.Def.type. Canonical indDef. End Exports. End IndChoiceType. Export IndChoiceType.Exports. #[global] Hint Unfold IndChoiceType.n : deriving. #[global] Hint Unfold IndChoiceType.sorts : deriving. #[global] Hint Unfold IndChoiceType.decl : deriving. #[global] Hint Unfold IndChoiceType.choice_class : deriving. #[global] Hint Unfold IndChoiceType.ind_class : deriving. #[global] Hint Unfold IndChoiceType.indDef : deriving. Section IndChoiceTypeInstances. Variables (T : indChoiceType) (i : fin (IndChoiceType.n T)). HB.instance Definition _ := IndChoiceType.choice_class i. End IndChoiceTypeInstances. Module IndCountType. Record type := Pack { n : nat; sorts : fin n -> Type; decl : declaration n; count_class : forall i, Countable (sorts i); ind_class : Ind.Def.class_of sorts decl; }. Definition indDef T := Ind.Def.Pack (ind_class T). Module Import Exports. Notation indCountType := type. Notation IndCountType := Pack. Coercion sorts : type >-> Funclass. Coercion indDef : type >-> Ind.Def.type. Canonical indDef. End Exports. End IndCountType. Export IndCountType.Exports. Section IndCountTypeInstances. Variables (T : indCountType) (i : fin (IndCountType.n T)). HB.instance Definition _ := IndCountType.count_class i. End IndCountTypeInstances. #[global] Hint Unfold IndCountType.n : deriving. #[global] Hint Unfold IndCountType.sorts : deriving. #[global] Hint Unfold IndCountType.decl : deriving. #[global] Hint Unfold IndCountType.count_class : deriving. #[global] Hint Unfold IndCountType.ind_class : deriving. #[global] Hint Unfold IndCountType.indDef : deriving. arthuraa-deriving-0e084ee/theories/infer.v000066400000000000000000000072661517411663100206760ustar00rootroot00000000000000From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype order. Set SsrOldRewriteGoalsOrder. (* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) From deriving Require Import base ind tactics. From Coq Require Import ZArith NArith String Ascii. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Open Scope deriving_scope. (* Use `eval red` (one-step delta on the head constant, then beta) to inline recursor constants into their underlying fix, falling back to `eval hnf` when the head is already a fix or lambda. This matters for mutual types: Combined Scheme produces a wrapper that calls the per-type recursors (M0_rect, M1_rect, ...) as constants. eval hnf refuses to delta-unfold a recursor whose structurally recursive argument is not yet supplied, so the destructor baked into Ind.Def.case would contain stuck terms like `M0_rect ... (M0A n)`. Because deriving_compute uses cbv with a fixed delta-whitelist that does not include user-defined recursor names, it cannot reduce these stuck terms, and derived definitions (eq_op, le, ...) carry unreduced recursor calls that blow up at simplification time. eval red does not have this restriction: it always unfolds the head constant, exposing the mutual fix so that iota reduction can proceed normally. *) Ltac head_red rec := match constr:(tt) with | _ => let r := eval red in rec in r | _ => let r := eval hnf in rec in r end. Ltac unwind_recursor rec := try red; match goal with | |- ?F -> ?G => let X := fresh "X" in intros X; unwind_recursor (rec X) | |- prod ?T1 ?T2 => let rec1 := head_red (rec.1) in let rec2 := head_red (rec.2) in split; [unwind_recursor rec1|unwind_recursor rec2] | |- forall x, _ => let rec' := head_red rec in intros x; destruct x; apply rec' end. Ltac ind_def rec := let Rec := eval red in rec in let H := constr:((fun n Ts D Cs RecT' Rec' Rec'' => fun (H : infer_ind _ Rec n Ts D Cs RecT' Rec' Rec'') => H) _ _ _ _ _ _ _ _) in match type of H with | infer_ind _ _ ?n ?Ts ?D ?Cs ?RecT' ?Rec' ?Rec'' => let case := constr:(ltac:(intros P; deriving_compute; unwind_recursor (Rec' P)) : forall P, RecT' P) in let case := constr:(fun S : fin n -> Type => case (fun i _ => S i)) in let case := constr:(@Ind.destructor_of_recursor n D Ts case) in let case := eval deriving_compute in case in refine (IndDef (@Ind.Def.Class n Ts D Cs (fun S => Rec' (fun i _ => S i)) case _ _ rec)); abstract (deriving_compute; intuition) end. Notation "[ 'indDef' 'for' rect ]" := (ltac:(ind_def rect)) (at level 0) : form_scope. (** In these two notations, we force the indType instance to be unfolded before returning it, so that it can be simplified. *) Notation "[ 'infer' 'indType' 'of' T 'as' sT n sorts D 'in' e ]" := (fun (sT' : indType) & phant_id T%type (Ind.sort sT') => fun n (sorts : fin n -> Type) (D : declaration n) => fun (def : Ind.Def.class_of sorts D) (i : fin n) (iE : T%type = sorts i) => let sT := Ind.Pack (@Ind.Mixin T (@Ind.Def.Pack n sorts D def) i iE) in fun & phant_id sT' sT => e) (at level 0, sT ident, n ident, sorts ident, D ident) : form_scope. Notation "[ 'infer' 'indType' 'of' T 'with' proj 'as' sT n sorts D cD 'in' e ]" := ([infer indType of T as sT n sorts D in fun (sD : decl_inst n proj n) & phant_id D (untag_decl sD) => fun (cD : forall i : fin n, sig_class proj (D i)) => fun & phant_id (decl_inst_class sD) cD => e]) (at level 0, sT ident, n ident, sorts ident, D ident, cD ident) : form_scope. arthuraa-deriving-0e084ee/theories/instances.v000066400000000000000000000112001517411663100215410ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype order. Set SsrOldRewriteGoalsOrder. (* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) From deriving Require Import base ind tactics infer compat. From deriving.instances Require Export eqtype tree_of_ind fintype order. From Coq Require Import ZArith NArith String Ascii. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Open Scope deriving_scope. Definition unit_indDef := [indDef for unit_rect]. Canonical unit_indType := IndType unit unit_indDef. Definition void_indDef := [indDef for Empty_set_rect]. Canonical void_indType := IndType void void_indDef. Definition bool_indDef := [indDef for bool_rect]. Canonical bool_indType := IndType bool bool_indDef. Definition nat_indDef := [indDef for nat_rect]. Canonical nat_indType := IndType nat nat_indDef. Definition option_indDef T := [indDef for @option_rect T]. Canonical option_indType T := IndType (option T) (option_indDef T). Section OptionOrderType. Variable Tord : orderType Order.default_display. Definition option_isOrder := Eval hnf in [derive isOrder for option Tord]. HB.instance Definition _ := option_isOrder. End OptionOrderType. Definition sum_indDef T1 T2 := [indDef for @sum_rect T1 T2]. Canonical sum_indType T1 T2 := IndType (T1 + T2) (sum_indDef T1 T2). Definition prod_indDef T1 T2 := [indDef for @prod_rect T1 T2]. Canonical prod_indType T1 T2 := IndType (T1 * T2) (prod_indDef T1 T2). Definition seq_indDef T := [indDef for @list_rect T]. Canonical seq_indType T := IndType (seq T) (seq_indDef T). Definition comparison_indDef := [indDef for comparison_rect]. Canonical comparison_indType := IndType comparison comparison_indDef. Definition comparison_hasDecEq := [derive hasDecEq for comparison]. HB.instance Definition _ := comparison_hasDecEq. Definition comparison_hasChoice := [derive hasChoice for comparison]. HB.instance Definition _ := comparison_hasChoice. Definition comparison_isCountable := [derive isCountable for comparison]. HB.instance Definition _ := comparison_isCountable. Definition comparison_isFinite := [derive isFinite for comparison]. HB.instance Definition _ := comparison_isFinite. Definition positive_indDef := [indDef for positive_rect]. Canonical positive_indType := IndType positive positive_indDef. Definition positive_hasDecEq := [derive hasDecEq for positive]. HB.instance Definition _ := positive_hasDecEq. Definition positive_hasChoice := [derive hasChoice for positive]. HB.instance Definition _ := positive_hasChoice. Definition positive_isCountable := [derive isCountable for positive]. HB.instance Definition _ := positive_isCountable. Definition bin_nat_indDef := [indDef for N_rect]. Canonical bin_nat_indType := IndType N bin_nat_indDef. Definition bin_nat_hasChoice := [derive hasChoice for N]. HB.instance Definition _ := bin_nat_hasChoice. Definition bin_nat_isCountable := [derive isCountable for N]. HB.instance Definition _ := bin_nat_isCountable. Definition Z_indDef := [indDef for Z_rect]. Canonical Z_indType := IndType Z Z_indDef. Definition Z_hasDecEq := [derive hasDecEq for Z]. HB.instance Definition _ := Z_hasDecEq. Definition Z_hasChoice := [derive hasChoice for Z]. HB.instance Definition _ := Z_hasChoice. Definition Z_isCountable := [derive isCountable for Z]. HB.instance Definition _ := Z_isCountable. Definition ascii_indDef := [indDef for ascii_rect]. Canonical ascii_indType := IndType ascii ascii_indDef. Definition ascii_hasDecEq := [derive hasDecEq for ascii]. HB.instance Definition _ := ascii_hasDecEq. Definition ascii_hasChoice := [derive hasChoice for ascii]. HB.instance Definition _ := ascii_hasChoice. Definition ascii_isCountable := [derive isCountable for ascii]. HB.instance Definition _ := ascii_isCountable. Definition ascii_isFinite := [derive isFinite for ascii]. HB.instance Definition _ := ascii_isFinite. Definition ascii_isOrder := [derive isOrder for ascii]. HB.instance Definition _ := ascii_isOrder. Definition string_indDef := [indDef for string_rect]. Canonical string_indType := IndType string string_indDef. Definition string_hasDecEq := [derive hasDecEq for string]. HB.instance Definition _ := string_hasDecEq. Definition string_hasChoice := [derive hasChoice for string]. HB.instance Definition _ := string_hasChoice. Definition string_isCountable := [derive isCountable for string]. HB.instance Definition _ := string_isCountable. Definition string_isOrder := [derive isOrder for string]. HB.instance Definition _ := string_isOrder. arthuraa-deriving-0e084ee/theories/instances/000077500000000000000000000000001517411663100213605ustar00rootroot00000000000000arthuraa-deriving-0e084ee/theories/instances/eqtype.v000066400000000000000000000110431517411663100230550ustar00rootroot00000000000000From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype order. Set SsrOldRewriteGoalsOrder. (* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) From deriving Require Import base ind tactics infer. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Open Scope deriving_scope. Module DerEqType. Section EqType. Variable T : indDef. Notation n := (Ind.Def.n T). Local Notation arg_class := (@arg_class n _ Equality.sort). Local Notation arg_inst := (arg_inst n Equality.sort). Local Notation arity_inst := (arity_inst n Equality.sort). Local Notation sig_inst := (sig_inst n Equality.sort). Local Notation decl_inst := (decl_inst n Equality.sort n). Variable (sT : forall i, sig_class Equality.sort (Ind.Def.decl T i)). Import IndF. Definition eq_op_branch As (cAs : hlist' arg_class As) : hlist' (type_of_arg (T *F (fun i => T i -> bool))) As -> hlist' (type_of_arg T) As -> bool -> bool := arity_rec _ (fun As => hlist' _ As -> hlist' _ As -> bool -> bool) (fun _ _ b => b) (fun R As rec x y b => rec x.(tl) y.(tl) (b && (x.(hd) == y.(hd)))) (fun j As rec x y b => rec x.(tl) y.(tl) (b && x.(hd).2 y.(hd))) As cAs. (* FIXME: Do we really need these annotations? *) Definition eq_op : forall i, T i -> T i -> bool := rec (fun i args1 => case (fun args2 => match leq_fin (constr args2) (constr args1) with | inl e => eq_op_branch (hnth (sT i) (constr args1)) (args args1) (cast (hlist' (type_of_arg T) \o @nth_fin _ _) e (args args2)) true | inr _ => false end)). Lemma eq_opP i : Equality.axiom (@eq_op i). Proof. elim/indP: i / => i [xC xargs] y. rewrite /eq_op recE /= -/eq_op /=. rewrite -[y]unrollK caseE; move: {y} (unroll y)=> [yC yargs] /=. case le: (leq_fin yC xC)=> [e|b]; last first. constructor=> /Roll_inj /= [] e _. by move: le; rewrite e leq_finii. case: xC / e xargs {le} => /= xargs. apply/(@iffP (hmap' (type_of_arg_map (fun=> tag)) xargs = yargs)); first last. - by move=> /Roll_inj /IndF.inj. - by move=> <-. apply/(iffP idP)=> [H|<-]; last first. elim/arity_ind: {yC} _ / (hnth _ _) xargs {yargs}=> //= [|j] S As cAs. move=> /= IH [x xargs]; rewrite /= eqxx; exact: IH. move=> [[x xP] xargs] /=; rewrite (introT (xP _)) //; exact: cAs. suffices [//]: true /\ hmap' (type_of_arg_map (fun=> tag)) xargs = yargs. elim/arity_ind: {yC} _ / (hnth _ _) xargs yargs true H. - by move=> [] []. - move=> S As cAs IH /= [x xargs] [y yargs] /= b /IH. by case=> /andP [-> /eqP <-] <-. - move=> j As cAs /= IH [[x xP] xargs] [y yargs] /= b /IH. by case=> /andP [-> /xP <-] <-. Qed. End EqType. Definition pack (T : Type) := [infer indType of T with Equality.sort as sT n sorts D cD in cast (fun A => Equality.mixin_of A) (Ind.idxE sT)^-1 (hasDecEq.Axioms_ _ (@eq_opP sT cD (Ind.idx sT)))]. End DerEqType. Notation "[ 'derive' 'nored' 'hasDecEq' 'for' T ]" := (@DerEqType.pack T _ id _ _ _ _ _ _ id _ id _ id) (at level 0) : form_scope. Ltac simpl_hasDecEq T noredax := match eval hnf in noredax with | @hasDecEq.Axioms_ _ ?op ?opP => let op := eval unfold DerEqType.eq_op, DerEqType.eq_op_branch in op in let op := eval deriving_compute in op in exact (@hasDecEq.Axioms_ T op opP) end. Ltac derive_hasDecEq T := simpl_hasDecEq T [derive nored hasDecEq for T]. Notation "[ 'derive' 'hasDecEq' 'for' T ]" := (ltac:(derive_hasDecEq T)) (at level 0) : form_scope. Ltac derive_lazy_hasDecEq T := match eval hnf in [derive nored hasDecEq for T] with | @hasDecEq.Axioms_ _ ?op ?opP => let op := eval unfold DerEqType.eq_op, DerEqType.eq_op_branch in op in let op := eval deriving_lazy in op in exact (@hasDecEq.Axioms_ T op opP) end. Notation "[ 'derive' 'lazy' 'hasDecEq' 'for' T ]" := (ltac:(derive_lazy_hasDecEq T)) (at level 0) : form_scope. #[deprecated(since="deriving 0.2.0", note="Use [derive nored hasDecEq for _] instead")] Notation "[ 'derive' 'nored' 'eqMixin' 'for' T ]" := ([derive nored hasDecEq for T]) (at level 0) : form_scope. #[deprecated(since="deriving 0.2.0", note="Use [derive hasDecEq for _] instead")] Notation "[ 'derive' 'eqMixin' 'for' T ]" := ([derive hasDecEq for T]) (at level 0) : form_scope. #[deprecated(since="deriving 0.2.0", note="Use [derive lazy hasDecEq for _] instead")] Notation "[ 'derive' 'lazy' 'eqMixin' 'for' T ]" := ([derive lazy hasDecEq for T]) (at level 0) : form_scope. arthuraa-deriving-0e084ee/theories/instances/fintype.v000066400000000000000000000142621517411663100232320ustar00rootroot00000000000000From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype order. Set SsrOldRewriteGoalsOrder. (* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) From deriving Require Import base ind tactics infer. From Coq Require Import ZArith NArith String Ascii. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Open Scope deriving_scope. Module DerFinType. Import PolyType. Section FinType. Fixpoint allP T (P : T -> bool) (xs : seq T) : all P xs -> forall i : fin (size xs), P (nth_fin i) := match xs with | [::] => fun H i => match i with end | x :: xs => match P x as b return (P x = b -> b && all P xs -> forall i : fin (size (x :: xs)), P (nth_fin i)) with | true => fun e H i => match i with | None => e | Some j => allP H j end | false => ltac:(done) end erefl end. Fixpoint all_finbP n : forall (f : fin n -> bool), all_finb f -> forall i, f i := match n with | 0 => fun f _ i => match i with end | n.+1 => fun f => match f None as b return (f None = b -> b && @all_finb n (f \o Some) -> forall i : fin n.+1, f i) with | true => fun e H i => match i with | None => e | Some j => all_finbP H j end | false => ltac:(done) end erefl end. (** It is strange to derive a finType instance for a mutually inductive type, but you never know...*) Variable (T : indEqType). Notation n := (Ind.Def.n T). Notation D := (Ind.Def.decl T). Hypothesis sT : forall i, sig_class Finite.sort (D i). Hypothesis not_rec : all_finb (fun i => all (all (negb \o @is_rec n)) (D i)). Import IndF. Definition enum_branch_aux := arity_rec _ (fun As => all (negb \o @is_rec n) As -> seq.seq (hlist' (type_of_arg T) As)) (fun _ => [:: tt]%SEQ) (fun S As rec P => allpairs Cell (Finite.enum S) (rec P)) (fun i As rec P => ltac:(done)). Definition enum_branch i (j : Ind.Cidx D i) := enum_branch_aux (hnth (sT i) j) (allP (all_finbP not_rec i) j). Definition enum_ind i := seq.flatten [seq [seq Roll (Cons args) | args <- enum_branch j] | j <- list_of_seq (enum_fin (size (D i)))]. Lemma enum_indP i : Finite.axiom (enum_ind i). Proof. move=> /= x; rewrite -(unrollK x); case: {x} (unroll x)=> j xs. rewrite /enum_ind count_flatten -!map_comp /comp /=. have <- : seq.sumn [seq j == j' : nat | j' <- list_of_seq (enum_fin (size (D i)))] = 1. rewrite /Ind.Cidx in j {xs} *. elim: (size (D i)) j => [|m IH] //= [j|] /=. by rewrite list_of_seq_map -map_comp /comp /= -(IH j) add0n. rewrite list_of_seq_map -map_comp /comp /=; congr addn; apply/eqP/natnseq0P. by elim: (enum_fin m)=> {IH} // k ks /= <-. congr seq.sumn; apply/eq_map=> j' /=; rewrite count_map. have [<- {j'}|ne] /= := altP (j =P j'). set P := preim _ _. have PP : forall ys, reflect (xs = ys) (P ys). move=> ys; rewrite /P /=; apply/(iffP idP); last by move=> ->. by move=> /eqP/Roll_inj/IndF.inj ->. move: P PP. rewrite /enum_branch. elim/arity_ind: {j} _ / (hnth _ j) xs (allP _ _)=> //=. by move=> [] _ P /(_ tt); case. move=> S As cAs IH [x xs] As_not_rec P PP. elim: (Finite.enum S) (enumP x)=> //= y ys IHys. have [-> {y} [e]|ne] := altP (y =P x). rewrite count_cat count_map (IH xs); last first. by move=> zs; apply/(iffP (PP (x ::: zs))) => [[<-]|->]. congr succn. elim: ys e {IHys} => //= y ys; case: (altP eqP) => //= ne H /H. rewrite count_cat => ->; rewrite addn0. elim: (enum_branch_aux _ _)=> //= zs e ->; rewrite addn0. apply/eqP; rewrite eqb0; apply/negP=> /PP [] /esym/eqP. by rewrite (negbTE ne). rewrite count_cat; move=> /IHys ->; rewrite addn1; congr succn. elim: (enum_branch_aux _ _) {IHys}=> //= zs e ->; rewrite addn0. apply/eqP; rewrite eqb0; apply/negP=> /PP [] /esym/eqP. by rewrite (negbTE ne). set P := preim _ _. rewrite (@eq_count _ _ pred0) ?count_pred0 //. move=> ys /=; apply/negbTE; apply: contra ne. by move=> /eqP/Roll_inj/(congr1 (@constr _ _ _ i)) /= ->. Qed. End FinType. Definition pack (T : Type) := [infer indType of T with Finite.sort as sT n sorts D cD in fun (Ts : lift_class Equality.sort n) => fun & phant_id sorts (untag_sort Ts) => fun T_count & phant_id (lift_class_proj Equality.class Ts) T_count => let T_ind_count := @IndEqType _ _ _ T_count sT in fun cD' & phant_id cD cD' => fun (not_rec : all_finb (fun i => all (all (negb \o @is_rec n)) (D i))) => isFinite.Build _ (@enum_indP T_ind_count cD' not_rec (Ind.idx sT))]. End DerFinType. (** By default, the derived enumeration of a finite type is kept unnormalized, since it is not used much -- indeed, [Finite.enum] is even kept opaque. You can override this behavior by using the [[derive red finMixin for T]] variant below. *) Notation "[ 'derive' 'isFinite' 'for' T ]" := (@DerFinType.pack T _ id _ _ _ _ _ _ id _ id _ id _ id _ id _ id erefl : isFinite T%type ) (at level 0) : form_scope. Ltac derive_red_isFinite T := match eval hnf in [derive isFinite for T] with | @isFinite.Axioms_ ?T' ?eqP ?enum ?enumP=> let enum := eval unfold DerFinType.enum_ind, DerFinType.enum_branch, DerFinType.enum_branch_aux, DerFinType.allP, DerFinType.all_finbP, flatten, allpairs, foldr, map, cat in enum in let enum := eval deriving_compute in enum in exact (@isFinite.Build T eqP enum enumP) end. Notation "[ 'derive' 'red' 'isFinite' 'for' T ]" := (ltac:(derive_red_isFinite T)) (at level 0, format "[ 'derive' 'red' 'isFinite' 'for' T ]") : form_scope. #[deprecated(since="deriving 0.2.0", note="Use [derive isFinite for _]")] Notation "[ 'derive' 'finMixin' 'for' T ]" := ([derive isFinite for T]) (at level 0) : form_scope. #[deprecated(since="deriving 0.2.0", note="Use [derive red isFinite for _] instead")] Notation "[ 'derive' 'red' 'finMixin' 'for' T ]" := ([derive red isFinite for T]) (at level 0) : form_scope. arthuraa-deriving-0e084ee/theories/instances/order.v000066400000000000000000000205621517411663100226670ustar00rootroot00000000000000From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype order. Set SsrOldRewriteGoalsOrder. (* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) From deriving Require Import base ind tactics infer compat. From Coq Require Import ZArith NArith String Ascii. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Open Scope deriving_scope. Module DerOrderType. Section DerOrderType. Import Order.Total Order.Theory. Record packedOrderType := Pack { disp : Order.disp_t; sort : orderType disp; }. Section Def. Variable (T : indChoiceType). Notation n := (Ind.Def.n T). Notation D := (Ind.Def.decl T). Notation arg_class := (arg_class sort). Notation arg_inst := (arg_inst n sort). Notation arity_inst := (arity_inst n sort). Notation sig_inst := (sig_inst n sort). Notation decl_inst := (decl_inst n sort). Variable (sT : forall i, sig_class sort (D i)). Import IndF. Definition le_branch As (cAs : hlist' arg_class As) : hlist' (type_of_arg (T *F (fun i => T i -> bool))) As -> hlist' (type_of_arg T) As -> bool := @arity_rec _ _ _ (fun a => hlist' (type_of_arg (T *F (fun i => T i -> bool))) a -> hlist' (type_of_arg T) a -> bool) (fun _ _ => true) (fun R As rec x y => if x.(hd) == y.(hd) then rec x.(tl) y.(tl) else (x.(hd) <= y.(hd))%O) (fun j As rec x y => if x.(hd).1 == y.(hd) then rec x.(tl) y.(tl) else x.(hd).2 y.(hd)) As cAs. Definition le : forall i, T i -> T i -> bool := rec (fun i args1 => case (fun args2 => match leq_fin (constr args2) (constr args1) with | inl e => le_branch (hnth (sT i) (constr args1)) (args args1) (cast (hlist' (type_of_arg T) \o @nth_fin _ _) e (args args2)) | inr b => ~~ b end)). Lemma refl i : reflexive (@le i). Proof. elim/indP: i / => i [j args]. rewrite /le recE /= -/le caseE leq_finii /=. elim/arity_ind: {j} _ / (hnth _ _) args=> [[]|R As cAs IH|j As cAs IH] //=. case=> [x args]; rewrite /= eqxx; exact: IH. by case=> [[x xP] args] /=; rewrite eqxx; exact: IH. Qed. Lemma anti i : antisymmetric (@le i). Proof. elim/indP: i / => i [xi xargs] y. rewrite -[y]unrollK; case: {y} (unroll _)=> [yi yargs]. rewrite /le !recE -/le /= !caseE /=. case ie: (leq_fin yi xi) (leq_nat_of_fin yi xi)=> [e|b]. case: xi / e {ie} xargs=> xargs _ /=; rewrite leq_finii /= => h. congr (Roll (Cons _))=> /=. elim/arity_ind: {yi} (nth_fin yi) / (hnth _ _) xargs yargs h => [[] []|R As cAs IH|j As cAs IH] //=. case=> [x xargs] [y yargs] /=. rewrite eq_sym; case: (altP (_ =P _))=> [-> /IH <-|yx] //. by move=> /le_anti e; rewrite e eqxx in yx. case=> [[x xP] xargs] [y yargs] /=. rewrite eq_sym; case: (altP (_ =P _))=> [-> /IH <-|yx /xP e] //. by rewrite e eqxx in yx. case: (leq_fin xi yi) (leq_nat_of_fin xi yi)=> [e|b']. by rewrite e leq_finii in ie. move=> <- <-. have ne: nat_of_fin yi != nat_of_fin xi. by apply/eqP=> /nat_of_fin_inj e; rewrite e leq_finii in ie. by case: ltngtP ne. Qed. Lemma trans i : transitive (@le i). Proof. move=> y x z; elim/indP: i / x y z => i [xi xargs] y z. rewrite -[y]unrollK -[z]unrollK. move: (unroll y) (unroll z)=> {y z} [yi yargs] [zi zargs]. rewrite /le !recE /= -/le !caseE /=. case: (leq_fin yi xi) (leq_nat_of_fin yi xi)=> [e _|b] //. case: xi / e xargs=> /= xargs. case: (leq_fin zi yi) (leq_nat_of_fin zi yi)=> [e _|b] //. case: yi / e xargs yargs => xargs yargs /=. elim/arity_ind: {zi} _ / (hnth _ _) xargs yargs zargs => [//|R|j] As cAs IH /=. case=> [x xargs] [y yargs] [z zargs] /=. case: (altP (_ =P _)) => [<-|xy]. case: ifP=> // /eqP _; exact: IH. case: (altP (_ =P _)) => [<-|yz]; first by rewrite (negbTE xy). case: (altP (_ =P _)) => [<-|xz]; last exact: le_trans. move=> c1 c2; suffices e: x = y by rewrite e eqxx in xy. by have /andP/le_anti := conj c1 c2. case=> [[x xP] xargs] [y yargs] [z zargs] /=. case: (altP (x =P y))=> [<-|xy]. case: (altP (x =P z))=> [_|//]; exact: IH. case: (altP (x =P z))=> [<-|yz]. rewrite eq_sym (negbTE xy)=> le1 le2. suffices e : x = y by rewrite e eqxx in xy. by apply: anti; rewrite le1. case: (altP (_ =P _))=> [<-|_] //; exact: xP. move=> <- {b} ei. case: (leq_fin zi yi) (leq_nat_of_fin zi yi)=> [e _|_ <-]. case: yi / e yargs ei=> /= yargs. by rewrite leq_nat_of_fin; case: (leq_fin zi xi). case: (leq_fin zi xi) (leq_nat_of_fin zi xi)=> [e|_ <-]. by case: xi / e ei xargs; rewrite -ltnNge => /ltnW ->. move: ei; rewrite -!ltnNge; exact: ltn_trans. Qed. Lemma total i : total (@le i). Proof. elim/indP: i / => i [xi xargs] y. rewrite -[y]unrollK; case: {y} (unroll _)=> [yi yargs]. rewrite /le !recE /= -/le !caseE /= (leq_fin_swap xi yi). case: (leq_fin yi xi)=> [e|[] //]. case: xi / e xargs=> /= xargs. elim/arity_ind: {yi} _ / (hnth _ _) xargs yargs=> [[] []|R|j] //= As cAs IH. case=> [x xargs] [y yargs] /=. rewrite eq_sym; case: (altP eqP)=> [{y} _|]; first exact: IH. by rewrite le_total. case=> /= [[x xP] xargs] [y yargs] /=. by rewrite eq_sym; case: (altP eqP)=> ?; [apply: IH|apply: xP]. Qed. Definition ind_isOrder i := Eval unfold Order.isOrder.phant_Build in Order.isOrder.Build Order.default_display (T i) (fun _ _ => erefl) (fun _ _ => erefl) (fun _ _ => erefl) (@anti i) (@trans i) (@total i). End Def. End DerOrderType. Definition pack (T : Type) := [infer indType of T with sort as sT n Ts' D cD in fun (Ts : lift_class Choice.sort n) => fun & phant_id Ts' (untag_sort Ts) => fun T_choice & phant_id (lift_class_proj Choice.class Ts) T_choice => let T_ind_choice := @IndChoiceType _ _ _ T_choice sT in fun cD' & phant_id cD cD' => @ind_isOrder T_ind_choice cD' (Ind.idx sT)]. End DerOrderType. Canonical packOrderType disp (T : orderType disp) := DerOrderType.Pack T. Notation "[ 'derive' 'nored' 'isOrder' 'for' T ]" := (@DerOrderType.pack T%type _ id _ _ _ _ _ _ id _ id _ id _ id _ id _ id : Order.isOrder Order.default_display T%type ) (at level 0) : form_scope. (* FIXME: Axioms_ is an internal function *) Ltac simpl_isOrder T noredmixin := let mixin := eval hnf in noredmixin in let mixin := eval unfold DerOrderType.pack, DerOrderType.ind_isOrder in mixin in match mixin with | @Order.isOrder.Axioms_ ?d ?T' ?choice_m ?eq_m ?le ?lt ?meet ?join _ _ _ ?anti ?trans ?total => let le := eval unfold DerOrderType.le, DerOrderType.le_branch in le in let le := eval deriving_compute in le in exact (@Order.isOrder.Axioms_ d T choice_m eq_m le _ _ _ (fun _ _ => erefl) (fun _ _ => erefl) (fun _ _ => erefl) anti trans total) end. Ltac derive_isOrder T := simpl_isOrder T [derive nored isOrder for T]. Notation "[ 'derive' 'isOrder' 'for' T ]" := (ltac:(derive_isOrder T)) (at level 0, format "[ 'derive' 'isOrder' 'for' T ]") : form_scope. (* FIXME: Axioms_ is an internal function *) Ltac derive_lazy_isOrder T := let mixin := constr:([derive nored isOrder for T]) in let mixin := eval unfold DerOrderType.pack, DerOrderType.ind_isOrder in mixin in match mixin with | @Order.isOrder.Axioms_ ?d ?T' ?choice_m ?eq_m ?le ?lt ?meet ?join _ _ _ ?anti ?trans ?total => let le := eval unfold DerOrderType.le, DerOrderType.le_branch in le in let le := eval deriving_lazy in le in exact (@Order.isOrder.Axioms_ d T choice_m eq_m le _ meet join (fun _ _ => erefl) (fun _ _ => erefl) (fun _ _ => erefl) anti trans total) end. Notation "[ 'derive' 'lazy' 'isOrder' 'for' T ]" := (ltac:(derive_lazy_isOrder T)) (at level 0) : form_scope. #[deprecated(since="deriving 0.2.0", note="Use [derive nored isOrder for _] instead")] Notation "[ 'derive' 'nored' 'orderMixin' 'for' T ]" := ([derive nored isOrder for T]) (at level 0) : form_scope. #[deprecated(since="deriving 0.2.0", note="Use [derive isOrder for _] instead")] Notation "[ 'derive' 'orderMixin' 'for' T ]" := ([derive isOrder for T]) (at level 0) : form_scope. #[deprecated(since="deriving 0.2.0", note="Use [derive lazy isOrder for _] instead")] Notation "[ 'derive' 'lazy' 'orderMixin' 'for' T ]" := ([derive lazy isOrder for T]) (at level 0) : form_scope. arthuraa-deriving-0e084ee/theories/instances/tree_of_ind.v000066400000000000000000000100431517411663100240220ustar00rootroot00000000000000From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype order. Set SsrOldRewriteGoalsOrder. (* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *) From deriving Require Import base ind tactics infer. From Coq Require Import ZArith NArith String Ascii. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Open Scope deriving_scope. Section TreeOfInd. Variables (T : indDef). Notation n := (Ind.Def.n T). Let D := Ind.Def.decl T. Import GenTree. Import PolyType. Import IndF. Definition ind_arg := hsum (fun i => hsum' (hsum' (type_of_arg (fun=> void))) (D i)). Definition mk_ind_arg i (j : Ind.Cidx D i) (k : fin (size (nth_fin j))) : type_of_arg (fun=> void) (nth_fin k) -> ind_arg := fun x => hin (hin (hin x)). Definition proj_ind_arg i (j : Ind.Cidx D i) (k : fin (size (nth_fin j))) (x : ind_arg) : option (type_of_arg (fun=> void) (nth_fin k)) := if hproj i x is Some x then if hproj j x is Some x then hproj k x else None else None. Lemma mk_ind_argK i j k : pcancel (@mk_ind_arg i j k) (@proj_ind_arg i j k). Proof. by move=> x; rewrite /proj_ind_arg !hinK. Qed. Let wrap i (j : Ind.Cidx D i) (k : fin (size (nth_fin j))) : type_of_arg (fun=> tree ind_arg) (nth_fin k) -> tree ind_arg := match nth_fin k as A return (type_of_arg (fun=> void) A -> ind_arg) -> type_of_arg (fun=> tree ind_arg) A -> tree ind_arg with | NonRec R => fun c x => Leaf (c x) | Rec i' => fun c x => x end (@mk_ind_arg i j k). Definition tree_of_coq_ind : forall i, T i -> tree ind_arg := rec (fun i x => let j := constr x in Node (nat_of_fin j) (list_of_seq (seq_of_hlist (@wrap i j) (hmap' (type_of_arg_map (fun=> snd)) (args x))))). Fixpoint coq_ind_of_tree i (x : tree ind_arg) : option (T i) := match x with | Leaf _ => None | Node c xs => if fin_of_nat (size (D i)) c isn't Some j then None else let xs := seq_of_list [seq (t, coq_ind_of_tree^~ t) | t <- xs] in if hlist_of_seq (fun k ts => match nth_fin k as A return (ind_arg -> option (type_of_arg (fun=> void) A)) -> option (type_of_arg T A) with | NonRec R => fun f => if ts.1 is Leaf x then f x else None | Rec i' => fun _ => ts.2 i' end (@proj_ind_arg i j k)) xs is Some args then Some (Roll (Cons args)) else None end. Lemma tree_of_coq_indK i : pcancel (@tree_of_coq_ind i) (@coq_ind_of_tree i). Proof. elim/indP: i / => i [j xs]. rewrite /tree_of_coq_ind recE /= -/tree_of_coq_ind. rewrite nat_of_finK /hmap' !hmap_comp /=. set xs' := hlist_of_seq _ _. suffices -> : xs' = Some (hmap' (type_of_arg_map (fun=> tag)) xs) by []. rewrite {}/xs' seq_of_list_map list_of_seqK hlist_of_seq_map /= /wrap. move: (@mk_ind_arg i j) (@proj_ind_arg i j) (@mk_ind_argK i j). elim: {j} (nth_fin j) xs=> //= - [S|i'] As IH /= xs C p CK. by rewrite CK IH //= => j x; rewrite CK. case: xs=> [[x xP] xs] /=; rewrite xP IH //. by move=> j ?; rewrite CK. Qed. End TreeOfInd. Definition pack_tree_of_indK := fun (T : Type) => fun (sT_ind : indType) & phant_id (Ind.sort sT_ind) T => @tree_of_coq_indK sT_ind (Ind.idx sT_ind). Notation "[ 'derive' 'hasChoice' 'for' T ]" := (Choice.copy T%type (pcan_type (@pack_tree_of_indK T _ id))) (at level 0, format "[ 'derive' 'hasChoice' 'for' T ]") : form_scope. Notation "[ 'derive' 'isCountable' 'for' T ]" := (Countable.copy T%type (pcan_type (@pack_tree_of_indK T _ id))) (at level 0, format "[ 'derive' 'isCountable' 'for' T ]") : form_scope. #[deprecated(since="deriving 0.2.0", note="Use [derive hasChoice for _] instead")] Notation "[ 'derive' 'choiceMixin' 'for' T ]" := ([derive hasChoice for T]) (at level 0) : form_scope. #[deprecated(since="deriving 0.2.0", note="Use [derive isCountable for _] instead")] Notation "[ 'derive' 'countMixin' 'for' T ]" := ([derive isCountable for T]) (at level 0) : form_scope.