Note about the core, various fixes

README.md

@@ -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.

proofs-for-free.rkt

@@ -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))

stlc.rkt

@@ -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)])