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

Progress: module+ works, require/provide not yet.

Browse Source
This commit is contained in:
William J. Bowman 2015-01-30 03:31:29 -05:00
parent 59aff98158
commit 434c1aa72b
2 changed files with 119 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
nat.rkt
View File

@ -1,5 +1,6 @@
#lang s-exp "redex-curnel.rkt" #lang s-exp "redex-curnel.rkt"
(require "sugar.rkt") (require "sugar.rkt")
(provide nat z s add1 sub1 plus)
(module+ test (module+ test
(require rackunit)) (require rackunit))

184
redex-curnel.rkt
View File

@ -24,14 +24,14 @@
(v ::= (Π (x : t) t) (μ (x : t) t) (λ (x : t) t) x U) (v ::= (Π (x : t) t) (μ (x : t) t) (λ (x : t) t) x U)
(t e ::= (case e (x e) ...) v (t t))) (t e ::= (case e (x e) ...) v (t t)))
(define x? (redex-match? cicL x))
(define t? (redex-match? cicL t))
(define e? (redex-match? cicL e))
(define v? (redex-match? cicL v))
(define U? (redex-match? cicL U))
(module+ test (module+ test
(require rackunit) (require rackunit)
(define x? (redex-match? cicL x))
(define t? (redex-match? cicL t))
(define e? (redex-match? cicL e))
(define v? (redex-match? cicL v))
(define U? (redex-match? cicL U))
;; TODO: Rename these signatures, and use them in all future tests. ;; TODO: Rename these signatures, and use them in all future tests.
(define Σ (term (((∅ nat : Type) zero : nat) s : (Π (x : nat) nat)))) (define Σ (term (((∅ nat : Type) zero : nat) s : (Π (x : nat) nat))))
@ -600,11 +600,13 @@
racket/pretty racket/pretty
(submod ".." core) (submod ".." core)
redex/reduction-semantics redex/reduction-semantics
racket/provide-syntax
(for-syntax (for-syntax
racket racket
syntax/parse syntax/parse
racket/pretty racket/pretty
racket/trace racket/trace
(except-in racket/provide-transform export)
(except-in (submod ".." core) remove) (except-in (submod ".." core) remove)
redex/reduction-semantics)) redex/reduction-semantics))
(provide (provide
@ -612,9 +614,9 @@
require require
for-syntax for-syntax
only-in only-in
module+
#%module-begin #%module-begin
(rename-out (rename-out
[dep-module+ module+]
[dep-provide provide] [dep-provide provide]
[dep-lambda lambda] [dep-lambda lambda]
@ -643,10 +645,9 @@
;; reflection ;; reflection
(for-syntax (for-syntax
cur-expand cur-expand
(rename-out type-infer/syn
[type-infer^ type-infer] type-check/syn?
[type-check? type-check?] normalize/syn))
[reduce^ normalize])))
(begin-for-syntax (begin-for-syntax
(current-trace-notify (current-trace-notify
@ -693,49 +694,65 @@
(define (extend-env/syn! env x t) (env (extend-env/syn env x t))) (define (extend-env/syn! env x t) (env (extend-env/syn env x t)))
(define orig-insp (variable-reference->module-declaration-inspector ;; TODO: Still absurdly slow. Probably doing n^2 checks of sigma and
(#%variable-reference))) ;; gamma. And lookup on sigma, gamma are linear, so probably n^2 lookup time.
(define (type-infer/term t)
(let ([t (judgment-holds (types ,(sigma) ,(gamma) ,t t_0) t_0)])
(and (pair? t) (car t))))
(define (syntax->curnel-syntax syn) (denote syn (cur->datum syn)))
(define (denote syn t) #`(term (reduce #,(datum->syntax syn t))))
;; TODO: Blanket disarming is probably a bad idea.
(define orig-insp (variable-reference->module-declaration-inspector
(#%variable-reference)))
(define (disarm syn) (syntax-disarm syn orig-insp)) (define (disarm syn) (syntax-disarm syn orig-insp))
(define (core-expand syn) (denote syn (cur->datum syn))) ;; Locally expand everything down to core forms.
(define (core-expand syn)
(disarm
(if (identifier? syn)
syn
(local-expand syn 'expression
(append (syntax-e #'(term reduce dep-var #%app λ Π μ case
Type)))))))
(define (denote syn t) ;; Only type-check at the top-level, to prevent exponential
#`(term (reduce #,(datum->syntax syn t)))) ;; type-checking. Redex is expensive enough.
;; TODO: This results in less good error messages. Add an
;; algorithm to find the smallest ill-typed term.
(define inner-expand? (make-parameter #f))
;; Expand a piece of syntax into a curnel redex term
(define (cur->datum syn) (define (cur->datum syn)
(define (expand syn) ;; Main loop; avoid type
(disarm (if (identifier? syn)
syn
(local-expand syn 'expression
(append
(syntax-e #'(term reduce dep-var #%app λ Π μ case Type)))))))
(define reified-term (define reified-term
(let core-expand ([syn syn]) (parameterize ([inner-expand? #t])
(syntax-parse (expand syn) (trace-let cur->datum ([syn syn])
#:literals (term reduce #%app) (syntax-parse (core-expand syn)
#:datum-literals (case Π λ μ : Type) #:literals (term reduce #%app)
[x:id (syntax->datum #'x)] #:datum-literals (case Π λ μ : Type)
[(reduce e) (syntax->datum #'e)] [x:id (syntax->datum #'x)]
[(term e) (core-expand #'e)] [(reduce e) (syntax->datum #'e)]
;; TODO: should really check that b is one of the binders [(term e) (cur->datum #'e)]
;; Maybe make a syntax class for the binders, core forms, ;; TODO: should really check that b is one of the binders
;; etc. ;; Maybe make a syntax class for the binders, core forms,
[(b:id (x:id : t) e) ;; etc.
(let* ([x (syntax->datum #'x)] [(b:id (x:id : t) e)
[t (core-expand #'t)] (let* ([x (syntax->datum #'x)]
[e (parameterize ([gamma (extend-env/term gamma x t)]) [t (cur->datum #'t)]
(core-expand #'e))]) [e (parameterize ([gamma (extend-env/term gamma x t)])
(term (,(syntax->datum #'b) (,x : ,t) ,e)))] (cur->datum #'e))])
[(case e (ec eb) ...) (term (,(syntax->datum #'b) (,x : ,t) ,e)))]
(term (case ,(core-expand #'e) [(case e (ec eb) ...)
,@(map (lambda (c b) (term (case ,(cur->datum #'e)
`(,c ,(core-expand b))) ,@(map (lambda (c b) `(,c ,(cur->datum b)))
(syntax->datum #'(ec ...)) (syntax->datum #'(ec ...))
(syntax->list #'(eb ...)))))] (syntax->list #'(eb ...)))))]
[(#%app e1 e2) [(#%app e1 e2)
(term (,(core-expand #'e1) ,(core-expand #'e2)))]))) (term (,(cur->datum #'e1) ,(cur->datum #'e2)))]))))
(unless (judgment-holds (types ,(sigma) ,(gamma) ,reified-term t_0)) (unless (and inner-expand? (type-infer/term reified-term))
;; TODO: is this really a syntax error? ;; TODO: is this really a syntax error?
(raise-syntax-error 'cur "term is ill-typed:" (raise-syntax-error 'cur "term is ill-typed:"
(begin (printf "Sigma: ~s~nGamma: ~s~n" (sigma) (gamma)) (begin (printf "Sigma: ~s~nGamma: ~s~n" (sigma) (gamma))
@ -745,15 +762,15 @@
;; Reflection tools ;; Reflection tools
(define (type-infer^ syn) (define (type-infer/syn syn)
(let ([t (judgment-holds (types ,(sigma) ,(gamma) ,(cur->datum syn) t_0) t_0)]) (let ([t (type-infer/term (cur->datum syn))])
(and t (denote syn (car t))))) (and t (denote syn t))))
(define (type-check? syn type) (define (type-check/syn? syn type)
(let ([t (judgment-holds (types ,(sigma) ,(gamma) ,(cur->datum syn) t_0) t_0)]) (let ([t (type-infer/term (cur->datum syn))])
(equal? t (cur->datum type)))) (equal? t (cur->datum type))))
(define (reduce^ syn) (term (reduce (cur->datum syn)))) (define (normalize/syn syn) (denote syn (term (reduce (cur->datum syn)))))
(define (cur-expand syn) (define (cur-expand syn)
(disarm (local-expand syn 'expression (disarm (local-expand syn 'expression
@ -761,14 +778,49 @@
dep-fix dep-forall dep-var)))))) dep-fix dep-forall dep-var))))))
#;(define-syntax (dep-datum syn) (denote #'syn)) #;(define-syntax (dep-datum syn) (denote #'syn))
;; TODO: Add extend-env calls. Will be tricky with sigma and gamma (begin-for-syntax
;; being separate. (define envs (list #'(void)))
(define (filter-cur-transformer syn modes)
(partition (lambda (x)
(let ([x (syntax->datum (export-local-id x))])
(and (x? x)
(or (term (lookup ,(gamma) ,x))
(term (lookup ,(sigma) ,x))))))
(apply append (map (lambda (e) (expand-export e modes))
(syntax->list syn))))))
(define-syntax extend-env-and-provide
(make-provide-transformer
(lambda (syn modes)
(syntax-case syn ()
[(_ e ...)
(let-values ([(cur ~cur) (filter-cur-transformer #'(e ...) '())])
(set! envs (for/list ([e cur])
(let* ([x (syntax->datum (export-local-id e))]
[t (type-infer/term x)]
[env (if (term (lookup ,(gamma) ,x)) #'gamma #'sigma)])
#`(extend-env/term! #,env #,(export-out-sym e) #,t))))
~cur)]))))
(define-syntax (dep-provide syn) (define-syntax (dep-provide syn)
(syntax-parse syn (syntax-case syn ()
[(_ name ...) [(_ e ...)
#`(provide name ...) #`(begin
#;#`(begin-for-syntax (provide (extend-env-and-provide e ...))
(extend-env/syn! ))])) (begin-for-syntax
;; TODO: Here, I think I need to define and export a
;; new gamma and sigma, and redefine require to import them
;; and merge them with the existing gamma/sigma.
(gamma (term #,(gamma)))
(sigma (term #,(sigma)))
#;#,@envs))]))
(trace-define-syntax (dep-module+ syn)
(syntax-case syn ()
[(_ name body ...)
#`(module+ name
(begin-for-syntax
(gamma (term #,(gamma)))
(sigma (term #,(sigma))))
body ...)]))
;; TODO: Can these be simplified further? ;; TODO: Can these be simplified further?
;; TODO: Can we make core-expand some kind of parameter that is only ;; TODO: Can we make core-expand some kind of parameter that is only
@ -776,23 +828,23 @@
;; not in the main loop? ;; not in the main loop?
(define-syntax (dep-lambda syn) (define-syntax (dep-lambda syn)
(syntax-case syn (:) (syntax-case syn (:)
[(_ (x : t) e) (core-expand #`(λ (x : t) e))])) [(_ (x : t) e) (syntax->curnel-syntax #`(λ (x : t) e))]))
(define-syntax (dep-app syn) (define-syntax (dep-app syn)
(syntax-case syn () (syntax-case syn ()
[(_ e1 e2) (core-expand #`(#%app e1 e2))])) [(_ e1 e2) (syntax->curnel-syntax #`(#%app e1 e2))]))
(define-syntax (dep-case syn) (define-syntax (dep-case syn)
(syntax-case syn () (syntax-case syn ()
[(_ e ...) (core-expand #`(case e ...))])) [(_ e ...) (syntax->curnel-syntax #`(case e ...))]))
(define-syntax (dep-forall syn) (define-syntax (dep-forall syn)
(syntax-case syn (:) (syntax-case syn (:)
[(_ (x : t) e) (core-expand #`(Π (x : t) e))])) [(_ (x : t) e) (syntax->curnel-syntax #`(Π (x : t) e))]))
(define-syntax (dep-fix syn) (define-syntax (dep-fix syn)
(syntax-case syn (:) (syntax-case syn (:)
[(_ (x : t) e) (core-expand #`(μ (x : t) e))])) [(_ (x : t) e) (syntax->curnel-syntax #`(μ (x : t) e))]))
(define-syntax (dep-inductive syn) (define-syntax (dep-inductive syn)
(syntax-case syn (:) (syntax-case syn (:)
@ -819,7 +871,7 @@
;; #'e. Maybe denote final terms into Racket. Or keep an ;; #'e. Maybe denote final terms into Racket. Or keep an
;; environment and have denote do a giant substitution ;; environment and have denote do a giant substitution
(let () #;[t (core-expand #'e)] (let () #;[t (core-expand #'e)]
(gamma (extend-env/syn gamma #'id (type-infer^ #'e))) (extend-env/syn! gamma #'id (type-infer/syn #'e))
#'(void))])) ) #'(void))])) )
(require 'sugar) (require 'sugar)