checkpoint
svn: r13715 original commit: a8a9af73d86e90fc725c59fb244dc32a11311385
This commit is contained in:
Sam Tobin-Hochstadt
parent
2183983a1b
commit
91244ed599
|
|
@ -4,6 +4,10 @@
|
|||
(require mzlib/etc)
|
||||
(require "rep-utils.ss" "free-variance.ss")
|
||||
|
||||
|
||||
|
||||
#|
|
||||
|
||||
(de True-Effect () [#:frees #f] [#:fold-rhs #:base])
|
||||
|
||||
(de False-Effect () [#:frees #f] [#:fold-rhs #:base])
|
||||
|
|
@ -39,3 +43,4 @@
|
|||
(de Latent-Var-False-Effect () [#:frees #f] [#:fold-rhs #:base])
|
||||
|
||||
;; could also have latent true/false effects, but seems pointless
|
||||
|#
|
||||
22
collects/typed-scheme/rep/object-rep.ss
Normal file
22
collects/typed-scheme/rep/object-rep.ss
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
#lang scheme/base
|
||||
|
||||
(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 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 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)])
|
||||
|
||||
(dlo LBot () [#:frees #f] [#: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)])
|
||||
|
|
@ -15,132 +15,146 @@
|
|||
syntax/stx
|
||||
(rename-in (utils utils) [id mk-id])))
|
||||
|
||||
(provide == dt de print-type* print-effect* Type Type? Effect Effect? defintern hash-id Type-seq Effect-seq Type-key)
|
||||
(provide == defintern hash-id (for-syntax fold-target))
|
||||
|
||||
|
||||
|
||||
;; hash table for defining folds over types
|
||||
(define-values-for-syntax (type-name-ht effect-name-ht)
|
||||
(values (make-hasheq) (make-hasheq)))
|
||||
|
||||
(provide (for-syntax type-name-ht effect-name-ht))
|
||||
|
||||
|
||||
;; all types are Type?
|
||||
(define-struct/printer Type (seq key) (lambda (a b c) ((unbox print-type*) a b c)))
|
||||
|
||||
(define-struct/printer Effect (seq key) (lambda (a b c) ((unbox print-effect*) a b c)))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;; type/effect definition macro
|
||||
|
||||
(define-for-syntax type-rec-id #'type-rec-id)
|
||||
(define-for-syntax effect-rec-id #'effect-rec-id)
|
||||
(define-for-syntax fold-target #'fold-target)
|
||||
|
||||
(provide (for-syntax type-rec-id effect-rec-id fold-target))
|
||||
(define-for-syntax (mk par ht-stx)
|
||||
(define-syntax-class opt-cnt-id
|
||||
#:attributes (i cnt)
|
||||
(pattern i:id
|
||||
#:with cnt #'any/c)
|
||||
(pattern [i:id cnt]))
|
||||
(define-syntax-class no-provide-kw
|
||||
(pattern #:no-provide))
|
||||
(define-syntax-class idlist
|
||||
#:attributes ((i 1) (cnt 1) fs)
|
||||
(pattern (oci:opt-cnt-id ...)
|
||||
#:with (i ...) #'(oci.i ...)
|
||||
#:with (cnt ...) #'(oci.cnt ...)
|
||||
#:with fs #'(i ...)))
|
||||
(define (combiner f flds)
|
||||
(syntax-parse flds
|
||||
[() #'empty-hash-table]
|
||||
[(e) #`(#,f e)]
|
||||
[(e ...) #`(combine-frees (list (#,f e) ...))]))
|
||||
(define-syntax-class frees-pat
|
||||
#:transparent
|
||||
#:attributes (f1 f2)
|
||||
(pattern (f1:expr f2:expr))
|
||||
(pattern (#f)
|
||||
#:with f1 #'empty-hash-table
|
||||
#:with f2 #'empty-hash-table))
|
||||
(define-syntax-class fold-pat
|
||||
#:transparent
|
||||
#:attributes (e)
|
||||
(pattern #:base
|
||||
#:with e fold-target)
|
||||
(pattern ex:expr
|
||||
#:with e #'#'ex))
|
||||
(lambda (stx)
|
||||
(syntax-parse stx
|
||||
[(dform nm:id flds:idlist ([[#:key key-expr:expr]] #:opt
|
||||
[[#:intern intern?:expr]] #:opt
|
||||
[[#:frees . frees:frees-pat]] #:opt
|
||||
[[#:fold-rhs fold-rhs:fold-pat]] #:opt
|
||||
[[#:contract cnt:expr]] #:opt
|
||||
[no-provide?:no-provide-kw] #:opt) ...*)
|
||||
(with-syntax*
|
||||
([ex (mk-id #'nm #'nm ":")]
|
||||
[kw-stx (string->keyword (symbol->string #'nm.datum))]
|
||||
[parent par]
|
||||
[(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)]
|
||||
[*maker (mk-id #'nm "*" #'nm)]
|
||||
[**maker (mk-id #'nm "**" #'nm)]
|
||||
[*maker-cnt (if enable-contracts?
|
||||
(or #'cnt #'(flds.cnt ... . -> . pred))
|
||||
#'any/c)]
|
||||
[ht-stx ht-stx]
|
||||
[bfs-fold-rhs (cond [#'fold-rhs #`(lambda (tr er) #,#'fold-rhs.e)]
|
||||
[else #'(lambda (type-rec-id effect-rec-id)
|
||||
#`(*maker (#,type-rec-id flds.i) ...))])]
|
||||
[provides (if #'no-provide?
|
||||
#'(begin)
|
||||
#`(begin
|
||||
(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))])
|
||||
(syntax-parse #'flds.fs
|
||||
[_ #:when #'intern?
|
||||
(mk #'intern?)]
|
||||
[() (mk #'#f)]
|
||||
[(f) (mk #'f)]
|
||||
[_ (mk #'(list . flds.fs))]))]
|
||||
[frees
|
||||
(with-syntax ([(f1 f2) (if #'frees
|
||||
#'(frees.f1 frees.f2)
|
||||
(list (combiner #'free-vars* #'flds.fs)
|
||||
(combiner #'free-idxs* #'flds.fs)))])
|
||||
(quasisyntax/loc stx
|
||||
(w/c nm ([*maker *maker-cnt])
|
||||
(define (*maker . flds.fs)
|
||||
(define v (**maker . flds.fs))
|
||||
(unless-in-table
|
||||
var-table v
|
||||
(define fvs f1)
|
||||
(define fis f2)
|
||||
(hash-set! var-table v fvs)
|
||||
(hash-set! index-table v fis))
|
||||
v))))])
|
||||
#`(begin
|
||||
(define-struct (nm parent) flds.fs #:inspector #f)
|
||||
(define-match-expander ex
|
||||
(lambda (s)
|
||||
(syntax-parse s
|
||||
[(_ . fs)
|
||||
#:with pat (syntax/loc s (_ _ . fs))
|
||||
(syntax/loc s (struct nm pat))])))
|
||||
(begin-for-syntax
|
||||
(hash-set! ht-stx 'kw-stx (list #'ex #'flds.fs bfs-fold-rhs #'#,stx)))
|
||||
intern
|
||||
provides
|
||||
frees))])))
|
||||
|
||||
(define-syntaxes (dt de)
|
||||
(let ()
|
||||
(define-syntax-class opt-cnt-id
|
||||
#:attributes (i cnt)
|
||||
(pattern i:id
|
||||
#:with cnt #'any/c)
|
||||
(pattern [i:id cnt]))
|
||||
(define-syntax-class no-provide-kw
|
||||
(pattern #:no-provide))
|
||||
(define-syntax-class idlist
|
||||
#:attributes ((i 1) (cnt 1) fs)
|
||||
(pattern (oci:opt-cnt-id ...)
|
||||
#:with (i ...) #'(oci.i ...)
|
||||
#:with (cnt ...) #'(oci.cnt ...)
|
||||
#:with fs #'(i ...)))
|
||||
(define (combiner f flds)
|
||||
(syntax-parse flds
|
||||
[() #'empty-hash-table]
|
||||
[(e) #`(#,f e)]
|
||||
[(e ...) #`(combine-frees (list (#,f e) ...))]))
|
||||
(define-syntax-class frees-pat
|
||||
#:transparent
|
||||
#:attributes (f1 f2)
|
||||
(pattern (f1:expr f2:expr))
|
||||
(pattern (#f)
|
||||
#:with f1 #'empty-hash-table
|
||||
#:with f2 #'empty-hash-table))
|
||||
(define-syntax-class fold-pat
|
||||
#:transparent
|
||||
#:attributes (e)
|
||||
(pattern #:base
|
||||
#:with e fold-target)
|
||||
(pattern ex:expr
|
||||
#:with e #'#'ex))
|
||||
(define (mk par ht-stx)
|
||||
(lambda (stx)
|
||||
(syntax-parse stx
|
||||
[(dform nm:id flds:idlist ([[#:key key-expr:expr]] #:opt
|
||||
[[#:intern intern?:expr]] #:opt
|
||||
[[#:frees . frees:frees-pat]] #:opt
|
||||
[[#:fold-rhs fold-rhs:fold-pat]] #:opt
|
||||
[[#:contract cnt:expr]] #:opt
|
||||
[no-provide?:no-provide-kw] #:opt) ...*)
|
||||
(with-syntax*
|
||||
([ex (mk-id #'nm #'nm ":")]
|
||||
[kw-stx (string->keyword (symbol->string #'nm.datum))]
|
||||
[parent par]
|
||||
[(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)]
|
||||
[*maker (mk-id #'nm "*" #'nm)]
|
||||
[**maker (mk-id #'nm "**" #'nm)]
|
||||
[*maker-cnt (if enable-contracts?
|
||||
(or #'cnt #'(flds.cnt ... . -> . pred))
|
||||
#'any/c)]
|
||||
[ht-stx ht-stx]
|
||||
[bfs-fold-rhs (cond [#'fold-rhs #`(lambda (tr er) #,#'fold-rhs.e)]
|
||||
[else #'(lambda (type-rec-id effect-rec-id)
|
||||
#`(*maker (#,type-rec-id flds.i) ...))])]
|
||||
[provides (if #'no-provide?
|
||||
#'(begin)
|
||||
#`(begin
|
||||
(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))])
|
||||
(syntax-parse #'flds.fs
|
||||
[_ #:when #'intern?
|
||||
(mk #'intern?)]
|
||||
[() (mk #'#f)]
|
||||
[(f) (mk #'f)]
|
||||
[_ (mk #'(list . flds.fs))]))]
|
||||
[frees
|
||||
(with-syntax ([(f1 f2) (if #'frees
|
||||
#'(frees.f1 frees.f2)
|
||||
(list (combiner #'free-vars* #'flds.fs)
|
||||
(combiner #'free-idxs* #'flds.fs)))])
|
||||
(quasisyntax/loc stx
|
||||
(w/c nm ([*maker *maker-cnt])
|
||||
(define (*maker . flds.fs)
|
||||
(define v (**maker . flds.fs))
|
||||
(unless-in-table
|
||||
var-table v
|
||||
(define fvs f1)
|
||||
(define fis f2)
|
||||
(hash-set! var-table v fvs)
|
||||
(hash-set! index-table v fis))
|
||||
v))))])
|
||||
#`(begin
|
||||
(define-struct (nm parent) flds.fs #:inspector #f)
|
||||
(define-match-expander ex
|
||||
(lambda (s)
|
||||
(syntax-parse s
|
||||
[(_ . fs)
|
||||
#:with pat (syntax/loc s (_ _ . fs))
|
||||
(syntax/loc s (struct nm pat))])))
|
||||
(begin-for-syntax
|
||||
(hash-set! ht-stx 'kw-stx (list #'ex #'flds.fs bfs-fold-rhs #'#,stx)))
|
||||
intern
|
||||
provides
|
||||
frees))])))
|
||||
(values (mk #'Type #'type-name-ht) (mk #'Effect #'effect-name-ht))))
|
||||
|
||||
(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))
|
||||
#:transparent
|
||||
(pattern i:id
|
||||
#:with lower-s (string-downcase (symbol->string #'i.datum))
|
||||
#:with (fld-names ...) default-flds
|
||||
#: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 first-letter (symbol->string #'d-name.datum))
|
||||
(pattern [i:id #:fields extra-fld-names:id ...]
|
||||
#:with (fld-names ...) (datum->syntax #f (append (syntax->list default-flds)
|
||||
(syntax->list #'(extra-fld-names ...))))
|
||||
#:with lower-s (string-downcase (symbol->string #'i.datum))
|
||||
#:with first-letter (string-ref #'lower-s 0)))
|
||||
(define-syntax-class type-name
|
||||
#:transparent
|
||||
(pattern :type-name-base
|
||||
#:with name #'i
|
||||
#:with printer (mk-id #'i "print-" #'lower-s "*")
|
||||
#:with ht (mk-id #'i #'lower-s "-name-ht")
|
||||
#:with rec-id (mk-id #'i #'lower-s "-rec-id")
|
||||
#:with d-id (mk-id #'i "d" #'first-letter)
|
||||
#:with (_ _ pred? accs ...)
|
||||
(datum->syntax #f (build-struct-names #'name (syntax->list #'(fld-names ...)) #f #t #'name))))
|
||||
(syntax-parse stx
|
||||
[(_ i:type-name ...)
|
||||
#'(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-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]
|
||||
[PathElem #:d pe])
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@
|
|||
"rep-utils.ss" "effect-rep.ss" "free-variance.ss"
|
||||
mzlib/trace scheme/match
|
||||
scheme/contract
|
||||
stxclass/util
|
||||
(for-syntax scheme/base))
|
||||
|
||||
(define name-table (make-weak-hasheq))
|
||||
|
|
@ -161,7 +162,7 @@
|
|||
(and rest (type-rec-id rest))
|
||||
(and drest (cons (type-rec-id (car drest)) (cdr drest)))
|
||||
(for/list ([kw kws])
|
||||
(cons (Keyword-kw kw) (type-rec-id (Keyword-ty kw)) (Keyword-require? kw)))
|
||||
(make Keyword (Keyword-kw kw) (type-rec-id (Keyword-ty kw)) (Keyword-require? kw)))
|
||||
(map effect-rec-id thn-eff)
|
||||
(map effect-rec-id els-eff))])
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user