├── README.md ├── cic.rkt ├── info.rkt ├── redex-utils.rkt └── snoc-env.rkt /README.md: -------------------------------------------------------------------------------- 1 | CIC 2 | === 3 | 4 | A Redex model of CIC as specified in [Chapter 4 of the Coq reference manual](https://coq.inria.fr/doc/Reference-Manual006.html#Cic-inductive-definitions). 5 | 6 | We currently model the following parts of the CIC spec: 7 | 8 | * CC; Caveats: 9 | - Use `(@ e e)` instead of juxtaposition for application syntax. 10 | - Missing global assumptions and definitions. 11 | * βιδζη conversion 12 | * Subtyping 13 | * Infinite hierarchy of Type 14 | * Predicative Set 15 | * Impredicative Prop 16 | * Parameterized indexed inductive families; 17 | Caveats: 18 | - Missing mutually inductive families, since they can be encoded via indexed families; see, e.g., [The Rooster and the Syntactic Bracket](https://arxiv.org/abs/1309.5767) for the construction. 19 | * Strict positivity checking 20 | * Dependent pattern matching 21 | * Allowed elimination sorts, including "Prop-extended" (elimination to any sort from empty and singleton Prop) 22 | * Recursive functions; 23 | Caveats: 24 | - Missing mutually recursive functions. 25 | - Expects recursive functions to be well-defined on their first argument. 26 | * Termination checking 27 | 28 | We do not plan to model: 29 | 30 | * Coinductive families 31 | -------------------------------------------------------------------------------- /cic.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | #| 3 | | TeX-input mode symbols used: 4 | | λ is \lambda 5 | | Π is \Pi 6 | | Γ is \Gamma 7 | | · is \cdot 8 | | Δ is \Delta 9 | | Ξ is \Xi 10 | | Θ is \Theta 11 | | 12 | | δ is \delta 13 | | β is \beta 14 | | ζ is \zeta 15 | | ι is \iota 16 | | 17 | | ≡ is \equiv 18 | | η is \eta 19 | | ₁ is _1 20 | | ₂ is _2 21 | | ≼ is \preceq 22 | |# 23 | 24 | (require 25 | redex/reduction-semantics 26 | (only-in racket/dict dict-ref) 27 | (only-in racket/function curry) 28 | "redex-utils.rkt" 29 | "snoc-env.rkt") 30 | (module+ test 31 | (require redex-chk)) 32 | 33 | (provide 34 | (all-defined-out)) 35 | 36 | ;; Syntax 37 | (define-language cicL 38 | (i j k n ::= natural) 39 | (c D x y f ::= variable-not-otherwise-mentioned) 40 | 41 | (U ::= (Type i) Set Prop) 42 | (e t ::= c x (λ (x : t) e) (@ e e) (Π (x : t) t) U (let (x = e : t) e) (case e e (e ...)) (fix f : t e)) 43 | (Γ ::= · (Γ (x : t)) (Γ (x = e : t))) 44 | (Δ ::= · (Δ (D : n t Γ))) 45 | 46 | (Ξ ::= hole (Π (x : t) Ξ)) ; Telescopes, as Π contexts 47 | (Θ ::= hole (@ Θ e)) ; Argument lists, as application contexts 48 | 49 | #:binding-forms 50 | (λ (x : t) e #:refers-to x) 51 | (Π (x : t) e #:refers-to x) 52 | (let (x = e : t) e_body #:refers-to x) 53 | (fix f : t e #:refers-to f)) 54 | 55 | ;; ------------------------------------------------------------------------ 56 | ;; Handy meta-functions and syntax sugar 57 | 58 | (begin ;; sugar 59 | 60 | ;; TODO: Proper definitions pending https://github.com/racket/redex/issues/54 61 | (define-extended-language cic-sugarL cicL 62 | (Γ-decl ::= (x : t) (x = e : t)) 63 | #;(C ::= (cross t)) 64 | (me mt ::= any #;t #;C) 65 | (ann ::= (x : mt) mt)) 66 | 67 | (define-metafunction cic-sugarL 68 | -> : ann ... mt -> mt 69 | [(-> mt) 70 | mt] 71 | [(-> (x : mt_0) ann ... mt) 72 | (Π (x : mt_0) (-> ann ... mt))] 73 | [(-> mt_0 ann ... mt) 74 | (-> (x : mt_0) ann ... mt)]) 75 | 76 | (define-metafunction cic-sugarL 77 | ;; Would like this to enforce at least 1 arg, but this makes writing translation easier 78 | λ* : (x : mt) ... me -> me 79 | [(λ* me) me] 80 | [(λ* (x : mt) (x_r : mt_r) ... me) 81 | (λ (x : mt) (λ* (x_r : mt_r) ... me))]) 82 | 83 | (define-metafunction cic-sugarL 84 | let* : ([x = me : mt] ...) me -> mt 85 | [(let* () me) 86 | me] 87 | [(let* ([x = me : mt] any_0 ...) me_body) 88 | (let (x = me : mt) (let* (any_0 ...) me_body))]) 89 | 90 | (define-metafunction cic-sugarL 91 | @* : me me ... -> me 92 | [(@* me) me] 93 | [(@* me_0 me_1 me ...) 94 | (@* (@ me_0 me_1) me ...)])) 95 | 96 | (module+ test 97 | (require 98 | (rename-in 99 | (submod "..") 100 | [@* @] 101 | [let* let] 102 | [λ* λ])) 103 | (provide (all-defined-out)) 104 | 105 | (default-language cicL) 106 | (default-equiv (curry alpha-equivalent? cicL)) 107 | 108 | (define-term Δ0 109 | (· (False : 0 Prop ·))) 110 | 111 | (define-term Δ01 112 | (Δ0 (Unit : 0 Prop (· (tt : Unit))))) 113 | 114 | (define-term Δb 115 | (Δ01 (Bool : 0 Set ((· (true : Bool)) (false : Bool))))) 116 | 117 | (define-term Δnb 118 | (Δb (Nat : 0 Set ((· (z : Nat)) (s : (Π (x : Nat) Nat)))))) 119 | 120 | ;; Tests parameters 121 | (define-term Δlist 122 | (Δnb (List : 1 (Π (A : Set) Set) 123 | ((· (nil : (Π (A : Set) (@ List A)))) 124 | (cons : (-> (A : Set) (a : A) (ls : (@ List A)) (@ List A))))))) 125 | 126 | ;; Check that all constructors have explicit parameter declarations; implicit is surface sugar 127 | (define-term Δbadlist 128 | (Δnb (List : 1 (Π (A : Set) Set) 129 | ((· (nil : (@ List A))) 130 | (cons : (-> (a : A) (ls : (@ List A)) (@ List A))))))) 131 | 132 | (define-term subn 133 | (fix f : (Π (x : Nat) Nat) 134 | (λ (x : Nat) 135 | (case x (λ (x : Nat) Nat) (z (λ (x : Nat) (@ f x))))))) 136 | 137 | (define-term plus 138 | (fix + : (Π (n : Nat) (Π (m : Nat) Nat)) 139 | (λ (n : Nat) 140 | (λ (m : Nat) 141 | (case n (λ (x : Nat) Nat) 142 | (m 143 | (λ (x : Nat) 144 | (@ s (@ (@ + x) m))))))))) 145 | 146 | ;; ill-typed but well-formed 147 | (define-term subn-bad1 148 | (fix f : (Π (x : Nat) Nat) 149 | (λ (x : Nat) 150 | (case x (λ (x : Nat) Nat) (z (λ (x : Nat) (@ f z))))))) 151 | 152 | (define-term subn-bad2 153 | (fix f : (Π (x : Nat) Nat) 154 | (λ (A : Set) 155 | (λ (x : Nat) 156 | (case x (λ (x : Nat) Nat) (z (λ (x : Nat) (@ f x)))))))) 157 | 158 | (define-term Ω 159 | (fix f : (Π (x : Nat) Nat) 160 | (λ (x : Nat) 161 | (@ f x)))) 162 | 163 | (redex-chk 164 | #:lang cicL 165 | #:m Δ Δnb 166 | #:m Δ Δlist 167 | #:m Δ Δbadlist 168 | #:m (cross e) hole 169 | #:m (cross e) (@ (λ (x : t) hole) z) 170 | #:m U Prop 171 | #:m U (Type 0) 172 | #:m U Set 173 | #:f #:m U Type 174 | #:f #:m e (fix x : Type x) 175 | #:m e (fix x : Set x) 176 | #:m (in-hole hole (Π (x : D) U)) (Π (x : Nat) Set) 177 | #:m (in-hole Ξ_D (Π (x : D) U)) (Π (x : Nat) Set) 178 | #:m e subn 179 | #:m e plus 180 | #:m e subn-bad1 181 | #:m e subn-bad2 182 | #:m e Ω 183 | #:m (in-hole Θ Nat) (@ Nat) 184 | #:m (in-hole Ξ (in-hole Θ Nat)) (Π (x : Nat) (@ Nat)) 185 | #:m (in-hole hole (Π (x : (in-hole Θ D)) U)) (Π (x : (@ Nat)) Set) 186 | #:m (in-hole Ξ_D (Π (x : (in-hole Θ D)) U)) (Π (x : (@ Nat)) Set))) 187 | 188 | ;; ------------------------------------------------------------------------ 189 | ;; Universes 190 | 191 | (begin ;; universes 192 | 193 | ;; What is the upper bound on two universes 194 | (define-judgment-form cicL 195 | #:mode (<=U I I) 196 | #:contract (<=U U U) 197 | 198 | [------------- 199 | (<=U Prop U)] 200 | 201 | [-------------- 202 | (<=U Set Set)] 203 | 204 | [------------------- 205 | (<=U Set (Type i))] 206 | 207 | [(side-condition ,(<= (term i) (term j))) 208 | ------------------------ 209 | (<=U (Type i) (Type j))]) 210 | 211 | (define-judgment-form cicL 212 | #:mode (max-U I I O) 213 | #:contract (max-U U U U) 214 | 215 | [(<=U U_1 U_2) 216 | -------------------- 217 | (max-U U_1 U_2 U_2)] 218 | 219 | [(<=U U_2 U_1) 220 | -------------------- 221 | (max-U U_1 U_2 U_1)])) 222 | 223 | (module+ test 224 | (redex-judgment-holds-chk 225 | <=U 226 | [Prop Set] 227 | [Prop Prop] 228 | [Set Set] 229 | [Prop (Type 5)] 230 | [Set (Type 5)] 231 | [#:f (Type 5) Set] 232 | [#:f (Type 5) Prop] 233 | [#:f Set Prop] 234 | [#:f (Type 5) (Type 1)]) 235 | 236 | (redex-judgment-holds-chk 237 | max-U 238 | [Prop Set Set] 239 | [Prop Prop Prop] 240 | [Set Set Set] 241 | [Prop (Type 5) (Type 5)] 242 | [Set (Type 5) (Type 5)] 243 | [(Type 5) Set (Type 5)] 244 | [(Type 5) Prop (Type 5)] 245 | [Set Prop Set] 246 | [(Type 5) (Type 1) (Type 5)])) 247 | 248 | ;; ------------------------------------------------------------------------ 249 | ;; Dynamic Semantics. 250 | 251 | (begin ;; dynamics 252 | 253 | ;; small step reductions 254 | (define (cicL--> Δ Γ) 255 | (term-let ([Γ Γ] [Δ Δ]) 256 | (reduction-relation 257 | cicL 258 | (--> x e 259 | (where (x = e : t) (snoc-env-ref Γ x)) 260 | "δ") 261 | (--> (@ (λ (x : t) e_0) e_1) 262 | (substitute e_0 x e_1) 263 | "β") 264 | (--> (let (x = e_0 : t) e_1) 265 | (substitute e_1 x e_0) 266 | "ζ") 267 | (--> (case (in-hole Θ c_i) _ (e_0 ... e_n)) 268 | (in-hole Θ_i e_i) 269 | (where #t (Δ-in-constructor-dom Δ c_i)) 270 | (where/hidden e_i (select-method Δ c_i e_0 ... e_n)) 271 | (where Θ_i (take-indicies Δ c_i Θ)) 272 | "ι1") 273 | (--> (@ (name e_f (fix f : t_f (λ (x : t) e))) (name e_a (in-hole Θ c))) 274 | (substitute (substitute e f e_f) x e_a) 275 | (where #t (Δ-in-constructor-dom Δ c)) 276 | "ι2")))) 277 | 278 | ;; Select the method in e ... that corresponds to the constructor c 279 | (define-metafunction cicL 280 | select-method : Δ c e ... -> e 281 | [(select-method Δ c e ..._0) 282 | e_mi 283 | (where D (Δ-key-by-constructor Δ c)) 284 | ;; Methods must match number of constructors 285 | (where (c_r ..._0) (Δ-ref-constructors Δ D)) 286 | (where e_mi ,(dict-ref (term ((c_r . e) ...)) (term c)))]) 287 | 288 | ;; Reduce anywhere 289 | (define (cicL-->* Δ Γ) 290 | (compatible-closure (cicL--> Δ Γ) cicL e)) 291 | 292 | ;; Reduce e to a normal form 293 | (define-metafunction cicL 294 | reduce : Δ Γ e -> e 295 | [(reduce Δ Γ e) 296 | ,(car (apply-reduction-relation* (cicL-->* (term Δ) (term Γ)) (term e) #:cache-all? #t))]) 297 | 298 | ;; A judgment version, for easy use in the type system 299 | (define-judgment-form cicL 300 | #:mode (normalize I I I O) 301 | #:contract (normalize Δ Γ e e) 302 | 303 | [(where e_0 (reduce Δ Γ e)) 304 | ---------------------- 305 | (normalize Δ Γ e e_0)])) 306 | 307 | (module+ test 308 | (redex-chk 309 | #:lang cicL 310 | (reduce Δnb · Nat) Nat 311 | (reduce · · (@ (λ (x : (Type 0)) x) z)) z 312 | (reduce · · f) f 313 | (reduce · · (in-hole (@ hole z) (λ (x : Nat) Nat))) Nat 314 | (reduce Δnb · (case z (λ (x : Nat) Nat) (z (λ (x : Nat) x)))) z 315 | (reduce Δlist · (case (@ nil Nat) (λ (ls : (@ List Nat)) Bool) (true false))) true 316 | (reduce Δnb (· (x : Nat)) (@ subn x)) (@ subn x) 317 | (reduce Δnb · (@ subn z)) z 318 | (reduce Δnb · (@ subn (@ s z))) z 319 | (reduce Δnb · (@ (@ plus z) z)) z 320 | (reduce Δnb · (@ (@ plus (@ s z)) z)) (@ s z) 321 | (reduce Δnb · (@ (@ plus z) (@ s z))) (@ s z) 322 | (reduce Δnb · (@ (@ plus (@ s z)) (@ s z))) (@ s (@ s z)))) 323 | 324 | ;; ------------------------------------------------------------------------ 325 | ;; Equivalence 326 | 327 | (define-judgment-form cicL 328 | #:mode (convert I I I I) 329 | #:contract (convert Δ Γ e_1 e_2) 330 | 331 | [(normalize Δ Γ e_0 e_0p) 332 | (normalize Δ Γ e_1 e_1p) 333 | ;; NB: workaround issue #99 https://github.com/racket/redex/issues/99 334 | (where (e e) (e_0p e_1p)) 335 | ----------------- "≡" 336 | (convert Δ Γ e_0 e_1)] 337 | 338 | [(normalize Δ Γ e_0 (λ (x : t) e)) 339 | (normalize Δ Γ e_1 e_2) 340 | (convert Δ (Γ (x : t)) e (@ e_2 x)) 341 | ----------------- "≡-η₁" 342 | (convert Δ Γ e_0 e_1)] 343 | 344 | [(normalize Δ Γ e_1 (λ (x : t) e)) 345 | (normalize Δ Γ e_0 e_2) 346 | (convert Δ (Γ (x : t)) (@ e_2 x) e) 347 | ----------------- "≡-η₂" 348 | (convert Δ Γ e_0 e_1)]) 349 | 350 | (module+ test 351 | (define ((cicL-equiv Δ Γ) x y) 352 | (judgment-holds (convert ,Δ ,Γ ,x ,y))) 353 | 354 | (parameterize ([default-equiv (cicL-equiv (term Δnb) (term ·))]) 355 | (redex-chk 356 | #:lang cicL 357 | #:eq (λ (x : Set) (@ f x)) (reduce · (· (f : (Π (x : Set) Set))) f) 358 | #:eq (λ (x : Nat) (@ s x)) (reduce Δnb · s) 359 | #:eq z (@ subn z) 360 | #:eq z (@ subn (@ s z)) 361 | #:eq (Π (y : Set) Set) (Π (p : Set) Set)))) 362 | 363 | ;; ------------------------------------------------------------------------ 364 | ;; Subtyping 365 | 366 | ;; Is e_1 a subtype of e_2 367 | ;; NB: Not quite as specified; ≼-U axioms instead of deriving them 368 | (define-judgment-form cicL 369 | #:mode (subtype I I I I) 370 | #:contract (subtype Δ Γ e_1 e_2) 371 | 372 | [(convert Δ Γ e_0 e_1) 373 | ---------------------- "≼-≡" 374 | (subtype Δ Γ e_0 e_1)] 375 | 376 | [(<=U U_0 U_1) 377 | ---------------------- "≼-U" 378 | (subtype Δ Γ U_0 U_1)] 379 | 380 | [(convert Δ Γ t_0 t_1) 381 | (subtype Δ (Γ (x_0 : t_0)) e_0 (substitute e_1 x_1 x_0)) 382 | ------------------------------------------------------ "≼-Π" 383 | (subtype Δ Γ (Π (x_0 : t_0) e_0) (Π (x_1 : t_1) e_1))]) 384 | 385 | (module+ test 386 | (redex-judgment-holds-chk 387 | (subtype · ·) 388 | [Prop Prop] 389 | [Prop Set] 390 | [Prop (Type 1)] 391 | [Set (Type 1)] 392 | [#:f Set Prop] 393 | [Set (Type 5)] 394 | [(Type 1) (Type 5)] 395 | [#:f (Type 5) (Type 1)] 396 | [(Π (x : Prop) Prop) (Π (x : Prop) Set)] 397 | [#:f (Π (x : Prop) Prop) (Π (x : Set) Set)] 398 | [#:f (Π (x : Set) Prop) (Π (x : Prop) Set)] 399 | [(Π (x : Set) Prop) (Π (x : Set) Set)] 400 | [(@ (λ (x : (Type 1)) Set) Set) Set])) 401 | 402 | ;; ------------------------------------------------------------------------ 403 | ;; Typing 404 | 405 | (begin ;; well-formed environment 406 | 407 | (define-judgment-form cicL 408 | #:mode (valid-parameters I I I I) 409 | #:contract (valid-parameters Δ n t t) 410 | 411 | [------------------------------- 412 | (valid-parameters Δ 0 t_0 t_1)] 413 | 414 | [(valid-parameters Δ ,(sub1 (term n)) t_0 t_1) 415 | ------------------------------------------------------- 416 | (valid-parameters Δ n (Π (x : t) t_0) (Π (y : t) t_1))]) 417 | 418 | ;; Holds when the type t is a valid type for a constructor of D 419 | (define-judgment-form cicL 420 | #:mode (valid-constructors I I) 421 | #:contract (valid-constructors (Δ (D : n t Γ)) Γ) 422 | 423 | [------------------------- "VC-Empty" 424 | (valid-constructors Δ ·)] 425 | 426 | [;; constructor's type must return the inductive type D 427 | (where (in-hole Ξ (in-hole Θ D)) t) 428 | ;; First n arguments (parameters) of the constructor must match those of the inductive 429 | (valid-parameters Δ n t t_D) 430 | (strict-positivity-cond Δ_0 (· (D : t_D)) D t) 431 | (type-infer Δ (· (D : t_D)) t U) 432 | (valid-constructors Δ_0 Γ_c) 433 | -----------------------------------------------------------------"VC-C" 434 | (valid-constructors (name Δ_0 (Δ (D : n t_D _))) (Γ_c (c : t)))]) 435 | 436 | ;; Under global declarations Δ, is the term environment well-formed? 437 | (define-judgment-form cicL 438 | #:mode (wf I I) 439 | #:contract (wf Δ Γ) 440 | 441 | [--------- "W-Empty" 442 | (wf · ·)] 443 | 444 | [(wf Δ Γ) 445 | (type-infer Δ Γ t U) 446 | ------------------- "W-Local-Assum" 447 | (wf Δ (Γ (x : t)))] 448 | 449 | [(wf Δ Γ) 450 | (type-check Δ Γ e t) 451 | (type-infer Δ Γ t U) 452 | ----------------------- "W-Local-Def" 453 | (wf Δ (Γ (x = e : t)))] 454 | 455 | ;; NB: Not quite as specified: 456 | ;; * valid-constructors loops over constructors, rather than precomputing environments and using ... notation 457 | ;; Primarily this is because ... notation makes checking the result type of each constructor 458 | ;; awkward, but also ... notation makes random testing harder. 459 | ;; * check t_D directly rather than splitting parameter telescope manually. 460 | ;; * Γ must be empty, to guide search 461 | [(wf Δ ·) 462 | (where #f (Δ-in-dom Δ D)) 463 | (where (c_i ...) (Δ-ref-constructors Δ_0 D)) 464 | (where (c_!_0 ...) (c_i ...)) ; all constructors unique 465 | (type-infer Δ · t_D U_D) 466 | (valid-constructors Δ_0 Γ_c) 467 | ---------------------------------------------------------- "W-Ind" 468 | (wf (name Δ_0 (Δ (D : n (name t_D (in-hole Ξ U)) Γ_c))) ·)])) 469 | 470 | (module+ test 471 | (redex-judgment-holds-chk 472 | (valid-constructors Δ01) 473 | [(· (tt : Unit))]) 474 | 475 | (redex-relation-chk 476 | wf 477 | [· ·] 478 | [Δ0 ·] 479 | [Δ01 ·] 480 | [Δb ·] 481 | [Δnb ·] 482 | [Δnb (· (x : Nat))] 483 | [Δlist ·] 484 | [#:f Δbadlist ·] 485 | [Δlist (· (x = (λ (x : Nat) (λ (y : Nat) y)) : (Π (x : Nat) (Π (y : Nat) Nat))))] 486 | [Δlist ((· (x = (λ (x : Nat) (λ (y : Nat) y)) : (Π (x : Nat) (Π (y : Nat) Nat)))) 487 | (y = (λ (x : Nat) (λ (y : Nat) y)) : (Π (x : Nat) (Π (y : Nat) Nat))))] 488 | [Δlist (· (x = subn : (Π (y : Nat) Nat)))] 489 | [Δnb (· (x = subn : (Π (y : Nat) Nat)))] 490 | ; This passes, but is very slow without a large cache. 491 | #;[Δnb ((· (x = subn : (Π (y : Nat) Nat))) 492 | (z = subn : (Π (y : Nat) Nat)))])) 493 | 494 | (begin ;; typing 495 | 496 | ;; Under global declarations Δ and term environment Γ, can we infer a type t for term e? 497 | (define-judgment-form cicL 498 | #:mode (type-infer I I I O) 499 | #:contract (type-infer Δ Γ e t) 500 | 501 | [(wf Δ Γ) 502 | ------------------------------- "Ax-Prop" 503 | (type-infer Δ Γ Prop (Type 1))] 504 | 505 | [(wf Δ Γ) 506 | ------------------------------ "Ax-Set" 507 | (type-infer Δ Γ Set (Type 1))] 508 | 509 | [(wf Δ Γ) (where j ,(add1 (term i))) 510 | ----------------------------------- "Ax-Type" 511 | (type-infer Δ Γ (Type i) (Type j))] 512 | 513 | [(Γ-in Γ x t) (wf Δ Γ) 514 | --------------------- "Var" 515 | (type-infer Δ Γ x t)] 516 | 517 | [(type-infer Δ Γ t_0 U) 518 | (type-check Δ (Γ (x : t_0)) t Prop) 519 | -------------------------------------- "Prod-Prop" 520 | (type-infer Δ Γ (Π (x : t_0) t) Prop)] 521 | 522 | [(type-infer Δ Γ t_0 U) 523 | (in U (Set Prop)) 524 | (type-check Δ (Γ (x : t_0)) t Set) 525 | ------------------------------------- "Prod-Set" 526 | (type-infer Δ Γ (Π (x : t_0) t) Set)] 527 | 528 | [(type-infer Δ Γ t_0 U_1) 529 | (type-infer Δ (Γ (x : t_0)) t U_2) 530 | ;; NB: Not quite as specified, to make algorithmic. 531 | (max-U U_1 U_2 U_3) 532 | ------------------------------------- "Prod-Type" 533 | (type-infer Δ Γ (Π (x : t_0) t) U_3)] 534 | 535 | [(type-infer Δ (Γ (x : t_0)) e t) 536 | (type-infer Δ Γ (Π (x : t_0) t) U) 537 | ------------------------------------------------- "Lam" 538 | (type-infer Δ Γ (λ (x : t_0) e) (Π (x : t_0) t))] 539 | 540 | [(type-infer Δ Γ e_0 (Π (x : t_1) t)) 541 | (type-check Δ Γ e_1 t_1) 542 | -------------------------------------------------- "App" 543 | (type-infer Δ Γ (@ e_0 e_1) (substitute t x e_1))] 544 | 545 | [(type-check Δ Γ e t) 546 | (type-infer Δ (Γ (x = e : t)) e_body t_body) 547 | ------------------------------------------------------------------ "Let" 548 | (type-infer Δ Γ (let (x = e : t) e_body) (substitute t_body x e))] 549 | 550 | [(Δ-type-in Δ D t) (wf Δ Γ) 551 | --------------------- "Ind" 552 | (type-infer Δ Γ D t)] 553 | 554 | [(Δ-constr-in Δ c t) (wf Δ Γ) 555 | --------------------- "Constr" 556 | (type-infer Δ Γ c t)] 557 | 558 | [(type-infer Δ Γ e (name t_I (in-hole Θ D))) 559 | (where Θ_p (take-parameters Δ D Θ)) ;; Extend Γ with parameters determined from e_Di ... 560 | (where Θ_i (take-indicies Δ D Θ)) 561 | (check-motive Δ Γ t_I D Θ_p e_motive) ;; Check the motive matches the inductive type 562 | (where t (@ (in-hole Θ_i e_motive) e)) (type-infer Δ Γ t U) 563 | (check-methods Δ Γ D t Θ_p (e_m ...)) ;; Check the methods match their constructors, and return type from motive 564 | ------------------------------------------------- "match" 565 | (type-infer Δ Γ (case e e_motive (e_m ..._1)) t)] 566 | 567 | [(terminates Δ e_fix) 568 | (type-infer Δ Γ t U) 569 | (type-check Δ (Γ (f : t)) e t) 570 | ---------------------------------------------- "Fix" 571 | (type-infer Δ Γ (name e_fix (fix f : t e)) t)]) 572 | 573 | ;; Under global declarations Δ and term environment Γ, does e have a type that is convertible to t? 574 | (define-judgment-form cicL 575 | #:mode (type-check I I I I) 576 | #:contract (type-check Δ Γ e t) 577 | 578 | [(type-infer Δ Γ e t_1) (type-infer Δ Γ t U) (subtype Δ Γ t_1 t) 579 | --------------------- "Conv" 580 | (type-check Δ Γ e t)])) 581 | 582 | (module+ test 583 | (redex-judgment-holds-chk 584 | (type-infer · ·) 585 | [(Type 0) (Type 1)] 586 | [(Π (a : Prop) Prop) U]) 587 | 588 | (redex-relation-chk 589 | (type-check · ·) 590 | [(Type 0) (Type 1)] 591 | [#:f (Π (x : (Type 0)) (Type 0)) (Type 0)] 592 | [(Π (x : (Type 0)) (Type 0)) (Type 1)] 593 | [#:f (Π (x : (Type 0)) x) (Type 0)] 594 | [#:f Prop (Type 0)] 595 | [Set (Type 1)] 596 | [Prop (Type 1)] 597 | [Prop (Type 2)] 598 | [(Π (x : Set) Set) (Type 1)] 599 | [(Π (x : Prop) x) Prop] 600 | [(Π (x : Prop) Prop) (Type 1)] 601 | [(λ (x : Set) x) (Π (x : Set) Set)] 602 | [(λ (x : Set) x) (-> Set Set)]) 603 | 604 | (redex-judgment-holds-chk 605 | (type-infer Δlist ·) 606 | [(λ (x : Nat) Nat) t] 607 | [(λ (x : Nat) Nat) t] 608 | [(case z (λ (x : Nat) Nat) (z (λ (x : Nat) x))) t] 609 | [#:f nil (@ List A)] 610 | [nil (Π (x : Set) (@ List x))] 611 | [(@ nil Nat) t] 612 | [(@ List Nat) Set] 613 | [List (Π (x_A : Set) Set)] 614 | [cons (Π (x_A : Set) (Π (x_a : x_A) (Π (x_r : (@ List x_A)) (@ List x_A))))] 615 | [(@ cons Nat z (@ nil Nat)) t] 616 | [subn t] 617 | [plus t] 618 | [#:f subn-bad1 t] 619 | [#:f subn-bad2 t] 620 | [#:f Ω t]) 621 | 622 | (redex-relation-chk 623 | type-check 624 | [· (· (Nat : (Type 0))) (Π (n : Nat) Nat) (Type 1)] 625 | [· (· (Nat : Set)) (Π (n : Nat) Nat) (Type 1)] 626 | [Δnb (· (x : Nat)) Nat Set] 627 | [Δnb (· (Nat : Set)) (λ (n : Nat) n) (Π (n : Nat) Nat)] 628 | [Δnb ((· (f : (-> Nat Nat))) (x : Nat)) 629 | (case x (λ (x : Nat) Nat) 630 | (z 631 | (λ (x : Nat) (@ f x)))) 632 | Nat] 633 | [Δnb (· (f : (-> Nat Nat))) 634 | (λ (x : Nat) 635 | (case x (λ (x : Nat) Nat) 636 | (z 637 | (λ (x : Nat) (@ f x))))) 638 | (Π (y : Nat) Nat)]) 639 | 640 | (redex-relation-chk 641 | (type-check Δlist ·) 642 | [Nat Set] 643 | [z Nat] 644 | [(@ s z) Nat] 645 | [(Π (x : Nat) Set) (Type 1)] 646 | [(λ (x : Nat) Nat) (Π (x : Nat) Set)] 647 | [(λ (x : Nat) x) (Π (x : Nat) Nat)] 648 | [(case z (λ (x : Nat) Nat) (z (λ (x : Nat) x))) Nat] 649 | [(case true (λ (x : Bool) Nat) (z (@ s z))) Nat] 650 | [(fix f : (-> Nat Nat) 651 | (λ (x : Nat) 652 | (case x (λ (x : Nat) Nat) 653 | (z 654 | (λ (x : Nat) (@ s x)))))) 655 | (Π (x : Nat) Nat)] 656 | [(fix f : (-> Nat Nat) 657 | (λ (x : Nat) 658 | (case x (λ (x : Nat) Nat) 659 | (z 660 | (λ (x : Nat) (@ f x)))))) 661 | (Π (x : Nat) Nat)] 662 | [#:f (fix f : (-> Nat Nat) 663 | (λ (x : Nat) 664 | (case x (λ (x : Nat) Nat) 665 | ((@ f x) 666 | (λ (y : Nat) (@ f x)))))) 667 | (Π (x : Nat) Nat)] 668 | [(let ([n = z : Nat]) z) Nat] 669 | [(let ([n = z : Nat]) n) Nat] 670 | [(let ([Nat^ = Nat : Set] [n = z : Nat^]) n) Nat] 671 | [(@ cons Nat z (@ nil Nat)) (@ List Nat)] 672 | [(case (@ cons Nat z (@ nil Nat)) (λ (ls : (@ List Nat)) Bool) 673 | (true (λ (n : Nat) (ls : (@ List Nat)) false))) Bool])) 674 | 675 | ;; ------------------------------------------------------------------------ 676 | ;; Typing aux 677 | 678 | (begin ;; strict positivity 679 | 680 | ;; t satisfied the strict positivity condition for D 681 | ;; translated from https://coq.inria.fr/doc/Reference-Manual006.html#Cic-inductive-definitions 682 | (define-judgment-form cicL 683 | #:mode (strict-positivity-cond I I I I) 684 | #:contract (strict-positivity-cond Δ Γ D t) 685 | 686 | [(side-condition (not-free-in D Θ)) 687 | --------------------------------------------- "SP-App" 688 | (strict-positivity-cond Δ Γ D (in-hole Θ D))] 689 | 690 | [(occurs-strictly-positively Δ Γ D t_0) 691 | (strict-positivity-cond Δ Γ D t_1) 692 | ------------------------------------------------- "SP-Π" 693 | (strict-positivity-cond Δ Γ D (Π (x : t_0) t_1))]) 694 | 695 | ;; D occurs strictly positively in t 696 | (define-judgment-form cicL 697 | #:mode (occurs-strictly-positively I I I I) 698 | #:contract (occurs-strictly-positively Δ Γ D t) 699 | 700 | [(side-condition (not-free-in D t)) 701 | ------------------------------------- "OSP-NotIn" 702 | (occurs-strictly-positively Δ Γ D t)] 703 | 704 | [(normalize Δ Γ t (in-hole Θ D)) 705 | (side-condition (not-free-in D Θ)) 706 | ------------------------------------- "OSP-NotArg" 707 | (occurs-strictly-positively Δ Γ D t)] 708 | 709 | [(normalize Δ Γ t (Π (x : t_0) t_1)) 710 | (side-condition (not-free-in D t_0)) 711 | (occurs-strictly-positively Δ Γ D t_1) 712 | ------------------------------------- "OSP-Π" 713 | (occurs-strictly-positively Δ Γ D t)] 714 | 715 | [(normalize Δ Γ t (in-hole Θ D_i)) 716 | (where (D_!_0 D_!_0) (D D_i)) ;; D_i is a different inductive type 717 | (side-condition (Δ-in-dom Δ D_i)) 718 | (where n (Δ-ref-parameter-count Δ D_i)) 719 | ;; D not free in the index arguments of D_i 720 | (side-condition (not-free-in D (Θ-drop Θ n))) 721 | ;; Instantiated types of the constructors for D_i satisfy the nested positivity condition for D 722 | (where Θ_p (Θ-take Θ n)) 723 | (where ((c : t_c) ...) (Δ-ref-constructor-map Δ D_i)) 724 | (nested-positivity-condition Δ Γ D D_i (instantiate t_c Θ_p)) ... 725 | ------------------------------------- "OSP-Ind" 726 | (occurs-strictly-positively Δ Γ D t)]) 727 | 728 | ;; The type t of a constructor for D_i satisfied the nested positivity condition for D 729 | (define-judgment-form cicL 730 | #:mode (nested-positivity-condition I I I I I) 731 | #:contract (nested-positivity-condition Δ Γ D D_i t) 732 | 733 | [(side-condition (Δ-in-dom Δ D_i)) 734 | (where n (Δ-ref-parameter-count Δ D_i)) 735 | (side-condition (not-free-in D (Θ-drop Θ n))) 736 | -------------------------------------------------------- "NPC-App" 737 | (nested-positivity-condition Δ Γ D D_i (in-hole Θ D_i))] 738 | 739 | [(occurs-strictly-positively Δ Γ D t_0) 740 | (nested-positivity-condition Δ Γ D D_i t_1) 741 | ---------------------------------------------------------- "NPC-Π" 742 | (nested-positivity-condition Δ Γ D D_i (Π (x : t_0) t_1))])) 743 | 744 | (module+ test 745 | (redex-judgment-holds-chk 746 | (strict-positivity-cond Δnb ·) 747 | [Bool Bool] 748 | [Nat Nat] 749 | [Nat (Π (x : Nat) Nat)])) 750 | 751 | (begin ;; match aux 752 | 753 | ;; Can an inductive type D that lives in U_A be eliminated to some type that lives in U_B? 754 | ;; NB: Omitting the prod rule as that rule is used to just "type checks" the motive, which we do 755 | ;; separately. 756 | ;; This judgment is only responsible for checking the universes 757 | (define-judgment-form cicL 758 | #:mode (elimable I I I I) 759 | #:contract (elimable Δ D U_A U_B) 760 | 761 | [(side-condition ,(not (eq? (term U_1) (term Prop)))) 762 | ----------------------- "Set&Type" 763 | (elimable Δ D U_1 U_2)] 764 | 765 | [------------------------- "Prop" 766 | (elimable Δ D Prop Prop)] 767 | 768 | [(where () (Δ-ref-constructor-map Δ D)) 769 | ---------------------- "Prop-extended-empty" 770 | (elimable Δ D Prop U)] 771 | 772 | [(where ((c : (in-hole Ξ (in-hole Θ_c D)))) (Δ-ref-constructor-map Δ D)) 773 | (where ((_ : Prop) ...) (Ξ-flatten Ξ)) 774 | ---------------------- "Prop-extended-singleton" 775 | (elimable Δ D Prop U)]) 776 | 777 | (define-judgment-form cicL 778 | #:mode (check-motive I I I I I I) 779 | #:contract (check-motive Δ Γ t D Θ e) 780 | 781 | [(where Ξ_D (Δ-ref-index-Ξ Δ D Θ_p)) 782 | ;; check that the motive matches the inductive index telescope, i.e., the telescope sans parameters. 783 | ;; TODO: Check subtyping between Ξ_D, rather than α-equiv? 784 | (type-infer Δ Γ e (in-hole Ξ_D (Π (x : t_D) U_B))) 785 | (subtype Δ Γ t_D (Ξ-apply Ξ_D (in-hole Θ_p D))) 786 | ;; Check that this is a valid elimination sort 787 | ;; TODO: Test = type 788 | (type-infer Δ Γ t_I U_A) 789 | (elimable Δ D U_A U_B) 790 | ------------------------------- 791 | (check-motive Δ Γ t_I D Θ_p e)]) 792 | 793 | (define-judgment-form cicL 794 | #:mode (check-methods I I I I I I) 795 | #:contract (check-methods Δ Γ D t Θ (e ...)) 796 | 797 | [(where (c ..._1) (Δ-ref-constructors Δ D)) 798 | (where (Ξ_c ..._1) ((Δ-constructor-ref-index-Ξ Δ c Θ) ...)) 799 | (type-check Δ Γ e (in-hole Ξ_c t)) ... 800 | ---------------------------------- 801 | (check-methods Δ Γ D t Θ (e ...))])) 802 | 803 | (begin ;; guard condition 804 | 805 | ;; Check that the body of f, e, is guarded w.r.t y, an inductive argument of type D, with 806 | ;; accumulated recursive arguments (x ...). 807 | (define-judgment-form cicL 808 | #:mode (guard I I I I I I) 809 | #:contract (guard Δ y D f (x ...) e) 810 | 811 | [(where #t (not-free-in f e)) 812 | ---------------------- "Guard-NotIn" 813 | (guard Δ y D f any e)] 814 | 815 | [(in x any) 816 | (where (e ...) (Θ-flatten Θ)) 817 | (guard Δ y D f any e) ... 818 | -------------------------- "Guard-Rec" 819 | (guard Δ y D f any (@ f (in-hole Θ x)))] 820 | 821 | [(guard Δ y D f any e_1) 822 | (guard Δ y D f any e_2) 823 | ---------------------------------------------------------- 824 | (guard Δ y D (name f e_!_1) any (@ (name e_1 e_!_1) e_2))] 825 | 826 | [(guard Δ y D f any t) 827 | (guard Δ y D f any e) 828 | ---------------------------------- 829 | (guard Δ y D f any (λ (x : t) e))] 830 | 831 | [(guard Δ y D f any t) 832 | (guard Δ y D f any e) 833 | ---------------------------------- 834 | (guard Δ y D f any (Π (x : t) e))] 835 | 836 | [(guard Δ y D f any e_1) 837 | (guard Δ y D f any t) 838 | (guard Δ y D f any e_2) 839 | ---------------------------------- 840 | (guard Δ y D f any (let (x = e_1 : t) e_2))] 841 | 842 | [(guard Δ y D f any e) 843 | (guard Δ y D f any e_motive) 844 | (guard Δ y D f any e_methods) ... 845 | ------------------------------------------------------ 846 | (guard Δ y D f any (case e e_motive (e_methods ...)))] 847 | 848 | [(where (in-hole Θ x_0) e) 849 | (in x_0 (x ... y)) 850 | (where (e_j ...) (Θ-flatten Θ)) 851 | (guard Δ y D f (x ...) e_j) ... 852 | (guard Δ y D f (x ...) e_motive) 853 | ;; structurally smaller variables. 854 | (where (((x_more ...) e_body) ...) (split-methods Δ D any)) 855 | (guard Δ y D f (x ... x_more ...) e_body) ... 856 | ---------------------------------------------- "Guard-CaseSmaller" 857 | (guard Δ y D f (x ...) (case e e_motive any))]) 858 | 859 | ;; Splits the methods into their structurally smaller arguments and the body of the method 860 | (define-metafunction cicL 861 | split-methods : Δ D (e ...) -> (((x ...) e) ...) 862 | [(split-methods Δ D (e ..._0)) 863 | ((split-method D n e) ...) 864 | (where (c ..._0) (Δ-ref-constructors Δ D)) 865 | (where (n ..._0) ((Δ-constructor-ref-non-parameter-count Δ c) ...))]) 866 | 867 | ;; Splits a method into its structurally smaller arguments and the body of the method, where the 868 | ;; structurally smaller arguments are the first n arguments 869 | ;; NB: Relies on clause order 870 | (define-metafunction cicL 871 | split-method : D n e -> ((x ...) e) 872 | [(split-method D 0 e) 873 | (() e)] 874 | [(split-method D n (λ (x : t) e)) 875 | ((x x_r ...) e_r) 876 | (side-condition (term (free-in D t))) 877 | (where ((x_r ...) e_r) (split-method D ,(sub1 (term n)) e))] 878 | [(split-method D n (λ (x : t) e)) 879 | ((x_r ...) e_r) 880 | (side-condition (term (not-free-in D t))) 881 | (where ((x_r ...) e_r) (split-method D ,(sub1 (term n)) e))]) 882 | 883 | ;; Does e terminate? 884 | (define-judgment-form cicL 885 | #:mode (terminates I I) 886 | #:contract (terminates Δ e) 887 | 888 | [(Δ-type-in Δ D _) 889 | (guard Δ y D f () e) 890 | ----------------------------------------------------- 891 | (terminates Δ (fix f : (Π (x : (in-hole Θ D)) t) (λ (y : (in-hole Θ D)) e)))])) 892 | 893 | ;; ------------------------------------------------------------------------ 894 | ;; Vital meta-functions 895 | 896 | (begin ;; Γ defs 897 | ;; Make x : t ∈ Γ a little easier to use, prettier to render 898 | (define-judgment-form cicL 899 | #:mode (Γ-in I I O) 900 | #:contract (Γ-in Γ x t) 901 | 902 | [(where (x any ... : t) (snoc-env-ref Γ x)) 903 | ------------------------------- 904 | (Γ-in Γ x t)])) 905 | 906 | (begin ;; Δ defs 907 | (define-metafunction cicL 908 | Δ-in-dom : Δ D -> #t or #f 909 | [(Δ-in-dom Δ D) (snoc-env-in-dom Δ D)]) 910 | 911 | (define-metafunction cicL 912 | Δ-in-constructor-dom : Δ c -> #t or #f 913 | [(Δ-in-constructor-dom Δ c) 914 | ,(ormap (lambda (Γ_c) (term (snoc-env-in-dom ,Γ_c c))) (term (Γ_c ...))) 915 | (where ((_ _ _ _ Γ_c) ...) (snoc-env->als Δ))]) 916 | 917 | ;; make D : t ∈ Δ a little easier to use, prettier to render 918 | (define-judgment-form cicL 919 | #:mode (Δ-type-in I I O) 920 | #:contract (Δ-type-in Δ D t) 921 | 922 | [(where (D : _ t _) (snoc-env-ref Δ D)) 923 | ------------------------------- 924 | (Δ-type-in Δ D t)]) 925 | 926 | ;; Return the number of parameters for the inductive type D 927 | (define-metafunction cicL 928 | Δ-ref-parameter-count : Δ_0 D_0 -> n 929 | #:pre (Δ-in-dom Δ_0 D_0) 930 | [(Δ-ref-parameter-count Δ D) 931 | n 932 | (where (D : n _ _) (snoc-env-ref Δ D))]) 933 | 934 | ;; Return the number of parameters for the inductive type D that has a constructor c_0 935 | (define-metafunction cicL 936 | Δ-constructor-ref-parameter-count : Δ_0 c_0 -> n 937 | #:pre (Δ-in-constructor-dom Δ_0 c_0) 938 | [(Δ-constructor-ref-parameter-count Δ c) 939 | n 940 | (where (D : n _ _) (Δ-ref-by-constructor Δ c))]) 941 | 942 | ;; Return the number of non-parameters arguments for the constructor c_0 943 | (define-metafunction cicL 944 | Δ-constructor-ref-non-parameter-count : Δ_0 c_0 -> n 945 | #:pre (Δ-in-constructor-dom Δ_0 c_0) 946 | [(Δ-constructor-ref-non-parameter-count Δ c) 947 | ,(- (term (Ξ-length Ξ)) (term n)) 948 | (where n (Δ-constructor-ref-parameter-count Δ c)) 949 | (judgment-holds (Δ-constr-in Δ c (in-hole Ξ (in-hole Θ D))))]) 950 | 951 | ;; Returns the inductively defined type that x constructs 952 | (define-metafunction cicL 953 | Δ-key-by-constructor : Δ_0 c_0 -> D 954 | #:pre (Δ-in-constructor-dom Δ_0 c_0) 955 | [(Δ-key-by-constructor Δ c) 956 | D 957 | (where (_ ... (D _ _ _ Γ_c) _ ...) (snoc-env->als Δ)) 958 | (side-condition (term (snoc-env-in-dom Γ_c c)))]) 959 | 960 | (define-metafunction cicL 961 | Δ-ref-by-constructor : Δ_0 c_0 -> (D : n t Γ_c) 962 | #:pre (Δ-in-constructor-dom Δ_0 c_0) 963 | [(Δ-ref-by-constructor Δ c) 964 | (snoc-env-ref Δ D) 965 | (where D (Δ-key-by-constructor Δ c))]) 966 | 967 | ;; Returns the constructor map for the inductively defined type D in the signature Δ 968 | (define-metafunction cicL 969 | Δ-ref-constructor-map : Δ_0 D_0 -> ((c : t) ...) 970 | #:pre (Δ-in-dom Δ_0 D_0) 971 | [(Δ-ref-constructor-map Δ D) 972 | ,(term (snoc-env->als Γ_c)) 973 | (where (_ _ _ _ Γ_c) (snoc-env-ref Δ D))]) 974 | 975 | (define-metafunction cicL 976 | Δ-ref-constructors : Δ_0 D_0 -> (c ...) 977 | #:pre (Δ-in-dom Δ_0 D_0) 978 | [(Δ-ref-constructors Δ D) 979 | (c ...) 980 | (where ((c _ _) ...) (Δ-ref-constructor-map Δ D))]) 981 | 982 | ;; Return the type of the constructor c_i 983 | (define-metafunction cicL 984 | Δ-ref-constructor-type : Δ_0 c_0 -> t 985 | #:pre (Δ-in-constructor-dom Δ_0 c_0) 986 | [(Δ-ref-constructor-type Δ c) 987 | t 988 | (where (_ _ _ _ Γ_c) (Δ-ref-by-constructor Δ c)) 989 | (judgment-holds (Γ-in Γ_c c t))]) 990 | 991 | ;; Make c : t ∈ Δ a little easier to use, prettier to render 992 | (define-judgment-form cicL 993 | #:mode (Δ-constr-in I I O) 994 | #:contract (Δ-constr-in Δ c t) 995 | 996 | [(side-condition (Δ-in-constructor-dom Δ c)) 997 | (where t (Δ-ref-constructor-type Δ c)) 998 | ------------------------------- 999 | (Δ-constr-in Δ c t)]) 1000 | 1001 | (define-metafunction cicL 1002 | Δ-ref-index-Ξ : Δ_0 D_0 Θ_0 -> Ξ 1003 | #:pre ,(and (term (Δ-in-dom Δ_0 D_0)) 1004 | (= (term (Θ-length Θ_0)) (term (Δ-ref-parameter-count Δ_0 D_0)))) 1005 | [(Δ-ref-index-Ξ Δ D Θ) 1006 | Ξ 1007 | (where (D : _ t _) (snoc-env-ref Δ D)) 1008 | (where (in-hole Ξ U) (instantiate t Θ))]) 1009 | 1010 | (define-metafunction cicL 1011 | Δ-constructor-ref-index-Ξ : Δ_0 c_0 Θ_0 -> Ξ 1012 | #:pre ,(and (term (Δ-in-constructor-dom Δ_0 c_0)) 1013 | (= (term (Θ-length Θ_0)) (term (Δ-constructor-ref-parameter-count Δ_0 c_0)))) 1014 | [(Δ-constructor-ref-index-Ξ Δ c Θ) 1015 | Ξ 1016 | (where t (Δ-ref-constructor-type Δ c)) 1017 | (where (in-hole Ξ (in-hole Θ_0 D)) (instantiate t Θ))]) 1018 | 1019 | ;; constructors appear applied to their parameters and indices, but methods expect indices 1020 | ;; create a new application context without the the parameters 1021 | (define-metafunction cicL 1022 | take-indicies : Δ c Θ -> Θ 1023 | [(take-indicies Δ c Θ) 1024 | (Θ-drop Θ n) 1025 | (judgment-holds (Δ-constr-in Δ c t)) 1026 | (where n (Δ-constructor-ref-parameter-count Δ c))] 1027 | [(take-indicies Δ D Θ) 1028 | (Θ-drop Θ n) 1029 | (where n (Δ-ref-parameter-count Δ D))]) 1030 | 1031 | (define-metafunction cicL 1032 | take-parameters : Δ_0 D_0 Θ -> Θ 1033 | #:pre (Δ-in-dom Δ_0 D_0) 1034 | [(take-parameters Δ D Θ) 1035 | (Θ-take Θ n) 1036 | (where n (Δ-ref-parameter-count Δ D))])) 1037 | 1038 | (begin ;; aux defs 1039 | (define-metafunction cicL 1040 | Ξ-build : (x : t) ... -> Ξ 1041 | [(Ξ-build) 1042 | hole] 1043 | [(Ξ-build any any_r ...) 1044 | (Π any (Ξ-build any_r ...))]) 1045 | 1046 | (define-metafunction cicL 1047 | Ξ-apply : Ξ e_0 -> (in-hole Θ e_0) 1048 | [(Ξ-apply hole e) e] 1049 | [(Ξ-apply (Π (x : t) Ξ) e) 1050 | (Ξ-apply Ξ (@ e x))]) 1051 | 1052 | ;; Return the list of bindings from Ξ in reverse dependency order 1053 | (define-metafunction cicL 1054 | Ξ-flatten : Ξ -> ((x : t) ...) 1055 | [(Ξ-flatten hole) 1056 | ()] 1057 | [(Ξ-flatten (Π (x : t) Ξ)) 1058 | ((x : t) any ...) 1059 | (where (any ...) (Ξ-flatten Ξ))]) 1060 | 1061 | (define-metafunction cicL 1062 | Ξ-length : Ξ -> n 1063 | [(Ξ-length Ξ) 1064 | ,(length (term (Ξ-flatten Ξ)))]) 1065 | 1066 | ;; Return the list of operands from Θ in reverse dependency order 1067 | (define-metafunction cicL 1068 | Θ-flatten : Θ -> (e ...) 1069 | [(Θ-flatten hole) 1070 | ()] 1071 | [(Θ-flatten (@ Θ e)) 1072 | (any ... e) 1073 | (where (any ...) (Θ-flatten Θ))]) 1074 | 1075 | (define-metafunction cicL 1076 | Θ-length : Θ -> n 1077 | [(Θ-length Θ) 1078 | ,(length (term (Θ-flatten Θ)))]) 1079 | 1080 | (define-metafunction cicL 1081 | Θ-drop : Θ_0 n_0 -> Θ 1082 | #:pre ,(<= (term n_0) (term (Θ-length Θ_0))) 1083 | [(Θ-drop Θ 0) 1084 | Θ] 1085 | [(Θ-drop (in-hole Θ (@ hole e)) n) 1086 | (Θ-drop Θ ,(sub1 (term n)))]) 1087 | 1088 | (define-metafunction cicL 1089 | Θ-take : Θ_0 n_0 -> Θ 1090 | #:pre ,(<= (term n_0) (term (Θ-length Θ_0))) 1091 | [(Θ-take Θ 0) 1092 | hole] 1093 | [(Θ-take (in-hole Θ (@ hole e)) n) 1094 | (in-hole (Θ-take Θ ,(sub1 (term n))) (@ hole e))]) 1095 | 1096 | ;; Instantiate a Π type 1097 | (define-metafunction cicL 1098 | instantiate : t Θ -> t 1099 | [(instantiate t hole) 1100 | t] 1101 | [(instantiate (Π (x : t) t_1) (in-hole Θ (@ hole e))) 1102 | (instantiate (substitute t_1 x e) Θ)])) 1103 | 1104 | (module+ test 1105 | (redex-chk 1106 | (Δ-in-constructor-dom · x) #f) 1107 | 1108 | (redex-chk 1109 | #:lang cicL 1110 | (Ξ-length hole) 0 1111 | (Ξ-length (Π (x : Set) hole)) 1 1112 | (Δ-ref-constructor-type Δnb z) Nat 1113 | (Δ-ref-constructor-type Δnb s) (Π (x : Nat) Nat) 1114 | (Δ-ref-index-Ξ Δnb Nat hole) hole 1115 | (Δ-ref-constructor-map Δnb Nat) ((z : Nat) (s : (Π (x : Nat) Nat))) 1116 | 1117 | #:m hole (Δ-constructor-ref-index-Ξ Δnb z hole) 1118 | #:m (Π (x : Nat) hole) (Δ-constructor-ref-index-Ξ Δnb s hole) 1119 | #:m hole (Δ-constructor-ref-index-Ξ Δlist nil (@ hole Nat)) 1120 | 1121 | #:m (Π (x_2 : Nat) (Π (x_3 : (@ List Nat)) hole)) (Δ-constructor-ref-index-Ξ Δlist cons (@ hole Nat)) 1122 | (Ξ-apply hole Nat) Nat 1123 | (in-hole hole (Π (x : (Ξ-apply hole Nat)) Set)) (Π (x : Nat) Set) 1124 | (Δ-key-by-constructor Δnb z) Nat)) 1125 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection 'multi) 3 | (define deps '("base" ("redex-lib" #:version "1.11") "redex-chk")) 4 | (define build-deps '()) 5 | (define pkg-desc "model of CIC.") 6 | (define version "2.0") 7 | (define pkg-authors '(wilbowma)) 8 | -------------------------------------------------------------------------------- /redex-utils.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | redex/reduction-semantics) 5 | 6 | (provide (all-defined-out)) 7 | 8 | (define-language anyL) 9 | 10 | (define-metafunction anyL 11 | subst-all : any (any ...) (any ...) -> any 12 | [(subst-all any () ()) any] 13 | [(subst-all any (any_x any_xs ...) (any_a any_as ...)) 14 | (subst-all (substitute any any_x any_a) (any_xs ...) (any_as ...))]) 15 | 16 | ;; Determine if x appears free in any, by using substitution 17 | (define-metafunction anyL 18 | not-free-in : any any -> #t or #f 19 | [(not-free-in any_x any) 20 | #t 21 | (where any (substitute any any_x any_fresh)) 22 | (where any_fresh ,(variable-not-in (term (any any_x)) 'fresh))] 23 | [(not-free-in any_x any) 24 | #f]) 25 | 26 | (define-metafunction anyL 27 | free-in : any any -> #t or #f 28 | [(free-in any_x any) 29 | ,(not (term (not-free-in any_x any)))]) 30 | 31 | (define-judgment-form anyL 32 | #:mode (in I I) 33 | #:contract (in any (any ...)) 34 | 35 | [---------------------------------- 36 | (in any (any_0 ... any any_r ...))]) 37 | 38 | (define-judgment-form anyL 39 | #:mode (not-in I I) 40 | #:contract (not-in any (any ...)) 41 | 42 | [(side-condition ,(not (member (term any) (term (any_0 ...))))) 43 | ---------------------------------- 44 | (not-in any (any_0 ...))]) 45 | 46 | (require 47 | (for-syntax 48 | racket/base 49 | syntax/parse 50 | (only-in redex/private/term-fn judgment-form-mode judgment-form-lang) 51 | (only-in racket/syntax format-id))) 52 | 53 | (define-syntax (define-remoded-judgment-form syn) 54 | (syntax-parse syn 55 | [(_ lang j1 #:mode (j2 m ...)) 56 | #:with (any ...) (build-list (length (attribute m)) (lambda (x) (format-id #f "any_~a" x))) 57 | 58 | (quasisyntax/loc syn 59 | (define-judgment-form lang 60 | #:mode (j2 m ...) 61 | 62 | [(j1 any ...) 63 | ------------- 64 | (j2 any ...)]))])) 65 | 66 | (define-syntax (define-input-judgment-form syn) 67 | (syntax-parse syn 68 | [(_ lang j1 j2) 69 | #:with (I ...) (map (lambda _ #'I) (judgment-form-mode (syntax-local-value #'j1))) 70 | (quasisyntax/loc syn 71 | (define-remoded-judgment-form lang j1 #:mode (j2 I ...)))])) 72 | 73 | (require (only-in redex-chk redex-judgment-holds-chk)) 74 | (define-syntax (redex-judgment-holds-chk/t syn) 75 | (syntax-parse syn 76 | [(_ (~or j:id (j:id args ...)) tests ...) 77 | #:with j2 (format-id syn "~a/t" #'j) 78 | #:with tag (format-id syn "~a/tag" #'j) 79 | #`(begin 80 | #,(unless (syntax-local-value #'tag (lambda _ #f)) 81 | #`(begin 82 | (define-input-judgment-form #,(judgment-form-lang (syntax-local-value #'j)) j j2) 83 | (define-syntax (tag) #t))) 84 | (redex-judgment-holds-chk 85 | #,(if (attribute args) 86 | #'(j2 args ...) 87 | #'j2) 88 | tests ...))])) 89 | 90 | (define (maybe-project-judgment ans) 91 | (if (pair? ans) 92 | (if (> (length ans) 1) 93 | ans 94 | (car ans)) 95 | (if (null? ans) 96 | #f 97 | ans))) 98 | 99 | (define-syntax (pretty-judgment-holds syn) 100 | (syntax-parse syn 101 | [(_ (j arg ...) maybe ...) 102 | #`(maybe-project-judgment (judgment-holds (j arg ...) maybe ...))])) 103 | 104 | (define-syntax (functionalize-judgment syn) 105 | (syntax-parse syn 106 | [(_ judgment-name:id n:nat pattern ...) 107 | #:with (args ...) (build-list (eval #'n) (lambda (x) (format-id syn "x~a" x))) 108 | #`(lambda (args ...) (pretty-judgment-holds (judgment-name ,args ... pattern ...) pattern ...))])) 109 | 110 | (define-syntax (functionalize-metafunction syn) 111 | (syntax-parse syn 112 | [(_ metafunction-name:id) 113 | #`(lambda args (term (metafunction-name ,@args)))])) 114 | 115 | (module+ test 116 | (require redex-chk) 117 | (default-language anyL) 118 | (define-judgment-form anyL 119 | #:mode (out I O) 120 | 121 | [(out any any)]) 122 | 123 | (define-remoded-judgment-form anyL out #:mode (out2 I I)) 124 | (define-input-judgment-form anyL out out3) 125 | 126 | (redex-chk 127 | #:lang anyL 128 | (not-free-in D D) #f 129 | (substitute hole D y) hole 130 | (not-free-in D hole) #t) 131 | 132 | (redex-judgment-holds-chk 133 | out 134 | [x x]) 135 | 136 | (redex-judgment-holds-chk 137 | out2 138 | [x x]) 139 | 140 | (redex-judgment-holds-chk 141 | out3 142 | [x x])) 143 | -------------------------------------------------------------------------------- /snoc-env.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require 4 | redex/reduction-semantics 5 | racket/dict) 6 | (provide (all-defined-out)) 7 | 8 | (define-language snocL 9 | (snoc-env ::= · (snoc-env (any any ...)))) 10 | 11 | ;; Flatten a snoc-env into an als, in reverse dependency order 12 | ;; (i.e. the first element may depends all later elements) 13 | (define-metafunction snocL 14 | _snoc-env->als : snoc-env -> ((any any ...) ...) 15 | [(_snoc-env->als ·) ()] 16 | [(_snoc-env->als (snoc-env (any any_r ...))) 17 | ,(cons (term (any any_r ...)) (term (_snoc-env->als snoc-env)))]) 18 | 19 | (define-metafunction snocL 20 | snoc-env->als : snoc-env -> ((any any ...) ...) 21 | [(snoc-env->als snoc-env) 22 | ,(reverse (term (_snoc-env->als snoc-env)))]) 23 | 24 | (define-metafunction snocL 25 | snoc-env-in-dom : snoc-env any -> #t or #f 26 | [(snoc-env-in-dom snoc-env any) 27 | ,(dict-has-key? (term (snoc-env->als snoc-env)) (term any))]) 28 | 29 | (define-metafunction snocL 30 | snoc-env-not-in-dom : snoc-env any -> #t or #f 31 | [(snoc-env-not-in-dom snoc-env any) 32 | ,(not (term (snoc-env-in-dom snoc-env any)))]) 33 | 34 | (define-metafunction snocL 35 | snoc-env-ref : snoc-env_0 any_0 -> any or #f 36 | [(snoc-env-ref snoc-env any_d) 37 | (any_d any_r ...) 38 | (where (any_r ...) ,(dict-ref (term (snoc-env->als snoc-env)) (term any_d) (lambda () #f)))] 39 | [(snoc-env-ref _ _) #f]) 40 | 41 | ;; Merge any number of snoc-envs, given in dependency order 42 | ;; (i.e. the last snoc-env may depend on all previous snoc-envs) 43 | (define-metafunction snocL 44 | snoc-env-merge : snoc-env snoc-env ... -> snoc-env 45 | [(snoc-env-merge snoc-env_0 snoc-env ...) 46 | ,(for/fold ([env (term snoc-env_0)]) 47 | ([snoc-env (term (snoc-env ...))]) 48 | (for/fold ([env env]) 49 | ([decl (term (snoc-env->als ,snoc-env))]) 50 | (term (,env ,decl))))]) 51 | 52 | ;; Take any number of snoc-envs, and snoc-env members, in dependency order, and create a new snoc-env 53 | (define-metafunction snocL 54 | snoc-env-build : snoc-env snoc-env ... ((any any ...) ...) -> snoc-env 55 | [(snoc-env-build snoc-env ... ((any ...) ...)) 56 | ,(for/fold ([env (term (snoc-env-merge snoc-env ...))]) 57 | ([decl (term ((any ...) ...))]) 58 | (term (,env ,decl)))]) 59 | 60 | 61 | (define-judgment-form snocL 62 | #:mode (snoc-env-in I I O) 63 | #:contract (snoc-env-in snoc-env any any) 64 | 65 | [(side-condition (snoc-env-in-dom snoc-env any_k)) 66 | (where (any_k any_v ...) (snoc-env-ref snoc-env any_k)) 67 | ------------------------------- 68 | (snoc-env-in snoc-env any_k (any_v ...))]) 69 | --------------------------------------------------------------------------------