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

Note about the core, various fixes

Browse Source
This commit is contained in:
William J. Bowman 2015-02-05 02:34:05 -05:00
parent 027f031b20
commit 51972880b3
3 changed files with 68 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
README.md
View File

@ -30,3 +30,5 @@ translation defined in [Proofs for Free](http://staff.city.ac.uk/~ross/papers/pr
Open up anything in `stdlib/` to see some standard dependent-type
formalisms.
Open up `redex-curnel.rkt` to see the entire "trusted" core.

5
proofs-for-free.rkt
View File

@ -71,7 +71,8 @@
(define-type CPSf (forall* (ans : Type) (k : (-> X ans)) ans))
(define (CPSf-relation (f1 : CPSf) (f2 : CPSf))
(translate (forall* (ans : Type) (k : (-> X ans)) ans))
;; Run performs substitution, among other things, at compile.
(translate (run CPSf))
(module+ test
(require rackunit)
(check-equal?
@ -86,7 +87,7 @@
(define-type paramCPSf (forall* (f : CPSf) (CPSf-relation f f)))
(define (id (X : Type) (x : X)) x)
(define-theorem thm:cont-shuffle
(define-theorem thm:continuation-shuffle
(forall* (f : CPSf)
(ans : Type)
(ansr : (-> ans ans Type))

125
stlc.rkt
View File

@ -1,5 +1,5 @@
#lang s-exp "redex-curnel.rkt"
(require racket/trace "stdlib/nat.rkt" "stdlib/sugar.rkt" "oll.rkt"
(require "stdlib/nat.rkt" "stdlib/sugar.rkt" "oll.rkt"
"stdlib/maybe.rkt" "stdlib/bool.rkt" "stdlib/prop.rkt")
(define-language stlc
@ -11,7 +11,68 @@
(type (A B) ::= boolty unitty (-> A B) (* A A))
(term (e) ::= x v (app e e) (lambda (x : A) e) (cons e e)
(let (x x) = e in e)))
;; A parser.
;; TODO: Abstract this over stlc-type, and provide from in OLL
(data gamma : Type
(emp-gamma : gamma)
(ext-gamma : (->* gamma var stlc-type gamma)))
(define-rec (lookup-gamma (g : gamma) (x : var) : (maybe stlc-type))
(case* g
[emp-gamma (none stlc-type)]
[(ext-gamma (g1 : gamma) (v1 : var) (t1 : stlc-type))
(if (var-equal? v1 x)
(some stlc-type t1)
(lookup-gamma g1 x))]))
(define-relation (has-type gamma stlc-term stlc-type)
#:output-coq "stlc.v"
#:output-latex "stlc.tex"
[(g : gamma)
------------------------ T-Unit
(has-type g (stlc-val-->-stlc-term stlc-unit) stlc-unitty)]
[(g : gamma)
------------------------ T-True
(has-type g (stlc-val-->-stlc-term stlc-true) stlc-boolty)]
[(g : gamma)
------------------------ T-False
(has-type g (stlc-val-->-stlc-term stlc-false) stlc-boolty)]
[(g : gamma) (x : var) (t : style-type)
(== (maybe stlc-type) (lookup-gamma g x) (some stlc-type t))
------------------------ T-Var
(has-type g (var-->-stlc-term x) t)]
[(g : gamma) (e1 : stlc-term) (e2 : stlc-term)
(t1 : stlc-type) (t2 : stlc-type)
(has-type g e1 t1)
(has-type g e2 t2)
---------------------- T-Pair
(has-type g (stlc-cons e1 e2) (stlc-* t1 t2))]
[(g : gamma) (e1 : stlc-term) (e2 : stlc-term)
(t1 : stlc-type) (t2 : stlc-type)
(has-type g e1 (stlc-* t1 t2))
(has-type (extend-gamma (extend-gamma g x t1) t y2) e2 t)
---------------------- T-Pair
(has-type g (stlc-let x y e1 e2) t)]
[(g : gamma) (e1 : stlc-term) (t1 : stlc-type) (t2 : stlc-type) (x : var)
(has-type (extend-gamma g x t1) e1 t2)
---------------------- T-Fun
(has-type g (stlc-lambda x t1 e1) (stlc--> t1 t2))]
[(g : gamma) (e1 : stlc-term) (e2 : stlc-term)
(t1 : stlc-type) (t2 : stlc-type)
(has-type g e1 (stlc--> t1 t2))
(has-type g e2 t1)
---------------------- T-App
(has-type g (stlc-app e1 e2) t2)])
;; A parser, for a deep-embedding of STLC.
;; TODO: We should be able to generate these
;; TODO: When generating a parser, will need something like (#:name app (e e))
;; so I can name a constructor without screwing with syntax.
@ -74,63 +135,3 @@
(check-equal?
(begin-stlc #t)
(stlc-val-->-stlc-term stlc-true)))
;; TODO: Abstract this over stlc-type, and provide from in OLL
(data gamma : Type
(emp-gamma : gamma)
(ext-gamma : (->* gamma var stlc-type gamma)))
(define-rec (lookup-gamma (g : gamma) (x : var) : (maybe stlc-type))
(case* g
[emp-gamma (none stlc-type)]
[(ext-gamma (g1 : gamma) (v1 : var) (t1 : stlc-type))
(if (var-equal? v1 x)
(some stlc-type t1)
(lookup-gamma g1 x))]))
(define-relation (has-type gamma stlc-term stlc-type)
#:output-coq "stlc.v"
#:output-latex "stlc.tex"
[(g : gamma)
------------------------ T-Unit
(has-type g (stlc-val-->-stlc-term stlc-unit) stlc-unitty)]
[(g : gamma)
------------------------ T-True
(has-type g (stlc-val-->-stlc-term stlc-true) stlc-boolty)]
[(g : gamma)
------------------------ T-False
(has-type g (stlc-val-->-stlc-term stlc-false) stlc-boolty)]
[(g : gamma) (x : var) (t : style-type)
(== (maybe stlc-type) (lookup-gamma g x) (some stlc-type t))
------------------------ T-Var
(has-type g (var-->-stlc-term x) t)]
[(g : gamma) (e1 : stlc-term) (e2 : stlc-term)
(t1 : stlc-type) (t2 : stlc-type)
(has-type g e1 t1)
(has-type g e2 t2)
---------------------- T-Pair
(has-type g (stlc-cons e1 e2) (stlc-* t1 t2))]
[(g : gamma) (e1 : stlc-term) (e2 : stlc-term)
(t1 : stlc-type) (t2 : stlc-type)
(has-type g e1 (stlc-* t1 t2))
(has-type (extend-gamma (extend-gamma g x t1) t y2) e2 t)
---------------------- T-Pair
(has-type g (stlc-let x y e1 e2) t)]
[(g : gamma) (e1 : stlc-term) (t1 : stlc-type) (t2 : stlc-type) (x : var)
(has-type (extend-gamma g x t1) e1 t2)
---------------------- T-Fun
(has-type g (stlc-lambda x t1 e1) (stlc--> t1 t2))]
[(g : gamma) (e1 : stlc-term) (e2 : stlc-term)
(t1 : stlc-type) (t2 : stlc-type)
(has-type g e1 (stlc--> t1 t2))
(has-type g e2 t1)
---------------------- T-App
(has-type g (stlc-app e1 e2) t2)])