suzanne.soy/cur
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Module language, positivity checking, more tests

Browse Source 
* redex-core is now a module language, complete with fancyness. For
  documentation, TODO.
* Added examples file using the module language.
This commit is contained in:
William J. Bowman 2014-07-22 21:20:35 +02:00
parent 176f08dd92
commit 754a32a3ea
2 changed files with 553 additions and 354 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
example.rkt Normal file
View File

@ -0,0 +1,30 @@
#lang s-exp "redex-core.rkt"
(define-syntax (-> syn)
(syntax-case syn ()
[(_ t1 t2)
(with-syntax ([(x) (generate-temporaries '(1))])
#'(forall (x : t1) t2))]))
(data true : Type
(TT : true))
(data nat : Type
(z : nat)
(s : (-> nat nat)))
(lambda (nat : Type)
((lambda (x : (forall (y : Type) Type)) (x nat))
(lambda (y : Type) y)))
(lambda (nat : Type) nat)
(lambda (y : (-> nat nat))
(lambda (x : nat) (y x)))
(define y (lambda (x : true) x))
(define (y1 (x : true)) x)
y1
(define (y2 (x1 : true) (x2 : true)) x1)
(y2 TT TT)

351
redex-core.rkt
View File

@ -1,26 +1,20 @@
#lang racket/base #lang racket
(require (module core racket
(require
(only-in racket/set set=?) (only-in racket/set set=?)
(only-in racket curry)
redex/reduction-semantics) redex/reduction-semantics)
(provide
(all-defined-out))
#;(provide ;; References:
define-constructor-for ;; http://www3.di.uminho.pt/~mjf/pub/SFV-CIC-2up.pdf
match ;; https://www.cs.uoregon.edu/research/summerschool/summer11/lectures/oplss-herbelin1.pdf
define-fun ;; http://www.emn.fr/z-info/ntabareau/papers/universe_polymorphism.pdf
define-rec
lambda)
;; Core language. Surface langauge should provide short-hand, such as
;; References: ;; -> for non-dependent function types, and type inference.
;; http://www3.di.uminho.pt/~mjf/pub/SFV-CIC-2up.pdf (define-language dtracketL
;; https://www.cs.uoregon.edu/research/summerschool/summer11/lectures/oplss-herbelin1.pdf
;; http://www.emn.fr/z-info/ntabareau/papers/universe_polymorphism.pdf
;; Core language. Surface langauge should provide short-hand, such as
;; -> for non-dependent function types, and type inference.
(define-language dtracketL
(i ::= natural) (i ::= natural)
(U ::= Type (Unv i)) (U ::= Type (Unv i))
(x ::= variable-not-otherwise-mentioned) (x ::= variable-not-otherwise-mentioned)
@ -28,7 +22,7 @@
(v ::= (Π (x : t) t) (λ (x : t) t) x U) (v ::= (Π (x : t) t) (λ (x : t) t) x U)
(t e ::= (case e (x e) (x e)...) v (t t))) (t e ::= (case e (x e) (x e)...) v (t t)))
(module+ test (module+ test
(require rackunit) (require rackunit)
(check-true (redex-match? dtracketL x (term T))) (check-true (redex-match? dtracketL x (term T)))
(check-true (redex-match? dtracketL x (term truth))) (check-true (redex-match? dtracketL x (term truth)))
@ -45,10 +39,10 @@
(check-true (redex-match? dtracketL v (term (λ (x_0 : (Unv 0)) x_0)))) (check-true (redex-match? dtracketL v (term (λ (x_0 : (Unv 0)) x_0))))
(check-true (redex-match? dtracketL t (term (λ (x_0 : (Unv 0)) x_0))))) (check-true (redex-match? dtracketL t (term (λ (x_0 : (Unv 0)) x_0)))))
;; 'A' ;; 'A'
;; Types of Universes ;; Types of Universes
;; Replace with sub-typing ;; Replace with sub-typing
(define-judgment-form dtracketL (define-judgment-form dtracketL
#:mode (unv-ok I O) #:mode (unv-ok I O)
#:contract (unv-ok U U) #:contract (unv-ok U U)
@ -61,9 +55,9 @@
----------------- -----------------
(unv-ok (Unv i_0) (Unv i_1))]) (unv-ok (Unv i_0) (Unv i_1))])
;; 'R' ;; 'R'
;; Kinding, I think ;; Kinding, I think
(define-judgment-form dtracketL (define-judgment-form dtracketL
#:mode (unv-kind I I O) #:mode (unv-kind I I O)
#:contract (unv-kind U U U) #:contract (unv-kind U U U)
@ -77,9 +71,10 @@
---------------- ----------------
(unv-kind (Unv i_1) (Unv i_2) (Unv i_3))]) (unv-kind (Unv i_1) (Unv i_2) (Unv i_3))])
;; NB: Substitution is hard ;; NB: Substitution is hard
(define-metafunction dtracketL (define-metafunction dtracketL
subst : t x t -> t subst : t x t -> t
[(subst U x t) U]
[(subst x x t) t] [(subst x x t) t]
[(subst x_0 x t) x_0] [(subst x_0 x t) x_0]
[(subst (Π (x : t_0) t_1) x t) (Π (x : t_0) t_1)] [(subst (Π (x : t_0) t_1) x t) (Π (x : t_0) t_1)]
@ -87,14 +82,14 @@
[(subst (Π (x_0 : t_0) t_1) x t) (Π (x_0 : t_0) (subst t_1 x t))] [(subst (Π (x_0 : t_0) t_1) x t) (Π (x_0 : t_0) (subst t_1 x t))]
[(subst (λ (x_0 : t_0) t_1) x t) (λ (x_0 : t_0) (subst t_1 x t))] [(subst (λ (x_0 : t_0) t_1) x t) (λ (x_0 : t_0) (subst t_1 x t))]
[(subst (e_0 e_1) x t) ((subst e_0 x t) (subst e_1 x t))]) [(subst (e_0 e_1) x t) ((subst e_0 x t) (subst e_1 x t))])
;; NB: ;; NB:
;; TODO: Why do I not have tests for substitutions?!?!?!?!?!?!?!!?!?!?!?!?!?!!??!?! ;; TODO: Why do I not have tests for substitutions?!?!?!?!?!?!?!!?!?!?!?!?!?!!??!?!
(define-extended-language dtracket-redL dtracketL (define-extended-language dtracket-redL dtracketL
(E hole (E t) (λ (x : t) E) (Π (x : t) E))) (E hole (E t) (λ (x : t) E) (Π (x : t) E)))
;; TODO: Congruence-closure instead of β ;; TODO: Congruence-closure instead of β
(define ==β (define ==β
(reduction-relation dtracket-redL (reduction-relation dtracket-redL
(==> ((Π (x : t_0) t_1) t_2) (==> ((Π (x : t_0) t_1) t_2)
(subst t_1 x t_2)) (subst t_1 x t_2))
@ -104,10 +99,10 @@
[(--> (in-hole E t_0) (in-hole E t_1)) [(--> (in-hole E t_0) (in-hole E t_1))
(==> t_0 t_1)])) (==> t_0 t_1)]))
(define-metafunction dtracket-redL (define-metafunction dtracket-redL
reduce : e -> e reduce : e -> e
[(reduce e) ,(car (apply-reduction-relation* ==β (term e)))]) [(reduce e) ,(car (apply-reduction-relation* ==β (term e)))])
(module+ test (module+ test
(check-equal? (term (reduce Type)) (term Type)) (check-equal? (term (reduce Type)) (term Type))
(check-equal? (term (reduce ((λ (x : t) x) Type))) (term Type)) (check-equal? (term (reduce ((λ (x : t) x) Type))) (term Type))
(check-equal? (term (reduce ((Π (x : t) x) Type))) (term Type)) (check-equal? (term (reduce ((Π (x : t) x) Type))) (term Type))
@ -116,37 +111,37 @@
(check-equal? (term (reduce (Π (x : t) ((Π (x_0 : t) x_0) x)))) (check-equal? (term (reduce (Π (x : t) ((Π (x_0 : t) x_0) x))))
(term (Π (x : t) x)))) (term (Π (x : t) x))))
;; TODO: Bi-directional and inference? ;; TODO: Bi-directional and inference?
;; http://www.cs.ox.ac.uk/ralf.hinze/WG2.8/31/slides/stephanie.pdf ;; http://www.cs.ox.ac.uk/ralf.hinze/WG2.8/31/slides/stephanie.pdf
(define-extended-language dtracket-typingL dtracketL (define-extended-language dtracket-typingL dtracketL
(Σ Γ ::= ∅ (Γ x : t))) (Σ Γ ::= ∅ (Γ x : t)))
;; NB: Depends on clause order ;; NB: Depends on clause order
(define-metafunction dtracket-typingL (define-metafunction dtracket-typingL
lookup : Γ x -> t or #f lookup : Γ x -> t or #f
[(lookup ∅ x) #f] [(lookup ∅ x) #f]
[(lookup (Γ x : t) x) t] [(lookup (Γ x : t) x) t]
[(lookup (Γ x_0 : t_0) x_1) (lookup Γ x_1)]) [(lookup (Γ x_0 : t_0) x_1) (lookup Γ x_1)])
;; NB: Depends on clause order ;; NB: Depends on clause order
(define-metafunction dtracket-typingL (define-metafunction dtracket-typingL
remove : Γ x -> Γ remove : Γ x -> Γ
[(remove ∅ x) ∅] [(remove ∅ x) ∅]
[(remove (Γ x : t) x) Γ] [(remove (Γ x : t) x) Γ]
[(remove (Γ x_0 : t_0) x_1) (remove Γ x_1)]) [(remove (Γ x_0 : t_0) x_1) (remove Γ x_1)])
(define-metafunction dtracket-typingL (define-metafunction dtracket-typingL
result-type : Σ t -> t or #f result-type : Σ t -> t or #f
[(result-type Σ (Π (x : t) e)) (result-type Σ e)] [(result-type Σ (Π (x : t) e)) (result-type Σ e)]
[(result-type Σ x) ,(and (term (lookup Σ x)) (term x))] [(result-type Σ x) ,(and (term (lookup Σ x)) (term x))]
[(result-type Σ t) #f]) [(result-type Σ t) #f])
(module+ test (module+ test
(define Σ (term (((∅ nat : Type) zero : nat) s : (Π (x : nat) nat)))) (define Σ (term (((∅ nat : Type) zero : nat) s : (Π (x : nat) nat))))
(check-equal? (term nat) (term (result-type ,Σ (Π (x : nat) nat)))) (check-equal? (term nat) (term (result-type ,Σ (Π (x : nat) nat))))
(check-equal? (term nat) (term (result-type ,Σ nat)))) (check-equal? (term nat) (term (result-type ,Σ nat))))
(define-judgment-form dtracket-typingL (define-judgment-form dtracket-typingL
#:mode (constructor-for I I O) #:mode (constructor-for I I O)
#:contract (constructor-for Σ t x) #:contract (constructor-for Σ t x)
@ -157,7 +152,7 @@
[(constructor-for Σ t_1 x) [(constructor-for Σ t_1 x)
------------- -------------
(constructor-for (Σ x_0 : t_0) t_1 x)]) (constructor-for (Σ x_0 : t_0) t_1 x)])
(module+ test (module+ test
(check-true (check-true
(judgment-holds (constructor-for ((∅ truth : Type) T : truth) truth T))) (judgment-holds (constructor-for ((∅ truth : Type) T : truth) truth T)))
(check-true (check-true
@ -169,13 +164,13 @@
(constructor-for (((∅ nat : Type) zero : nat) s : (Π (x : nat) nat)) (constructor-for (((∅ nat : Type) zero : nat) s : (Π (x : nat) nat))
nat x) x) nat x) x)
(list (term zero) (term s)))) (list (term zero) (term s))))
(define-metafunction dtracket-typingL (define-metafunction dtracket-typingL
constructors-for : Σ t (x ...) -> #t or #f constructors-for : Σ t (x ...) -> #t or #f
[(constructors-for Σ t (x ...)) [(constructors-for Σ t (x ...))
,((lambda (x y) (and (set=? x y) (= (length x) (length y)))) ,((lambda (x y) (and (set=? x y) (= (length x) (length y))))
(term (x ...)) (term (x ...))
(judgment-holds (constructor-for Σ t x_00) x_00))]) (judgment-holds (constructor-for Σ t x_00) x_00))])
(module+ test (module+ test
(check-true (check-true
(term (constructors-for (((∅ nat : Type) zero : nat) s : (Π (x : nat) nat)) (term (constructors-for (((∅ nat : Type) zero : nat) s : (Π (x : nat) nat))
nat (zero s)))) nat (zero s))))
@ -183,21 +178,21 @@
(term (constructors-for (((∅ nat : Type) zero : nat) s : (Π (x : nat) nat)) (term (constructors-for (((∅ nat : Type) zero : nat) s : (Π (x : nat) nat))
nat (zero))))) nat (zero)))))
(define-metafunction dtracketL (define-metafunction dtracketL
branch-type : t t t -> t branch-type : t t t -> t
[(branch-type t_ind (Π (x_0 : t) e_0) (Π (x_1 : t) e_1)) [(branch-type t_ind (Π (x_0 : t) e_0) (Π (x_1 : t) e_1))
(branch-type t_ind e_0 e_1)] (branch-type t_ind e_0 e_1)]
[(branch-type t_ind t_ind t) t]) [(branch-type t_ind t_ind t) t])
(module+ test (module+ test
(check-equal? (term Type) (term (branch-type nat (lookup ,Σ zero) Type))) (check-equal? (term Type) (term (branch-type nat (lookup ,Σ zero) Type)))
(check-equal? (term nat) (term (branch-type nat nat nat))) (check-equal? (term nat) (term (branch-type nat nat nat)))
(check-equal? (term Type) (term (branch-type nat (lookup ,Σ s) (Π (x : nat) Type))))) (check-equal? (term Type) (term (branch-type nat (lookup ,Σ s) (Π (x : nat) Type)))))
(define-metafunction dtracket-typingL (define-metafunction dtracket-typingL
branch-types-match : Σ (x ...) (t ...) t t -> #t or #f branch-types-match : Σ (x ...) (t ...) t t -> #t or #f
[(branch-types-match Σ (x ...) (t_11 ...) t t_1) [(branch-types-match Σ (x ...) (t_11 ...) t t_1)
,(andmap (curry equal? (term t)) (term ((branch-type t_1 (lookup Σ x) t_11) ...)))]) ,(andmap (curry equal? (term t)) (term ((branch-type t_1 (lookup Σ x) t_11) ...)))])
(module+ test (module+ test
(check-true (check-true
(term (branch-types-match ((∅ truth : Type) T : truth) () () Type nat))) (term (branch-types-match ((∅ truth : Type) T : truth) () () Type nat)))
(check-true (check-true
@ -205,7 +200,50 @@
(check-true (check-true
(term (branch-types-match ,Σ (zero s) (nat (Π (x : nat) nat)) nat nat)))) (term (branch-types-match ,Σ (zero s) (nat (Π (x : nat) nat)) nat nat))))
(define-judgment-form dtracket-typingL (define-metafunction dtracketL
positive : t any -> #t or #f
;; Type; not a inductive constructor
[(positive U any) #t]
;; nat
[(positive x_0 x_0) #t]
;; nat -> t_1 ... -> nat
[(positive (Π (x : x_1) t_1) x_0)
(positive t_1 x_0)]
;; Type -> t_1 ... -> nat
[(positive (Π (x : U) t_1) x_0)
(positive t_1 x_0)]
;; (t_0 -> t_2) -> t_1 ... -> nat
[(positive (Π (x : (Π (x_1 : t_0) t_2)) t_1) x_0)
,(and (term (copositive (Π (x_1 : t_0) t_2) x_0)) (term (positive t_1 x_0)))])
(define-metafunction dtracketL
copositive : t any -> #t or #f
[(copositive U any) #t]
[(copositive x_0 x_0) #f]
[(copositive (Π (x : x_0) t_1) x_0) #f]
;; x_1 -> t_1 ... -> nat
[(copositive (Π (x : x_1) t_1) x_0)
(positive t_1 x_0)]
[(copositive (Π (x : U) t_1) x_0)
(positive t_1 x_0)]
[(copositive (Π (x : (Π (x_1 : t_0) t_2)) t_1) x_0)
,(and (term (positive (Π (x_1 : t_0) t_2) x_0)) (term (copositive t_1 x_0)))])
(module+ test
(check-true (term (positive nat nat)))
(check-true (term (positive (Π (x : nat) nat) nat)))
;; (nat -> nat) -> nat
(check-false (term (positive (Π (x : (Π (y : nat) nat)) nat) nat)))
;; (Type -> nat) -> nat
(check-true (term (positive (Π (x : (Π (y : Type) nat)) nat) nat)))
;; (((nat -> Type) -> nat) -> nat)
(check-true (term (positive (Π (x : (Π (y : (Π (x : nat) Type)) nat)) nat) nat)))
(check-false (term (positive (Π (x : (Π (y : (Π (x : nat) nat)) nat)) nat) nat)))
(check-true (term (positive Type #f)))
)
(define-judgment-form dtracket-typingL
#:mode (wf I I) #:mode (wf I I)
#:contract (wf Σ Γ) #:contract (wf Σ Γ)
@ -217,16 +255,17 @@
(wf Σ (Γ x : t))] (wf Σ (Γ x : t))]
[(types Σ ∅ t U) [(types Σ ∅ t U)
(side-condition (positive t (result-type Σ t)))
----------------- -----------------
(wf (Σ x : t) ∅)]) (wf (Σ x : t) ∅)])
(module+ test (module+ test
(check-true (judgment-holds (wf ∅ ∅))) (check-true (judgment-holds (wf ∅ ∅)))
(check-true (judgment-holds (wf (∅ truth : Type) ∅))) (check-true (judgment-holds (wf (∅ truth : Type) ∅)))
(check-true (judgment-holds (wf ∅ (∅ x : Type)))) (check-true (judgment-holds (wf ∅ (∅ x : Type))))
(check-true (judgment-holds (wf (∅ nat : Type) (∅ x : nat)))) (check-true (judgment-holds (wf (∅ nat : Type) (∅ x : nat))))
(check-true (judgment-holds (wf (∅ nat : Type) (∅ x : (Π (x : nat) nat)))))) (check-true (judgment-holds (wf (∅ nat : Type) (∅ x : (Π (x : nat) nat))))))
(define-judgment-form dtracket-typingL (define-judgment-form dtracket-typingL
#:mode (types I I I O) #:mode (types I I I O)
#:contract (types Σ Γ e t) #:contract (types Σ Γ e t)
@ -281,7 +320,7 @@
(types Γ t_1 U) (types Γ t_1 U)
----------------- "DTR-Conversion" ----------------- "DTR-Conversion"
(types Γ e t_1)]) (types Γ e t_1)])
(module+ test (module+ test
(check-true (judgment-holds (types ∅ ∅ Type (Unv 0)))) (check-true (judgment-holds (types ∅ ∅ Type (Unv 0))))
(check-true (judgment-holds (types ∅ (∅ x : Type) Type (Unv 0)))) (check-true (judgment-holds (types ∅ (∅ x : Type) Type (Unv 0))))
(check-true (judgment-holds (types ∅ (∅ x : Type) x Type))) (check-true (judgment-holds (types ∅ (∅ x : Type) x Type)))
@ -332,9 +371,31 @@
(types (((∅ nat : Type) zero : nat) s : (Π (x : nat) nat)) (types (((∅ nat : Type) zero : nat) s : (Π (x : nat) nat))
∅ ∅
(case zero (zero (s zero))) (case zero (zero (s zero)))
nat)))) nat)))
(define Σ0 (term ∅))
(define lam (term (λ (nat : Type) nat)))
(check-equal?
(term (Π (nat : Type) Type))
(judgment-holds (types ,Σ0 ∅ ,lam t) t))
(define Σ2 (term (((∅ nat : Type) z : nat) s : (Π (x : nat) nat))))
(check-equal?
(term (Π (nat : Type) Type))
(judgment-holds (types ,Σ2 ∅ ,lam t) t))
(check-equal?
(term (Π (x : (Π (y : Type) y)) nat))
(judgment-holds (types (∅ nat : Type) ∅ (λ (x : (Π (y : Type) y)) (x nat))
t) t))
(check-equal?
(term (Π (y : Type) Type))
(judgment-holds (types (∅ nat : Type) ∅ (λ (y : Type) y) t) t))
(check-equal?
(term Type)
(judgment-holds (types (∅ nat : Type) ∅
((λ (x : (Π (y : Type) Type)) (x nat))
(λ (y : Type) y))
t) t)))
(define-judgment-form dtracket-typingL (define-judgment-form dtracket-typingL
#:mode (type-check I I I) #:mode (type-check I I I)
#:contract (type-check Γ e t) #:contract (type-check Γ e t)
@ -342,14 +403,14 @@
--------------- ---------------
(type-check Σ e (reduce t))]) (type-check Σ e (reduce t))])
;; Infer-core Language ;; Infer-core Language
;; A relaxed core where annotation are optional. ;; A relaxed core where annotation are optional.
(define-extended-language dtracket-surfaceL dtracketL (define-extended-language dtracket-surfaceL dtracketL
(v ::= .... (λ x e) (Π t e)) (v ::= .... (λ x e) (Π t e))
(t e ::= .... (data x (x : t) (x : t) ...) (case e ([e e] ...)) (e : t))) (t e ::= .... (data x (x : t) (x : t) ...) (case e ([e e] ...)) (e : t)))
;; http://www.cs.ox.ac.uk/ralf.hinze/WG2.8/31/slides/stephanie.pdf ;; http://www.cs.ox.ac.uk/ralf.hinze/WG2.8/31/slides/stephanie.pdf
#;(define-judgment-form dtracket-typingL #;(define-judgment-form dtracket-typingL
#:mode (synth I I O) #:mode (synth I I O)
#:contract (synth Γ t t) #:contract (synth Γ t t)
@ -377,35 +438,143 @@
[(check Γ e t) [(check Γ e t)
----------------- "DTR-SAnnotate" ----------------- "DTR-SAnnotate"
(synth Γ (e : t) t)]) (synth Γ (e : t) t)]) )
#;(define-judgment-form dtracket-typingL (module sugar racket
#:mode (check I I I) (require
#:contract (check Γ t t) racket/trace
racket/pretty
(submod ".." core)
redex/reduction-semantics
(for-syntax
racket
racket/pretty
racket/trace
(except-in (submod ".." core) remove)
redex/reduction-semantics))
(provide
;; Basic syntax
#%module-begin
(rename-out
[dep-lambda lambda]
[dep-lambda λ]
[dep-app #%app]
[(check (Γ x : t_0) e t_1) [dep-forall forall]
----------------- "DTR-Abstraction" [dep-forall ∀]
(check Γ (λ x e) (Π (x : t_0) t_1))]
[(synth Γ e t) [dep-inductive data]
----------------- "DTR-SSynth" [dep-case case]
(check Γ e t)])
#;(module+ test
(check-equal?
(list (term (Unv 0)))
(judgment-holds (synth ∅ Type U) U))
(check-equal?
(list (term Unv 0))
(judgment-holds (synth (∅ x : Type) Type U)))
(check-equal?
(list (term Type))
(judgment-holds (synth (∅ x : Type) x U)))
(check-equal?
(list (term Type))
(judgment-holds (synth ((∅ x_0 : Type) x_1 : Type) (Π (x_3 : x_0) x_1) U)))
(check-equal? [dep-var #%top])
(list ()) ;; DYI syntax extension
(judgment-holds (synth ∅ (λ (x : Type) x) (Π (x : Type) Type)))) define-syntax
(check-true (judgment-holds (types ∅ (λ (y : Type) (λ (x : y) x)) (rename-out [dep-define define])
(Π (y : Type) (Π (x : y) y)))))) syntax-case
syntax-rules
(for-syntax (all-from-out racket)))
(begin-for-syntax
(current-trace-notify
(parameterize ([pretty-print-depth #f]
[pretty-print-columns 'infinity])
(lambda (x)
(pretty-display x)
(newline))))
(current-trace-print-args
(let ([cwtpr (current-trace-print-args)])
(lambda (s l kw l2 n)
(cwtpr s (map syntax->datum l) kw l2 n))))
(current-trace-print-results
(let ([cwtpr (current-trace-print-results)])
(lambda (s l n)
(cwtpr s (map syntax->datum l) n)))))
;; WEEEEEEE
(define gamma
(make-parameter (term ∅)
(lambda (x)
(unless (redex-match? dtracket-typingL Γ x)
(error 'core-error "We build a bad gamma ~s" x))
x)))
(define sigma
(make-parameter (term ∅)#;(term (((∅ nat : Type) z : nat) s : (Π (x : nat) nat)))
(lambda (x)
(unless (redex-match? dtracket-typingL Σ x)
(error 'core-error "We build a bad sigma ~s" x))
x)))
#;(define-syntax (-> syn)
(syntax-case syn ()
[(_ t1 t2)
(with-syntax ([(x) (generate-temporaries '(1))])
#'(dep-forall (x : t1) t2))]))
(define-syntax (dep-lambda syn)
(syntax-case syn (:)
[(_ (x : t) e)
#`(let* ([lam (term (λ (x : ,t)
,(let ([x (term x)])
(parameterize ([gamma (term (,(gamma) ,x : ,t))])
e))))])
(unless (judgment-holds (types ,(sigma) ,(gamma) ,lam t_0))
(error 'type-checking "Term is ill-typed: ~s" lam))
lam)]))
(define-syntax (curry-app syn)
(syntax-case syn ()
[(_ e1 e2) #'(term (,e1 ,e2))]
[(_ e1 e2 e3 ...)
#'(curry-app (term (,e1 ,e2)) e3 ...)]))
(define-syntax (dep-app syn)
(syntax-case syn ()
[(_ e1 e2 ...)
#'(term (reduce ,(curry-app e1 e2 ...))) ]))
(define-syntax-rule (dep-case e (x0 e0) ...)
(term (case ,e (,x0 ,e0) ...)))
(define-syntax (dep-inductive syn)
(syntax-case syn (:)
[(_ i : ti (x1 : t1) ...)
#'(begin
(sigma (term (,(sigma) i : ,ti)))
(for ([x (list (term x1) ...)]
[t (list (term ,t1) ...)])
(sigma (term (,(sigma) ,x : ,t)))))]))
;; TODO: Lots of shared code with dep-lambda
(define-syntax (dep-forall syn)
(syntax-case syn (:)
[(_ (x : t) e)
#`(let ([tmp (term (Π (x : ,t)
,(let ([x (term x)])
(parameterize ([gamma (term (,(gamma) ,x : ,t))])
e))))])
(unless (judgment-holds (types ,(sigma) ,(gamma) ,tmp U_0))
(error 'type-checking "Term is ill-typed: ~s" tmp))
tmp)]))
(define-syntax (dep-var syn)
(syntax-case syn ()
[(_ . id)
#'(let ()
(unless (judgment-holds (types ,(sigma) ,(gamma) ,(term id) t_0))
(error 'unbound "Unbound variable: ~s" (term id)))
(term id))]))
(define-syntax (curry-lambda syn)
(syntax-case syn (:)
[(_ ((x : t) (xr : tr) ...) e)
#'(dep-lambda (x : t) (curry-lambda ((xr : tr) ...) e))]
[(_ () e) #'e]))
;; TODO: Syntax-parse
(define-syntax (dep-define syn)
(syntax-case syn (:)
[(_ (name (x : t) ...) e)
#'(define name (curry-lambda ((x : t) ...) e))]
[(_ id e)
#'(define id e)])))
(require 'sugar)
(provide (all-from-out 'sugar))