Finished new representation defs and folding.
New definition of `define-requirer' that doesn't use lib requires. New `defprinter' syntax. svn: r13755 original commit: 0edfd7f31f8e85b7d0176c28baebeae22e34de00
This commit is contained in:
Sam Tobin-Hochstadt
parent
2cb1ecef74
commit
6a8ae14330
|
|
@ -7,9 +7,11 @@
|
|||
"free-variance.ss"
|
||||
"interning.ss"
|
||||
mzlib/etc
|
||||
scheme/contract
|
||||
(for-meta 1 stxclass/util)
|
||||
scheme/contract
|
||||
(for-syntax
|
||||
scheme/list
|
||||
stxclass/util
|
||||
scheme/match
|
||||
stxclass
|
||||
scheme/base
|
||||
syntax/struct
|
||||
|
|
@ -138,63 +140,87 @@
|
|||
provides
|
||||
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)
|
||||
(define anys (for/list ([i rec-ids]) any/c))
|
||||
(with-syntax* ([(fresh-ids ...) (generate-temporaries rec-ids)])
|
||||
(let ([ht (hash-copy ht)])
|
||||
(define (mk-matcher kw)
|
||||
(datum->syntax stx (string->symbol (string-append (keyword->string kw) ":"))))
|
||||
(define/contract (put k lst)
|
||||
(keyword? (list/c syntax?
|
||||
syntax?
|
||||
(lambda (p) (procedure-arity-includes? p (length rec-ids)))
|
||||
syntax?)
|
||||
. -> . void?)
|
||||
(hash-set! ht k lst))
|
||||
(define (add-clause cl)
|
||||
(syntax-parse cl
|
||||
[(kw:keyword #:matcher mtch pats ... expr)
|
||||
(put (syntax-e #'kw) (list #'mtch
|
||||
(syntax/loc cl (pats ...))
|
||||
(lambda () #'expr)
|
||||
cl))]
|
||||
[(kw:keyword pats ... expr)
|
||||
(put (syntax-e #'kw) (list (mk-matcher (syntax-e #'kw))
|
||||
(syntax/loc cl (pats ...))
|
||||
(lambda () #'expr)
|
||||
cl))]))
|
||||
;(define i.tmp-rec-id i.rec-id) ...
|
||||
(define (gen-clause k v)
|
||||
(define match-ex (car v))
|
||||
(define pats (cadr v))
|
||||
(define body-f (caddr v))
|
||||
(define tmpx (printf "got to here 1~n"))
|
||||
(define src (cadddr v))
|
||||
(define pat (quasisyntax/loc src (#,match-ex . #,pats)))
|
||||
(define tmpx2 (printf "got to here 2: ~a ~a~n" body-f (object-name body-f)))
|
||||
(define cl (quasisyntax/loc src (#,pat #,(body-f))))
|
||||
(define tmpx3 (printf "got to here 3~n"))
|
||||
cl)
|
||||
(define-syntax-class (sized-id-list k)
|
||||
(pattern (i:id ...)
|
||||
#:when (= k (length (syntax->list #'(i ...))))))
|
||||
(syntax-parse stx
|
||||
[(tc fresh-ids ty . clauses)
|
||||
#:declare fresh-ids (sized-id-list (length rec-ids))
|
||||
(begin
|
||||
(map add-clause (syntax->list #'clauses))
|
||||
(with-syntax ([old-rec-id type-rec-id]
|
||||
[(let-clauses ...)
|
||||
(for/list ([rec-id rec-ids]
|
||||
[i (syntax->list #'fresh-ids)])
|
||||
#`[#,rec-id #,i])])
|
||||
#`(let (let-clauses ...
|
||||
[#,fold-target ty])
|
||||
;; then generate the fold
|
||||
#,(quasisyntax/loc stx
|
||||
(match #,fold-target
|
||||
#,@(hash-map ht gen-clause))))))])))))
|
||||
(define new-ht (hash-copy ht))
|
||||
(define (mk-matcher kw)
|
||||
(datum->syntax stx (string->symbol (string-append (keyword->string kw) ":"))))
|
||||
(define/contract (put k lst)
|
||||
(keyword? (list/c syntax?
|
||||
syntax?
|
||||
(-> syntax?)
|
||||
syntax?)
|
||||
. -> . void?)
|
||||
(hash-set! new-ht k lst))
|
||||
(define (add-clause cl)
|
||||
(syntax-parse cl
|
||||
[(kw:keyword #:matcher mtch pats ... expr)
|
||||
(put (syntax-e #'kw) (list #'mtch
|
||||
(syntax/loc cl (pats ...))
|
||||
(lambda () #'expr)
|
||||
cl))]
|
||||
[(kw:keyword pats ... expr)
|
||||
(put (syntax-e #'kw) (list (mk-matcher (syntax-e #'kw))
|
||||
(syntax/loc cl (pats ...))
|
||||
(lambda () #'expr)
|
||||
cl))]))
|
||||
(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)
|
||||
(match v
|
||||
[(list match-ex pats body-f src)
|
||||
(let ([pat (quasisyntax/loc src (#,match-ex . #,pats))])
|
||||
(quasisyntax/loc src (#,pat #,(body-f))))]))
|
||||
(define-syntax-class (keyword-in kws)
|
||||
#:attributes (datum)
|
||||
(pattern k:keyword
|
||||
#:when (memq #'k.datum kws)
|
||||
#:with datum #'k.datum))
|
||||
(define-syntax-class (sized-list kws)
|
||||
#:description (format "keyword expr pairs matching with keywords in the list ~a" kws)
|
||||
(pattern ((~or [k e:expr]) ...)
|
||||
#: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
|
||||
[(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)
|
||||
|
|
@ -222,6 +248,7 @@
|
|||
#:transparent
|
||||
(pattern :type-name-base
|
||||
#:with name #'i
|
||||
#:with keyword (string->keyword (symbol->string (syntax-e #'i)))
|
||||
#:with tmp-rec-id (generate-temporary)
|
||||
#:with case (mk-id #'i #'lower-s "-case")
|
||||
#:with printer (mk-id #'i "print-" #'lower-s "*")
|
||||
|
|
@ -233,6 +260,7 @@
|
|||
(syntax-parse stx
|
||||
[(_ i:type-name ...)
|
||||
(with-syntax* ([(fresh-ids ...) (generate-temporaries #'(i.name ...))]
|
||||
[(default-ids ...) (generate-temporaries #'(i.name ...))]
|
||||
[fresh-ids-list #'(fresh-ids ...)]
|
||||
[(anys ...) (for/list ([i (syntax->list #'fresh-ids-list)]) #'any/c)])
|
||||
#'(begin
|
||||
|
|
@ -242,11 +270,20 @@
|
|||
(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-for-syntax i.rec-id #'i.rec-id) ...
|
||||
(provide i.case ...)
|
||||
(provide i.case ...)
|
||||
(define-syntaxes (i.case ...)
|
||||
(let ()
|
||||
(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])
|
||||
|
|
|
|||
|
|
@ -130,15 +130,6 @@
|
|||
[#:frees (λ (f) (combine-frees (map f (cons dty rs))))]
|
||||
[#: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
|
||||
(dt arr ([dom (listof Type?)]
|
||||
[rng (or/c Values? ValuesDots?)]
|
||||
|
|
@ -287,7 +278,7 @@
|
|||
(provide set-union-maker! get-union-maker)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
#|
|
||||
|
||||
;; remove-dups: List[Type] -> List[Type]
|
||||
;; removes duplicate types from a SORTED list
|
||||
(define (remove-dups types)
|
||||
|
|
@ -295,67 +286,11 @@
|
|||
[(null? (cdr types)) types]
|
||||
[(type-equal? (car types) (cadr 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)
|
||||
(if (zero? n) t
|
||||
(add-scopes (sub1 n) (*Scope t))))
|
||||
|
|
@ -366,6 +301,26 @@
|
|||
(match sc
|
||||
[(Scope: sc*) (remove-scopes (sub1 n) 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
|
||||
;; where n is the length of names
|
||||
|
|
@ -591,23 +546,6 @@
|
|||
(list syms (PolyDots-body* syms t))))
|
||||
(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)
|
||||
|
||||
|
|
|
|||
|
|
@ -10,8 +10,6 @@
|
|||
|
||||
(provide with-syntax* syntax-map start-timing do-time reverse-begin printf/log
|
||||
with-logging-to-file log-file-name ==
|
||||
print-type*
|
||||
print-effect*
|
||||
define-struct/printer
|
||||
id
|
||||
filter-multiple
|
||||
|
|
@ -25,27 +23,25 @@
|
|||
rep utils typecheck infer env private)
|
||||
|
||||
(define-syntax (define-requirer stx)
|
||||
(syntax-case stx ()
|
||||
[(_ nm)
|
||||
(syntax-parse stx
|
||||
[(_ nm:id)
|
||||
#`(...
|
||||
(define-require-syntax nm
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id ...)
|
||||
(andmap identifier? (syntax->list #'(id ...)))
|
||||
(with-syntax ([(id* ...)
|
||||
(map (lambda (id)
|
||||
(datum->syntax
|
||||
id
|
||||
(string->symbol
|
||||
(string-append
|
||||
"typed-scheme/"
|
||||
#,(symbol->string (syntax-e #'nm))
|
||||
"/"
|
||||
(symbol->string (syntax-e id))))
|
||||
id id))
|
||||
(syntax->list #'(id ...)))])
|
||||
(syntax/loc stx (combine-in id* ...)))]))))]))
|
||||
(define-require-syntax (nm stx)
|
||||
(syntax-parse stx
|
||||
[(_ id:identifier ...)
|
||||
(with-syntax ([(id* ...)
|
||||
(map (lambda (id)
|
||||
(datum->syntax
|
||||
id
|
||||
`(file
|
||||
,(path->string
|
||||
(build-path (collection-path "typed-scheme"
|
||||
#,(symbol->string (syntax-e #'nm)))
|
||||
(string-append (symbol->string (syntax-e id))
|
||||
".ss"))))
|
||||
id id))
|
||||
(syntax->list #'(id ...)))])
|
||||
(syntax/loc stx (combine-in id* ...)))])))]))
|
||||
|
||||
|
||||
(define-requirer rep)
|
||||
|
|
@ -168,11 +164,17 @@
|
|||
[(_ val)
|
||||
#'(? (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 print-effect* (box (lambda _ (error "print-effect* not yet defined"))))
|
||||
(define-syntax-rule (defprinter t ...)
|
||||
(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)
|
||||
|
||||
(define-syntax (define-struct/printer stx)
|
||||
|
|
@ -195,6 +197,7 @@
|
|||
(define (f v)
|
||||
(cond [(string? v) v]
|
||||
[(symbol? v) (symbol->string v)]
|
||||
[(char? v) (string v)]
|
||||
[(identifier? v) (symbol->string (syntax-e v))]))
|
||||
(datum->syntax kw (string->symbol (apply string-append (map f args)))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user