diff --git a/collects/typed-scheme/rep/filter-rep.ss b/collects/typed-scheme/rep/filter-rep.ss index 0812e04fe1..d468d109f8 100644 --- a/collects/typed-scheme/rep/filter-rep.ss +++ b/collects/typed-scheme/rep/filter-rep.ss @@ -4,43 +4,29 @@ (require mzlib/etc) (require "rep-utils.ss" "free-variance.ss") +(df Bot () [#:fold-rhs #:base]) + +(df TypeFilter ([t Type?] [p (listof PathElem?)] [v identifier?]) + [#:intern (list t p (hash-id v))] + [#:frees (combine-frees (map free-vars* (cons t p))) + (combine-frees (map free-idxs* (cons t p)))] + [#:fold-rhs (*TypeFilter (type-rec-id t) (map pathelem-rec-id p) v)]) + +(df NotTypeFilter ([t Type?] [p (listof PathElem?)] [v identifier?]) + [#:intern (list t p (hash-id v))] + [#:frees (combine-frees (map free-vars* (cons t p))) + (combine-frees (map free-idxs* (cons t p)))] + [#:fold-rhs (*NotTypeFilter (type-rec-id t) (map pathelem-rec-id p) v)]) -#| +(dlf LBot () [#:fold-rhs #:base]) -(de True-Effect () [#:frees #f] [#:fold-rhs #:base]) +(dlf LTypeFilter ([t Type?] [p (listof PathElem?)]) + [#:frees (combine-frees (map free-vars* (cons t p))) + (combine-frees (map free-idxs* (cons t p)))] + [#:fold-rhs (*LTypeFilter (type-rec-id t) (map pathelem-rec-id p))]) -(de False-Effect () [#:frees #f] [#:fold-rhs #:base]) - -;; v is an identifier -(de Var-True-Effect ([v identifier?]) [#:intern (hash-id v)] [#:frees #f] [#:fold-rhs #:base]) - -;; v is an identifier -(de Var-False-Effect ([v identifier?]) [#:intern (hash-id v)] [#:frees #f] [#:fold-rhs #:base]) - -;; t is a Type -;; v is an identifier -(de Restrict-Effect ([t Type?] [v identifier?]) [#:intern (list t (hash-id v))] [#:frees (free-vars* t) (free-idxs* t)] - [#:fold-rhs (*Restrict-Effect (type-rec-id t) v)]) - -;; t is a Type -;; v is an identifier -(de Remove-Effect ([t Type?] [v identifier?]) - [#:intern (list t (hash-id v))] - [#:frees (free-vars* t) (free-idxs* t)] - [#:fold-rhs (*Remove-Effect (type-rec-id t) v)]) - -;; t is a Type -(de Latent-Restrict-Effect ([t Type?]) [#:frees (free-vars* t) (free-idxs* t)] - [#:fold-rhs (*Latent-Restrict-Effect (type-rec-id t))]) - -;; t is a Type -(de Latent-Remove-Effect ([t Type?]) [#:frees (free-vars* t) (free-idxs* t)] - [#:fold-rhs (*Latent-Remove-Effect (type-rec-id t))]) - -(de Latent-Var-True-Effect () [#:frees #f] [#:fold-rhs #:base]) - -(de Latent-Var-False-Effect () [#:frees #f] [#:fold-rhs #:base]) - -;; could also have latent true/false effects, but seems pointless -|# \ No newline at end of file +(dlf LNotTypeFilter ([t Type?] [p (listof PathElem?)]) + [#:frees (combine-frees (map free-vars* (cons t p))) + (combine-frees (map free-idxs* (cons t p)))] + [#:fold-rhs (*LNotTypeFilter (type-rec-id t) (map pathelem-rec-id p))]) diff --git a/collects/typed-scheme/rep/object-rep.ss b/collects/typed-scheme/rep/object-rep.ss index e56bddd583..4a6f10a28c 100644 --- a/collects/typed-scheme/rep/object-rep.ss +++ b/collects/typed-scheme/rep/object-rep.ss @@ -2,21 +2,21 @@ (require scheme/match scheme/contract "rep-utils.ss" "free-variance.ss") -(dpe CarPE () [#:frees #f] [#:fold-rhs #:base]) -(dpe CdrPE () [#:frees #f] [#:fold-rhs #:base]) +(dpe CarPE () [#:fold-rhs #:base]) +(dpe CdrPE () [#:fold-rhs #:base]) (dpe StructPE ([t Type?] [idx natural-number/c]) [#:frees (free-vars* t) (free-idxs* t)] [#:fold-rhs (*StructPE (type-rec-id t) idx)]) -(do Bot () [#:frees #f] [#:fold-rhs #:base]) +(do Empty () [#:fold-rhs #:base]) (do Path ([p (listof PathElem?)] [v identifier?]) [#:intern (list p (hash-id v))] [#:frees (combine-frees (map free-vars* p)) (combine-frees (map free-idxs* p))] - [#:fold-rhs (*Path (map pathelem-rec-id t) v)]) + [#:fold-rhs (*Path (map pathelem-rec-id p) v)]) -(dlo LBot () [#:frees #f] [#:fold-rhs #:base]) +(dlo LEmpty () [#:fold-rhs #:base]) (dlo LPath ([p (listof PathElem?)] [idx natural-number/c]) [#:frees (combine-frees (map free-vars* p)) (combine-frees (map free-idxs* p))] - [#:fold-rhs (*LPath (map pathelem-rec-id t) idx)]) \ No newline at end of file + [#:fold-rhs (*LPath (map pathelem-rec-id p) idx)]) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index ad394dfdc8..0cfd62bd35 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -19,7 +19,7 @@ (define-for-syntax fold-target #'fold-target) -(define-for-syntax (mk par ht-stx) +(define-for-syntax (mk par ht-stx key?) (define-syntax-class opt-cnt-id #:attributes (i cnt) (pattern i:id @@ -80,7 +80,10 @@ (provide ex pred acc ...) (p/c (rename *maker maker *maker-cnt))))] [intern - (let ([mk (lambda (int) #`(defintern (**maker . flds.fs) maker #,int #:extra-arg key-expr))]) + (let ([mk (lambda (int) #`(defintern (**maker . flds.fs) maker #,int + #,@(if key? + #'(#:extra-arg key-expr) + #'())))]) (syntax-parse #'flds.fs [_ #:when #'intern? (mk #'intern?)] @@ -121,20 +124,25 @@ (define-syntax (make-prim-type stx) (define default-flds #'(seq)) (define-syntax-class type-name-base - #:attributes (i lower-s first-letter (fld-names 1)) + #:attributes (i lower-s first-letter key? (fld-names 1)) #:transparent (pattern i:id #:with lower-s (string-downcase (symbol->string #'i.datum)) + #:when (printf "loc1: ~a~n" #'lower-s) #:with (fld-names ...) default-flds + #:with key? #'#f #:with first-letter (string-ref #'lower-s 0)) (pattern [i:id #:d d-name:id] #:with (fld-names ...) default-flds #:with lower-s (string-downcase (symbol->string #'i.datum)) + #:with key? #'#f #:with first-letter (symbol->string #'d-name.datum)) - (pattern [i:id #:fields extra-fld-names:id ...] + (pattern [i:id #:key] #:with (fld-names ...) (datum->syntax #f (append (syntax->list default-flds) - (syntax->list #'(extra-fld-names ...)))) + (syntax->list #'(key)))) #:with lower-s (string-downcase (symbol->string #'i.datum)) + #:when (printf "loc2: ~v~n" (syntax->datum #'lower-s)) + #:with key? #'#t #:with first-letter (string-ref #'lower-s 0))) (define-syntax-class type-name #:transparent @@ -151,10 +159,10 @@ #'(begin (provide i.d-id ... i.printer ... i.name ... i.pred? ... i.accs ... ... (for-syntax i.ht ... i.rec-id ...)) - (define-syntax i.d-id (mk #'i.name #'i.ht)) ... + (define-syntax i.d-id (mk #'i.name #'i.ht i.key?)) ... (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) ...)])) -(make-prim-type [Type #:fields 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])