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

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

@ -8,8 +8,10 @@
"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,20 +140,18 @@
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)])
(let ([ht (hash-copy ht)])
(define (mk-matcher kw) (define (mk-matcher kw)
(datum->syntax stx (string->symbol (string-append (keyword->string kw) ":")))) (datum->syntax stx (string->symbol (string-append (keyword->string kw) ":"))))
(define/contract (put k lst) (define/contract (put k lst)
(keyword? (list/c syntax? (keyword? (list/c syntax?
syntax? syntax?
(lambda (p) (procedure-arity-includes? p (length rec-ids))) (-> syntax?)
syntax?) syntax?)
. -> . void?) . -> . void?)
(hash-set! ht k lst)) (hash-set! new-ht k lst))
(define (add-clause cl) (define (add-clause cl)
(syntax-parse cl (syntax-parse cl
[(kw:keyword #:matcher mtch pats ... expr) [(kw:keyword #:matcher mtch pats ... expr)
@ -164,37 +164,63 @@
(syntax/loc cl (pats ...)) (syntax/loc cl (pats ...))
(lambda () #'expr) (lambda () #'expr)
cl))])) cl))]))
;(define i.tmp-rec-id i.rec-id) ... (define-syntax-class clause
(pattern
(k:keyword #:matcher mtch pats ... e:expr)
#:with kw #'k.datum
#:with val (list #'mtch
(syntax #;#;/loc (current-syntax-context) (pats ...))
(lambda () #'e)
#'here #;(current-syntax-context)))
(pattern
(k:keyword pats ... e:expr)
#:with kw (syntax-e #'k)
#:with val (list (mk-matcher #'kw)
(syntax #;#;/loc (current-syntax-context) (pats ...))
(lambda () #'e)
#'here #;(current-syntax-context))))
(define (gen-clause k v) (define (gen-clause k v)
(define match-ex (car v)) (match v
(define pats (cadr v)) [(list match-ex pats body-f src)
(define body-f (caddr v)) (let ([pat (quasisyntax/loc src (#,match-ex . #,pats))])
(define tmpx (printf "got to here 1~n")) (quasisyntax/loc src (#,pat #,(body-f))))]))
(define src (cadddr v)) (define-syntax-class (keyword-in kws)
(define pat (quasisyntax/loc src (#,match-ex . #,pats))) #:attributes (datum)
(define tmpx2 (printf "got to here 2: ~a ~a~n" body-f (object-name body-f))) (pattern k:keyword
(define cl (quasisyntax/loc src (#,pat #,(body-f)))) #:when (memq #'k.datum kws)
(define tmpx3 (printf "got to here 3~n")) #:with datum #'k.datum))
cl) (define-syntax-class (sized-list kws)
(define-syntax-class (sized-id-list k) #:description (format "keyword expr pairs matching with keywords in the list ~a" kws)
(pattern (i:id ...) (pattern ((~or [k e:expr]) ...)
#:when (= k (length (syntax->list #'(i ...)))))) #:declare k (keyword-in kws)
#:when (equal? (length (attribute k.datum)) (length (remove-duplicates (attribute k.datum))))
#:with mapping (for/hash ([k* (attribute k.datum)]
[e* (attribute e)])
(values k* e*))
))
(syntax-parse stx (syntax-parse stx
[(tc fresh-ids ty . clauses) [(tc recs ty clauses:clause ...)
#:declare fresh-ids (sized-id-list (length rec-ids)) #:declare recs (sized-list kws)
(begin (begin
(map add-clause (syntax->list #'clauses)) (for ([k (attribute clauses.kw)]
(with-syntax ([old-rec-id type-rec-id] [v (attribute clauses.val)])
[(let-clauses ...) (put k v))
(with-syntax ([(let-clauses ...)
(for/list ([rec-id rec-ids] (for/list ([rec-id rec-ids]
[i (syntax->list #'fresh-ids)]) [k kws])
#`[#,rec-id #,i])]) #`[#,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 ... #`(let (let-clauses ...
[#,fold-target ty]) [#,fold-target ty])
;; then generate the fold ;; then generate the fold
#,(quasisyntax/loc stx #,(quasisyntax/loc stx
(match #,fold-target (match #,fold-target
#,@(hash-map ht gen-clause))))))]))))) #,@(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
@ -246,7 +274,16 @@
(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)

41
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 ...)
(andmap identifier? (syntax->list #'(id ...)))
(with-syntax ([(id* ...) (with-syntax ([(id* ...)
(map (lambda (id) (map (lambda (id)
(datum->syntax (datum->syntax
id id
(string->symbol `(file
(string-append ,(path->string
"typed-scheme/" (build-path (collection-path "typed-scheme"
#,(symbol->string (syntax-e #'nm)) #,(symbol->string (syntax-e #'nm)))
"/" (string-append (symbol->string (syntax-e id))
(symbol->string (syntax-e id)))) ".ss"))))
id id)) id id))
(syntax->list #'(id ...)))]) (syntax->list #'(id ...)))])
(syntax/loc stx (combine-in id* ...)))]))))])) (syntax/loc stx (combine-in id* ...)))])))]))
(define-requirer rep) (define-requirer rep)
@ -168,10 +164,16 @@
[(_ 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)
@ -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)))))