pax_global_header00006660000000000000000000000064147234564640014531gustar00rootroot0000000000000052 comment=9dcb5de11b26afa8c14a137f164413a61612a53d deriving-0.2.1/000077500000000000000000000000001472345646400133405ustar00rootroot00000000000000deriving-0.2.1/.circleci/000077500000000000000000000000001472345646400151735ustar00rootroot00000000000000deriving-0.2.1/.circleci/config.yml000066400000000000000000000054461472345646400171740ustar00rootroot00000000000000# Use the latest 2.1 version of CircleCI pipeline process engine. See: https://circleci.com/docs/2.0/configuration-reference version: 2.1 # Use a package of configuration called an orb. defaults: &defaults environment: OPAMJOBS: 2 OPAMVERBOSE: 1 OPAMYES: true TERM: xterm commands: startup: steps: - checkout prepare: parameters: mathcomp-version: type: string default: dev steps: - run: name: Install dependencies command: | opam repo add coq-extra-dev https://coq.inria.fr/opam/extra-dev opam update opam pin add coq-mathcomp-ssreflect \ --kind=version << parameters.mathcomp-version >> opam install --deps-only . set-jobs: steps: - run: name: Set number of jobs command: | opam var --global jobs=1 build: steps: - run: name: Building deriving command: | opam var jobs opam install --with-test . jobs: coq-8-17-mathcomp-2-0-0: <<: *defaults steps: - startup - prepare: mathcomp-version: '2.0.0' - build docker: - image: coqorg/coq:8.17 resource_class: 'large' coq-8-17-mathcomp-2-2-0: <<: *defaults steps: - startup - prepare: mathcomp-version: '2.2.0' - build docker: - image: coqorg/coq:8.17 resource_class: 'large' coq-8-18-mathcomp-2-0-0: <<: *defaults steps: - startup - prepare: mathcomp-version: '2.0.0' - build docker: - image: coqorg/coq:8.18 resource_class: 'large' coq-8-18-mathcomp-dev: <<: *defaults steps: - startup - prepare: mathcomp-version: 'dev' - build docker: - image: coqorg/coq:8.18 resource_class: 'large' coq-8-19-mathcomp-2-2-0: <<: *defaults steps: - startup - prepare: mathcomp-version: '2.2.0' - build docker: - image: coqorg/coq:8.19 resource_class: 'large' coq-8-19-mathcomp-2-3-0: <<: *defaults steps: - startup - prepare: mathcomp-version: '2.3.0' - build docker: - image: coqorg/coq:8.19 resource_class: 'large' coq-8-19-mathcomp-dev: <<: *defaults steps: - startup - prepare: mathcomp-version: 'dev' - build docker: - image: coqorg/coq:8.19 resource_class: 'large' coq-dev: <<: *defaults steps: - startup - prepare: mathcomp-version: 'dev' - build docker: - image: coqorg/coq:dev resource_class: 'large' workflows: build: jobs: - coq-8-17-mathcomp-2-0-0 - coq-8-17-mathcomp-2-2-0 - coq-8-18-mathcomp-2-0-0 - coq-8-18-mathcomp-dev - coq-8-19-mathcomp-2-2-0 - coq-8-19-mathcomp-2-3-0 - coq-8-19-mathcomp-dev - coq-dev deriving-0.2.1/.gitignore000066400000000000000000000002361472345646400153310ustar00rootroot00000000000000*.vo *.vok *.vos *.glob *.d *.aux CoqMakefile CoqMakefile.conf theories/tactics.v .dir-locals.el .direnv .envrc make_tactics make_tactics.cmo make_tactics.cmideriving-0.2.1/CHANGELOG.md000066400000000000000000000034031472345646400151510ustar00rootroot00000000000000# 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.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.1...HEAD [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 deriving-0.2.1/CoqMakefile.local000066400000000000000000000013261472345646400165360ustar00rootroot00000000000000TESTVFILES=$(wildcard tests/*.v) TESTVOFILES=$(TESTVFILES:.v=.vo) UNFOLDFILES = theories/ind.v theories/base.v 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: deriving-0.2.1/LICENSE000066400000000000000000000020501472345646400143420ustar00rootroot00000000000000Copyright 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. deriving-0.2.1/Makefile000066400000000000000000000013261472345646400150020ustar00rootroot00000000000000# 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 deriving-0.2.1/README.md000066400000000000000000000070421472345646400146220ustar00rootroot00000000000000# Deriving ─ Generic instances for Coq inductive types [![arthuraa](https://circleci.com/gh/arthuraa/deriving.svg?style=shield)](https://circleci.com/gh/arthuraa/deriving/tree/master) 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 - Coq 8.17 -- 8.19 - `coq-mathcomp-ssreflect` 2.0.0 -- 2.3.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 deriving-0.2.1/TODO.org000066400000000000000000000006621472345646400146220ustar00rootroot00000000000000* 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 deriving-0.2.1/_CoqProject000066400000000000000000000007111472345646400154720ustar00rootroot00000000000000-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 deriving-0.2.1/coq-deriving.opam000066400000000000000000000020121472345646400166000ustar00rootroot00000000000000opam-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" & < "8.20~") | (= "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" } deriving-0.2.1/flake.lock000066400000000000000000000026361472345646400153030ustar00rootroot00000000000000{ "nodes": { "flake-utils": { "inputs": { "systems": "systems" }, "locked": { "lastModified": 1694529238, "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=", "owner": "numtide", "repo": "flake-utils", "rev": "ff7b65b44d01cf9ba6a71320833626af21126384", "type": "github" }, "original": { "owner": "numtide", "repo": "flake-utils", "type": "github" } }, "nixpkgs": { "locked": { "lastModified": 1733064805, "narHash": "sha256-7NbtSLfZO0q7MXPl5hzA0sbVJt6pWxxtGWbaVUDDmjs=", "owner": "NixOS", "repo": "nixpkgs", "rev": "31d66ae40417bb13765b0ad75dd200400e98de84", "type": "github" }, "original": { "id": "nixpkgs", "type": "indirect" } }, "root": { "inputs": { "flake-utils": "flake-utils", "nixpkgs": "nixpkgs" } }, "systems": { "locked": { "lastModified": 1681028828, "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", "owner": "nix-systems", "repo": "default", "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", "type": "github" }, "original": { "owner": "nix-systems", "repo": "default", "type": "github" } } }, "root": "root", "version": 7 } deriving-0.2.1/flake.nix000066400000000000000000000021431472345646400151420ustar00rootroot00000000000000{ 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-utils.url = "github:numtide/flake-utils"; outputs = { self, nixpkgs, flake-utils }: flake-utils.lib.eachDefaultSystem (system: let pkgs = nixpkgs.legacyPackages.${system}; in rec { packages = rec { coq = pkgs.coq_8_19; coqPackages = pkgs.coqPackages_8_19.overrideScope (self: super: { mathcomp = super.mathcomp.override { version = "2.2.0"; }; deriving = super.deriving.overrideAttrs { version = "0.2.1"; src = ./.; }; }); ocaml = pkgs.ocaml; }; devShell = pkgs.mkShell { packages = with packages; [ coq coqPackages.mathcomp.ssreflect ocaml ]; }; } ); } deriving-0.2.1/make_tactics.ml000066400000000000000000000016671472345646400163330ustar00rootroot00000000000000let 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 deriving-0.2.1/tests/000077500000000000000000000000001472345646400145025ustar00rootroot00000000000000deriving-0.2.1/tests/mutual.v000066400000000000000000000042451472345646400162050ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype finset order. 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. (* FIXME: Why aren't the recursors being simplified away here? *) 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. (* FIXME: Why aren't the recursors being simplified away here? *) 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. deriving-0.2.1/tests/nested.v000066400000000000000000000033571472345646400161630ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype finset order. 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. deriving-0.2.1/tests/records.v000066400000000000000000000013011472345646400163250ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import all_ssreflect. From deriving Require Import deriving. 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. deriving-0.2.1/tests/syntax.v000066400000000000000000000122351472345646400162220ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype finset order. 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. deriving-0.2.1/tests/three.v000066400000000000000000000017021472345646400160000ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype finset order. 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. deriving-0.2.1/tests/tree.v000066400000000000000000000017631472345646400156370ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype finset order. 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. deriving-0.2.1/theories/000077500000000000000000000000001472345646400151625ustar00rootroot00000000000000deriving-0.2.1/theories/base.v000066400000000000000000001110771472345646400162720ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype order. 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. deriving-0.2.1/theories/compat.v000066400000000000000000000011271472345646400166350ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype order. 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. deriving-0.2.1/theories/deriving.v000066400000000000000000000001011472345646400171500ustar00rootroot00000000000000From deriving Require Export ind tactics infer instances compat. deriving-0.2.1/theories/ind.v000066400000000000000000000776541472345646400161460ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype. 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) of 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 of 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. deriving-0.2.1/theories/infer.v000066400000000000000000000047351472345646400164650ustar00rootroot00000000000000From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype order. 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. 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 := eval hnf in rec.1 in let rec2 := eval hnf in rec.2 in split; [unwind_recursor rec1|unwind_recursor rec2] | |- forall x, _ => let rec' := eval hnf in 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. deriving-0.2.1/theories/instances.v000066400000000000000000000107751472345646400173520ustar00rootroot00000000000000From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype order. 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. deriving-0.2.1/theories/instances/000077500000000000000000000000001472345646400171515ustar00rootroot00000000000000deriving-0.2.1/theories/instances/eqtype.v000066400000000000000000000105421472345646400206510ustar00rootroot00000000000000From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype order. 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 derive_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_compute in op in exact (@hasDecEq.Axioms_ T op opP) end. 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. deriving-0.2.1/theories/instances/fintype.v000066400000000000000000000140571472345646400210250ustar00rootroot00000000000000From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype order. 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. deriving-0.2.1/theories/instances/order.v000066400000000000000000000202521472345646400204540ustar00rootroot00000000000000From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype order. 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 derive_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_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. 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. deriving-0.2.1/theories/instances/tree_of_ind.v000066400000000000000000000076401472345646400216240ustar00rootroot00000000000000From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype order. 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.