├── .gitignore ├── .gitlab-ci.yml ├── COPYING ├── Dockerfile ├── Makefile ├── README.md ├── _CoqProject ├── agda-rr ├── cast-cic.agda └── ett-rr.agda ├── opam ├── src ├── ePlugin.ml ├── ePlugin.mli ├── eTranslate.ml ├── eTranslate.mli ├── eUtil.ml ├── eUtil.mli ├── exception.mlpack └── g_exception.ml4 ├── tests ├── Makefile └── list_theorem.v └── theories └── Effects.v /.gitignore: -------------------------------------------------------------------------------- 1 | # -*- mode: gitignore; -*- 2 | *~ 3 | \#*\# 4 | 5 | *.aux 6 | *.vo 7 | *.glob 8 | *.v.d 9 | *.cmo 10 | *.cmx 11 | *.cmxs 12 | *.o 13 | *.cmi 14 | *.cmt 15 | *.cmti 16 | *.cma 17 | *.cmxa 18 | *.d 19 | *.a 20 | *.log 21 | Makefile.coq 22 | Makefile.coq.conf 23 | *.agdai -------------------------------------------------------------------------------- /.gitlab-ci.yml: -------------------------------------------------------------------------------- 1 | image: docker:stable 2 | services: 3 | - docker:dind 4 | 5 | variables: 6 | IMAGE: "$CI_REGISTRY_IMAGE:$CI_COMMIT_SHA" 7 | 8 | docker: 9 | script: 10 | - docker login -u gitlab-ci-token -p "$CI_JOB_TOKEN" "$CI_REGISTRY" 11 | - docker build --pull -t "$IMAGE" . 12 | - docker push "$IMAGE" 13 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE 2 | Version 2, December 2004 3 | 4 | Copyright (C) 2004 Sam Hocevar 5 | 6 | Everyone is permitted to copy and distribute verbatim or modified 7 | copies of this license document, and changing it is allowed as long 8 | as the name is changed. 9 | 10 | DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE 11 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 12 | 13 | 0. You just DO WHAT THE FUCK YOU WANT TO. 14 | 15 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM coqorg/coq:8.8 2 | 3 | WORKDIR /home/coq/exceptional-tt 4 | 5 | COPY . . 6 | 7 | RUN ["/bin/bash", "--login", "-c", "set -x \ 8 | && opam update \ 9 | && opam pin -y -n add coq-exceptional-tt . \ 10 | && opam install -y -v -j $NJOBS coq-exceptional-tt \ 11 | && opam list \ 12 | && opam clean -a -c -s --logs"] 13 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ifeq "$(COQBIN)" "" 2 | COQBIN=$(dir $(shell which coqtop))/ 3 | endif 4 | 5 | %: Makefile.coq 6 | 7 | Makefile.coq: _CoqProject 8 | $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq 9 | 10 | tests: all 11 | @$(MAKE) -C tests -s clean 12 | @$(MAKE) -C tests -s all 13 | 14 | -include Makefile.coq 15 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # A Reasonably Exceptional Type Theory in Coq 2 | 3 | This plugin allows to automatically translate Coq terms in such a way that 4 | they can now use exceptions in a controlled way. This can be useful for 5 | programming, e.g. to allow failure locally and prove after the fact that 6 | assuming a few properties the translated term does not fail, without endangering 7 | reduction nor polluting the type signature as a monadic translation would do. 8 | 9 | A draft paper describing the translation can be found 10 | [here](https://www.xn--pdrot-bsa.fr/articles/reasonably-exceptional.pdf). 11 | 12 | # Compilation 13 | 14 | This requires Coq 8.8. If the `COQBIN` variable is correctly set, a `make` 15 | invokation should be enough. 16 | 17 | Alternatively, one can install this plugin through OPAM. Assuming the Coq 18 | repositories are available (see [the official documentation](https://github.com/coq/opam-coq-archive)), 19 | it is enough to do the following. 20 | 21 | ``` 22 | opam pin add coq-exceptional-tt https://github.com/CoqHott/exceptional-tt.git 23 | opam install coq-exceptional-tt 24 | ``` 25 | 26 | # Use of the plugin 27 | 28 | The plugin adds new vernacular commands which we describe below. 29 | 30 | ## Effect Translate 31 | 32 | ``` 33 | Effect Translate GLOBAL [using GLOBAL]. 34 | ``` 35 | 36 | This command translates the given global definition into the type theory with 37 | exception. The resulting term is parameterized over the type of exceptions used. 38 | It can be restricted to a particular exception type by adding the `using` 39 | clause. 40 | 41 | The resulting theory features exceptions in the Type hierarchy, which also means 42 | it is inconsistent in general. As such, Type-living terms should be used to 43 | write effectful, potentially exception raising-programs 44 | 45 | Conversely, the Prop-restricted theory is guaranteed to be exception-free and 46 | thus consistent. This is why Prop-living properties should be used to denote 47 | safe logical properties over the effectful programs. 48 | 49 | ## Effect Implementation 50 | 51 | ``` 52 | Effect Definition IDENT : TYPE [using GLOBAL]. 53 | ``` 54 | 55 | This command opens the proof mode and ask the user to provide a proof of 56 | TYPE in the effectful translation. When the proof is complete, the axiom IDENT 57 | is added to Coq, a term IDENTᵉ is defined with the content of the proof, and 58 | the axiom IDENT is registered to be mapped to IDENTᵉ through the effectful 59 | translation. 60 | 61 | # Examples 62 | 63 | The repository contains a few examples in the `tests` folder. 64 | 65 | # Caveat 66 | 67 | Sections are not handled. 68 | 69 | Some programs involving complex CIC features not part of the RETT source theory 70 | will fail to be translated with either anomalies or type errors. For instance, 71 | the translation does not handle primitive records nor universe polymorphism yet, 72 | and notoriously tricky Prop-Type interactions like template polymorphism will 73 | break the translation. 74 | 75 | # License 76 | 77 | This software is licensed under the WTFPL 2.0. 78 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -R theories/ Weakly 2 | -I src/ 3 | 4 | src/eUtil.ml 5 | src/eUtil.mli 6 | src/eTranslate.ml 7 | src/eTranslate.mli 8 | src/ePlugin.ml 9 | src/ePlugin.mli 10 | src/g_exception.ml4 11 | src/exception.mlpack 12 | 13 | theories/Effects.v 14 | -------------------------------------------------------------------------------- /agda-rr/cast-cic.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting --prop --confluence-check --cumulativity #-} 2 | 3 | open import Agda.Primitive 4 | open import Agda.Builtin.Bool 5 | open import Agda.Builtin.Nat 6 | open import Agda.Builtin.List 7 | open import Agda.Builtin.Equality 8 | open import Agda.Builtin.Equality.Rewrite 9 | open import Agda.Builtin.Sigma 10 | open import Agda.Builtin.Unit 11 | open import Data.Vec.Base 12 | open import Data.Bool 13 | open import Data.Sum 14 | open import Data.Product using (_×_) 15 | open import ett-rr 16 | 17 | {- Axiomatisation of the Cast calculus -} 18 | 19 | {- diagonal cases -} 20 | 21 | postulate cast : (A : Set ℓ) (B : Set ℓ₁) → A → B 22 | 23 | postulate cast-set : (A : Set ℓ) → cast (Set ℓ) (Set ℓ) A ≡ A 24 | 25 | {-# REWRITE cast-set #-} 26 | 27 | postulate cast-prop : (A : Prop ℓ) → cast (Prop ℓ) (Prop ℓ) A ≡ A 28 | 29 | {-# REWRITE cast-prop #-} 30 | 31 | postulate cast-Pi : (A : Set ℓ) (B : A → Set ℓ₁) (A' : Set ℓ₂) (B' : A' → Set ℓ₃) (f : (a : A) → B a) → 32 | cast ((a : A) → B a) ((a' : A') → B' a') f ≡ 33 | λ (a' : A') → cast _ _ (f (cast A' A a')) 34 | 35 | {-# REWRITE cast-Pi #-} 36 | 37 | postulate cast-Sigma : (A : Set ℓ) (B : A → Set ℓ₁) (A' : Set ℓ₂) (B' : A' → Set ℓ₃) (p : Σ {a = ℓ} {b = ℓ₁} A B) → 38 | cast (Σ A B) (Σ A' B') p ≡ (cast {ℓ = ℓ} {ℓ₁ = ℓ₂} A A' (p .fst) , cast (B (p .fst)) (B' (cast A A' (p .fst))) (p .snd)) 39 | 40 | {-# REWRITE cast-Sigma #-} 41 | 42 | postulate cast-Sum-inj₁ : (A A' : Set ℓ) (B B' : Set ℓ₁) (a : A) → 43 | cast (A ⊎ B) (A' ⊎ B') (inj₁ a) ≡ inj₁ (cast A A' a) 44 | 45 | postulate cast-Sum-inj₂ : (A A' : Set ℓ) (B B' : Set ℓ₁) (b : B) → 46 | cast (A ⊎ B) (A' ⊎ B') (inj₂ b) ≡ inj₂ (cast B B' b) 47 | 48 | postulate cast-Sum-raise : (A A' : Set ℓ) (B B' : Set ℓ₁) (a : A) → 49 | cast (A ⊎ B) (A' ⊎ B') (raise _) ≡ raise _ 50 | 51 | postulate cast-Sum-unk : (A A' : Set ℓ) (B B' : Set ℓ₁) (a : A) → 52 | cast (A ⊎ B) (A' ⊎ B') (unk _) ≡ unk _ 53 | 54 | {-# REWRITE cast-Sum-inj₁ #-} 55 | {-# REWRITE cast-Sum-inj₂ cast-Sum-raise cast-Sum-unk #-} 56 | 57 | postulate cast-List-nil : (A A' : Set ℓ) → 58 | cast (List A) (List A') [] ≡ [] 59 | 60 | postulate cast-List-cons : (A A' : Set ℓ) (a : A) (l : List {a = ℓ} A) → 61 | cast (List A) (List {a = ℓ} A') (a ∷ l) ≡ 62 | cast A A' a ∷ cast (List A) (List A') l 63 | 64 | postulate cast-List-raise : (A A' : Set ℓ) → 65 | cast (List A) (List A') (raise (List _)) ≡ raise (List _) 66 | postulate cast-List-unk : (A A' : Set ℓ) → 67 | cast (List A) (List A') (unk (List _)) ≡ unk (List _) 68 | 69 | {-# REWRITE cast-List-nil #-} 70 | {-# REWRITE cast-List-cons cast-List-raise cast-List-unk #-} 71 | 72 | postulate cast-Nat-zero : cast Nat Nat 0 ≡ 0 73 | 74 | postulate cast-Nat-suc : (n : Nat ) → cast Nat Nat (suc n) ≡ suc (cast _ _ n) 75 | 76 | postulate cast-Nat-raise : cast Nat Nat (raise Nat) ≡ raise Nat 77 | 78 | postulate cast-Nat-unk : cast Nat Nat (unk Nat) ≡ unk Nat 79 | 80 | {-# REWRITE cast-Nat-zero cast-Nat-suc cast-Nat-raise cast-Nat-unk #-} 81 | 82 | postulate cast-Bool-true : cast Bool Bool true ≡ true 83 | 84 | postulate cast-Bool-false : cast Bool Bool false ≡ false 85 | 86 | postulate cast-Bool-raise : cast Bool Bool (raise Bool) ≡ raise Bool 87 | 88 | postulate cast-Bool-unk : cast Bool Bool (unk Bool) ≡ unk Bool 89 | 90 | {-# REWRITE cast-Bool-true cast-Bool-false cast-Bool-raise cast-Bool-unk #-} 91 | 92 | postulate cast-Unit : cast ⊤ ⊤ tt ≡ tt 93 | {- Beware that raise ⊤ ≡ tt ≡ unk ⊤ because of definitional singleton -} 94 | postulate cast-Unit-raise : cast ⊤ ⊤ (raise ⊤) ≡ raise ⊤ 95 | postulate cast-Unit-unk : cast ⊤ ⊤ (unk ⊤) ≡ unk ⊤ 96 | 97 | {-# REWRITE cast-Unit cast-Unit-raise cast-Unit-unk #-} 98 | 99 | {- non-diagonal cases -} 100 | 101 | postulate cast-Set-bad : (A : Set (lsuc ℓ)) → cast (Set (lsuc ℓ)) (Set ℓ) A ≡ raise _ 102 | 103 | {-# REWRITE cast-Set-bad #-} 104 | 105 | postulate cast-raise : ∀ ℓ ℓ₁ → (x : raise {ℓ = lsuc ℓ} (Set ℓ)) (A : Set ℓ₁) → cast (raise {ℓ = lsuc ℓ} (Set ℓ)) A x ≡ raise _ 106 | 107 | {-# REWRITE cast-raise #-} 108 | 109 | postulate cast-Pi-Sigma : (A A' : Set ℓ) (B : A → Set ℓ₁) (B' : A' → Set ℓ₁) (f : (a : A) → B a) → 110 | cast ((a : A) → B a) (Σ {a = ℓ} {b = ℓ₁} A' B') f ≡ raise (Σ A' B') 111 | 112 | {-# REWRITE cast-Pi-Sigma #-} 113 | 114 | postulate cast-Pi-Nat : (A : Set ℓ) (B : A → Set ℓ₁) (f : (a : A) → B a) → 115 | cast ((a : A) → B a) Nat f ≡ raise Nat 116 | 117 | {-# REWRITE cast-Pi-Nat #-} 118 | 119 | -- missing many conflict rules 120 | 121 | 122 | 123 | {- Rules specific to Unk -} 124 | 125 | {- unk-cast ℓ A a is just a copy of cast A (Unk ℓ) a 126 | but we need to split it off for rewriting. 127 | Making it private so that the only closed values we can create in Unk ℓ come from cast -} 128 | private 129 | postulate unk-cast : ∀ (A : Set ℓ) → A → Unk (lsuc ℓ) 130 | 131 | postulate cast-Unk : (A : Set ℓ) (B : Set ℓ₁) (f : A) → 132 | cast (Unk (lsuc ℓ)) B (unk-cast A f) ≡ cast A B f 133 | {-# REWRITE cast-Unk #-} 134 | 135 | postulate cast-Unk-raise : ∀ ℓ → (B : Set ℓ₁) → 136 | cast (Unk ℓ) B (raise _) ≡ raise _ 137 | {-# REWRITE cast-Unk-raise #-} 138 | 139 | postulate cast-Pi-Unk : (A : Set ℓ) (B : A → Set ℓ₁) (f : (a : A) → B a) → 140 | cast ((a : A) → B a) (Unk (lsuc (ℓ ⊔ ℓ₁))) f ≡ unk-cast (Unk ℓ → Unk ℓ₁) (cast ((a : A) → B a) (Unk ℓ → Unk ℓ₁) f) 141 | 142 | 143 | {-# REWRITE cast-Pi-Unk #-} 144 | 145 | postulate cast-Pi-Unk-bad : (f : Unk ℓ → Unk ℓ₁) → 146 | cast (Unk ℓ → Unk ℓ₁) (Unk (ℓ ⊔ ℓ₁)) f ≡ raise _ 147 | 148 | {-# REWRITE cast-Pi-Unk-bad #-} 149 | 150 | postulate cast-Sigma-Unk : (A : Set ℓ) (B : A → Set ℓ₁) (x : Σ {a = ℓ} {b = ℓ₁} A B) → 151 | cast (Σ A B) (Unk (lsuc (ℓ ⊔ ℓ₁))) x ≡ unk-cast (_×_ {a = ℓ} {b = ℓ₁} (Unk ℓ) (Unk ℓ₁)) (cast (Σ A B) (Unk ℓ × Unk ℓ₁) x) 152 | 153 | {-# REWRITE cast-Sigma-Unk #-} 154 | 155 | 156 | delta : Unk ℓ → Unk ℓ 157 | delta {ℓ} x = cast (Unk ℓ) (Unk ℓ → Unk ℓ) x x 158 | 159 | omega : Unk ℓ 160 | omega {ℓ} = delta {ℓ = ℓ} (cast (Unk ℓ → Unk ℓ) (Unk ℓ) (delta {ℓ = ℓ})) 161 | 162 | foo : Unk (lsuc lzero) 163 | foo = cast (Nat → Nat → Nat) (Unk _) _+_ 164 | 165 | postulate cast-Nat-Unk : (n : Nat) → cast Nat (Unk (lsuc lzero)) n ≡ unk-cast Nat n 166 | 167 | record i (A : Set ℓ) : Set (ℓ ⊔ ℓ₁) where 168 | constructor inj 169 | field 170 | uninj : A 171 | 172 | open i public 173 | 174 | postulate cast-Nat-Unk' : (n : Nat) → cast (i {ℓ = ℓ} {ℓ₁ = ℓ₁} Nat) (Unk (lsuc ℓ)) (inj n) ≡ unk-cast Nat n 175 | 176 | postulate cast-Nat-iNat : (n : Nat) → cast Nat (i {ℓ = ℓ} {ℓ₁ = ℓ₁} Nat) n ≡ inj n 177 | 178 | {-# REWRITE cast-Nat-Unk cast-Nat-Unk' cast-Nat-iNat #-} 179 | 180 | retr : (A : Set ℓ) (a : A) → A 181 | retr {ℓ} A a = cast (Unk (lsuc ℓ)) A (cast A (Unk (lsuc ℓ)) a) 182 | 183 | retr-0 : retr {lzero} Nat 0 ≡ 0 184 | retr-0 = refl 185 | 186 | 187 | 188 | retr-arr : (A : Set ℓ) (a : A) → A 189 | retr-arr {ℓ} A = retr (A → A) (λ a → a) 190 | 191 | zero' : Nat 192 | zero' = uninj (retr-arr {lsuc lzero} (i {ℓ₁ = lsuc lzero} Nat) (inj 0)) 193 | -------------------------------------------------------------------------------- /agda-rr/ett-rr.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --rewriting --prop --confluence-check #-} 2 | 3 | open import Agda.Primitive 4 | open import Agda.Builtin.Bool 5 | open import Agda.Builtin.Nat 6 | open import Agda.Builtin.List 7 | open import Agda.Builtin.Equality 8 | open import Agda.Builtin.Equality.Rewrite 9 | open import Agda.Builtin.Sigma 10 | open import Agda.Builtin.Unit 11 | open import Data.Vec.Base 12 | open import Data.Bool 13 | open import Data.Sum 14 | 15 | variable ℓ ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Level 16 | 17 | record Top ℓ : Set ℓ where 18 | constructor ⟨⟩ 19 | 20 | 21 | {- 22 | Axiomatisation of ExTT 23 | -} 24 | 25 | postulate raise : (A : Set ℓ) → A 26 | 27 | -- we now state rewrite rules for raise 28 | 29 | postulate raise-Pi : (A : Set ℓ) (B : A → Set ℓ₁) → 30 | raise ((a : A) → B a) ≡ λ a → raise (B a) 31 | 32 | {-# REWRITE raise-Pi #-} 33 | 34 | postulate raise-Sigma : (A : Set ℓ) (B : A → Set ℓ₁) → 35 | raise (Σ A B) ≡ (raise A , raise (B (raise A))) 36 | 37 | {-# REWRITE raise-Sigma #-} 38 | 39 | nat-rec : (P : Nat → Set ℓ) (P0 : P 0) (PS : (n : Nat) → P n → P (suc n)) → (n : Nat) → P n 40 | nat-rec P P0 PS zero = P0 41 | nat-rec P P0 PS (suc n) = PS n (nat-rec P P0 PS n) 42 | 43 | postulate raise-nat-rec : (P : Nat → Set ℓ) (P0 : P 0) (PS : (n : Nat) → P n → P (suc n)) → 44 | nat-rec P P0 PS (raise Nat) ≡ raise (P (raise Nat)) 45 | 46 | {-# REWRITE raise-nat-rec #-} 47 | 48 | postulate catch-nat : (P : Nat → Set ℓ) (P0 : P 0) (PS : (n : Nat) → P n → P (suc n)) → 49 | (Praise : P (raise Nat)) → (n : Nat) → P n 50 | 51 | postulate catch-nat-zero : (P : Nat → Set ℓ) (P0 : P 0) (PS : (n : Nat) → P n → P (suc n)) → 52 | (Praise : P (raise Nat)) → catch-nat P P0 PS Praise 0 ≡ P0 53 | 54 | postulate catch-nat-suc : (P : Nat → Set ℓ) (P0 : P 0) (PS : (n : Nat) → P n → P (suc n)) → 55 | (Praise : P (raise Nat)) → (n : Nat) → 56 | catch-nat P P0 PS Praise (suc n) ≡ PS n (catch-nat P P0 PS Praise n) 57 | 58 | postulate catch-nat-raise : (P : Nat → Set ℓ) (P0 : P 0) (PS : (n : Nat) → P n → P (suc n)) → 59 | (Praise : P (raise Nat)) → catch-nat P P0 PS Praise (raise Nat) ≡ Praise 60 | 61 | {-# REWRITE catch-nat-zero #-} 62 | {-# REWRITE catch-nat-suc #-} 63 | {-# REWRITE catch-nat-raise #-} 64 | 65 | postulate raise-Top : raise (Top ℓ) ≡ ⟨⟩ 66 | 67 | {-# REWRITE raise-Top #-} 68 | 69 | postulate raise-Set : raise (Set ℓ) ≡ Top ℓ 70 | 71 | {-# REWRITE raise-Set #-} 72 | 73 | 74 | 75 | 76 | {- 77 | Axiomatisation of unk 78 | -} 79 | 80 | postulate unk : (A : Set ℓ) → A 81 | 82 | -- we now state rewrite rules for unk 83 | 84 | postulate unk-Pi : (A : Set ℓ) (B : A → Set ℓ₁) → 85 | unk ((a : A) → B a) ≡ λ a → unk (B a) 86 | 87 | {-# REWRITE unk-Pi #-} 88 | 89 | postulate unk-Sigma : (A : Set ℓ) (B : A → Set ℓ₁) → 90 | unk (Σ A B) ≡ (unk A , unk (B (unk A))) 91 | 92 | {-# REWRITE unk-Sigma #-} 93 | 94 | postulate unk-nat-rec : (P : Nat → Set ℓ) (P0 : P 0) (PS : (n : Nat) → P n → P (suc n)) → 95 | nat-rec P P0 PS (unk Nat) ≡ unk (P (unk Nat)) 96 | 97 | {-# REWRITE unk-nat-rec #-} 98 | 99 | postulate catch-unk-nat : (P : Nat → Set ℓ) (P0 : P 0) (PS : (n : Nat) → P n → P (suc n)) → 100 | (Punk : P (unk Nat)) → (n : Nat) → P n 101 | 102 | postulate catch-unk-nat-zero : (P : Nat → Set ℓ) (P0 : P 0) (PS : (n : Nat) → P n → P (suc n)) → 103 | (Punk : P (unk Nat)) → catch-unk-nat P P0 PS Punk 0 ≡ P0 104 | 105 | postulate catch-unk-nat-suc : (P : Nat → Set ℓ) (P0 : P 0) (PS : (n : Nat) → P n → P (suc n)) → 106 | (Punk : P (unk Nat)) → (n : Nat) → 107 | catch-unk-nat P P0 PS Punk (suc n) ≡ PS n (catch-unk-nat P P0 PS Punk n) 108 | 109 | postulate catch-unk-nat-unk : (P : Nat → Set ℓ) (P0 : P 0) (PS : (n : Nat) → P n → P (suc n)) → 110 | (Punk : P (unk Nat)) → catch-unk-nat P P0 PS Punk (unk Nat) ≡ Punk 111 | 112 | {-# REWRITE catch-unk-nat-zero #-} 113 | {-# REWRITE catch-unk-nat-suc #-} 114 | {-# REWRITE catch-unk-nat-unk #-} 115 | 116 | postulate unk-Top : unk (Top ℓ) ≡ ⟨⟩ 117 | 118 | {-# REWRITE unk-Top #-} 119 | 120 | Unk : ∀ ℓ → Set ℓ 121 | Unk ℓ = unk (Set ℓ) 122 | 123 | -- postulate Unk : ∀ ℓ → Set (lsuc ℓ) 124 | -- -- record Unk ℓ : Set (lsuc ℓ) where 125 | -- -- constructor box 126 | -- -- field 127 | -- -- type : Set ℓ 128 | -- -- elem : type 129 | 130 | -- postulate raise-Unk : ∀ ℓ → raise (Unk ℓ) ≡ box (raise (Set ℓ)) (raise _) 131 | 132 | -- {-# REWRITE raise-Unk #-} 133 | 134 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "coq-exceptional-tt" 3 | version: "0.1" 4 | maintainer: "Pierre-Marie Pédrot " 5 | author: "Pierre-Marie Pédrot " 6 | bug-reports: "https://github.com/CoqHott/exceptional-tt/issues" 7 | license: "WTFPL 2.0" 8 | homepage: "https://github.com/CoqHott/exceptional-tt" 9 | dev-repo: "https://github.com/CoqHott/exceptional-tt.git" 10 | build: [ 11 | [make "COQBIN=\"\"" "-j%{jobs}%"] 12 | ] 13 | install: [make "install"] 14 | remove: [make "uninstall"] 15 | depends: [ 16 | "coq" { >= "8.8" & < "8.9" } 17 | ] 18 | synopsis: "Implementation of the Reasonably Exceptional Type Theory in Coq" 19 | -------------------------------------------------------------------------------- /src/ePlugin.ml: -------------------------------------------------------------------------------- 1 | open CErrors 2 | open Pp 3 | open Util 4 | open Names 5 | open Term 6 | open Decl_kinds 7 | open Libobject 8 | open Mod_subst 9 | open Globnames 10 | 11 | (** Utilities *) 12 | 13 | let translate_name id = 14 | let id = Id.to_string id in 15 | Id.of_string (id ^ "ᵉ") 16 | 17 | (** Record of translation between globals *) 18 | 19 | type translator = ETranslate.translator 20 | 21 | let empty_translator = 22 | let open ETranslate in 23 | let refss = [ 24 | (param_cst, param_cst_e); 25 | (tm_exception, tm_exception_e); 26 | (tm_raise, tm_raise_e) 27 | ] 28 | in 29 | let map acc (s,t) = 30 | Cmap.add s (GlobGen (ConstRef t)) acc 31 | in 32 | let refss = List.fold_left map Cmap.empty refss in 33 | let inds = Mindmap.add param_mod (GlobGen param_mod_e) Mindmap.empty in 34 | let prefs = Cmap.empty in 35 | let pinds = Mindmap.empty in 36 | { 37 | ETranslate.refs = refss; 38 | inds = inds; 39 | prefs = prefs; 40 | pinds = pinds; 41 | wrefs = Cmap.empty; 42 | winds = Mindmap.empty; 43 | paramrefs = Mindmap.empty; 44 | paraminds = Mindmap.empty; 45 | } 46 | 47 | let translator : translator ref = 48 | Summary.ref ~name:"Effect Global Table" empty_translator 49 | 50 | type extension_type = 51 | | ExtEffect 52 | | ExtParam 53 | 54 | type extension = 55 | | ExtConstant of Constant.t * global_reference 56 | | ExtInductive of MutInd.t * MutInd.t 57 | | ExtParamInductive of MutInd.t * MutInd.t 58 | | ExtParamConstant of MutInd.t * global_reference 59 | 60 | type translator_obj = 61 | | ExtendEffect of extension_type * global_reference option * extension list 62 | 63 | let extend_constant exn cst gr map = match exn with 64 | | None -> Cmap.add cst (ETranslate.GlobGen gr) map 65 | | Some exn -> 66 | let old = 67 | try Cmap.find cst map 68 | with Not_found -> ETranslate.GlobImp Refmap.empty 69 | in 70 | match old with 71 | | ETranslate.GlobImp imp -> 72 | let imp = Refmap.add exn gr imp in 73 | Cmap.add cst (ETranslate.GlobImp imp) map 74 | | ETranslate.GlobGen _ -> assert false 75 | 76 | let extend_inductive exn ind nind map = match exn with 77 | | None -> Mindmap.add ind (ETranslate.GlobGen nind) map 78 | | Some exn -> 79 | let old = 80 | try Mindmap.find ind map 81 | with Not_found -> ETranslate.GlobImp Refmap.empty 82 | in 83 | match old with 84 | | ETranslate.GlobImp imp -> 85 | let imp = Refmap.add exn nind imp in 86 | Mindmap.add ind (ETranslate.GlobImp imp) map 87 | | ETranslate.GlobGen _ -> assert false 88 | 89 | let extend_translator tr knd exn l = 90 | let open ETranslate in 91 | let fold accu ext = match knd, ext with 92 | | ExtEffect, ExtConstant (cst, gr) -> 93 | { accu with refs = extend_constant exn cst gr accu.refs } 94 | | ExtEffect, ExtInductive (mind, mind') -> 95 | { accu with inds = extend_inductive exn mind mind' accu.inds } 96 | | ExtParam, ExtConstant (cst, gr) -> 97 | { accu with prefs = extend_constant exn cst gr accu.prefs } 98 | | ExtParam, ExtInductive (mind, mind') -> 99 | { accu with pinds = extend_inductive exn mind mind' accu.pinds } 100 | | _ -> accu 101 | in 102 | List.fold_left fold tr l 103 | 104 | let cache_translator (_, l) = match l with 105 | | ExtendEffect (knd, exn, l) -> 106 | translator := extend_translator !translator knd exn l 107 | 108 | let load_translator _ obj = cache_translator obj 109 | let open_translator _ obj = cache_translator obj 110 | 111 | let subst_extension subst ext = match ext with 112 | | ExtConstant (cst, gr) -> 113 | let cst' = subst_constant subst cst in 114 | let gr' = subst_global_reference subst gr in 115 | if cst' == cst && gr' == gr then ext 116 | else ExtConstant (cst', gr') 117 | | ExtInductive (smind, tmind) -> 118 | let smind' = subst_mind subst smind in 119 | let tmind' = subst_mind subst tmind in 120 | if smind' == smind && tmind' == tmind then ext 121 | else ExtInductive (smind', tmind') 122 | (** what !!! *) 123 | | ExtParamConstant (smind, gr) -> 124 | let smind' = subst_mind subst smind in 125 | let gr' = subst_global_reference subst gr in 126 | if smind' == smind && gr' == gr then ext 127 | else ExtParamConstant (smind', gr') 128 | | ExtParamInductive (smind, tmind) -> 129 | let smind' = subst_mind subst smind in 130 | let tmind' = subst_mind subst tmind in 131 | if smind' == smind && tmind' == tmind then ext 132 | else ExtParamInductive (smind', tmind') 133 | 134 | let subst_translator (subst, obj) = match obj with 135 | | ExtendEffect (knd, exn, l) -> 136 | let exn' = Option.smartmap (fun gr -> subst_global_reference subst gr) exn in 137 | let l' = List.smartmap (fun e -> subst_extension subst e) l in 138 | if exn' == exn && l' == l then obj else ExtendEffect (knd, exn', l') 139 | 140 | let in_translator : translator_obj -> obj = 141 | declare_object { (default_object "FORCING TRANSLATOR") with 142 | cache_function = cache_translator; 143 | load_function = load_translator; 144 | open_function = open_translator; 145 | discharge_function = (fun (_, o) -> Some o); 146 | classify_function = (fun o -> Substitute o); 147 | subst_function = subst_translator; 148 | } 149 | 150 | (** Tactic *) 151 | 152 | let solve_evars env sigma c = 153 | let evdref = ref sigma in 154 | let c = Typing.e_solve_evars env evdref c in 155 | (!evdref, c) 156 | 157 | let declare_axiom id uctx ty = 158 | let uctx = Entries.Monomorphic_const_entry uctx in 159 | let pe = (None, (ty, uctx), None) in 160 | let pd = Entries.ParameterEntry pe in 161 | let decl = (pd, IsAssumption Definitional) in 162 | let cst_ = Declare.declare_constant id decl in 163 | cst_ 164 | 165 | let declare_constant id uctx c t = 166 | let uctx = Entries.Monomorphic_const_entry uctx in 167 | let ce = Declare.definition_entry ~types:t ~univs:uctx c in 168 | let cd = Entries.DefinitionEntry ce in 169 | let decl = (cd, IsProof Lemma) in 170 | let cst_ = Declare.declare_constant id decl in 171 | cst_ 172 | 173 | let declare_constant_wo_ty id uctx c = 174 | let uctx = Entries.Monomorphic_const_entry uctx in 175 | let ce = Declare.definition_entry ~univs:uctx c in 176 | let cd = Entries.DefinitionEntry ce in 177 | let decl = (cd, IsProof Lemma) in 178 | let cst_ = Declare.declare_constant id decl in 179 | cst_ 180 | 181 | let on_one_id f ids cst = match ids with 182 | | None -> f (Nametab.basename_of_global (ConstRef cst)) 183 | | Some [id] -> id 184 | | Some _ -> user_err (str "Not the right number of provided names") 185 | 186 | let translate_constant err translator cst ids = 187 | let id = on_one_id translate_name ids cst in 188 | (** Translate the type *) 189 | let env = Global.env () in 190 | let (typ, uctx) = Global.type_of_global_in_context env (ConstRef cst) in 191 | let typ = EConstr.of_constr typ in 192 | let sigma = Evd.from_env env in 193 | let (sigma, typ) = ETranslate.translate_type err translator env sigma typ in 194 | let sigma, _ = Typing.type_of env sigma typ in 195 | let body, _ = Option.get (Global.body_of_constant cst) in 196 | let body = EConstr.of_constr body in 197 | let (sigma, body) = ETranslate.translate err translator env sigma body in 198 | let evdref = ref sigma in 199 | let () = Typing.e_check env evdref body typ in 200 | let sigma = !evdref in 201 | let body = EConstr.to_constr sigma body in 202 | let typ = EConstr.to_constr sigma typ in 203 | let uctx = UState.context_set (Evd.evar_universe_context sigma) in 204 | let cst_ = declare_constant id uctx body typ in 205 | [ExtConstant (cst, ConstRef cst_)] 206 | 207 | (** Fix potential mismatch between the generality of parametricity and effect 208 | translations *) 209 | let instantiate_error env sigma err gen c_ = match err with 210 | | None -> (sigma, c_) 211 | | Some err -> 212 | if gen then 213 | let (sigma, err) = Evd.fresh_global env sigma err in 214 | (sigma, mkApp (c_, [| err |])) 215 | else (sigma, c_) 216 | 217 | let primitives_from_declaration env (ind: Names.mutual_inductive) = 218 | let open Declarations in 219 | let (mind, _) = Inductive.lookup_mind_specif env (ind, 0) in 220 | let (_, projs, _) = Option.get (Option.get mind.mind_record) in 221 | Array.to_list projs 222 | 223 | let translate_inductive_gen f err translator (ind, _) = 224 | let env = Global.env () in 225 | let (mind, _ as specif) = Inductive.lookup_mind_specif env (ind, 0) in 226 | 227 | let primitive_records = Inductive.is_primitive_record specif in 228 | 229 | let mind' = EUtil.process_inductive mind in 230 | let mind_ = f err translator env ind mind mind' in 231 | let ((_, kn), _) = Declare.declare_mind mind_ in 232 | let ind_ = Global.mind_of_delta_kn kn in 233 | let extensions = 234 | if primitive_records then 235 | let env = Global.env () in 236 | let proj = primitives_from_declaration env ind in 237 | let proj_ = primitives_from_declaration env ind_ in 238 | let pair = List.combine proj proj_ in 239 | List.map (fun (p, pe) -> ExtConstant (p, ConstRef pe)) pair 240 | else 241 | [] 242 | in 243 | (ExtInductive (ind, ind_)) :: extensions 244 | 245 | let one_ind_in_prop ind_arity = 246 | let open Declarations in 247 | match ind_arity with 248 | | RegularArity ar -> is_prop_sort ar.mind_sort 249 | | TemplateArity _ -> false 250 | 251 | let typeclass_declaration err translator ind_names_decl ind_name param_ind = 252 | let env = Global.env () in 253 | let func = ETranslate.param_instance_inductive in 254 | 255 | let (sigma, base_instance_ty, pinstance) = func err translator env ind_names_decl param_ind in 256 | 257 | (* Polymorphic Axiom declaration *) 258 | let id = Nameops.add_suffix ind_name "_instance" in 259 | let uctx = UState.context_set (Evd.evar_universe_context sigma) in 260 | let instance_name = declare_axiom id uctx (EConstr.to_constr sigma base_instance_ty) in 261 | let _,dirPath,label = Constant.repr3 instance_name in 262 | let qualid = Libnames.make_qualid dirPath (Label.to_id label) in 263 | let () = Classes.existing_instance true (CAst.make (Libnames.Qualid qualid)) None in 264 | (* -- *) 265 | 266 | let pid = translate_name id in 267 | let tp = EConstr.to_constr sigma pinstance in 268 | let pinstance_name = declare_constant_wo_ty pid uctx tp in 269 | ExtConstant (instance_name, ConstRef pinstance_name) 270 | 271 | let instantiate_parametric_modality err translator (name, n) ext = 272 | let module D = Declarations in 273 | let env = Global.env () in 274 | let (mind, _ as specif) = Inductive.lookup_mind_specif env (name, 0) in 275 | let find_map = function 276 | | ExtInductive (n,m) when MutInd.equal name n -> Some m 277 | | _ -> None 278 | in 279 | let name_e = List.find_map find_map ext in 280 | let global_app name = match err with 281 | | None -> ETranslate.GlobGen name 282 | | Some exn -> ETranslate.GlobImp (Refmap.singleton exn name) 283 | in 284 | let translator = 285 | ETranslate.({ translator with inds = Mindmap.add name (global_app name_e) translator.inds }) 286 | in 287 | let mind' = EUtil.process_inductive mind in 288 | let mind_ = ETranslate.param_mutual_inductive err translator env (name, name_e) mind mind' in 289 | 290 | let ((_, kn), _) = Declare.declare_mind mind_ in 291 | let name_param = Global.mind_of_delta_kn kn in 292 | let iter id = 293 | let id_ind = Nameops.add_suffix id "_ind" in 294 | let reference = CAst.make @@ Misctypes.AN (CAst.make (Libnames.Ident id)) in 295 | let scheme = Vernacexpr.InductionScheme (true, reference, InProp) in 296 | Indschemes.do_scheme [Some (CAst.make id_ind), scheme] 297 | in 298 | let mind_names = Entries.(List.map (fun i -> i.mind_entry_typename) mind_.mind_entry_inds) in 299 | let () = List.iter iter mind_names in 300 | 301 | let ind_name_decl = (name, name_e, name_param) in 302 | let ty_decl = typeclass_declaration in 303 | let fold_map (i, translator) one_d = 304 | let open ETranslate in 305 | let ext = ty_decl err translator ind_name_decl D.(one_d.mind_typename) (one_d, i) in 306 | let refs = match ext with 307 | | ExtConstant (cst, glob_ref) -> Cmap.add cst (global_app glob_ref) translator.refs 308 | | _ -> translator.refs 309 | in 310 | let translator = { translator with refs } in 311 | ((succ i, translator), ext) 312 | in 313 | let ((_, translator), instances) = 314 | List.fold_map fold_map (0, translator) (Array.to_list D.(mind.mind_packets)) 315 | in 316 | let env = Global.env () in 317 | let (sigma, ind, ind_e, ind_e_ty) = ETranslate.parametric_induction err translator env name mind in 318 | 319 | 320 | (* Parametrict induction *) 321 | let name = Declarations.(mind.mind_packets.(0).mind_typename) in 322 | let induction_name = Nameops.add_suffix name "_ind_param" in 323 | let uctx = UState.context_set (Evd.evar_universe_context sigma) in 324 | let cst_ind = declare_axiom induction_name uctx (EConstr.to_constr sigma ind) in 325 | 326 | let induction_name_e = Nameops.add_suffix induction_name "ᵉ" in 327 | let uctx = UState.context_set (Evd.evar_universe_context sigma) in 328 | let ind_e = EConstr.to_constr sigma ind_e in 329 | let ind_e_ty = EConstr.to_constr sigma ind_e_ty in 330 | let cst_ind_e = declare_constant induction_name_e uctx ind_e ind_e_ty in 331 | (* ********************* *) 332 | 333 | ExtConstant (cst_ind, ConstRef cst_ind_e) :: instances 334 | 335 | let try_instantiate_parametric_modality err translator (name, n) ext = 336 | let module D = Declarations in 337 | let env = Global.env () in 338 | let (mind, _ as specif) = Inductive.lookup_mind_specif env (name, 0) in 339 | let arity_mind = Array.map (fun ind -> D.(ind.mind_arity) ) D.(mind.mind_packets) in 340 | 341 | if Array.exists (fun i -> one_ind_in_prop i) arity_mind then [] 342 | else instantiate_parametric_modality err translator (name, n) ext 343 | 344 | let translate_inductive err translator ind = 345 | let base_ext = translate_inductive_gen ETranslate.translate_inductive err translator ind in 346 | let inst = try_instantiate_parametric_modality err translator ind base_ext in 347 | base_ext @ inst 348 | 349 | let msg_translate = function 350 | | ExtConstant (cst, gr) -> 351 | (str "Global " ++ Printer.pr_global (ConstRef cst) ++ 352 | str " has been translated as " ++ Printer.pr_global gr ++ str ".") 353 | | ExtInductive (smind, tmind) -> 354 | let mib = Global.lookup_mind smind in 355 | let len = Array.length mib.Declarations.mind_packets in 356 | let l = List.init len (fun n -> (IndRef (smind, n), IndRef (tmind, n))) in 357 | let pr (src, dst) = 358 | (str "Global " ++ Printer.pr_global src ++ 359 | str " has been translated as " ++ Printer.pr_global dst ++ str ".") 360 | in 361 | prlist_with_sep fnl pr l 362 | | ExtParamInductive _ -> 363 | str "Parametric inducitve extension" 364 | | ExtParamConstant _ -> 365 | str "Parametric constant extension" 366 | 367 | let translate ?exn ?names gr = 368 | let ids = names in 369 | let err = Option.map Nametab.global exn in 370 | let gr = Nametab.global gr in 371 | let translator = !translator in 372 | let ans = match gr with 373 | | ConstRef cst -> translate_constant err translator cst ids 374 | | IndRef ind -> translate_inductive err translator ind 375 | | ConstructRef _ -> user_err (str "Use the translation over the corresponding inductive type instead.") 376 | | VarRef _ -> user_err (str "Variable translation not handled.") 377 | in 378 | let ext = ExtendEffect (ExtEffect, err, ans) in 379 | let () = Lib.add_anonymous_leaf (in_translator ext) in 380 | let msg = prlist_with_sep fnl msg_translate ans in 381 | Feedback.msg_info msg 382 | 383 | (** Implementation in the forcing layer *) 384 | 385 | let implement ?exn id typ = 386 | let env = Global.env () in 387 | let translator = !translator in 388 | let err = Option.map Nametab.global exn in 389 | let id_ = translate_name id in 390 | let sigma = Evd.from_env env in 391 | let (typ, uctx) = Constrintern.interp_type env sigma typ in 392 | let sigma = Evd.from_ctx uctx in 393 | let (sigma, typ) = solve_evars env sigma typ in 394 | let (sigma, typ_) = ETranslate.translate_type err translator env sigma typ in 395 | let typ = EConstr.to_constr sigma typ in 396 | let (sigma, _) = Typing.type_of env sigma typ_ in 397 | let hook _ dst = 398 | (** Declare the original term as an axiom *) 399 | let param = (None, (typ, Entries.Monomorphic_const_entry (Evd.evar_universe_context_set uctx)), None) in 400 | let cb = Entries.ParameterEntry param in 401 | let cst = Declare.declare_constant id (cb, IsDefinition Definition) in 402 | (** Attach the axiom to the forcing implementation *) 403 | let ext = ExtendEffect (ExtEffect, err, [ExtConstant (cst, dst)]) in 404 | Lib.add_anonymous_leaf (in_translator ext) 405 | in 406 | let hook ctx = Lemmas.mk_hook hook in 407 | let sigma, _ = Typing.type_of env sigma typ_ in 408 | let kind = Global, false, DefinitionBody Definition in 409 | let () = Lemmas.start_proof_univs id_ kind sigma typ_ hook in 410 | () 411 | 412 | (** Error handling *) 413 | 414 | let pr_global = function 415 | | VarRef id -> str "Variable " ++ Nameops.pr_id id 416 | | ConstRef cst -> str "Constant " ++ Constant.print cst 417 | | IndRef (ind, _) -> str "Inductive " ++ MutInd.print ind 418 | | ConstructRef ((ind, _), _) -> str "Inductive " ++ MutInd.print ind 419 | 420 | let _ = register_handler begin function 421 | | ETranslate.MissingGlobal (eff, gr) -> 422 | let eff = match eff with 423 | | None -> str "for generic exceptions" 424 | | Some gr -> str "for instance" ++ spc () ++ Printer.pr_global gr 425 | in 426 | str "No translation for global " ++ Printer.pr_global gr ++ spc () ++ eff ++ str "." 427 | | ETranslate.MissingPrimitive gr -> 428 | let ref = pr_global gr in 429 | str "Missing primitive: " ++ ref ++ str "." 430 | | ETranslate.MatchEliminationNotSupportedOnTranslation -> 431 | str "Elimination error: this match is not allowed under the translation" 432 | | _ -> raise Unhandled 433 | end 434 | 435 | (** List translate *) 436 | 437 | module Generic = struct 438 | open Libnames 439 | open Names 440 | 441 | let generic_translate ?exn 442 | (gr_list:reference list) 443 | (generic: ?exn:reference -> ?names:Id.t list-> reference -> unit) = 444 | let fold () gr = generic ?exn gr in 445 | List.fold_left fold () gr_list 446 | end 447 | open Generic 448 | 449 | let list_translate ?exn gr_list = 450 | generic_translate ?exn gr_list translate 451 | -------------------------------------------------------------------------------- /src/ePlugin.mli: -------------------------------------------------------------------------------- 1 | open Names 2 | open Libnames 3 | 4 | val translate : ?exn:reference -> ?names:Id.t list -> reference -> unit 5 | 6 | val implement : ?exn:reference -> Id.t -> Constrexpr.constr_expr -> unit 7 | 8 | (** Translate of list *) 9 | val list_translate : ?exn:reference -> reference list -> unit 10 | -------------------------------------------------------------------------------- /src/eTranslate.ml: -------------------------------------------------------------------------------- 1 | 2 | module CVars = Vars 3 | 4 | open Util 5 | open Context 6 | open Rel.Declaration 7 | open Names 8 | open Term 9 | open EConstr 10 | open Entries 11 | open Declarations 12 | open Globnames 13 | open Pp 14 | 15 | type effect = global_reference option 16 | 17 | exception MissingGlobal of effect * global_reference 18 | exception MissingPrimitive of global_reference 19 | exception MatchEliminationNotSupportedOnTranslation 20 | 21 | type 'a global_translation = 22 | | GlobGen of 'a 23 | (** Implementation generic over the type of exceptions *) 24 | | GlobImp of 'a Refmap.t 25 | (** For every type of exceptions, a specialized implementation. *) 26 | 27 | type translator = { 28 | refs : global_reference global_translation Cmap.t; 29 | inds : MutInd.t global_translation Mindmap.t; 30 | prefs : global_reference global_translation Cmap.t; 31 | pinds : MutInd.t global_translation Mindmap.t; 32 | wrefs : global_reference global_translation Cmap.t; 33 | winds : MutInd.t global_translation Mindmap.t; 34 | paramrefs : global_reference global_translation Mindmap.t; 35 | paraminds : MutInd.t global_translation Mindmap.t; 36 | } 37 | 38 | type context = { 39 | error : global_reference option; 40 | (** Whether the translation is relativized to a specific error type *) 41 | translator : translator; 42 | env_src : Environ.env; 43 | env_tgt : Environ.env; 44 | } 45 | 46 | let push_assum na (t, te) env = { env with 47 | env_src = EConstr.push_rel (LocalAssum (na, t)) env.env_src; 48 | env_tgt = EConstr.push_rel (LocalAssum (na, te)) env.env_tgt; 49 | } 50 | 51 | let push_def na (c, ce) (t, te) env = { env with 52 | env_src = EConstr.push_rel (LocalDef (na, c, t)) env.env_src; 53 | env_tgt = EConstr.push_rel (LocalDef (na, ce, te)) env.env_tgt; 54 | } 55 | 56 | let translate_name id = 57 | let id = Id.to_string id in 58 | Id.of_string (id ^ "ᵉ") 59 | 60 | let translate_internal_name id = 61 | let id = Id.to_string id in 62 | Id.of_string (id ^ "ᵒ") 63 | 64 | let translate_failure id = 65 | let id = Id.to_string id in 66 | Id.of_string (id ^ "ᴱ") 67 | 68 | let translate_param_name id = 69 | let id = Id.to_string id in 70 | Id.of_string (id ^ "_param") 71 | 72 | let translate_instance_name id = 73 | let id = Id.to_string id in 74 | Id.of_string (id ^ "_instance") 75 | 76 | let lift_rel_context n ctx = 77 | let fold k d accu = 78 | let d = Context.Rel.Declaration.map_constr (fun c -> Vars.liftn n k c) d in 79 | d :: accu 80 | in 81 | List.fold_right_i fold 1 ctx [] 82 | 83 | (** Coq-defined values *) 84 | 85 | let effect_path = 86 | DirPath.make (List.map Id.of_string ["Effects"; "Weakly"]) 87 | 88 | let make_kn name = 89 | KerName.make2 (MPfile effect_path) (Label.make name) 90 | 91 | let prop_e = ConstRef (Constant.make1 (make_kn "Propᵉ")) 92 | let type_e = ConstRef (Constant.make1 (make_kn "Typeᵉ")) 93 | let el_e = ConstRef (Constant.make1 (make_kn "El")) 94 | let prod_e = ConstRef (Constant.make1 (make_kn "Prodᵉ")) 95 | let err_e = ConstRef (Constant.make1 (make_kn "Err")) 96 | let typeval_e = ConstructRef ((MutInd.make1 (make_kn "type"), 0), 1) 97 | 98 | let param_mod = MutInd.make1 (make_kn "Param") 99 | let param_mod_e = MutInd.make1 (make_kn "Paramᵉ") 100 | 101 | let param_cst = Constant.make1 (make_kn "param") 102 | let param_cst_e = Constant.make1 (make_kn "paramᵉ") 103 | 104 | let tm_exception = Constant.make1 (make_kn "Exception") 105 | let tm_exception_e = Constant.make1 (make_kn "Exceptionᵉ") 106 | 107 | let tm_raise = Constant.make1 (make_kn "raise") 108 | let tm_raise_e = Constant.make1 (make_kn "raiseᵉ") 109 | 110 | 111 | 112 | let name_errtype = Id.of_string "E" 113 | let name_err = Id.of_string "e" 114 | 115 | (** Handling of globals *) 116 | 117 | let get_instance err = function 118 | | GlobGen x -> true, x 119 | | GlobImp m -> 120 | match err with 121 | | None -> raise Not_found (** No generic implementation *) 122 | | Some gr -> false, Refmap.find gr m 123 | 124 | let instantiate_error err env sigma gen c_ = match err with 125 | | None -> (sigma, c_) 126 | | Some err -> 127 | if gen then 128 | let (sigma, err) = Evd.fresh_global env sigma err in 129 | (sigma, mkApp (c_, [| EConstr.of_constr err |])) 130 | else (sigma, c_) 131 | 132 | let get_cst env cst = 133 | try get_instance env.error (Cmap.find cst env.translator.refs) 134 | with Not_found -> raise (MissingGlobal (env.error, ConstRef cst)) 135 | 136 | let get_ind env (ind, n) = 137 | try 138 | let gen, ind = get_instance env.error (Mindmap.find ind env.translator.inds) in 139 | gen, (ind, n) 140 | with Not_found -> raise (MissingGlobal (env.error, IndRef (ind, n))) 141 | 142 | let apply_global env sigma gr = 143 | let gen, gr = match gr with 144 | | ConstructRef (ind, n) -> 145 | let gen, ind = get_ind env ind in 146 | gen, ConstructRef (ind, n) 147 | | IndRef ind -> 148 | let gen, ind = get_ind env ind in 149 | gen, IndRef ind 150 | | ConstRef cst -> get_cst env cst 151 | | VarRef _ -> CErrors.user_err (str "Variables not handled") 152 | in 153 | let (sigma, c) = Evd.fresh_global env.env_tgt sigma gr in 154 | let c = EConstr.of_constr c in 155 | if gen then 156 | let e = mkRel (Environ.nb_rel env.env_tgt) in 157 | (sigma, mkApp (c, [|e|])) 158 | else 159 | (sigma, c) 160 | 161 | let fresh_global env sigma gr = 162 | try 163 | let (sigma, c) = Evd.fresh_global env.env_tgt sigma gr in 164 | (sigma, EConstr.of_constr c) 165 | with Not_found -> raise (MissingPrimitive gr) 166 | 167 | (** Effect translation core *) 168 | 169 | let element env sigma is_prop c = 170 | let (sigma, value) = 171 | if is_prop then 172 | (sigma, c) 173 | else 174 | let (sigma, el) = fresh_global env sigma el_e in 175 | let e = mkRel (Environ.nb_rel env.env_tgt) in 176 | (sigma, mkApp (el, [|e; c|])) 177 | in 178 | (sigma, value) 179 | 180 | let translate_case_info env sigma ci mip = 181 | let gen, ci_ind = get_ind env ci.ci_ind in 182 | let nrealdecls = mip.mind_nrealdecls in 183 | let nrealargs = mip.mind_nrealargs in 184 | let ci_npar = if gen then 1 + ci.ci_npar else ci.ci_npar in 185 | let ci_cstr_ndecls = Array.append ci.ci_cstr_ndecls [|1 + nrealdecls|] in 186 | let ci_cstr_nargs = Array.append ci.ci_cstr_nargs [|1 + nrealargs|] in 187 | let tags = 188 | false :: (** additional exception argument *) 189 | Context.Rel.to_tags (List.firstn nrealdecls mip.mind_arity_ctxt) 190 | in 191 | let ci_pp_info = { ci.ci_pp_info with 192 | ind_tags = (not gen) :: ci.ci_pp_info.ind_tags; 193 | cstr_tags = Array.append ci.ci_pp_info.cstr_tags [|tags|]; 194 | } in 195 | { ci_ind; ci_npar; ci_cstr_ndecls; ci_cstr_nargs; ci_pp_info; } 196 | 197 | let translate_prop_case_info env sigma ci mip = 198 | let gen, ci_ind = get_ind env ci.ci_ind in 199 | let ci_npar = if gen then 1 + ci.ci_npar else ci.ci_npar in 200 | { ci with ci_ind; ci_npar; } 201 | 202 | let mk_default_ind env sigma (ind, u) = 203 | let e = mkRel (Environ.nb_rel env.env_tgt) in 204 | let (_, mip) = Inductive.lookup_mind_specif env.env_src ind in 205 | let err = Array.length mip.mind_consnames + 1 in 206 | let gen, ind = get_ind env ind in 207 | let (sigma, (ind, u)) = Evd.fresh_inductive_instance env.env_tgt sigma ind in 208 | let r = mkConstructU ((ind, err), EInstance.make u) in 209 | let r = if gen then mkApp (r, [|e|]) else r in 210 | (sigma, r) 211 | 212 | let mk_default_primitive_record env sigma (ind, u) = 213 | let (modd, dir, lab) = (MutInd.repr3 (fst ind)) in 214 | let cst = Constant.make3 modd dir lab in 215 | let (gen, default) = get_cst env cst in 216 | let (sigma, r) = fresh_global env sigma default in 217 | (sigma, gen, EInstance.kind sigma (snd (destConst sigma r)), r) 218 | 219 | let ind_in_prop mip = 220 | match mip.mind_arity with 221 | | RegularArity ar -> is_prop_sort ar.mind_sort 222 | | TemplateArity _ -> false 223 | 224 | (* From Γ ⊢ M : A produce [M] s.t. ⟦Γ⟧ ⊢ [M] : ⟦A⟧. *) 225 | let rec otranslate env sigma c = match EConstr.kind sigma c with 226 | | Rel n -> 227 | (sigma, mkRel n) 228 | | Sort s -> 229 | let e = mkRel (Environ.nb_rel env.env_tgt) in 230 | let is_prop = is_prop_sort (EConstr.ESorts.kind sigma s) in 231 | let sort_e = if is_prop then prop_e else type_e in 232 | let (sigma, t) = fresh_global env sigma sort_e in 233 | sigma, mkApp (t, [|e|]) 234 | | Cast (c, k, t) -> 235 | let (sigma, ce) = otranslate env sigma c in 236 | let (sigma, te) = otranslate_type env sigma t in 237 | let r = mkCast (ce, k, te) in 238 | (sigma, r) 239 | | Prod (na, t, u) -> 240 | let (sigma,ty) = Typing.type_of env.env_src sigma c in 241 | let is_prop = isSort sigma ty && is_prop_sort (ESorts.kind sigma (destSort sigma ty)) in 242 | if is_prop then 243 | let (sigma, ty) = otranslate_type env sigma c in 244 | (sigma, ty) 245 | else 246 | let e = mkRel (Environ.nb_rel env.env_tgt) in 247 | let (sigma, p) = fresh_global env sigma prod_e in 248 | let (sigma, te) = otranslate_type env sigma t in 249 | let env = push_assum na (t, te) env in 250 | let (sigma, ue) = otranslate env sigma u in 251 | let ue = mkLambda (na, te, ue) in 252 | let r = mkApp (p, [|e; te; ue|]) in 253 | (sigma, r) 254 | | Lambda (na, t, u) -> 255 | let (sigma, te) = otranslate_type env sigma t in 256 | let env = push_assum na (t, te) env in 257 | let (sigma, ue) = otranslate env sigma u in 258 | let r = mkLambda (na, te, ue) in 259 | (sigma, r) 260 | | LetIn (na, c, t, u) -> 261 | let (sigma, ce) = otranslate env sigma c in 262 | let (sigma, te) = otranslate_type env sigma t in 263 | let env = push_def na (c, ce) (t, te) env in 264 | let (sigma, ue) = otranslate env sigma u in 265 | let r = mkLetIn (na, ce, te, ue) in 266 | (sigma, r) 267 | | App (t, args) when isInd sigma t -> 268 | otranslate_ind env sigma (destInd sigma t) args 269 | | App (t, args) -> 270 | let (sigma, te) = otranslate env sigma t in 271 | let fold (sigma, argse) arg = 272 | let (sigma, arge) = otranslate env sigma arg in 273 | (sigma, arge :: argse) 274 | in 275 | let (sigma, argse) = Array.fold_left fold (sigma, []) args in 276 | let r = mkApp (te, Array.rev_of_list argse) in 277 | (sigma, r) 278 | | Var id -> 279 | let (sigma, c) = apply_global env sigma (VarRef id) in 280 | (sigma, c) 281 | | Const (p, _) -> 282 | let (sigma, c) = apply_global env sigma (ConstRef p) in 283 | (sigma, c) 284 | | Ind (ind, u) -> 285 | otranslate_ind env sigma (ind, u) [||] 286 | | Construct (c, _) -> 287 | let (sigma, c) = apply_global env sigma (ConstructRef c) in 288 | (sigma, c) 289 | | Case (ci, r, c, p) -> 290 | let (_, mip) = Inductive.lookup_mind_specif env.env_src ci.ci_ind in 291 | let r_ctx, r_end = decompose_lam_assum sigma r in 292 | let p_env_src = EConstr.push_rel_context r_ctx env.env_src in 293 | let match_on_prop = ind_in_prop mip in 294 | let () = 295 | let module S = ESorts in 296 | if isSort sigma r_end then 297 | let sort = S.kind sigma (destSort sigma r_end) in 298 | ( if is_prop_sort sort && not match_on_prop then 299 | raise MatchEliminationNotSupportedOnTranslation ) 300 | else 301 | let p_sigma, r_end_type = Typing.type_of p_env_src sigma r_end in 302 | let sort = S.kind p_sigma (destSort p_sigma r_end_type) in 303 | if is_prop_sort sort && not match_on_prop then 304 | raise MatchEliminationNotSupportedOnTranslation 305 | in 306 | let ci_translator = if match_on_prop then translate_prop_case_info else translate_case_info in 307 | let cie = ci_translator env sigma ci mip in 308 | let (ctx, r) = EConstr.decompose_lam_assum sigma r in 309 | let (sigma, env', ctxe) = otranslate_context env sigma ctx in 310 | let (sigma, ce) = otranslate env sigma c in 311 | let map sigma p = otranslate env sigma p in 312 | let (sigma, pe) = Array.fold_map map sigma p in 313 | let nE = Environ.nb_rel env'.env_tgt in 314 | (** The default constructor has as arguments the indices of the block plus an error *) 315 | let default_ctx = LocalAssum (Name name_err, mkRel (nE - 1)) :: List.tl ctxe in 316 | let default_case = 317 | (** Transform [Ind{I} params indices] into [Cstr{Iᴱ} params indices] *) 318 | let (ind, args) = Termops.decompose_app_vect sigma (get_type (List.hd ctxe)) in 319 | let (ind, u) = destInd sigma ind in 320 | let err = Array.length mip.mind_consnames + 1 in 321 | let args = Array.map (fun c -> Vars.lift 1 c) args in 322 | mkApp (mkConstructU ((ind, err), u), Array.append args [|mkRel 1|]) 323 | in 324 | let (sigma, re, default) = otranslate_type_and_err env' sigma r in 325 | let re = it_mkLambda_or_LetIn re ctxe in 326 | let default = Vars.subst1 default_case (Vars.liftn 1 2 default) in 327 | let default = mkApp (default, [|mkRel 1|]) in 328 | let default = it_mkLambda_or_LetIn default default_ctx in 329 | let pe = if match_on_prop then pe else Array.append pe [| default |] in 330 | (*let pe = Array.append pe [|default|] in*) 331 | let r = mkCase (cie, re, ce, pe) in 332 | (sigma, r) 333 | | Fix (fi, recdef) -> 334 | let (sigma, recdefe) = otranslate_recdef env sigma recdef in 335 | let r = mkFix (fi, recdefe) in 336 | (sigma, r) 337 | | CoFix (fi, recdef) -> 338 | let (sigma, recdefe) = otranslate_recdef env sigma recdef in 339 | let r = mkCoFix (fi, recdefe) in 340 | (sigma, r) 341 | | Proj (p, c) -> 342 | let constant = Names.Projection.constant p in 343 | let unfolded = Names.Projection.unfolded p in 344 | let _, glob_constante = get_cst env constant in 345 | let constante = Globnames.destConstRef glob_constante in 346 | let proje = Names.Projection.make constante unfolded in 347 | let (sigma, ce) = otranslate env sigma c in 348 | (sigma, mkProj (proje, ce)) 349 | | Meta _ -> assert false 350 | | Evar _ -> assert false 351 | 352 | and otranslate_recdef env sigma (nas, tys, bodies) = 353 | let fold i (env, sigma, ans) na t = 354 | let t = Vars.lift i t in 355 | let (sigma, te) = otranslate_type env sigma t in 356 | let env = push_assum na (t, te) env in 357 | (env, sigma, te :: ans) 358 | in 359 | let (env, sigma, tyse) = Array.fold_left2_i fold (env, sigma, []) nas tys in 360 | let tyse = Array.rev_of_list tyse in 361 | let (sigma, bodiese) = Array.fold_map (fun sigma c -> otranslate env sigma c) sigma bodies in 362 | (sigma, (nas, tyse, bodiese)) 363 | 364 | (* Special handling of types not to clutter the translation. 365 | From Γ ⊢ A : Type produce ⟦A⟧ s.t. ⟦Γ⟧ ⊢ ⟦A⟧ : Type. *) 366 | and otranslate_type env sigma t = match EConstr.kind sigma t with 367 | | App (c, args) when isInd sigma c -> 368 | let (ind, _) = destInd sigma c in 369 | let fold sigma c = otranslate env sigma c in 370 | let (sigma, args) = Array.fold_map fold sigma args in 371 | let (sigma, c) = apply_global env sigma (IndRef ind) in 372 | (sigma, mkApp (c, args)) 373 | | Ind (ind, _) -> 374 | let (sigma, c) = apply_global env sigma (IndRef ind) in 375 | (sigma, c) 376 | | Prod (na, t, u) -> 377 | let (sigma, te) = otranslate_type env sigma t in 378 | let env = push_assum na (t, te) env in 379 | let (sigma, ue) = otranslate_type env sigma u in 380 | (sigma, mkProd (na, te, ue)) 381 | | _ -> 382 | let is_prop = is_prop_sort (Typing.e_sort_of env.env_src (ref sigma) t) in 383 | let (sigma, t_) = otranslate env sigma t in 384 | let (sigma, t_) = element env sigma is_prop t_ in 385 | (sigma, t_) 386 | 387 | (* From Γ ⊢ A : Type produce 388 | - ⟦A⟧ s.t. ⟦Γ⟧ ⊢ ⟦A⟧ : Type 389 | - [A]ᴱ s.t. ⟦Γ⟧ ⊢ [A]ᴱ : E → ⟦A⟧ *) 390 | and otranslate_type_and_err env sigma t = match EConstr.kind sigma t with 391 | | App (c, args) when isInd sigma c -> 392 | let (ind, u) = destInd sigma c in 393 | let fold sigma c = otranslate env sigma c in 394 | let (sigma, args) = Array.fold_map fold sigma args in 395 | let (sigma, c) = apply_global env sigma (IndRef ind) in 396 | let (sigma, ind_def) = mk_default_ind env sigma (ind, u) in 397 | let ind_def = mkApp (ind_def, args) in 398 | (sigma, mkApp (c, args), ind_def) 399 | | Ind (ind, u) -> 400 | let (sigma, c) = apply_global env sigma (IndRef ind) in 401 | let (sigma, ind_def) = mk_default_ind env sigma (ind, u) in 402 | (sigma, c, ind_def) 403 | | Prod (na, t, u) -> 404 | let (sigma, te) = otranslate_type env sigma t in 405 | let env = push_assum na (t, te) env in 406 | let (sigma, ue, def) = otranslate_type_and_err env sigma u in 407 | let def = mkApp (Vars.liftn 1 2 def, [| mkRel 2 |]) in 408 | let e = mkRel (Environ.nb_rel env.env_tgt - 1) in 409 | let prod_def = mkLambda (Name name_err, e, mkLambda (na, Vars.lift 1 te, def)) in 410 | (sigma, mkProd (na, te, ue), prod_def) 411 | | _ -> 412 | let is_prop = is_prop_sort (Typing.e_sort_of env.env_src (ref sigma) t) in 413 | let (sigma, t_) = otranslate env sigma t in 414 | let (sigma, err) = fresh_global env sigma err_e in 415 | let e = mkRel (Environ.nb_rel env.env_tgt) in 416 | let t_def = mkApp (err, [|e; t_|]) in 417 | let (sigma, t_) = element env sigma is_prop t_ in 418 | (sigma, t_, t_def) 419 | 420 | (** Special handling of potentially partially applied inductive types not to 421 | clutter the translation *) 422 | and otranslate_ind env sigma (ind, u) args = 423 | let (mib, mip) = Inductive.lookup_mind_specif env.env_src ind in 424 | let is_prop = ind_in_prop mip in 425 | let fold sigma c = otranslate env sigma c in 426 | let (sigma, args) = Array.fold_map fold sigma args in 427 | if is_prop then 428 | let (sigma, c) = apply_global env sigma (IndRef ind) in 429 | (sigma, if Array.length args == 0 then c else mkApp (c, args)) 430 | else if Inductive.is_primitive_record (mib, mip) then 431 | (** Primitive default constructor 432 | This is wrong *) 433 | let e_var = mkRel (Environ.nb_rel env.env_tgt) in 434 | let (sigma, c) = apply_global env sigma (IndRef ind) in 435 | let (sigma, gen, _, def) = mk_default_primitive_record env sigma (ind, u) in 436 | let (sigma, typeval) = fresh_global env sigma typeval_e in 437 | let r = mkApp (typeval, [| e_var; mkApp (c, args); mkApp (def, args) |]) in 438 | let () = assert false in 439 | (sigma, r) 440 | else if Int.equal (Array.length args) (mib.mind_nparams + mip.mind_nrealargs) then 441 | (** Fully applied *) 442 | let e = mkRel (Environ.nb_rel env.env_tgt) in 443 | let (sigma, c) = apply_global env sigma (IndRef ind) in 444 | let (sigma, typeval) = fresh_global env sigma typeval_e in 445 | let (sigma, def) = mk_default_ind env sigma (ind, u) in 446 | let r = mkApp (typeval, [| e; mkApp (c, args); mkApp (def, args) |]) in 447 | (sigma, r) 448 | else 449 | (** Partially applied, we need to eta-expand it. *) 450 | let gen, ind = get_ind env ind in 451 | let (_, mip) = Inductive.lookup_mind_specif env.env_src ind in 452 | let (sigma, (ind, u)) = Evd.fresh_inductive_instance env.env_tgt sigma ind in 453 | let subst c = CVars.subst_instance_constr u c in 454 | let nctx = List.length mip.mind_arity_ctxt in 455 | let map d = 456 | let d = Rel.Declaration.map_constr subst d in 457 | of_rel_decl d 458 | in 459 | let ctx = List.map map mip.mind_arity_ctxt in 460 | let (sigma, typeval) = fresh_global env sigma typeval_e in 461 | let make_arg (n, accu) = function 462 | | LocalAssum _ -> (succ n, mkRel n :: accu) 463 | | LocalDef _ -> (succ n, accu) 464 | in 465 | let (_, arity) = List.fold_left make_arg (1, []) mip.mind_arity_ctxt in 466 | let u = EInstance.make u in 467 | let typ = applist (mkIndU (ind, u), arity) in 468 | let def_c = (ind, Array.length mip.mind_consnames) in 469 | let def = applist (mkConstructU (def_c, u), arity) in 470 | let r = mkApp (typeval, [| mkRel nctx; typ; def |]) in 471 | let r = it_mkLambda_or_LetIn r ctx in 472 | let r = if gen then mkApp (r, [| mkRel (Environ.nb_rel env.env_tgt) |]) else r in 473 | let r = mkApp (r, args) in 474 | (sigma, r) 475 | 476 | (* From ⊢ Γ produce ⊢ ⟦Γ⟧ *) 477 | and otranslate_context env sigma = function 478 | | [] -> sigma, env, [] 479 | | LocalAssum (na, t) :: params -> 480 | let (sigma, env, ctx) = otranslate_context env sigma params in 481 | let (sigma, te) = otranslate_type env sigma t in 482 | (sigma, push_assum na (t, te) env, LocalAssum (na, te) :: ctx) 483 | | LocalDef (na, b, t) :: params -> 484 | let (sigma, env, ctx) = otranslate_context env sigma params in 485 | let (sigma, te) = otranslate_type env sigma t in 486 | let (sigma, be) = otranslate env sigma b in 487 | (sigma, push_def na (b, be) (t, te) env, LocalDef (na, be, te) :: ctx) 488 | 489 | let make_error err env sigma = match err with 490 | | None -> 491 | let (sigma, s) = Evd.fresh_sort_in_family ~rigid:Evd.UnivRigid env sigma InType in 492 | let d = LocalAssum (Name name_errtype, Constr.mkSort s) in 493 | (sigma, d) 494 | | Some gr -> 495 | let (sigma, s) = Evd.fresh_sort_in_family ~rigid:Evd.UnivRigid env sigma InType in 496 | let (sigma, c) = Evd.fresh_global env sigma gr in 497 | let d = LocalDef (Name name_errtype, c, Constr.mkSort s) in 498 | (sigma, d) 499 | 500 | let make_context error translator env sigma = 501 | let (sigma, decl) = make_error error env sigma in 502 | let env_tgt = Environ.push_rel decl env in 503 | let env = { 504 | error; 505 | translator; 506 | env_src = env; 507 | env_tgt; 508 | } in 509 | (sigma, env) 510 | 511 | let get_exception env = 512 | let rels = EConstr.rel_context env.env_tgt in 513 | List.last rels 514 | 515 | let translate err translator env0 sigma c = 516 | let (sigma, env) = make_context err translator env0 sigma in 517 | let (sigma, c_) = otranslate env sigma c in 518 | let decl = get_exception env in 519 | let c_ = mkLambda_or_LetIn decl c_ in 520 | let (sigma, _) = Typing.type_of env.env_src sigma c_ in 521 | (sigma, c_) 522 | 523 | let translate_type err translator env sigma c = 524 | let (sigma, env) = make_context err translator env sigma in 525 | let (sigma, c_) = otranslate_type env sigma c in 526 | let decl = get_exception env in 527 | let c_ = mkProd_or_LetIn decl c_ in 528 | let (sigma, _) = Typing.type_of env.env_src sigma c_ in 529 | (sigma, c_) 530 | 531 | let to_local_entry = function 532 | | LocalAssum (Name id, t) -> (id, Entries.LocalAssumEntry t) 533 | | LocalDef (Name id, b, t) -> (id, Entries.LocalDefEntry b) 534 | | _ -> assert false 535 | 536 | let dummy_kn id = 537 | KerName.make (MPfile DirPath.empty) DirPath.empty (Label.of_id id) 538 | 539 | let trans_name translation_function = function 540 | | Anonymous as anon -> anon 541 | | Name id -> Name (translation_function id) 542 | 543 | let name_projection_translate sigma translation_function record_builder = 544 | let rec aux sigma record_builder = 545 | match EConstr.kind sigma record_builder with 546 | | Prod (na, ty, bd) -> 547 | let trans_body = aux sigma bd in 548 | mkProd (trans_name translation_function na, ty, trans_body) 549 | | _ -> record_builder 550 | in 551 | aux sigma record_builder 552 | 553 | (** Locally extend a translator to fake an inductive definition *) 554 | let extend_inductive env mind0 mind = 555 | let open Univ in 556 | let univs = match mind0.mind_universes with 557 | | Monomorphic_ind _ -> Monomorphic_ind ContextSet.empty 558 | | Polymorphic_ind _ -> Polymorphic_ind AUContext.empty 559 | | Cumulative_ind _ -> Polymorphic_ind AUContext.empty (** FIXME *) 560 | in 561 | (** Dummy inductive. It is only used for its universe context, that we set to 562 | be empty. *) 563 | let mbi = { mind0 with mind_universes = univs } in 564 | let ind_name = dummy_kn (translate_internal_name mind0.mind_packets.(0).mind_typename) in 565 | let mind = MutInd.make1 ind_name in 566 | let env_tgt = Environ.add_mind mind mbi env.env_tgt in 567 | let ext = match env.error with 568 | | None -> GlobGen mind 569 | | Some exn -> GlobImp (Refmap.singleton exn mind) 570 | in 571 | let translator = { env.translator with inds = Mindmap.add mind ext env.translator.inds } in 572 | mind, { env with translator; env_tgt } 573 | 574 | let abstract_mind sigma mind n k c = 575 | let rec aux k c = match EConstr.kind sigma c with 576 | | Rel m -> 577 | if m <= k then c 578 | else mkRel (k + m) 579 | | Ind ((ind, m), _) when MutInd.equal mind ind -> 580 | mkRel (k + n - m) 581 | | _ -> 582 | map_with_binders sigma succ aux k c 583 | in 584 | aux k c 585 | 586 | let translate_constructors env sigma mind0 mind ind0 ind = 587 | let mutind, env = extend_inductive env mind0 mind in 588 | let nblock = Array.length mind0.mind_packets in 589 | let mk_ind n = mkInd (mutind, nblock - (n + 1)) in 590 | let subst0 = List.init nblock mk_ind in 591 | let map sigma t = 592 | (** A bit of term mangling: indices in the context referring to the 593 | inductive types we're building do not have the right type. *) 594 | let t = EConstr.of_constr t in 595 | let t = Vars.substnl subst0 (Environ.nb_rel env.env_src) t in 596 | let (sigma, te) = otranslate_type env sigma t in 597 | let te = abstract_mind sigma mutind nblock (Environ.nb_rel env.env_tgt) te in 598 | (sigma, te) 599 | in 600 | List.fold_map map sigma ind.mind_entry_lc 601 | 602 | let translate_inductive_body env sigma mind0 mind n ind0 ind = 603 | let typename = translate_internal_name ind.mind_entry_typename in 604 | let is_prop = match ind0.mind_arity with 605 | | RegularArity ar -> is_prop_sort ar.mind_sort 606 | | TemplateArity _ -> false 607 | in 608 | let constructors = List.map translate_name ind.mind_entry_consnames in 609 | let nindices = List.length ind0.mind_arity_ctxt - List.length mind0.mind_params_ctxt in 610 | let arity_ctx, _ = List.chop nindices ind0.mind_arity_ctxt in 611 | let (sigma, arity_env, arity_ctx') = otranslate_context env sigma (List.map EConstr.of_rel_decl arity_ctx) in 612 | let inSort = if is_prop then InProp else InType in 613 | let (sigma, sort) = Evd.fresh_sort_in_family ~rigid:Evd.UnivRigid env.env_tgt sigma inSort in 614 | let arity = it_mkProd_or_LetIn (mkSort sort) arity_ctx' in 615 | let (sigma, _) = Typing.type_of env.env_tgt sigma arity in 616 | let (sigma, lc) = translate_constructors env sigma mind0 mind ind0 ind in 617 | let lc = List.map (fun c -> EConstr.to_constr sigma c) lc in 618 | let fail_name = translate_failure ind.mind_entry_typename in 619 | let fail_arg (n, accu) = function 620 | | LocalAssum _ -> (succ n, mkRel n :: accu) 621 | | LocalDef _ -> (succ n, accu) 622 | in 623 | (** FIXME, probably wrong indices for mutual inductive blocks *) 624 | let (arity, fail_name_list, fail_case_list) = 625 | let arity = EConstr.to_constr sigma arity in 626 | if not is_prop then 627 | let (_, fail_args) = List.fold_left fail_arg (2, []) (Environ.rel_context arity_env.env_tgt) in 628 | let n = 1 + (mind0.mind_ntypes - n) + Environ.nb_rel arity_env.env_tgt in 629 | let fail_case = applist (mkRel n, fail_args) in 630 | let fail_ctx = LocalAssum (Anonymous, mkRel (1 + List.length ind0.mind_arity_ctxt)) :: arity_ctx' in 631 | let fail_case = it_mkProd_or_LetIn fail_case fail_ctx in 632 | (arity, [fail_name], [EConstr.to_constr sigma fail_case]) 633 | else 634 | (arity, [], []) 635 | in 636 | let ind = { ind with 637 | mind_entry_typename = typename; 638 | mind_entry_arity = arity; 639 | mind_entry_consnames = constructors @ fail_name_list; 640 | mind_entry_lc = lc @ fail_case_list; 641 | } in 642 | (sigma, ind) 643 | 644 | let translate_primitive_record env sigma mind_d mind_e = 645 | let _, env = extend_inductive env mind_d mind_e in 646 | let ind_e = List.hd mind_e.mind_entry_inds in 647 | let ind_d = mind_d.mind_packets.(0) in 648 | let ind_name = translate_internal_name ind_e.mind_entry_typename in 649 | let (sigma, sort) = Evd.fresh_sort_in_family ~rigid:Evd.UnivRigid env.env_tgt sigma InType in 650 | let ar = mkSort sort in 651 | let cons_name = translate_name (List.hd ind_e.mind_entry_consnames) in 652 | let (sigma, constr_type) = translate_constructors env sigma mind_d mind_e ind_d ind_e in 653 | let constr_type = List.hd constr_type in 654 | let constr_type_name = name_projection_translate sigma translate_name constr_type in 655 | let ind = { ind_e with 656 | mind_entry_typename = ind_name; 657 | mind_entry_arity = EConstr.to_constr sigma ar; 658 | mind_entry_consnames = [cons_name]; 659 | mind_entry_lc = [EConstr.to_constr sigma constr_type_name] 660 | } 661 | in 662 | (sigma, ind) 663 | 664 | let translate_inductive err translator env _ mind0 (mind : Entries.mutual_inductive_entry) = 665 | let sigma = Evd.from_env env in 666 | let (sigma, env) = make_context err translator env sigma in 667 | let (sigma, env, _) = otranslate_context env sigma (List.map EConstr.of_rel_decl mind0.mind_params_ctxt) in 668 | let (sigma, inds) = 669 | if Inductive.is_primitive_record (mind0,mind0.mind_packets.(0)) then 670 | let (sigma, pind) = translate_primitive_record env sigma mind0 mind in 671 | (sigma, [pind]) 672 | else 673 | let inds = List.combine (Array.to_list mind0.mind_packets) mind.mind_entry_inds in 674 | let inds = List.mapi (fun i (ind, ind0) -> (i, ind, ind0)) inds in 675 | let map sigma (n, ind0, ind) = translate_inductive_body env sigma mind0 mind n ind0 ind in 676 | let sigma, inds = List.fold_map map sigma inds in 677 | (sigma, inds) 678 | in 679 | let sigma, inds, params = EUtil.retype_inductive env.env_tgt sigma (EConstr.rel_context env.env_tgt) inds in 680 | let params = List.map to_local_entry params in 681 | let uctx = UState.context (Evd.evar_universe_context sigma) in 682 | let univs = match mind.mind_entry_universes with 683 | | Monomorphic_ind_entry _ -> Monomorphic_ind_entry (Univ.ContextSet.of_context uctx) 684 | | Polymorphic_ind_entry _ -> Polymorphic_ind_entry uctx 685 | | Cumulative_ind_entry _ -> Polymorphic_ind_entry uctx (** FIXME *) 686 | in 687 | let mind = { mind with 688 | mind_entry_inds = inds; 689 | mind_entry_params = params; 690 | mind_entry_universes = univs; 691 | } in 692 | mind 693 | 694 | (** Generate parametric inductive for a given inductive *) 695 | 696 | let param_lift param_offset c = 697 | let n = List.length param_offset in 698 | let fold accum i = 699 | let current = accum + i in (current, mkRel current) 700 | in 701 | let total,offsets = List.fold_map fold 0 param_offset in 702 | Vars.substl offsets (Vars.liftn n (n + 1) c) 703 | 704 | let param_top_decls env is_ind_prop = 705 | List.firstn (if is_ind_prop then 2 else 1) (EConstr.rel_context env.env_tgt) 706 | 707 | let rec term_finish_in_ind sigma t ind_name = match EConstr.kind sigma t with 708 | | App (t, _) -> isInd sigma t && MutInd.equal (fst (fst (destInd sigma t))) ind_name 709 | | Ind (ind,_) -> MutInd.equal (fst ind) ind_name 710 | | Prod (_, _, body) -> term_finish_in_ind sigma body ind_name 711 | | _ -> false 712 | 713 | let rec term_finish_in_ind_exact sigma t ind_name n = match EConstr.kind sigma t with 714 | | App (t, _) -> isInd sigma t && MutInd.equal (fst (fst (destInd sigma t))) ind_name 715 | | Ind (ind,_) -> MutInd.equal (fst ind) ind_name && snd ind == n 716 | | Prod (_, _, body) -> term_finish_in_ind_exact sigma body ind_name n 717 | | _ -> false 718 | 719 | let param_env_accum_up_to param_env n = 720 | List.fold_left (fun a acc -> a + acc) 0 (List.firstn n param_env) 721 | 722 | let rec otranslate_param env param_env sigma (ind, ind_e) c = match EConstr.kind sigma c with 723 | | Rel n -> 724 | let m = param_env_accum_up_to param_env n in 725 | (sigma, mkRel m) 726 | | Sort _ | Prod _ -> 727 | 728 | let (sigma, c_) = otranslate_param env param_env sigma (ind, ind_e) c in 729 | let c_ = param_lift param_env c_ in 730 | let (sigma, w) = otranslate_param_type env param_env sigma (ind, ind_e) c in 731 | let w = mkLambda (Anonymous, c_, w) in 732 | (sigma, w) 733 | | Lambda (na, t, u) -> assert false 734 | | LetIn (na, c, t, u) -> 735 | let (sigma, c_) = otranslate_param env param_env sigma (ind, ind_e) c in 736 | let (sigma, t_) = otranslate_param_type env param_env sigma (ind, ind_e) t in 737 | let is_ind_param = term_finish_in_ind sigma t ind in 738 | let (sigma, ctw, param_env) = 739 | if is_ind_param then (sigma, (None, None), 1 :: param_env) 740 | else let (s, cw) = otranslate_param env param_env sigma (ind, ind_e) c in 741 | let (s, tw) = otranslate_param_type env param_env s (ind, ind_e) t in 742 | (s, (Some cw, Some tw), 2 :: param_env) 743 | in 744 | let nenv = push_def na (c, c_) (t, t_) env in 745 | let ctx = param_top_decls nenv is_ind_param in 746 | let (sigma, ur) = otranslate_param nenv param_env sigma (ind, ind_e) u in 747 | let r = it_mkLambda_or_LetIn ur ctx in 748 | (sigma, r) 749 | | App (t, args) -> 750 | let args = Array.to_list args in 751 | let (sigma, tw) = otranslate_param env param_env sigma (ind, ind_e) t in 752 | let fold t (sigma, accum) = 753 | let (sigma, t_) = otranslate_param env param_env sigma (ind, ind_e) t in 754 | (sigma, t_ :: accum) 755 | in 756 | let (sigma, argsw) = List.fold_right fold args (sigma, []) in 757 | let w = applist (tw, argsw) in 758 | (sigma, w) 759 | | Var id -> 760 | apply_global env sigma (VarRef id) 761 | | Const (p, _) -> 762 | let (sigma, c) = apply_global env sigma (ConstRef p) in 763 | (sigma, c) 764 | | Ind ((ind', n), u) when MutInd.equal ind ind' -> 765 | let mind,_ = Inductive.lookup_mind_specif env.env_tgt (ind',n) in 766 | let e = Environ.nb_rel env.env_tgt in 767 | let mind_t = mkRel (e + mind.mind_ntypes - n) in 768 | let gen, _ = get_ind env (ind',n) in 769 | let mind_t = if gen then mkApp (mind_t, [|mkRel e|]) else mind_t in 770 | (sigma, mind_t) 771 | | Ind (ind, _) -> 772 | let (sigma, c) = apply_global env sigma (IndRef ind) in 773 | (sigma, c) 774 | | Construct (c, _) -> 775 | let (sigma, c) = apply_global env sigma (ConstructRef c) in 776 | (sigma, c) 777 | | Case (ci, r, d, p) -> assert false 778 | | Cast (c, k, t) -> 779 | let (sigma, ce) = otranslate_param env param_env sigma (ind, ind_e) c in 780 | let (sigma, te) = otranslate_param_type env param_env sigma (ind, ind_e) t in 781 | let r = mkCast (ce, k, te) in 782 | (sigma, r) 783 | | _ -> 784 | (sigma, c) 785 | and otranslate_param_type env param_env sigma (ind, ind_e) c = match EConstr.kind sigma c with 786 | | Sort s -> 787 | otranslate_type env sigma c 788 | | Prod (na,t,u) -> 789 | let (sigma, t_) = otranslate_type env sigma t in 790 | let t_ = param_lift param_env t_ in 791 | let is_ind_param = term_finish_in_ind sigma t ind in 792 | let nenv = push_assum na (t, t_) env in 793 | let (sigma, nenv, param_env) = 794 | if not is_ind_param then (sigma, nenv, 1 :: param_env) 795 | else let (sigma, tp) = otranslate_param_type env param_env sigma (ind, ind_e) t in 796 | let assum_env = EConstr.push_rel (LocalAssum (na, tp)) nenv.env_tgt in 797 | let new_env = { nenv with env_tgt = assum_env; } in 798 | (sigma, new_env, 2 :: param_env) 799 | in 800 | let (sigma, uw) = otranslate_param_type nenv param_env sigma (ind, ind_e) u in 801 | let n = if is_ind_param then 3 else 2 in 802 | let uw = Vars.liftn 1 (if is_ind_param then 4 else 3) uw in 803 | let uw = Vars.subst1 (mkApp (mkRel n, [| mkRel (n - 1) |])) uw in 804 | let ctx = param_top_decls nenv is_ind_param in 805 | let ctx = lift_rel_context 1 ctx in 806 | let r = it_mkProd_or_LetIn uw ctx in 807 | (sigma, r) 808 | | _ -> 809 | let (sigma, cr) = otranslate_param env param_env sigma (ind, ind_e) c in 810 | (sigma, mkApp (Vars.lift 1 cr, [| mkRel 1 |])) 811 | 812 | let param_constr err env sigma gen (block, block_e, n) mind_d mind_e one_d one_e = 813 | (*let _, env = extend_inductive env mind_d mind_e in*) 814 | let nblock = Array.length mind_d.mind_packets in 815 | let gen = Option.is_empty err in 816 | let mk_ind n = mkInd (block, nblock - (n + 1)) in 817 | let subst0 = List.init nblock mk_ind in 818 | let map (c, sigma) t = 819 | let t = EConstr.of_constr t in 820 | let t = Vars.substnl subst0 (Environ.nb_rel env.env_src) t in 821 | let param_env = List.init (List.length mind_e.mind_entry_params) (fun i -> 1) in 822 | let (sigma, te) = otranslate_param_type env param_env sigma (block, block_e) t in 823 | 824 | let (sigma, (c_, u)) = Evd.fresh_constructor_instance env.env_tgt sigma ((block_e,n), c) in 825 | let constr = mkConstructU (c_, EInstance.make u) in 826 | 827 | let args = List.init (List.length mind_e.mind_entry_params) (fun i -> mkRel (i + 1)) in 828 | let args = List.rev args in 829 | let n_params = List.length mind_e.mind_entry_params in 830 | let e = n_params + 1 in 831 | let constr = if gen then mkApp (constr, [|mkRel e|]) else constr in 832 | let constr = applist (constr, args) in 833 | let te = Vars.subst1 constr te in 834 | ((succ c, sigma), te) 835 | in 836 | let ((_, sigma), lc) = List.fold_map map (1,sigma) one_e.mind_entry_lc in 837 | (sigma, lc) 838 | 839 | let param_inductive err env sigma (block, block_e, n as total_ind) mind_d mind_e one_d one_e = 840 | let typename = translate_param_name one_e.mind_entry_typename in 841 | let mind_arity_ctxt = List.map EConstr.of_rel_decl one_d.mind_arity_ctxt in 842 | let nindices = List.length one_d.mind_arity_ctxt - List.length mind_d.mind_params_ctxt in 843 | let index_ctxt, _ = List.chop nindices mind_arity_ctxt in 844 | let (sigma, arity_env, arity_ctx') = otranslate_context env sigma index_ctxt in 845 | let gen = Option.is_empty err in 846 | let (sigma, (ind_, u)) = Evd.fresh_inductive_instance env.env_tgt sigma (block_e, n) in 847 | let ind_ = mkIndU (ind_, EInstance.make u) in 848 | let make_arg (n, accu) = function 849 | | LocalAssum _ -> (succ n, mkRel n :: accu) 850 | | LocalDef _ -> (succ n, accu) 851 | in 852 | let (_, args) = List.fold_left make_arg (1,[]) mind_arity_ctxt in 853 | let args = if gen then mkRel (Environ.nb_rel arity_env.env_tgt) :: args else args in 854 | let ind_ = applist (ind_, args) in 855 | let self = LocalAssum (Anonymous, ind_) in 856 | let (sigma, sort) = Evd.fresh_sort_in_family ~rigid:Evd.UnivRigid env.env_tgt sigma InProp in 857 | let arity = it_mkProd_or_LetIn (mkSort sort) (self :: arity_ctx') in 858 | let (sigma, _) = Typing.type_of env.env_tgt sigma arity in 859 | 860 | (*let ext = match env.error with 861 | | None -> GlobGen block_e 862 | | Some exn -> GlobImp (Refmap.singleton exn block_e) 863 | in 864 | let translator = { env.translator with inds = Mindmap.add block ext env.translator.inds } in 865 | let env = { env with translator } in*) 866 | let (sigma, lc) = param_constr err env sigma gen total_ind mind_d mind_e one_d one_e in 867 | let lc = List.map (fun c -> EConstr.to_constr sigma c) lc in 868 | 869 | let consnames = List.map translate_param_name one_e.mind_entry_consnames in 870 | let ind = { one_e with 871 | mind_entry_typename = typename; 872 | mind_entry_arity = EConstr.to_constr sigma arity; 873 | mind_entry_consnames = consnames; 874 | mind_entry_lc = lc; 875 | } in 876 | (sigma, ind) 877 | 878 | let param_mutual_inductive err translator env (block, block_e) mind_d mind_e = 879 | let sigma = Evd.from_env env in 880 | let (sigma, env) = make_context err translator env sigma in 881 | 882 | let of_rel_decl_param_ctxt = List.map EConstr.of_rel_decl mind_d.mind_params_ctxt in 883 | let (sigma, env, _) = otranslate_context env sigma of_rel_decl_param_ctxt in 884 | let inds = List.combine (Array.to_list mind_d.mind_packets) mind_e.mind_entry_inds in 885 | let inds = List.mapi (fun i (l,r) -> (i,l,r)) inds in 886 | let map sigma (n, ind_d, ind_e) = 887 | param_inductive err env sigma (block, block_e, n) mind_d mind_e ind_d ind_e 888 | in 889 | let (sigma, param_inds) = List.fold_map map sigma inds in 890 | 891 | let env_context = EConstr.rel_context env.env_tgt in 892 | let sigma, inds, params = EUtil.retype_inductive env.env_tgt sigma env_context param_inds in 893 | let params = List.map to_local_entry params in 894 | let uctx = UState.context (Evd.evar_universe_context sigma) in 895 | let univs = match mind_e.mind_entry_universes with 896 | | Monomorphic_ind_entry _ -> Monomorphic_ind_entry (Univ.ContextSet.of_context uctx) 897 | | Polymorphic_ind_entry _ -> Polymorphic_ind_entry uctx 898 | | Cumulative_ind_entry _ -> Polymorphic_ind_entry uctx (** FIXME *) 899 | in 900 | let mind = { mind_e with 901 | mind_entry_inds = inds; 902 | mind_entry_params = params; 903 | mind_entry_universes = univs; 904 | } in 905 | mind 906 | 907 | let param_instance_inductive err translator env (name,name_e,name_param) (one_d, n) = 908 | let sigma = Evd.from_env env in 909 | let gen = Option.is_empty err in 910 | 911 | let arity = Declarations.(one_d.mind_arity_ctxt) in 912 | let ctx = List.map EConstr.of_rel_decl arity in 913 | let param_ind = (param_mod, 0) in 914 | let sigma,(param_ind, u) = Evd.fresh_inductive_instance env sigma param_ind in 915 | let param_ind = mkIndU (param_ind, EInstance.make u) in 916 | let args = List.rev (List.init (List.length ctx) (fun i -> mkRel (i + 1))) in 917 | let sigma, (ind, u) = Evd.fresh_inductive_instance env sigma (name, n) in 918 | let ind = mkIndU (ind, EInstance.make u) in 919 | let ty = applist (ind, args) in 920 | let body = mkApp (param_ind, [| ty |]) in 921 | let instance_ty = it_mkProd_or_LetIn body ctx in 922 | let sigma,_ = Typing.type_of env sigma instance_ty in 923 | 924 | let (sigma, cenv) = make_context err translator env sigma in 925 | let (sigma, decl_e) = make_error err env sigma in 926 | 927 | let arity_ctx = List.map EConstr.of_rel_decl one_d.mind_arity_ctxt in 928 | let (sigma, cenv, _) = otranslate_context cenv sigma arity_ctx in 929 | let ctx = EConstr.rel_context cenv.env_tgt in 930 | let e = List.length ctx in 931 | let param_constr = ((param_mod_e, 0), 1) in 932 | let sigma,(param_constr, u) = Evd.fresh_constructor_instance env sigma param_constr in 933 | let param_constr = mkConstructU (param_constr, EInstance.make u) in 934 | let param_constr = mkApp (param_constr, [|mkRel e|]) in 935 | let args = List.rev (List.init (List.length ctx - 1) (fun i -> mkRel (i + 1))) in 936 | let sigma, (ind, u) = Evd.fresh_inductive_instance env sigma (name_e, n) in 937 | let ind = mkIndU (ind, EInstance.make u) in 938 | let ind = if gen then mkApp (ind, [|mkRel (List.length ctx)|]) else ind in 939 | let ty = applist (ind, args) in 940 | let (sigma, typeval) = Evd.fresh_global env sigma typeval_e in 941 | let typeval = EConstr.of_constr typeval in 942 | let def_cons = Array.length one_d.mind_user_lc in 943 | let (sigma, (def, u)) = Evd.fresh_constructor_instance env sigma ((name_e,n), def_cons + 1) in 944 | let def = mkConstructU (def, EInstance.make u) in 945 | let def_args = if gen then mkRel e :: args else args in 946 | let param_ty = mkApp (typeval, [| mkRel e; ty; applist (def, def_args) |]) in 947 | 948 | let sigma, (ind_p, u) = Evd.fresh_inductive_instance env sigma (name_param, n) in 949 | let ind_p = mkIndU (ind_p, EInstance.make u) in 950 | let gen = Option.is_empty err in 951 | let ind_p = if gen then mkApp (ind_p, [|mkRel (List.length ctx + 1)|]) else ind_p in 952 | let args = List.map (fun i -> Vars.lift 1 i) args in 953 | let inner_func = applist (ind_p, args) in 954 | let func = mkLambda (Anonymous, ty, mkApp (inner_func, [| mkRel 1 |])) in 955 | 956 | let body = mkApp (param_constr, [|param_ty; func|]) in 957 | let param_instance = it_mkLambda_or_LetIn body ctx in 958 | let sigma,_ = Typing.type_of env sigma param_instance in 959 | 960 | (sigma, instance_ty, param_instance) 961 | 962 | (* 963 | let catch_inductive err translator env name mind_d = 964 | let sigma = Evd.from_env env in 965 | let (sigma, env) = make_context err translator env sigma in 966 | let n = 0 in 967 | 968 | let one_d = mind_d.mind_packets.(n) in 969 | let nindices = List.length one_d.mind_arity_ctxt - List.length mind_d.mind_params_ctxt in 970 | let mind_arity_ctxt = List.map EConstr.of_rel_decl one_d.mind_arity_ctxt in 971 | let (param, arity) = List.chop nindices mind_arity_ctxt in 972 | let param = List.filter (fun decl -> Rel.Declaration.is_local_assum decl) param in 973 | let sort = Evd.fresh_sort_in_family ~rigid:Evd.UnivRigid env.env_tgt sigma InType in 974 | let (sigma, (ind, u)) = Evd.fresh_inductive_instance env.env_tgt sigma (name, n) in 975 | let ind = mkIndU (ind, EInstance.make u) in 976 | let predicate = it_mkProd_or_LetIn ind arity in 977 | let predicate_args = one_d.mind_nrealargs in 978 | let map n = 979 | () 980 | in 981 | () 982 | *) 983 | 984 | let rec induction_generator sigma params_number constr_ty ind n_ind = 985 | match EConstr.kind sigma constr_ty with 986 | | App (t, args) -> 987 | let _, arity = Array.chop params_number args in 988 | let arity = Array.map (fun a -> Vars.lift 2 a) arity in 989 | mkApp (mkRel 2, Array.append arity [| mkRel 1 |]) 990 | | Ind (name, _) -> 991 | mkApp (mkRel 2, [| mkRel 1 |]) 992 | | Prod (na, t, b) -> 993 | let end_in_ind = term_finish_in_ind_exact sigma t ind n_ind in 994 | let rest = induction_generator sigma params_number b ind n_ind in 995 | let body = 996 | if end_in_ind then 997 | let ty = induction_generator sigma params_number t ind n_ind in 998 | let ty = Vars.liftn 1 2 ty in 999 | let rest = Vars.liftn 4 4 rest in 1000 | let subst = [mkApp (mkRel 3, [| mkRel 2|]); mkRel 4; mkRel 2] in 1001 | let rest = Vars.substnl subst 0 rest in 1002 | mkProd (Anonymous, ty, rest) 1003 | else 1004 | let rest = Vars.liftn 3 4 rest in 1005 | let subst = [(mkApp (mkRel 2, [| mkRel 1 |])); mkRel 3; mkRel 1] in 1006 | let rest = Vars.substnl subst 0 rest in 1007 | rest 1008 | in 1009 | let t = mkProd (na, Vars.lift 2 t, body) in 1010 | t 1011 | | _ -> constr_ty 1012 | 1013 | let dummy_param mind = 1014 | let _,_,l = MutInd.repr3 mind in 1015 | Lib.make_kn (Nameops.add_suffix (Label.to_id l) "_dummy_param") 1016 | 1017 | let rec induction_predicate_gen sigma params_number constr_ty ind n_ind dummy = 1018 | match EConstr.kind sigma constr_ty with 1019 | | Ind _ -> 1020 | dummy 1021 | | App (_, args) -> 1022 | let args = Array.map (fun i -> Vars.lift 1 i) args in 1023 | let _,args = Array.chop params_number args in 1024 | mkApp (dummy, args) 1025 | | Prod (na, t, b) -> 1026 | let bp = induction_predicate_gen sigma params_number b ind n_ind dummy in 1027 | let bp = Vars.liftn 2 3 bp in 1028 | let subst = [mkRel 2; mkRel 1] in 1029 | let bp = Vars.substnl subst 0 bp in 1030 | mkProd (na, Vars.lift 1 t, bp) 1031 | | _ -> constr_ty 1032 | 1033 | let rec induction_predicate_generator sigma params_number constr_ty ind n_ind dummy = 1034 | match EConstr.kind sigma constr_ty with 1035 | | (App _ | Ind _) -> 1036 | mkRel 1 1037 | | Prod (na, t, b) -> 1038 | let end_in_ind = term_finish_in_ind_exact sigma t ind n_ind in 1039 | let bp = induction_predicate_generator sigma params_number b ind n_ind dummy in 1040 | let body = 1041 | if end_in_ind then 1042 | let tp = induction_predicate_gen sigma params_number t ind n_ind dummy in 1043 | let tp = Vars.liftn 3 2 tp in 1044 | let tp = Vars.subst1 (mkRel 3) tp in 1045 | let bp = Vars.liftn 4 4 bp in 1046 | let subst = [mkApp (mkRel 3, [|mkRel 1|]); mkRel 4; mkRel 2] in 1047 | let bp = Vars.substnl subst 0 bp in 1048 | mkLambda (Anonymous, tp, bp) 1049 | else 1050 | let bp = Vars.liftn 3 4 bp in 1051 | let subst = [mkApp (mkRel 2, [|mkRel 1|]); mkRel 3; mkRel 1] in 1052 | Vars.substnl subst 0 bp 1053 | in 1054 | let t = mkLambda (na, Vars.lift 2 t, body) in 1055 | t 1056 | | _ -> constr_ty 1057 | 1058 | let recover_param sigma name predicate term = 1059 | let rec map_binder n term = 1060 | match EConstr.kind sigma term with 1061 | | Ind ((m,_), _) when MutInd.equal name m -> mkRel n 1062 | | App (t, args) when (EConstr.isInd sigma t) && 1063 | MutInd.equal name (fst (fst (EConstr.destInd sigma t))) -> 1064 | mkApp (mkRel n, args) 1065 | | _ -> map_with_binders sigma succ map_binder n term 1066 | in 1067 | map_binder predicate term 1068 | 1069 | 1070 | let source_induction sigma env name mind_d n = 1071 | let one_d = mind_d.mind_packets.(n) in 1072 | 1073 | let nindices = List.length one_d.mind_arity_ctxt - List.length mind_d.mind_params_ctxt in 1074 | let nparams = Declarations.(mind_d.mind_nparams) in 1075 | let mind_arity_ctxt = List.map EConstr.of_rel_decl one_d.mind_arity_ctxt in 1076 | let (arity_ctx, param_ctx) = List.chop nindices mind_arity_ctxt in 1077 | let real_param_ctx = List.filter (fun decl -> Rel.Declaration.is_local_assum decl) param_ctx in 1078 | let (sigma, sort) = Evd.fresh_sort_in_family env.env_tgt sigma InProp in 1079 | 1080 | let (sigma, (ind, u)) = Evd.fresh_inductive_instance env.env_tgt sigma (name, n) in 1081 | let ind = mkIndU (ind, EInstance.make u) in 1082 | let app_args = List.init (List.length one_d.mind_arity_ctxt) (fun i -> mkRel (i + 1)) in 1083 | let app_ind = applist (ind, List.rev app_args) in 1084 | let predicate = it_mkProd_or_LetIn (mkProd (Anonymous, app_ind, (mkSort sort))) arity_ctx in 1085 | let substl_ind = List.init mind_d.mind_ntypes (fun i -> mkInd (name, i)) in 1086 | let decompose_map cty = 1087 | let _, non_param_cty = EConstr.decompose_prod_n_assum sigma nparams cty in 1088 | let non_param_cty = Vars.substnl substl_ind nparams non_param_cty in 1089 | non_param_cty 1090 | in 1091 | let mind_user_lc = Array.to_list one_d.mind_user_lc in 1092 | let mind_user_lc = List.map EConstr.of_constr mind_user_lc in 1093 | let constr_types = List.map decompose_map mind_user_lc in 1094 | let params_args = List.rev (List.init nparams (fun n -> mkRel (n + 2))) in 1095 | let map i constr = 1096 | let constr_ind = induction_generator sigma nparams constr name n in 1097 | let constr_ind = Vars.liftn 1 3 constr_ind in 1098 | let ind_constr = mkConstruct ((name, n), (i + 1)) in 1099 | let constr_constr = Vars.substl [(applist (ind_constr, params_args)); mkRel 1] constr_ind in 1100 | Vars.lift i constr_constr 1101 | in 1102 | let pred_map = List.map_i map 0 constr_types in 1103 | let predicates_ctx = List.map (fun i -> Rel.Declaration.LocalAssum (Anonymous, i)) pred_map in 1104 | 1105 | let n_predicates = List.length predicates_ctx in 1106 | let arity_ctx = Rel.map (fun i -> Vars.lift (n_predicates + 1) i) arity_ctx in 1107 | 1108 | let param_inds = List.init nparams (fun n -> mkRel (n_predicates + nindices + 1 + n + 1)) in 1109 | let param_inds = List.rev param_inds in 1110 | let index_inds = List.rev (List.init nindices (fun n -> mkRel (n + 1))) in 1111 | let full_args_ind = param_inds @ index_inds in 1112 | let ind_cons = applist (ind, full_args_ind) in 1113 | 1114 | let ctxt = Rel.add (Rel.Declaration.LocalAssum 1115 | (Name (Id.of_string "P"), predicate)) real_param_ctx 1116 | in 1117 | let ctxt = List.fold_left (fun acc d -> Rel.add d acc) ctxt predicates_ctx in 1118 | let ctxt = List.fold_left (fun acc d -> Rel.add d acc) ctxt (List.rev arity_ctx) in 1119 | let ctxt = Rel.add (Rel.Declaration.LocalAssum (Anonymous, ind_cons)) ctxt in 1120 | 1121 | let base_instance_name = translate_instance_name Declarations.(one_d.mind_typename) in 1122 | let instance_name = Constant.make1 (Lib.make_kn base_instance_name) in 1123 | let (sigma, (instance_t, u)) = Evd.fresh_constant_instance env.env_src sigma instance_name in 1124 | let instance_t = mkConstU (instance_t, EInstance.make u) in 1125 | let instance_t = applist (instance_t, List.map (Vars.lift 1) full_args_ind) in 1126 | let param_ind = mkApp (mkProj ((Projection.make param_cst false), instance_t), [| mkRel 1 |] ) in 1127 | let ctxt = Rel.add (Rel.Declaration.LocalAssum (Anonymous, param_ind)) ctxt in 1128 | 1129 | let predicate = mkRel (nindices + 2 + n_predicates + 1) in 1130 | let predicate_args = List.init nindices (fun n -> mkRel (n + 3)) in 1131 | let predicate_args = List.rev (mkRel 2 :: predicate_args) in 1132 | let induction_pr = it_mkProd_or_LetIn (applist (predicate, predicate_args)) ctxt in 1133 | induction_pr 1134 | 1135 | let parametric_induction err translator env name mind_d = 1136 | let sigma = Evd.from_env env in 1137 | let (sigma, env) = make_context err translator env sigma in 1138 | 1139 | let n = 0 in 1140 | let one_d = mind_d.mind_packets.(n) in 1141 | let nparams = Declarations.(mind_d.mind_nparams) in 1142 | let nindices = List.length one_d.mind_arity_ctxt - List.length mind_d.mind_params_ctxt in 1143 | let induction_pr = source_induction sigma env name mind_d n in 1144 | 1145 | let sigma,induction_pr_tr = otranslate_type env sigma induction_pr in 1146 | let induction_pr_tr_ctx, _ = EConstr.decompose_prod_assum sigma induction_pr_tr in 1147 | 1148 | let (_,_,l) = MutInd.repr3 name in 1149 | let name_param = Nameops.add_suffix (Label.to_id l) "_param" in 1150 | let name_param = MutInd.make1 (Lib.make_kn name_param) in 1151 | 1152 | let mind_d_param,_ = Inductive.lookup_mind_specif env.env_src (name_param, 0) in 1153 | let one_d_param = mind_d_param.mind_packets.(n) in 1154 | let mind_param = List.init mind_d.mind_ntypes (fun n -> n) in 1155 | let fold_map sigma n = 1156 | let (sigma, (ind, u)) = Evd.fresh_inductive_instance env.env_src sigma (name_param, n) in 1157 | (sigma, mkIndU (ind, EInstance.make u)) 1158 | in 1159 | let sigma, ind_subst = List.fold_map fold_map sigma mind_param in 1160 | 1161 | let ind_param_induction = Nameops.add_suffix one_d.mind_typename "_param_ind" in 1162 | let sigma, (ind_param_induction, u) = 1163 | let cst = (Constant.make1 (Lib.make_kn ind_param_induction)) in 1164 | Evd.fresh_constant_instance env.env_src sigma cst 1165 | in 1166 | let cst = mkConstU (ind_param_induction, EInstance.make u) in 1167 | let n_preds = Array.length one_d.mind_user_lc in 1168 | let params_offset = nindices + n_preds + 3 in 1169 | 1170 | let map m constr_ty = 1171 | let constr_ty = EConstr.of_constr constr_ty in 1172 | let constr_ty = Vars.substnl ind_subst 0 constr_ty in 1173 | let _,constr_ty = EConstr.decompose_prod_n_assum sigma (nparams + 1) constr_ty in 1174 | let ind_pred_gen = induction_predicate_generator in 1175 | let dummy_param_name = MutInd.make1 (dummy_param name) in 1176 | let dummy_term = mkInd (dummy_param_name, 0) in 1177 | let generator_predicates = ind_pred_gen sigma (nparams + 1) constr_ty name_param m dummy_term in 1178 | let generator_predicates = recover_param sigma dummy_param_name 2 generator_predicates in 1179 | let lift = n_preds + nindices + 2 in 1180 | let generator_predicates = Vars.liftn lift 2 generator_predicates in 1181 | Vars.subst1 (mkRel (2 + nindices + n_preds - m)) generator_predicates 1182 | in 1183 | let pred_trans = Array.mapi map one_d_param.mind_user_lc in 1184 | 1185 | let cst_predicate = 1186 | let param_arity_ctx,_ = List.chop (nindices + 1) Declarations.(one_d_param.mind_arity_ctxt) in 1187 | let param_arity_ctx = List.map EConstr.of_rel_decl param_arity_ctx in 1188 | let pind_arity = List.rev (List.init (nindices + 1) (fun n -> mkRel (n + 1))) in 1189 | let pind_param = List.rev (List.init (nparams + 1) (fun n -> mkRel (n + nindices + 2))) in 1190 | let pind = List.nth ind_subst n in 1191 | let pind_arg = applist (pind, pind_param @ pind_arity) in 1192 | let body_predicate = mkLambda (Anonymous, pind_arg, mkRel 0) in 1193 | let predicate = it_mkLambda_or_LetIn body_predicate param_arity_ctx in 1194 | let predicate = Vars.lift 1 predicate in 1195 | let predicate_ctx,_ = EConstr.decompose_lam_assum sigma predicate in 1196 | let predicate_rel = nindices + 3 in 1197 | let body_predicate = applist (mkRel predicate_rel, List.map (Vars.lift 1) pind_arity) in 1198 | it_mkLambda_or_LetIn body_predicate predicate_ctx 1199 | in 1200 | let cst_predicate = Vars.lift (params_offset - 1) cst_predicate in 1201 | let cst_params = Array.init (nparams + 1) (fun n -> mkRel (n + 1 + params_offset)) in 1202 | let cst_arity = Array.init (nindices + 2) (fun n -> mkRel (n + 1)) in 1203 | let () = Array.rev cst_params in 1204 | let () = Array.rev cst_arity in 1205 | let cst_args = Array.(append (append cst_params (cons cst_predicate pred_trans)) cst_arity) in 1206 | let app_cst = mkApp (cst, cst_args) in 1207 | let trans_pred = it_mkLambda_or_LetIn app_cst induction_pr_tr_ctx in 1208 | let e = get_exception env in 1209 | let trans_pred = mkLambda_or_LetIn e trans_pred in 1210 | let sigma,_ = Typing.type_of env.env_src sigma trans_pred in 1211 | (sigma, induction_pr, trans_pred, mkProd_or_LetIn e induction_pr_tr) 1212 | -------------------------------------------------------------------------------- /src/eTranslate.mli: -------------------------------------------------------------------------------- 1 | open Names 2 | open Globnames 3 | 4 | type effect = global_reference option 5 | 6 | exception MissingGlobal of effect * global_reference 7 | exception MissingPrimitive of global_reference 8 | exception MatchEliminationNotSupportedOnTranslation 9 | 10 | type 'a global_translation = 11 | | GlobGen of 'a 12 | (** Implementation generic over the type of exceptions *) 13 | | GlobImp of 'a Refmap.t 14 | (** For every type of exceptions, a specialized implementation. *) 15 | 16 | val get_instance : effect -> 'a global_translation -> bool * 'a 17 | 18 | val instantiate_error : effect -> Environ.env -> Evd.evar_map -> bool -> EConstr.t -> Evd.evar_map * EConstr.t 19 | 20 | type translator = { 21 | refs : global_reference global_translation Cmap.t; 22 | inds : MutInd.t global_translation Mindmap.t; 23 | prefs : global_reference global_translation Cmap.t; 24 | pinds : MutInd.t global_translation Mindmap.t; 25 | wrefs : global_reference global_translation Cmap.t; 26 | winds : MutInd.t global_translation Mindmap.t; 27 | paramrefs : global_reference global_translation Mindmap.t; 28 | paraminds : MutInd.t global_translation Mindmap.t; 29 | } 30 | val param_mod: Names.MutInd.t 31 | val param_mod_e: Names.MutInd.t 32 | val param_cst: Names.Constant.t 33 | val param_cst_e: Names.Constant.t 34 | val tm_exception: Names.Constant.t 35 | val tm_exception_e: Names.Constant.t 36 | val tm_raise: Names.Constant.t 37 | val tm_raise_e: Names.Constant.t 38 | 39 | val translate : 40 | effect -> translator -> Environ.env -> Evd.evar_map -> EConstr.t -> Evd.evar_map * EConstr.t 41 | 42 | val translate_type : 43 | effect -> translator -> Environ.env -> Evd.evar_map -> EConstr.t -> Evd.evar_map * EConstr.t 44 | 45 | val translate_inductive : 46 | effect -> translator -> Environ.env -> MutInd.t -> Declarations.mutual_inductive_body -> 47 | Entries.mutual_inductive_entry -> Entries.mutual_inductive_entry 48 | 49 | val param_mutual_inductive : 50 | effect -> translator -> Environ.env -> MutInd.t * MutInd.t -> Declarations.mutual_inductive_body -> 51 | Entries.mutual_inductive_entry -> Entries.mutual_inductive_entry 52 | 53 | val param_instance_inductive : 54 | effect -> translator -> Environ.env -> MutInd.t * MutInd.t * MutInd.t-> 55 | Declarations.one_inductive_body * int -> Evd.evar_map * EConstr.t * EConstr.t 56 | 57 | val parametric_induction : 58 | effect -> translator -> Environ.env -> MutInd.t -> Declarations.mutual_inductive_body -> 59 | Evd.evar_map * EConstr.t * EConstr.t * EConstr.t 60 | -------------------------------------------------------------------------------- /src/eUtil.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open CErrors 3 | open Context 4 | open Rel.Declaration 5 | open Names 6 | open Term 7 | open EConstr 8 | open Declarations 9 | open Entries 10 | open Environ 11 | 12 | let sign_level env evd sign = 13 | let fold d (lev, env) = match d with 14 | | LocalDef _ -> lev, push_rel d env 15 | | LocalAssum (_, t) -> 16 | let s = Retyping.get_type_of env evd (EConstr.of_constr t) in 17 | let s = destSort evd (Reductionops.clos_whd_flags CClosure.all env evd s) in 18 | let u = univ_of_sort (ESorts.kind evd s) in 19 | (Univ.sup u lev, push_rel d env) 20 | in 21 | fst (List.fold_right fold sign (Univ.type0m_univ, env)) 22 | 23 | let extract_level env evd min tys = 24 | let map ty = 25 | let ctx, concl = Reduction.dest_prod_assum env ty in 26 | sign_level env evd (LocalAssum (Anonymous, concl) :: ctx) 27 | in 28 | let sorts = List.map map tys in 29 | List.fold_left Univ.sup min sorts 30 | 31 | let is_impredicative env u = 32 | u = Prop Null || (is_impredicative_set env && u = Prop Pos) 33 | 34 | let is_flexible_sort evd u = 35 | match Univ.Universe.level u with 36 | | Some l -> Evd.is_flexible_level evd l 37 | | None -> false 38 | 39 | let inductive_levels env sigma arities inds = 40 | let destarities = List.map (fun x -> x, Reduction.dest_arity env x) arities in 41 | let levels = List.map (fun (x,(ctx,a)) -> 42 | if a = Prop Null then None 43 | else Some (univ_of_sort a)) destarities 44 | in 45 | let map tys (arity, (ctx, du)) = 46 | let len = List.length tys in 47 | let minlev = Sorts.univ_of_sort du in 48 | let minlev = 49 | if len > 1 && not (is_impredicative env du) then 50 | Univ.sup minlev Univ.type0_univ 51 | else minlev 52 | in 53 | let minlev = 54 | (** Indices contribute. *) 55 | if Indtypes.is_indices_matter () && List.length ctx > 0 then ( 56 | let ilev = sign_level env sigma ctx in 57 | Univ.sup ilev minlev) 58 | else minlev 59 | in 60 | let clev = extract_level env sigma minlev tys in 61 | (clev, minlev, len) 62 | in 63 | let cstrs_levels, min_levels, sizes = CList.split3 (List.map2 map inds destarities) in 64 | (* Take the transitive closure of the system of constructors *) 65 | (* level constraints and remove the recursive dependencies *) 66 | let levels' = Universes.solve_constraints_system (Array.of_list levels) 67 | (Array.of_list cstrs_levels) (Array.of_list min_levels) 68 | in 69 | let sigma, arities = 70 | CList.fold_left3 (fun (sigma, arities) cu (arity,(ctx,du)) len -> 71 | if is_impredicative env du then 72 | (** Any product is allowed here. *) 73 | sigma, arity :: arities 74 | else (** If in a predicative sort, or asked to infer the type, 75 | we take the max of: 76 | - indices (if in indices-matter mode) 77 | - constructors 78 | - Type(1) if there is more than 1 constructor 79 | *) 80 | (** Constructors contribute. *) 81 | let sigma = 82 | if Sorts.is_set du then 83 | if not (Evd.check_leq sigma cu Univ.type0_univ) then 84 | raise (Indtypes.InductiveError Indtypes.LargeNonPropInductiveNotInType) 85 | else sigma 86 | else sigma 87 | (* Evd.set_leq_sort env sigma (Type cu) du *) 88 | in 89 | let sigma = 90 | if len >= 2 && Univ.is_type0m_univ cu then 91 | (** "Polymorphic" type constraint and more than one constructor, 92 | should not land in Prop. Add constraint only if it would 93 | land in Prop directly (no informative arguments as well). *) 94 | Evd.set_leq_sort env sigma (Prop Pos) du 95 | else sigma 96 | in 97 | let duu = Sorts.univ_of_sort du in 98 | let sigma = 99 | if not (Univ.is_small_univ duu) && Univ.Universe.equal cu duu then 100 | if is_flexible_sort sigma duu && not (Evd.check_leq sigma Univ.type0_univ duu) then 101 | Evd.set_eq_sort env sigma (Prop Null) du 102 | else sigma 103 | else Evd.set_eq_sort env sigma (Type cu) du 104 | in 105 | (sigma, arity :: arities)) 106 | (sigma, []) (Array.to_list levels') destarities sizes 107 | in 108 | (sigma, List.rev arities) 109 | 110 | let check_type env sigma c t = 111 | let evdref = ref sigma in 112 | let () = Typing.e_check env evdref c t in 113 | !evdref 114 | 115 | let retype_context env sigma ctx = 116 | let fold decl (env, sigma) = match decl with 117 | | LocalAssum (na, t) -> 118 | let (sigma, _) = Typing.type_of env sigma t in 119 | (EConstr.push_rel decl env, sigma) 120 | | LocalDef (na, b, t) -> 121 | let (sigma, _) = Typing.type_of env sigma t in 122 | let sigma = check_type env sigma b t in 123 | (EConstr.push_rel decl env, sigma) 124 | in 125 | let (_, sigma) = List.fold_right fold ctx (env, sigma) in 126 | sigma 127 | 128 | (** Infer the universe constraints for constructors *) 129 | let retype_inductive env sigma params inds = 130 | let env = Environ.pop_rel_context (Environ.nb_rel env) env in 131 | let sigma = retype_context env sigma params in 132 | let mk_arities sigma ind = 133 | let arity = it_mkProd_or_LetIn (EConstr.of_constr ind.mind_entry_arity) params in 134 | let (sigma, _) = Typing.type_of env sigma arity in 135 | (sigma, arity) 136 | in 137 | let (sigma, extarities) = List.fold_map mk_arities sigma inds in 138 | let fold env c ind = EConstr.push_rel (LocalAssum (Name ind.mind_entry_typename, c)) env in 139 | let env = List.fold_left2 fold env extarities inds in 140 | let env = EConstr.push_rel_context params env in 141 | let fold sigma ind = 142 | let fold sigma c = 143 | let (sigma, _) = Typing.type_of env sigma (EConstr.of_constr c) in 144 | sigma 145 | in 146 | let sigma = List.fold_left fold sigma ind.mind_entry_lc in 147 | (sigma, ind.mind_entry_lc) 148 | in 149 | let sigma, constructors = List.fold_map fold sigma inds in 150 | let arities = List.map (fun ind -> ind.mind_entry_arity) inds in 151 | let (sigma, arities) = inductive_levels env sigma arities constructors in 152 | let params = List.map (fun d -> EConstr.to_rel_decl sigma d) params in 153 | let sigma, nf = Evarutil.nf_evars_and_universes sigma in 154 | let map ind arity = { ind with 155 | mind_entry_arity = nf arity; 156 | mind_entry_lc = List.map nf ind.mind_entry_lc; 157 | } in 158 | let inds = List.map2 map inds arities in 159 | let params = Rel.map nf params in 160 | sigma, inds, params 161 | 162 | open Term 163 | 164 | let detype_param = 165 | function 166 | | LocalAssum (Name id, p) -> id, LocalAssumEntry p 167 | | LocalDef (Name id, p,_) -> id, LocalDefEntry p 168 | | _ -> anomaly (Pp.str "Unnamed inductive local variable.") 169 | 170 | (* Replace 171 | 172 | Var(y1)..Var(yq):C1..Cq |- Ij:Bj 173 | Var(y1)..Var(yq):C1..Cq; I1..Ip:B1..Bp |- ci : Ti 174 | 175 | by 176 | 177 | |- Ij: (y1..yq:C1..Cq)Bj 178 | I1..Ip:(B1 y1..yq)..(Bp y1..yq) |- ci : (y1..yq:C1..Cq)Ti[Ij:=(Ij y1..yq)] 179 | *) 180 | 181 | let abstract_inductive nparams inds = 182 | (* To be sure to be the same as before, should probably be moved to process_inductive *) 183 | let params' = let (_,arity,_,_,_) = List.hd inds in 184 | let (params,_) = decompose_prod_n_assum nparams arity in 185 | List.map detype_param params 186 | in 187 | let ind'' = 188 | List.map 189 | (fun (a,arity,template,c,lc) -> 190 | let _, short_arity = decompose_prod_n_assum nparams arity in 191 | let shortlc = 192 | List.map (fun c -> snd (decompose_prod_n_assum nparams c)) lc in 193 | { mind_entry_typename = a; 194 | mind_entry_arity = short_arity; 195 | mind_entry_template = template; 196 | mind_entry_consnames = c; 197 | mind_entry_lc = shortlc }) 198 | inds 199 | in (params',ind'') 200 | 201 | let refresh_polymorphic_type_of_inductive (_,mip) = 202 | match mip.mind_arity with 203 | | RegularArity s -> s.mind_user_arity, false 204 | | TemplateArity ar -> 205 | let ctx = List.rev mip.mind_arity_ctxt in 206 | mkArity (List.rev ctx, Type ar.template_level), true 207 | 208 | let process_inductive mib = 209 | let nparams = Context.Rel.length mib.mind_params_ctxt in 210 | let ind_univs = match mib.mind_universes with 211 | | Monomorphic_ind ctx -> Monomorphic_ind_entry ctx 212 | | Polymorphic_ind auctx -> 213 | let auctx = Univ.AUContext.repr auctx in 214 | Polymorphic_ind_entry auctx 215 | | Cumulative_ind cumi -> 216 | let auctx = Univ.ACumulativityInfo.univ_context cumi in 217 | let auctx = Univ.AUContext.repr auctx in 218 | Cumulative_ind_entry (Univ.CumulativityInfo.from_universe_context auctx) 219 | in 220 | let map mip = 221 | let arity, template = refresh_polymorphic_type_of_inductive (mib,mip) in 222 | (mip.mind_typename, 223 | arity, template, 224 | Array.to_list mip.mind_consnames, 225 | Array.to_list mip.mind_user_lc) 226 | in 227 | let inds = Array.map_to_list map mib.mind_packets in 228 | let (params', inds') = abstract_inductive nparams inds in 229 | let record = match mib.mind_record with 230 | | Some (Some (id, _, _)) -> Some (Some id) 231 | | Some None -> Some None 232 | | None -> None 233 | in 234 | { mind_entry_record = record; 235 | mind_entry_finite = mib.mind_finite; 236 | mind_entry_params = params'; 237 | mind_entry_inds = inds'; 238 | mind_entry_private = mib.mind_private; 239 | mind_entry_universes = ind_univs 240 | } 241 | 242 | let primitive_record mind = 243 | match mind.mind_record with 244 | | Some (Some _) -> true 245 | | _ -> false 246 | 247 | 248 | -------------------------------------------------------------------------------- /src/eUtil.mli: -------------------------------------------------------------------------------- 1 | open Entries 2 | open Declarations 3 | open Environ 4 | open Evd 5 | 6 | val retype_inductive : 7 | env -> evar_map -> EConstr.rel_context -> 8 | one_inductive_entry list -> 9 | evar_map * one_inductive_entry list * Context.Rel.t 10 | 11 | val process_inductive : mutual_inductive_body -> mutual_inductive_entry 12 | 13 | val primitive_record : mutual_inductive_body -> bool 14 | 15 | -------------------------------------------------------------------------------- /src/exception.mlpack: -------------------------------------------------------------------------------- 1 | EUtil 2 | ETranslate 3 | EPlugin 4 | G_exception 5 | -------------------------------------------------------------------------------- /src/g_exception.ml4: -------------------------------------------------------------------------------- 1 | open Stdarg 2 | open Ltac_plugin.Extraargs 3 | 4 | DECLARE PLUGIN "exception" 5 | 6 | let wit_lconstr = Obj.magic wit_lconstr 7 | (** FUCK YOU API *) 8 | 9 | VERNAC COMMAND EXTEND EffectTranslation CLASSIFIED AS SIDEFF 10 | | [ "Effect" "Translate" global(gr) ] -> 11 | [ EPlugin.translate gr ] 12 | | [ "Effect" "Translate" global(gr) "as" ne_ident_list(names) ] -> 13 | [ EPlugin.translate ~names gr ] 14 | | [ "Effect" "Translate" global(gr) "using" global(exn) ] -> 15 | [ EPlugin.translate ~exn gr ] 16 | 17 | | [ "Effect" "List" "Translate" global_list(gr) ] -> 18 | [ EPlugin.list_translate gr ] 19 | | [ "Effect" "List" "Translate" global_list(gr) "using" global(exn) ] -> 20 | [ EPlugin.list_translate ~exn gr ] 21 | 22 | END 23 | 24 | let classify_impl _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) 25 | 26 | VERNAC COMMAND EXTEND EffectImplementation CLASSIFIED BY classify_impl 27 | | [ "Effect" "Definition" ident(id) ":" lconstr(typ) ] -> 28 | [ EPlugin.implement id typ ] 29 | | [ "Effect" "Definition" ident(id) ":" lconstr(typ) "using" reference(exn) ] -> 30 | [ EPlugin.implement ~exn id typ ] 31 | 32 | END 33 | 34 | -------------------------------------------------------------------------------- /tests/Makefile: -------------------------------------------------------------------------------- 1 | ifeq "$(COQBIN)" "" 2 | COQBIN=$(dir $(shell which coqtop))/ 3 | endif 4 | 5 | all: $(patsubst %.v,%.v.log,$(wildcard *.v)) 6 | 7 | %.v.log: %.v 8 | $(COQBIN)coqtop -batch -I ../src -Q ../theories Weakly -lv $< > $@ 9 | if [ $$? = 0 ]; then \ 10 | echo " $<... OK"; \ 11 | else \ 12 | echo " $<... FAIL!"; \ 13 | fi; \ 14 | 15 | clean: 16 | rm -f *.log 17 | -------------------------------------------------------------------------------- /tests/list_theorem.v: -------------------------------------------------------------------------------- 1 | Require Import Weakly.Effects. 2 | 3 | Inductive nat@{i} : Type@{i} := 4 | O : nat | S : nat -> nat. 5 | 6 | Notation "0" := O. 7 | 8 | Inductive le : nat -> nat -> Prop := 9 | le_00 : le 0 0 10 | | le_0S : forall n, le 0 (S n) 11 | | le_S : forall n m : nat, le n m -> le (S n) (S m). 12 | 13 | Infix "<=" := le. 14 | 15 | Definition lt n m := S n <= m. 16 | 17 | Infix "<" := lt. 18 | 19 | Definition gt (n m:nat) := m < n. 20 | 21 | Infix ">" := gt. 22 | 23 | Definition le_S_n : forall n m : nat, S n <= S m -> n <= m. 24 | Proof. 25 | intros n m e. inversion e. assumption. 26 | Defined. 27 | 28 | Open Scope list. 29 | 30 | (* Define the translation of inductive types and some definitions *) 31 | 32 | Effect List Translate nat list False le lt gt eq not and or False_ind. 33 | Effect List Translate eq_ind eq_rect True eq_sym eq_ind_r le_ind. 34 | 35 | Scheme eqᵒ_rect := Induction for eqᵒ Sort Type. 36 | Scheme eqᵒ_ind := Induction for eqᵒ Sort Prop. 37 | Scheme listᵒ_rect := Induction for listᵒ Sort Type. 38 | Scheme listᵒ_ind := Induction for listᵒ Sort Prop. 39 | Scheme natᵒ_rect := Induction for natᵒ Sort Type. 40 | Scheme natᵒ_ind := Induction for natᵒ Sort Prop. 41 | 42 | Scheme leᵒ_ind := Induction for leᵒ Sort Prop. 43 | 44 | Effect List Translate list_rect nat_rect. 45 | 46 | Class ParamInd (A: Type) `{Param A} := { 47 | param_correct: forall e, param (raise A e) -> False 48 | }. 49 | 50 | Effect List Translate ParamInd param_correct. 51 | 52 | (* Define catch eliminators and parametric elimnators *) 53 | 54 | Effect Definition list_catch : forall A (P : list A -> Type), 55 | P nil -> (forall (a : A) (l : list A), P l -> P (a :: l)) -> (forall e, P (raise _ e)) -> forall l : list A, P l. 56 | Proof. 57 | cbn; intros; induction l; auto. 58 | Defined. 59 | 60 | Effect Definition list_catch_prop : forall A (P : list A -> Prop), 61 | P nil -> (forall (a : A) (l : list A), P l -> P (a :: l)) -> (forall e, P (raise _ e)) -> forall l : list A, P l. 62 | Proof. 63 | cbn; intros; induction l; auto. 64 | Defined. 65 | 66 | Effect Definition param_list_cons : forall A a (l:list A), param (cons a l) -> param l. 67 | Proof. 68 | cbn. intros. inversion H. auto. 69 | Defined. 70 | 71 | Effect Definition ParamIndList_ : forall A e, param (raise (list A) e) -> False. 72 | Proof. 73 | intros E A e H. inversion H. 74 | Defined. 75 | 76 | Instance ParamIndList A : ParamInd (list A). 77 | econstructor. apply ParamIndList_. 78 | Defined. 79 | 80 | Definition list_ind A (P : list A -> Prop) : 81 | P nil -> (forall (a : A) (l : list A), P l -> P (a :: l)) -> forall l : list A, param l -> P l. 82 | Proof. 83 | intros Pnil Pcons l; induction l using list_catch_prop. 84 | - intro. exact Pnil. 85 | - intros param_al. exact (Pcons a l (IHl (param_list_cons _ _ _ param_al))). 86 | - intros param_e. destruct (param_correct e param_e). 87 | Defined. 88 | 89 | Effect Definition nat_catch : forall (P : nat -> Type), 90 | P 0 -> (forall n, P n -> P (S n)) -> (forall e, P (raise _ e)) -> forall n, P n. 91 | Proof. 92 | cbn; intros; induction n; auto. 93 | Defined. 94 | 95 | (* Define propositional laws on eliminators *) 96 | 97 | Effect Definition list_catch_nil_eq : forall A (P : list A -> Type) Pnil Pcons Praise, 98 | list_catch A P Pnil Pcons Praise nil = Pnil. 99 | Proof. 100 | reflexivity. 101 | Defined. 102 | 103 | Effect Definition list_catch_cons_eq : forall A (P : list A -> Type) Pnil Pcons Praise a l, 104 | list_catch A P Pnil Pcons Praise (cons a l) = Pcons a l (list_catch A P Pnil Pcons Praise l). 105 | Proof. 106 | reflexivity. 107 | Defined. 108 | 109 | Effect Definition list_catch_raise_eq : forall A (P : list A -> Type) Pnil Pcons Praise e, 110 | list_catch A P Pnil Pcons Praise (raise _ e) = Praise e. 111 | Proof. 112 | reflexivity. 113 | Defined. 114 | 115 | Effect Definition list_rect_raise_eq : forall A (P : list A -> Type) Pnil Pcons e, 116 | list_rect P Pnil Pcons (raise _ e) = raise _ e. 117 | Proof. 118 | reflexivity. 119 | Defined. 120 | 121 | Effect Definition nat_catch_0_eq : forall (P : nat -> Type) P0 PS Praise, 122 | nat_catch P P0 PS Praise 0 = P0. 123 | Proof. 124 | reflexivity. 125 | Defined. 126 | 127 | Effect Definition nat_catch_S_eq : forall (P : nat -> Type) P0 PS Praise n, 128 | nat_catch P P0 PS Praise (S n) = PS n (nat_catch P P0 PS Praise n). 129 | Proof. 130 | reflexivity. 131 | Defined. 132 | 133 | Effect Definition nat_catch_raise_eq : forall (P : nat -> Type) P0 PS Praise e, 134 | nat_catch P P0 PS Praise (raise _ e) = Praise e. 135 | Proof. 136 | reflexivity. 137 | Defined. 138 | 139 | 140 | (* Now comes the real work in the coq/rett*) 141 | 142 | Definition length {A} (l: list A) : nat := list_rect (fun _ => nat) 0 (fun _ _ n => S n) l. 143 | 144 | (* Note that contrarily to the example in the paper, we define head and tail functions parametric in the error they raise *) 145 | 146 | Definition head {A} (l: list A) e : A := list_rect (fun _ => A) (raise _ e) (fun a _ _ => a) l. 147 | 148 | Definition tail {A} (l: list A) e : list A := list_rect (fun _ => list A) (raise _ e) (fun _ l _ => l) l. 149 | 150 | Hint Unfold length. 151 | 152 | (* we can translate the definitions to check they are well-defined *) 153 | 154 | Effect List Translate length tail head. 155 | 156 | (* Expected theorem *) 157 | 158 | Lemma nil_not_raise: forall A e, @nil A <> raise _ e. 159 | Proof. 160 | intros A e. 161 | assert (forall l', @nil A = l' -> (list_catch _ (fun _ => Prop) True (fun _ _ _ => False) (fun _ => False) l')). 162 | - intros l' eq. induction eq. 163 | rewrite list_catch_nil_eq. exact I. 164 | - intro eq. specialize (H (raise _ e) eq). 165 | rewrite list_catch_raise_eq in H. exact H. 166 | Defined. 167 | 168 | (* we can also translate the theorem to check it is well-defined *) 169 | 170 | Effect Translate nil_not_raise. 171 | 172 | Lemma cons_not_raise: forall A (l: list A) a e, 173 | (cons a l) <> raise _ e. 174 | Proof. 175 | intros A l a e. 176 | assert (forall l', (cons a l) = l' -> (list_catch _ (fun _ => Prop) False (fun _ _ _ => True) (fun _ => False) l')). 177 | - intros l' eq. induction eq. rewrite list_catch_cons_eq. exact I. 178 | - intro eq. specialize (H (raise _ e) eq). rewrite list_catch_raise_eq in H. exact H. 179 | Defined. 180 | 181 | Effect Translate cons_not_raise. 182 | 183 | Lemma raise_not_leq : forall (n:nat) e, 184 | n <= raise nat e -> False. 185 | Proof. 186 | intros n e leq. 187 | assert (forall n', n <= n' -> (nat_catch (fun _ => Prop) True (fun _ _ => True) (fun _ => False) n')). 188 | - clear leq e. intros n' leq. induction leq. rewrite nat_catch_0_eq. exact I. 189 | rewrite nat_catch_S_eq. exact I. rewrite nat_catch_S_eq. exact I. 190 | - specialize (H (raise _ e) leq). 191 | rewrite nat_catch_raise_eq in H. exact H. 192 | Defined. 193 | 194 | Effect Translate raise_not_leq. 195 | 196 | Lemma S_not_zero : forall (n:nat), 197 | S n = 0 -> False. 198 | Proof. 199 | intros n eq. 200 | assert (forall n, 0 = n -> (nat_catch (fun _ => Prop) True (fun _ _ => False) (fun _ => False) n)). 201 | - clear n eq. intros n eq. induction eq. rewrite nat_catch_0_eq. exact I. 202 | - specialize (H (S n) (eq_sym eq)). 203 | rewrite nat_catch_S_eq in H. exact H. 204 | Defined. 205 | 206 | Effect Translate S_not_zero. 207 | 208 | Effect Definition le_S_n' : forall n m : nat, S n <= S m -> n <= m. 209 | intros. inversion H. auto. 210 | Defined. 211 | 212 | Lemma non_empty_list_distinct_error: forall A n e (l: list A), 213 | n <= length l -> l <> raise _ e. 214 | Proof. 215 | intros A n e l. induction l using list_catch_prop ; cbn. 216 | - intros. apply nil_not_raise. 217 | - intros. apply cons_not_raise. 218 | - intros H. unfold length in H. rewrite list_rect_raise_eq in H. 219 | compute in H. destruct (raise_not_leq _ _ H). 220 | Defined. 221 | 222 | Effect Translate non_empty_list_distinct_error. 223 | 224 | Lemma onebiggerzero : S 0 <= 0 -> False. 225 | assert (forall n m, n <= m -> (nat_catch (fun _ => Prop) True (fun _ _ => m = 0 -> False) (fun _ => m = 0) n)). 226 | - intros n m leq. induction leq. rewrite nat_catch_0_eq. exact I. 227 | rewrite nat_catch_0_eq. exact I. 228 | rewrite nat_catch_S_eq. intro e. induction (S_not_zero _ e). 229 | - intro leq. specialize (H (S 0) 0 leq). 230 | rewrite nat_catch_S_eq in H. exact (H eq_refl). 231 | Defined. 232 | 233 | Effect Translate onebiggerzero. 234 | 235 | Lemma non_empty_list_distinct_tail_error: forall A e (l: list A), 236 | length l > 0 -> tail l e <> raise _ e. 237 | Proof. 238 | intros A e l; induction l using list_catch_prop; cbn. 239 | - intro absurd; induction (onebiggerzero absurd). 240 | - intros Hlength eq. apply le_S_n' in Hlength. eapply raise_not_leq. 241 | rewrite eq in Hlength. 242 | rewrite list_rect_raise_eq in Hlength. exact Hlength. 243 | - intros Hlength. unfold length in Hlength. rewrite list_rect_raise_eq in Hlength. 244 | induction (raise_not_leq _ _ Hlength). 245 | Defined. 246 | 247 | Effect Translate non_empty_list_distinct_tail_error. 248 | 249 | (* Check that proving with raise is not allowed *) 250 | Definition non_valid_theorem: forall A e (l: list A), 251 | length l > 0 -> tail l e = raise _ e := fun A e => raise _ e. 252 | Fail Effect Translate non_valid_theorem. 253 | 254 | Definition list_param_deep: forall {A} {H: Param A} (l: list A), Prop := 255 | fun A H => list_catch A (fun _ : list A => Prop) 256 | True 257 | (fun (a : A) (_ : list A) (lind : Prop) => param a /\ lind) 258 | (fun _ : Exception => False). 259 | 260 | Effect Translate list_param_deep. 261 | 262 | Lemma head_empty_list_no_error: forall A `{ParamInd A} 263 | e (l: list A), 264 | length l > 0 -> list_param_deep l -> head l e <> raise _ e. 265 | Proof. 266 | intros A A_param A_paramind e l. induction l using list_catch_prop. 267 | - intro absurd; induction (onebiggerzero absurd). 268 | - intros Hlength Hl. unfold list_param_deep in Hl. 269 | rewrite list_catch_cons_eq in Hl. cbn in *. 270 | destruct Hl as [Ha _]. intro eq. rewrite eq in Ha. apply (param_correct e Ha). 271 | - intros. unfold length in H. rewrite list_rect_raise_eq in H. compute in H. 272 | destruct (raise_not_leq _ _ H). 273 | Defined. 274 | 275 | Effect Translate head_empty_list_no_error. -------------------------------------------------------------------------------- /theories/Effects.v: -------------------------------------------------------------------------------- 1 | 2 | Declare ML Module "exception". 3 | 4 | Set Universe Polymorphism. 5 | Set Primitive Projections. 6 | 7 | Inductive any@{i} : Type@{i} := Any. 8 | 9 | Cumulative Inductive type@{i j} (E : Type@{i}) : Type := 10 | | TypeVal : forall (A : Type@{j}), (E -> A) -> type E 11 | | TypeErr : E -> type E. 12 | 13 | Definition El@{i j} {E : Type@{i}} (A : type@{i j} E) : Type@{j} := 14 | match A with 15 | | TypeVal _ A _ => A 16 | | TypeErr _ e => any@{j} 17 | end. 18 | 19 | Definition Err@{i j} {E : Type@{i}} (A : type@{i j} E) : E -> El@{i j} A := 20 | match A return E -> El A with 21 | | TypeVal _ _ e => e 22 | | TypeErr _ _ => fun _ => Any 23 | end. 24 | 25 | Definition Typeᵉ@{i j k} (E : Type@{i}) : type@{i k} E := 26 | TypeVal E (type@{i j} E) (TypeErr E). 27 | 28 | Definition Propᵉ@{i j} (E: Type@{i}): type@{i j} E := 29 | TypeVal E Prop (fun _ => True). 30 | 31 | Arguments Typeᵉ {_}. 32 | 33 | Definition Prodᵉ@{i j k l} (E : Type@{i}) (A : Type@{j}) 34 | (B : A -> type@{i k} E) : type@{i l} E := 35 | TypeVal E (forall x : A, El (B x)) (fun e x => Err (B x) e). 36 | 37 | (** Special handling of the Prop sort *) 38 | 39 | Cumulative Inductive prop@{i} (E : Type@{i}) : Type := 40 | | pTypeVal : forall (A : Prop), (E -> A) -> prop E 41 | | pTypeErr : E -> prop E. 42 | 43 | (* 44 | Definition Propᵉ@{i k} (E : Type@{i}) := TypeVal@{i k} E (prop E) (pTypeErr E). 45 | *) 46 | 47 | Definition pEl@{i} {E : Type@{i}} (A : prop E) : Prop:= 48 | match A with 49 | | pTypeVal _ A _ => A 50 | | pTypeErr _ e => True 51 | end. 52 | 53 | Axiom Exception: Type. 54 | Definition Exceptionᵉ (E: Type): type E := TypeVal E E (fun e => e). 55 | Axiom raise: forall (A: Type), Exception -> A. 56 | Definition raiseᵉ (E: Type) (A: @El E (@Typeᵉ E)) (e: @El E (Exceptionᵉ E)) := Err A e. 57 | 58 | Inductive Falseᵉ: Prop :=. 59 | 60 | Set Primitive Projections. 61 | Class Param (A: Type) := { 62 | param: A -> Prop; 63 | }. 64 | 65 | Class Paramᵉ (E: Type) (A: @El E (@Typeᵉ E)) := { 66 | paramᵉ: @El E A -> Prop; 67 | }. 68 | Unset Primitive Projections. 69 | 70 | (** 71 | Providing Exception and raise construction to work on the source theory. 72 | This terms only reify the underlying exceptinal Type 73 | *) 74 | 75 | (******************************) 76 | (*** Test handling of sorts ***) 77 | (******************************) 78 | 79 | (* 80 | Module Test. 81 | Set Universe Polymorphism. 82 | Inductive sort@{i j} (E : Type@{i}) : Prop := 83 | | sortType : forall (A : Type@{j}), (E -> A) -> sort E 84 | | sortProp : forall (A : Prop), (E -> A) -> sort E 85 | | sortErr : E -> sort E. 86 | Print sort. 87 | Definition type@{i j} (E: Type@{i}) : Type@{j}. 88 | Proof. exact (sort@{i j} E). Defined. 89 | 90 | Definition sTypeVal@{i j} (E: Type@{i}) (A: Type@{j}) (f: E -> A): type@{i j} E := 91 | sortType E A f. Print sTypeVal. 92 | Definition sTypeErr@{i j} (E: Type@{i}) (e: E): type@{i j} E := 93 | sortErr E e. 94 | 95 | Definition prop@{i} (E: Type@{i}) : Prop := 96 | sort@{i Set} E. 97 | Definition sPropVal@{i} (E: Type@{i}) (A: Prop) (f: E -> A): type@{i Set} E := 98 | sortType E A f. Print sPropVal. 99 | Definition sPropErr@{i j} (E: Type@{i}) (e: E): type@{i Set} E := 100 | sortErr E e. 101 | 102 | Definition sEl@{i j} {E : Type@{i}} (A : type@{i j} E) : Type@{j} := 103 | match A with 104 | | sortType _ A _ => A 105 | | sortProp _ _ _ => any@{j} 106 | | sortErr _ _ => any@{j} 107 | end. 108 | 109 | Definition sErr@{i j} {E : Type@{i}} (A : sort@{i j} E) : E -> sEl@{i j} A := 110 | match A return E -> sEl A with 111 | | sTypeVal _ _ e => e 112 | | sPropVal _ _ _ => fun _ => Any 113 | | sSortErr _ _ => fun _ => Any 114 | end. 115 | 116 | Definition sType@{i j k} {E : Type@{i}} : sort@{i k} E := 117 | sTypeVal E (sort@{i j} E) (sSortErr E). 118 | 119 | (** Prop related *) 120 | Definition spEl@{i} {E : Type@{i}} (A: sort@{i Set} E) : Prop:= 121 | match A with 122 | | sTypeVal _ _ _ => True 123 | | sPropVal _ A _ => A 124 | | sSortErr _ _ => True 125 | end. 126 | 127 | Definition spErr@{i j} {E : Type@{i}} (A : sort@{i Set} E) : E -> spEl@{i} A := 128 | match A return E -> spEl A with 129 | | sTypeVal _ _ e => fun _ => I 130 | | sPropVal _ _ e => e 131 | | sSortErr _ _ => fun _ => I 132 | end. 133 | 134 | Definition sProp@{i j} {E : Type@{i}} : sort@{i j} E := 135 | sTypeVal E (sort@{i Set} E) (PropErr E). 136 | 137 | End Test. 138 | *) 139 | 140 | (***************************) 141 | (** New handling of sorts **) 142 | (***************************) 143 | 144 | Module NewExc. 145 | Set Universe Polymorphism. 146 | Cumulative Inductive sort@{i j} (E : Type@{i}) : Type := 147 | | sortType : forall (A : Type@{j}), (E -> A) -> sort E 148 | | sortProp : forall (A : Prop), (E -> A) -> sort E 149 | | sortErr : E -> sort E. 150 | 151 | Definition type@{i j} (E: Type@{i}) := 152 | sort@{i j} E. 153 | Definition sTypeVal@{i j} (E: Type@{i}) (A: Type@{j}) (f: E -> A): type@{i j} E := 154 | sortType E A f. 155 | Definition sTypeErr@{i j} (E: Type@{i}) (e: E): type@{i j} E := 156 | sortErr@{i j} E e. 157 | 158 | Definition prop@{i} (E: Type@{i}) := 159 | sort@{i Set} E. 160 | Definition sPropVal@{i} (E: Type@{i}) (A: Prop) (f: E -> A): prop@{i} E := 161 | sortProp E A f. 162 | Definition sPropErr@{i} (E: Type@{i}) (e: E): prop@{i} E := 163 | sortErr E e. 164 | 165 | (** Type related *) 166 | Definition sEl@{i j} {E : Type@{i}} (A : type@{i j} E) : Type@{j} := 167 | match A with 168 | | sortType _ A _ => A 169 | | sortProp _ _ _ => any@{j} 170 | | sortErr _ _ => any@{j} 171 | end. 172 | 173 | Definition sErr@{i j} {E : Type@{i}} (A : type@{i j} E) : E -> sEl@{i j} A := 174 | match A return E -> sEl A with 175 | | sortType _ _ e => e 176 | | sortProp _ _ _ => fun _ => Any 177 | | sortErr _ _ => fun _ => Any 178 | end. 179 | 180 | Definition sType@{i j k} {E : Type@{i}} : type@{i k} E := 181 | sTypeVal E (type@{i j} E) (sTypeErr E). 182 | 183 | (** Prop related *) 184 | Definition spEl@{i} {E : Type@{i}} (A: prop@{i} E) : Prop:= 185 | match A with 186 | | sortType _ _ _ => True 187 | | sortProp _ A _ => A 188 | | sortErr _ _ => True 189 | end. 190 | 191 | Definition spErr@{i j} {E : Type@{i}} (A : sort@{i Set} E) : E -> spEl@{i} A := 192 | match A return E -> spEl A with 193 | | sortType _ _ e => fun _ => I 194 | | sortProp _ _ e => e 195 | | sortErr _ _ => fun _ => I 196 | end. 197 | 198 | Definition sProp@{i j} {E : Type@{i}} : type@{i j} E := 199 | sTypeVal E (prop@{i} E) (sPropErr E). 200 | 201 | End NewExc. 202 | --------------------------------------------------------------------------------