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

Started work to enable reflection

Browse Source 
* sigma, gamma extended at expand time
* All type-checking happens at expand time
* Locally expand all forms into core redex forms. However, this seems to
  be causing problems. Probably not controlling expansion just right.
This commit is contained in:
William J. Bowman 2015-01-27 23:55:50 -05:00
parent 96f9343029
commit c24650ef01
4 changed files with 162 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

193
cur-redex.rkt
View File

@ -610,13 +610,12 @@
(provide (provide
;; Basic syntax ;; Basic syntax
begin-for-syntax begin-for-syntax
#%module-begin
#%datum #%datum
require require
provide provide
for-syntax for-syntax
module+ module+
begin #%module-begin
(rename-out (rename-out
[dep-lambda lambda] [dep-lambda lambda]
[dep-lambda λ] [dep-lambda λ]
@ -630,10 +629,10 @@
[dep-inductive data] [dep-inductive data]
[dep-case case] [dep-case case]
[dep-var #%top]) [dep-var #%top]
[dep-define define])
;; DYI syntax extension ;; DYI syntax extension
define-syntax define-syntax
(rename-out [dep-define define])
(for-syntax (all-from-out syntax/parse)) (for-syntax (all-from-out syntax/parse))
syntax-case syntax-case
syntax-rules syntax-rules
@ -645,7 +644,7 @@
[type-check^ type-check] [type-check^ type-check]
[reduce^ reduce])) [reduce^ reduce]))
(begin-for-syntax #;(begin-for-syntax
(current-trace-notify (current-trace-notify
(parameterize ([pretty-print-depth #f] (parameterize ([pretty-print-depth #f]
[pretty-print-columns 'infinity]) [pretty-print-columns 'infinity])
@ -655,89 +654,157 @@
(current-trace-print-args (current-trace-print-args
(let ([cwtpr (current-trace-print-args)]) (let ([cwtpr (current-trace-print-args)])
(lambda (s l kw l2 n) (lambda (s l kw l2 n)
(cwtpr s (map syntax->datum l) kw l2 n)))) (cwtpr s (map (lambda (x) (if (syntax? x) (syntax->datum x)
x)) l) kw l2 n))))
(current-trace-print-results (current-trace-print-results
(let ([cwtpr (current-trace-print-results)]) (let ([cwtpr (current-trace-print-results)])
(lambda (s l n) (lambda (s l n)
(cwtpr s (map syntax->datum l) n))))) (cwtpr s (map (lambda (x) (if (syntax? x) (syntax->datum x) x)) l) n)))))
;; WEEEEEEE (begin-for-syntax
(define gamma
(make-parameter (term ∅)
(lambda (x)
(unless (redex-match? cic-typingL Γ x)
(error 'core-error "We build a bad gamma ~s" x))
x)))
(define sigma ;; WEEEEEEE
(make-parameter (term ∅) (define gamma
(lambda (x) (make-parameter (term ∅)
(unless (redex-match? cic-typingL Σ x) (lambda (x)
(error 'core-error "We build a bad sigma ~s" x)) (unless (redex-match? cic-typingL Γ x)
x))) (error 'core-error "We built a bad gamma ~s" x))
x)))
(define sigma
(make-parameter (term ∅)
(lambda (x)
(unless (redex-match? cic-typingL Σ x)
(error 'core-error "We built a bad sigma ~s" x))
x)))
(define bound (make-parameter '()))
(define (extend-bound id) (cons id (bound)))
(define orig-insp (variable-reference->module-declaration-inspector
(#%variable-reference)))
(define (disarm syn) (syntax-disarm syn orig-insp))
;; TODO: Pull expand, perhaps list of literals, into a library.
(define (cur-expand syn)
(disarm (local-expand syn 'expression
(syntax-e #'(term lambda forall data case fix Type #%app #%top
dep-inductive dep-case dep-lambda dep-app
dep-fix dep-forall dep-var)))))
(define (core-expand syn)
(define (expand syn)
(if (identifier? syn)
syn
(disarm (local-expand syn 'expression
(append
(syntax-e #'(term reduce #%app λ Π μ case))
(bound))))))
(let core-expand ([syn (expand syn)])
(syntax-parse syn
#:datum-literals (term reduce case Π λ μ :)
[x:id #'x]
[(reduce e) (core-expand #'e)]
[(term e) (core-expand #'e)]
;; TODO: should really check that b is one of the binders
[(b:id (x : t) e)
(let* ([x (core-expand #'x)]
[t (core-expand #'t)]
[e (parameterize ([gamma (extend-env gamma x t)]
[bound (extend-bound x)])
(core-expand #'e))])
#`(b (#,x : #,t) #,e))]
[(case e (ec eb) ...)
#`(case #,(core-expand #'e)
#,@(map (lambda (c b)
#`(#,(core-expand c)
#,(core-expand b)))
(syntax->list #'(ec ...))
(syntax->list #'(eb ...))))]
[(e ...)
#`(#,@(map core-expand (syntax->list #'(e ...))))])))
(define (cur->datum syn) (syntax->datum (core-expand syn)))
(define (extend-env env x t)
(term (,(env) ,(cur->datum x) : ,(cur->datum t))))
(define (denote syn) #`(term (reduce #,syn))))
(define-syntax (dep-lambda syn) (define-syntax (dep-lambda syn)
(syntax-case syn (:) (syntax-case syn (:)
[(_ (x : t) e) [(_ (x : t) e)
#`(let* ([lam (term (λ (x : ,t) (let* ([lam (core-expand #`(λ (x : t) e))])
,(let ([x (term x)]) (unless (judgment-holds (types ,(sigma) ,(gamma)
(parameterize ([gamma (term (,(gamma) ,x : ,t))]) ,(syntax->datum lam) t_0))
e))))]) (raise-syntax-error 'cur "λ is ill-typed:"
(unless (judgment-holds (types ,(sigma) ,(gamma) ,lam t_0)) (begin (printf "Sigma: ~s~nGamma: ~s~n" (sigma) (gamma)) lam)))
(error 'type-checking "Term is ill-typed: ~s" lam)) (denote lam))]))
lam)]))
(define-syntax (curry-app syn) (define-syntax (curry-app syn)
(syntax-case syn () (syntax-case syn ()
[(_ e1 e2) #'(term (,e1 ,e2))] [(_ e1 e2) #'(e1 e2)]
[(_ e1 e2 e3 ...) [(_ e1 e2 e3 ...)
#'(curry-app (term (,e1 ,e2)) e3 ...)])) #'(curry-app (e1 e2) e3 ...)]))
(define-syntax (dep-app syn) (trace-define-syntax (dep-app syn)
(syntax-case syn () (syntax-case syn ()
[(_ e1 e2 ...) [(_ e1 e2 ...)
#'(term (reduce ,(curry-app e1 e2 ...))) ])) (denote (core-expand #'(curry-app e1 e2 ...))) ]))
(define-syntax-rule (dep-case e (x0 e0) ...) (define-syntax (dep-case syn)
(term (reduce (case ,e (,x0 ,e0) ...)))) (syntax-case syn ()
[(_ e ...) (denote #'(case e ...))]))
(define-syntax (dep-inductive syn) (define-syntax (dep-inductive syn)
(syntax-case syn (:) (syntax-case syn (:)
[(_ i : ti (x1 : t1) ...) [(_ i : ti (x1 : t1) ...)
#'(begin (begin
(sigma (term (,(sigma) i : ,ti))) (sigma (extend-env sigma #'i #'ti))
(for ([x (list (term x1) ...)] (bound (extend-bound #'i))
[t (list (term ,t1) ...)]) (for ([x (syntax->list #`(x1 ...))]
(sigma (term (,(sigma) ,x : ,t)))))])) [t (syntax->list #`(t1 ...))])
(sigma (extend-env sigma x t))
(bound (extend-bound x)))
#'(void))]))
;; TODO: Lots of shared code with dep-lambda ;; TODO: Lots of shared code with dep-lambda
(define-syntax (dep-forall syn) (define-syntax (dep-forall syn)
(syntax-case syn (:) (syntax-case syn (:)
[(_ (x : t) e) [(_ (x : t) e)
#`(let ([tmp (term (Π (x : ,t) (let ([pi (core-expand #`(Π (x : t) e))])
,(let ([x (term x)]) (unless (judgment-holds (types ,(sigma) ,(gamma)
(parameterize ([gamma (term (,(gamma) ,x : ,t))]) ,(syntax->datum pi) U_0))
e))))]) (raise-syntax-error 'cur "Π is ill-typed:"
(unless (judgment-holds (types ,(sigma) ,(gamma) ,tmp U_0)) (begin (printf "Sigma: ~s~nGamma: ~s~n" (sigma) (gamma)) pi)))
(error 'type-checking "Term is ill-typed: ~s" tmp)) (denote pi))]))
tmp)]))
;; TODO: Right now, all top level things are variables, so typos can ;; TODO: Right now, all top level things are variables, so typos can
;; result in "unbound variable" errors. Should do something more ;; result in "unbound variable" errors. Should do something more
;; clever. ;; clever.
(define-syntax (dep-var syn) (define-syntax (dep-var syn)
(syntax-case syn () (syntax-case syn ()
[(_ . id) (denote #'id)])
#;(syntax-case syn ()
[(_ . id) [(_ . id)
#'(let () (let ([id #'id])
(unless (judgment-holds (types ,(sigma) ,(gamma) ,(term id) t_0)) (unless (judgment-holds (types ,(sigma) ,(gamma) ,(cur->datum id) t_0))
(error 'unbound "Unbound variable: ~s" (term id))) (raise-syntax-error 'cur "Unbound variable: ~s"
(term id))])) (begin (printf "Sigma: ~s~nGamma: ~s~n" (sigma) (gamma))
id)))
(if (bound? id)
(denote #`,#,id)
(denote id)))]))
(define-syntax (curry-lambda syn) (define-syntax (curry-lambda syn)
(syntax-case syn (:) (syntax-case syn (:)
[(_ ((x : t) (xr : tr) ...) e) [(_ ((x : t) (xr : tr) ...) e)
#'(dep-lambda (x : t) (curry-lambda ((xr : tr) ...) e))] #'(dep-lambda (x : t) (curry-lambda ((xr : tr) ...) e))]
[(_ () e) #'e])) [(_ () e) (denote #'e)]))
;; TODO: Syntax-parse ;; TODO: Syntax-parse
;; TODO: Don't use define; this results in duplicated type-checking, ;; TODO: Don't use define; this results in duplicated type-checking,
@ -749,20 +816,26 @@
(define-syntax (dep-define syn) (define-syntax (dep-define syn)
(syntax-case syn (:) (syntax-case syn (:)
[(_ (name (x : t) ...) e) [(_ (name (x : t) ...) e)
#'(define name (curry-lambda ((x : t) ...) e))] #'(dep-define name (curry-lambda ((x : t) ...) e))]
[(_ id e) [(_ id e)
#'(define id e)])) (let* ([expr (core-expand #'e)]
[type (car (judgment-holds (types ,(sigma) ,(gamma)
,(syntax->datum expr) t_0)
t_0))])
(gamma (extend-env gamma #'id type))
#`(define id #,(denote expr)))]))
(define-syntax (dep-fix syn) (define-syntax (dep-fix syn)
(syntax-case syn (:) (syntax-case syn (:)
[(_ (x : t) e) [(_ (x : t) e)
#`(let* ([lam (term (μ (x : ,t) (let* ([expr (core-expand #`(μ (x : t) e))]
,(let ([x (term x)]) [type (car (judgment-holds (types ,(sigma) ,(gamma)
(parameterize ([gamma (term (,(gamma) ,x : ,t))]) ,(syntax->datum expr)
e))))]) t_0)
(unless (judgment-holds (types ,(sigma) ,(gamma) ,lam t_0)) t_0))])
(error 'type-checking "Term is ill-typed: ~s" lam)) (unless (equal? (cur->datum #'t) type)
lam)])) (raise-syntax-error 'type-checking "Term is ill-typed: ~s" expr))
(denote expr))]))
;; TODO: Adding reflection will require building sigma, gamma, and ;; TODO: Adding reflection will require building sigma, gamma, and
;; doing type-checking at macro expand time, I think. ;; doing type-checking at macro expand time, I think.
@ -770,7 +843,7 @@
;; This will require a large change to the macros, so ought to branch ;; This will require a large change to the macros, so ought to branch
;; first. ;; first.
#;(define (type-infer^ syn) #;(define (type-infer^ syn)
(let ([t (judgment-holds (types ,(sigma) ,(gamma) ,(syntax->datum syn) t_0) t_0)]) (let ([t (judgment-holds (types ,(sigma) ,(gamma) ,(cur->datum syn) t_0) t_0)])
(and t (datum->syntax syn (car t))))) (and t (datum->syntax syn (car t)))))
) )

3
example.rkt
View File

@ -57,9 +57,8 @@
[s (lambda (x : nat) x)])) [s (lambda (x : nat) x)]))
(check-equal? (sub1 (s z)) z) (check-equal? (sub1 (s z)) z)
;; TODO: Plus require recursion and I don't have recursion!
(define plus (define plus
(fix (plus : (forall* (n1 : nat) (n2 : nat) nat)) (fix (plus : (forall (n1 : nat) (forall (n2 : nat) nat)))
(lambda (n1 : nat) (lambda (n1 : nat)
(lambda (n2 : nat) (lambda (n2 : nat)
(case n1 (case n1

28
nat.rkt
View File

@ -1,6 +1,34 @@
#lang s-exp "cur-redex.rkt" #lang s-exp "cur-redex.rkt"
(require "sugar.rkt") (require "sugar.rkt")
(module+ test
(require rackunit))
(data nat : Type (data nat : Type
(z : nat) (z : nat)
(s : (-> nat nat))) (s : (-> nat nat)))
(define (add1 (n : nat)) (s n))
(module+ test
(check-equal? (add1 (s z)) (s (s z))))
(define (sub1 (n : nat))
(case n
[z z]
[s (lambda (x : nat) x)]))
(module+ test
;; TODO: Um. For some reason, sigma becomes empty here?
(check-equal? (sub1 (s z)) z))
(define plus
(fix (plus : (forall* (n1 : nat) (n2 : nat) nat))
(lambda (n1 : nat)
(lambda (n2 : nat)
(case n1
[z n2]
[s (λ (x : nat) (plus x (s n2)))])))))
(module+ test
(check-equal? (plus z z) z)
(check-equal? (plus (s (s z)) (s (s z))) (s (s (s (s z))))))
(add1 (s z))
(sub1 (s z))

9
oll.rkt
View File

@ -167,15 +167,6 @@
(stlc-lambda : (->* var stlc-type stlc-term stlc-term)))) (stlc-lambda : (->* var stlc-type stlc-term stlc-term))))
(begin-for-syntax (begin-for-syntax
(define orig-insp (variable-reference->module-declaration-inspector
(#%variable-reference)))
(define (disarm syn) (syntax-disarm syn orig-insp))
;; TODO: Pull expand, perhaps list of literals, into a library.
(define (expand syn)
(disarm (local-expand syn 'expression (syntax-e #'(lambda forall data case fix Type #%app #%top)))))
(define (output-coq syn) (define (output-coq syn)
(syntax-parse (expand syn) (syntax-parse (expand syn)
[((~literal lambda) ~! (x:id (~datum :) t) body:expr) [((~literal lambda) ~! (x:id (~datum :) t) body:expr)