checkpoint

svn: r13715

collects/typed-scheme/rep/effect-rep.ss

@@ -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
+|#

collects/typed-scheme/rep/object-rep.ss

@@ -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)])

collects/typed-scheme/rep/rep-utils.ss

@@ -15,36 +15,11 @@
           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-syntaxes (dt de)
-  (let ()
+(define-for-syntax (mk par ht-stx)      
   (define-syntax-class opt-cnt-id
     #:attributes (i cnt)
     (pattern i:id
@@ -77,7 +52,6 @@
              #: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 
@@ -142,5 +116,45 @@
             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])

collects/typed-scheme/rep/type-rep.ss

@@ -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))])