From 6a8ae143308b73c7b521b85e89192577db942f59 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 20 Feb 2009 23:35:02 +0000 Subject: [PATCH] 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 --- collects/typed-scheme/rep/rep-utils.ss | 159 +++++++++++++++---------- collects/typed-scheme/rep/type-rep.ss | 106 ++++------------- collects/typed-scheme/utils/utils.ss | 53 +++++---- 3 files changed, 148 insertions(+), 170 deletions(-) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index e80c8871..ea867648 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -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]) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index 0e928d50..b837cd14 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -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 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 (typelist #'(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)))))