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

Finished new representation defs and folding.

Browse Source 
New definition of `define-requirer' that doesn't use lib requires.
New `defprinter' syntax.

svn: r13755
This commit is contained in:
Sam Tobin-Hochstadt 2009-02-20 23:35:02 +00:00
parent 428e7c471b
commit 0edfd7f31f
3 changed files with 148 additions and 170 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

159
collects/typed-scheme/rep/rep-utils.ss
View File

@ -7,9 +7,11 @@
"free-variance.ss" "free-variance.ss"
"interning.ss" "interning.ss"
mzlib/etc mzlib/etc
scheme/contract scheme/contract
(for-meta 1 stxclass/util)
(for-syntax (for-syntax
scheme/list
stxclass/util
scheme/match
stxclass stxclass
scheme/base scheme/base
syntax/struct syntax/struct
@ -138,63 +140,87 @@
provides provides
frees))]))) frees))])))
(define-for-syntax (mk-fold ht type-rec-id rec-ids) (define-for-syntax (mk-fold ht type-rec-id rec-ids kws)
(lambda (stx) (lambda (stx)
(define anys (for/list ([i rec-ids]) any/c)) (define new-ht (hash-copy ht))
(with-syntax* ([(fresh-ids ...) (generate-temporaries rec-ids)]) (define (mk-matcher kw)
(let ([ht (hash-copy ht)]) (datum->syntax stx (string->symbol (string-append (keyword->string kw) ":"))))
(define (mk-matcher kw) (define/contract (put k lst)
(datum->syntax stx (string->symbol (string-append (keyword->string kw) ":")))) (keyword? (list/c syntax?
(define/contract (put k lst) syntax?
(keyword? (list/c syntax? (-> syntax?)
syntax? syntax?)
(lambda (p) (procedure-arity-includes? p (length rec-ids))) . -> . void?)
syntax?) (hash-set! new-ht k lst))
. -> . void?) (define (add-clause cl)
(hash-set! ht k lst)) (syntax-parse cl
(define (add-clause cl) [(kw:keyword #:matcher mtch pats ... expr)
(syntax-parse cl (put (syntax-e #'kw) (list #'mtch
[(kw:keyword #:matcher mtch pats ... expr) (syntax/loc cl (pats ...))
(put (syntax-e #'kw) (list #'mtch (lambda () #'expr)
(syntax/loc cl (pats ...)) cl))]
(lambda () #'expr) [(kw:keyword pats ... expr)
cl))] (put (syntax-e #'kw) (list (mk-matcher (syntax-e #'kw))
[(kw:keyword pats ... expr) (syntax/loc cl (pats ...))
(put (syntax-e #'kw) (list (mk-matcher (syntax-e #'kw)) (lambda () #'expr)
(syntax/loc cl (pats ...)) cl))]))
(lambda () #'expr) (define-syntax-class clause
cl))])) (pattern
;(define i.tmp-rec-id i.rec-id) ... (k:keyword #:matcher mtch pats ... e:expr)
(define (gen-clause k v) #:with kw #'k.datum
(define match-ex (car v)) #:with val (list #'mtch
(define pats (cadr v)) (syntax #;#;/loc (current-syntax-context) (pats ...))
(define body-f (caddr v)) (lambda () #'e)
(define tmpx (printf "got to here 1~n")) #'here #;(current-syntax-context)))
(define src (cadddr v)) (pattern
(define pat (quasisyntax/loc src (#,match-ex . #,pats))) (k:keyword pats ... e:expr)
(define tmpx2 (printf "got to here 2: ~a ~a~n" body-f (object-name body-f))) #:with kw (syntax-e #'k)
(define cl (quasisyntax/loc src (#,pat #,(body-f)))) #:with val (list (mk-matcher #'kw)
(define tmpx3 (printf "got to here 3~n")) (syntax #;#;/loc (current-syntax-context) (pats ...))
cl) (lambda () #'e)
(define-syntax-class (sized-id-list k) #'here #;(current-syntax-context))))
(pattern (i:id ...) (define (gen-clause k v)
#:when (= k (length (syntax->list #'(i ...)))))) (match v
(syntax-parse stx [(list match-ex pats body-f src)
[(tc fresh-ids ty . clauses) (let ([pat (quasisyntax/loc src (#,match-ex . #,pats))])
#:declare fresh-ids (sized-id-list (length rec-ids)) (quasisyntax/loc src (#,pat #,(body-f))))]))
(begin (define-syntax-class (keyword-in kws)
(map add-clause (syntax->list #'clauses)) #:attributes (datum)
(with-syntax ([old-rec-id type-rec-id] (pattern k:keyword
[(let-clauses ...) #:when (memq #'k.datum kws)
(for/list ([rec-id rec-ids] #:with datum #'k.datum))
[i (syntax->list #'fresh-ids)]) (define-syntax-class (sized-list kws)
#`[#,rec-id #,i])]) #:description (format "keyword expr pairs matching with keywords in the list ~a" kws)
#`(let (let-clauses ... (pattern ((~or [k e:expr]) ...)
[#,fold-target ty]) #:declare k (keyword-in kws)
;; then generate the fold #:when (equal? (length (attribute k.datum)) (length (remove-duplicates (attribute k.datum))))
#,(quasisyntax/loc stx #:with mapping (for/hash ([k* (attribute k.datum)]
(match #,fold-target [e* (attribute e)])
#,@(hash-map ht gen-clause))))))]))))) (values k* e*))
))
(syntax-parse stx
[(tc recs ty clauses:clause ...)
#:declare recs (sized-list kws)
(begin
(for ([k (attribute clauses.kw)]
[v (attribute clauses.val)])
(put k v))
(with-syntax ([(let-clauses ...)
(for/list ([rec-id rec-ids]
[k kws])
#`[#,rec-id #,(hash-ref (attribute recs.mapping) k
#'values
#;
(lambda ()
(error (format
"failed to find key ~a in table ~a"
k (attribute recs.mapping)))))])])
#`(let (let-clauses ...
[#,fold-target ty])
;; then generate the fold
#,(quasisyntax/loc stx
(match #,fold-target
#,@(hash-map new-ht gen-clause))))))])))
(define-syntax (make-prim-type stx) (define-syntax (make-prim-type stx)
@ -222,6 +248,7 @@
#:transparent #:transparent
(pattern :type-name-base (pattern :type-name-base
#:with name #'i #:with name #'i
#:with keyword (string->keyword (symbol->string (syntax-e #'i)))
#:with tmp-rec-id (generate-temporary) #:with tmp-rec-id (generate-temporary)
#:with case (mk-id #'i #'lower-s "-case") #:with case (mk-id #'i #'lower-s "-case")
#:with printer (mk-id #'i "print-" #'lower-s "*") #:with printer (mk-id #'i "print-" #'lower-s "*")
@ -233,6 +260,7 @@
(syntax-parse stx (syntax-parse stx
[(_ i:type-name ...) [(_ i:type-name ...)
(with-syntax* ([(fresh-ids ...) (generate-temporaries #'(i.name ...))] (with-syntax* ([(fresh-ids ...) (generate-temporaries #'(i.name ...))]
[(default-ids ...) (generate-temporaries #'(i.name ...))]
[fresh-ids-list #'(fresh-ids ...)] [fresh-ids-list #'(fresh-ids ...)]
[(anys ...) (for/list ([i (syntax->list #'fresh-ids-list)]) #'any/c)]) [(anys ...) (for/list ([i (syntax->list #'fresh-ids-list)]) #'any/c)])
#'(begin #'(begin
@ -242,11 +270,20 @@
(define-for-syntax i.ht (make-hasheq)) ... (define-for-syntax i.ht (make-hasheq)) ...
(define-struct/printer i.name (i.fld-names ...) (lambda (a b c) ((unbox i.printer) a b c))) ... (define-struct/printer i.name (i.fld-names ...) (lambda (a b c) ((unbox i.printer) a b c))) ...
(define-for-syntax i.rec-id #'i.rec-id) ... (define-for-syntax i.rec-id #'i.rec-id) ...
(provide i.case ...) (provide i.case ...)
(define-syntaxes (i.case ...) (define-syntaxes (i.case ...)
(let () (let ()
(apply values (apply values
(map (lambda (ht) (mk-fold ht (car (list #'i.rec-id ...)) (list #'i.rec-id ...))) (list i.ht ...)))))))])) (map (lambda (ht)
(mk-fold ht
(car (list #'i.rec-id ...))
(list #'i.rec-id ...)
'(i.keyword ...)))
(list i.ht ...)))))))]))
(make-prim-type [Type #:key] Filter [LatentFilter #:d lf] Object [LatentObject #:d lo] (make-prim-type [Type #:key]
Filter
[LatentFilter #:d lf]
Object
[LatentObject #:d lo]
[PathElem #:d pe]) [PathElem #:d pe])

106
collects/typed-scheme/rep/type-rep.ss
View File

@ -130,15 +130,6 @@
[#:frees (λ (f) (combine-frees (map f (cons dty rs))))] [#:frees (λ (f) (combine-frees (map f (cons dty rs))))]
[#:fold-rhs (*ValuesDots (map type-rec-id rs) (type-rec-id dty) dbound)]) [#:fold-rhs (*ValuesDots (map type-rec-id rs) (type-rec-id dty) dbound)])
;; dom : Listof[Type]
;; rng : Type
;; rest : Option[Type]
;; drest : Option[Cons[Type,Name or nat]]
;; kws : Listof[Keyword]
;; rest and drest NOT both true
;; thn-eff : Effect
;; els-eff : Effect
;; arr is NOT a Type ;; arr is NOT a Type
(dt arr ([dom (listof Type?)] (dt arr ([dom (listof Type?)]
[rng (or/c Values? ValuesDots?)] [rng (or/c Values? ValuesDots?)]
@ -287,7 +278,7 @@
(provide set-union-maker! get-union-maker) (provide set-union-maker! get-union-maker)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#|
;; remove-dups: List[Type] -> List[Type] ;; remove-dups: List[Type] -> List[Type]
;; removes duplicate types from a SORTED list ;; removes duplicate types from a SORTED list
(define (remove-dups types) (define (remove-dups types)
@ -295,67 +286,11 @@
[(null? (cdr types)) types] [(null? (cdr types)) types]
[(type-equal? (car types) (cadr types)) (remove-dups (cdr types))] [(type-equal? (car types) (cadr types)) (remove-dups (cdr types))]
[else (cons (car types) (remove-dups (cdr types)))])) [else (cons (car types) (remove-dups (cdr types)))]))
|#
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; type/effect fold
#|
(define-syntaxes (type-case filter-case latentfilter-case object-case latentobject-case pathelem-case)
(let ()
(define (mk ht)
(lambda (stx)
(let ([ht (hash-copy ht)])
(define (mk-matcher kw)
(datum->syntax stx (string->symbol (string-append (keyword->string kw) ":"))))
(define (add-clause cl)
(syntax-case cl ()
[(kw #:matcher mtch pats ... expr)
(hash-set! ht (syntax-e #'kw) (list #'mtch
(syntax/loc cl (pats ...))
(lambda (tr er) #'expr)
cl))]
[(kw pats ... expr)
(hash-set! ht (syntax-e #'kw) (list (mk-matcher (syntax-e #'kw))
(syntax/loc cl (pats ...))
(lambda (tr er) #'expr)
cl))]))
(define rid #'type-rec-id)
(define erid #'effect-rec-id)
(define (gen-clause k v)
(define match-ex (car v))
(define pats (cadr v))
(define body-f (caddr v))
(define src (cadddr v))
(define pat (quasisyntax/loc src (#,match-ex . #,pats)))
(define cl (quasisyntax/loc src (#,pat #,(body-f rid erid))))
cl)
(syntax-case stx ()
[(tc rec-id ty clauses ...)
(syntax-case #'(clauses ...) ()
[([kw pats ... es] ...) #t]
[_ #f])
(syntax/loc stx (tc rec-id (lambda (e) (sub-eff rec-id e)) ty clauses ...))]
[(tc rec-id e-rec-id ty clauses ...)
(begin
(map add-clause (syntax->list #'(clauses ...)))
(with-syntax ([old-rec-id type-rec-id])
#`(let ([#,rid rec-id]
[#,erid e-rec-id]
[#,fold-target ty])
;; then generate the fold
#,(quasisyntax/loc stx
(match #,fold-target
#,@(hash-map ht gen-clause))))))]))))
(apply values
(map mk
(list type-name-ht filter-name-ht latentfilter-name-ht object-name-ht latentobject-name-ht pathelem-name-ht)))))
(provide type-case filter-case latentfilter-case object-case latentobject-case pathelem-case)
|#
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (add-scopes n t) (define (add-scopes n t)
(if (zero? n) t (if (zero? n) t
(add-scopes (sub1 n) (*Scope t)))) (add-scopes (sub1 n) (*Scope t))))
@ -366,6 +301,26 @@
(match sc (match sc
[(Scope: sc*) (remove-scopes (sub1 n) sc*)] [(Scope: sc*) (remove-scopes (sub1 n) sc*)]
[_ (int-err "Tried to remove too many scopes: ~a" sc)]))) [_ (int-err "Tried to remove too many scopes: ~a" sc)])))
;; type equality
(define type-equal? eq?)
;; inequality - good
(define (type<? s t)
(< (Type-seq s) (Type-seq t)))
(define (type-compare s t)
(cond [(eq? s t) 0]
[(type<? s t) 1]
[else -1]))
(define (Values* l)
(if (and (pair? l) (null? (cdr l)))
(car l)
(*Values l)))
#| #|
;; abstract-many : Names Type -> Scope^n ;; abstract-many : Names Type -> Scope^n
;; where n is the length of names ;; where n is the length of names
@ -591,23 +546,6 @@
(list syms (PolyDots-body* syms t)))) (list syms (PolyDots-body* syms t))))
(list nps bp)))]))) (list nps bp)))])))
;; type equality
(define type-equal? eq?)
;; inequality - good
(define (type<? s t)
(< (Type-seq s) (Type-seq t)))
(define (type-compare s t)
(cond [(eq? s t) 0]
[(type<? s t) 1]
[else -1]))
(define (Values* l)
(if (and (pair? l) (null? (cdr l)))
(car l)
(*Values l)))
;(trace subst subst-all) ;(trace subst subst-all)

53
collects/typed-scheme/utils/utils.ss
View File

@ -10,8 +10,6 @@
(provide with-syntax* syntax-map start-timing do-time reverse-begin printf/log (provide with-syntax* syntax-map start-timing do-time reverse-begin printf/log
with-logging-to-file log-file-name == with-logging-to-file log-file-name ==
print-type*
print-effect*
define-struct/printer define-struct/printer
id id
filter-multiple filter-multiple
@ -25,27 +23,25 @@
rep utils typecheck infer env private) rep utils typecheck infer env private)
(define-syntax (define-requirer stx) (define-syntax (define-requirer stx)
(syntax-case stx () (syntax-parse stx
[(_ nm) [(_ nm:id)
#`(... #`(...
(define-require-syntax nm (define-require-syntax (nm stx)
(lambda (stx) (syntax-parse stx
(syntax-case stx () [(_ id:identifier ...)
[(_ id ...) (with-syntax ([(id* ...)
(andmap identifier? (syntax->list #'(id ...))) (map (lambda (id)
(with-syntax ([(id* ...) (datum->syntax
(map (lambda (id) id
(datum->syntax `(file
id ,(path->string
(string->symbol (build-path (collection-path "typed-scheme"
(string-append #,(symbol->string (syntax-e #'nm)))
"typed-scheme/" (string-append (symbol->string (syntax-e id))
#,(symbol->string (syntax-e #'nm)) ".ss"))))
"/" id id))
(symbol->string (syntax-e id)))) (syntax->list #'(id ...)))])
id id)) (syntax/loc stx (combine-in id* ...)))])))]))
(syntax->list #'(id ...)))])
(syntax/loc stx (combine-in id* ...)))]))))]))
(define-requirer rep) (define-requirer rep)
@ -168,11 +164,17 @@
[(_ val) [(_ val)
#'(? (lambda (x) (equal? val x)))]))) #'(? (lambda (x) (equal? val x)))])))
(define-for-syntax printing? #t) (define-for-syntax printing? #f)
(define print-type* (box (lambda _ (error "print-type* not yet defined")))) (define-syntax-rule (defprinter t ...)
(define print-effect* (box (lambda _ (error "print-effect* not yet defined")))) (begin
(define t (box (lambda _ (error (format "~a not yet defined" 't))))) ...
(provide t ...)))
(defprinter
print-type* print-filter* print-latentfilter* print-object* print-latentobject*
print-pathelem*)
(require scheme/pretty mzlib/pconvert) (require scheme/pretty mzlib/pconvert)
(define-syntax (define-struct/printer stx) (define-syntax (define-struct/printer stx)
@ -195,6 +197,7 @@
(define (f v) (define (f v)
(cond [(string? v) v] (cond [(string? v) v]
[(symbol? v) (symbol->string v)] [(symbol? v) (symbol->string v)]
[(char? v) (string v)]
[(identifier? v) (symbol->string (syntax-e v))])) [(identifier? v) (symbol->string (syntax-e v))]))
(datum->syntax kw (string->symbol (apply string-append (map f args))))) (datum->syntax kw (string->symbol (apply string-append (map f args)))))