41b40fea2b
Lots of tests and examples cause the package to fail to build. These have been commented out until they can be fixed.
115 lines
3.9 KiB
Racket
115 lines
3.9 KiB
Racket
#lang racket/base
|
|
(error "Known bug: proofs-for-free.rkt way out of date")
|
|
#| TODO NB XXX This file is woefully out of date
|
|
#lang s-exp "../cur.rkt"
|
|
(require
|
|
"../stdlib/sugar.rkt"
|
|
"../stdlib/prop.rkt"
|
|
racket/trace
|
|
(for-syntax racket/syntax))
|
|
|
|
;; ---------
|
|
(begin-for-syntax
|
|
(define (rename_id i x)
|
|
(format-id x "~a~a" x i)))
|
|
|
|
(define-syntax (rename syn)
|
|
(syntax-case syn ()
|
|
[(_ i ls e)
|
|
(syntax-case #`(ls #,(cur-expand #'e)) (Type forall Unv lambda :)
|
|
[(_ Type) #'Type]
|
|
[(_ (Unv n)) #'(Unv n)]
|
|
[((xr ...) (lambda (x : t) e))
|
|
#'(lambda (x : (rename i (xr ...) t))
|
|
(rename i (xr ... x) e))]
|
|
[((xr ...) (forall (x : t) e))
|
|
#'(forall (x : (rename i (xr ...) t))
|
|
(rename i (xr ... x) e))]
|
|
[(ls (e1 e2))
|
|
#'((rename i ls e1) (rename i ls e2))]
|
|
[(ls x)
|
|
(if (member (syntax->datum #'x) (syntax->datum #'ls))
|
|
#'x
|
|
(rename_id (syntax->datum #'i) #'x))])]))
|
|
|
|
(trace-define-syntax (translate syn)
|
|
(syntax-parse (cur-expand (syntax-case syn () [(_ e) #'e]))
|
|
;; TODO: Need to add these to a literal set and export it
|
|
;; Or, maybe redefine syntax-parse
|
|
#:datum-literals (:)
|
|
#:literals (lambda forall data real-app case Type)
|
|
[Type
|
|
#'(lambda* (x1 : Type) (x2 : Type) (->* x1 x2 Type))]
|
|
[(forall (x : A) B)
|
|
(let ([x1 (rename_id 1 #'x)]
|
|
[x2 (rename_id 2 #'x)]
|
|
[xr (rename_id 'r #'x)])
|
|
#`(lambda* (f1 : (rename 1 () (forall (x : A) B)))
|
|
(f2 : (rename 2 () (forall (x : A) B)))
|
|
(forall* (#,x1 : (rename 1 () A)) (#,x2 : (rename 2 () A))
|
|
(#,xr : (run ((translate A) #,x1 #,x2)))
|
|
((translate B) (f1 #,x1) (f2 #,x2)))))]
|
|
[(lambda (x : A) B)
|
|
(let ([x1 (rename_id 1 #'x)]
|
|
[x2 (rename_id 2 #'x)]
|
|
[xr (rename_id 'r #'x)])
|
|
#`(lambda* (f1 : (rename 1 () (forall (x : A) B)))
|
|
(f2 : (rename 2 () (forall (x : A) B)))
|
|
(forall* (#,x1 : (rename 1 () A))
|
|
(#,x2 : (rename 2 () A))
|
|
(#,xr : (run ((translate A) #,x1 #,x2)))
|
|
((translate B) (f1 #,x1) (f2 #,x2)))))]
|
|
[(data id : t (c : tc) ...)
|
|
(let ([t #`(data #,(rename_id 'r #'id) : (translate t)
|
|
((translate c) : (translate tc)) ...)])
|
|
t)]
|
|
[(f a)
|
|
#`((translate f) (rename 1 () a) (rename 2 () a) (translate a))]
|
|
[x:id
|
|
;; TODO: Look up x and generate the relation. Otherwise I need to
|
|
;; manually translate all dependencies.
|
|
;; Not sure this is quite right; Racket's hygiene might `save' me.
|
|
(rename_id 'r #'x)]
|
|
[_ (raise-syntax-error "translate undefined for" syn)]))
|
|
|
|
(define-type X Type)
|
|
(define X1 X)
|
|
(define X2 X)
|
|
(define (Xr (x1 : X1) (x2 : X2)) true)
|
|
|
|
;; The type of a CPS function
|
|
(define-type CPSf (forall* (ans : Type) (k : (-> X ans)) ans))
|
|
|
|
(define (CPSf-relation (f1 : CPSf) (f2 : CPSf))
|
|
;; TODO: Fix run so I can simply use (run CPSf) to perform
|
|
;; substitution
|
|
#;(translate (run CPSf))
|
|
(translate (forall* (ans : Type) (k : (-> X ans)) ans)))
|
|
#;(module+ test
|
|
(require rackunit)
|
|
(check-equal?
|
|
(translate (forall* (ans : Type) (k : (-> X ans)) ans))
|
|
(forall* (ans1 : Type) (ans2 : Type) (ansr : (->* ans1 ans2 Type))
|
|
(forall* (k1 : (-> X ans1)) (k2 : (-> X ans2))
|
|
(kr : (forall* (_1 : X) (_2 : X) (_r : (Xr _1 _2))
|
|
(ansr (k1 _1) (k2 _2))))
|
|
(ansr (f1 ans1 k1) (f2 ans2 k2))))))
|
|
|
|
;; By parametricity, every CPSf is related it itself in the CPS relation
|
|
(define-type paramCPSf (forall* (f : CPSf) (CPSf-relation f f)))
|
|
(define (id (X : Type) (x : X)) x)
|
|
|
|
(define-theorem thm:continuation-shuffle
|
|
(forall* (f : CPSf)
|
|
(ans : Type)
|
|
(ansr : (-> ans ans Type))
|
|
(k : (-> X ans))
|
|
(ansr (f ans k) (k (f ans (id ans))))))
|
|
|
|
#;(define (rel (x1 : X) (x2 : X))
|
|
(and (Xr x1 x2)
|
|
))
|
|
|
|
#;(paramCPSf f X X rel k k)
|
|
|#
|