stxclass: added more contracts

svn: r13371

collects/stxclass/private/codegen.ss

@@ -36,13 +36,44 @@
         [(rhs:basic? rhs)
          (rhs:basic-parser rhs)]))
 
-;; fail : id id #:pattern datum #:reason datum #:fce FCE -> stx
+;; parse:clauses : stx identifier identifier -> stx
-(define (fail k x #:pattern [p #'#f] #:reason [reason #f] #:fce fce)
+(define (parse:clauses stx var failid)
-  (with-syntax ([k k] [x x] [p p] [reason reason]
+  (define clauses-kw-table
-                [fc-expr (frontier->expr fce)])
+    (list (list '#:literals check-literals-list)))
-    #`(let ([failcontext fc-expr])
+  (define-values (chunks clauses-stx) (chunk-kw-seq/no-dups stx clauses-kw-table))
-        #;(printf "failed: reason=~s, p=~s\n  fc=~s\n" reason p failcontext)
+  (define literals
-        (k x p 'reason failcontext))))
+    (cond [(assq '#:literals chunks) => caddr]
+          [else null]))
+  (define (clause->pk clause)
+    (syntax-case clause ()
+      [(p . rest)
+       (let-values ([(rest decls _ sides)
+                     (parse-pattern-directives #'rest
+                                               #:sc? #f
+                                               #:literals literals)])
+         (syntax-case rest ()
+           [(b)
+            (let* ([pattern (parse-pattern #'p decls 0)])
+              (make-pk (list pattern)
+                       (expr:convert-sides sides
+                                           (pattern-attrs pattern)
+                                           var
+                                           (lambda (iattrs)
+                                             (wrap-pattern-body/attrs iattrs
+                                                                      0
+                                                                      #'b)))))]
+           [_
+            (wrong-syntax clause "expected single body expression")]))]))
+  (unless (stx-list? clauses-stx)
+    (wrong-syntax clauses-stx "expected sequence of clauses"))
+  (let ([pks (map clause->pk (stx->list clauses-stx))])
+    (if (pair? pks)
+        (parse:pks (list var)
+                   (list (empty-frontier var))
+                   pks
+                   failid)
+        (fail failid var #:fce (empty-frontier var)))))
+
 
 ;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK)
 (define (rhs->pks rhs relsattrs main-var)
@@ -65,7 +96,7 @@
                                                    remap
                                                    main-var)))))]))
 
-
+;; expr:convert-sides : (listof SideClause) (listof IAttr) id stx -> stx
 (define (expr:convert-sides sides iattrs main-var k)
   (match sides
     ['() (k iattrs)]
@@ -107,44 +138,16 @@
       (wrong-syntax id "expected identifier")))
   (syntax->list stx))
 
+;; fail : id id #:pattern datum #:reason datum #:fce FCE -> stx
+(define (fail k x #:pattern [p #'#f] #:reason [reason #f] #:fce fce)
+  (with-syntax ([k k] [x x] [p p] [reason reason]
+                [fc-expr (frontier->expr fce)])
+    #`(let ([failcontext fc-expr])
+        #;(printf "failed: reason=~s, p=~s\n  fc=~s\n" reason p failcontext)
+        (k x p 'reason failcontext))))
 
-;; parse:clauses : stx identifier identifier -> stx
+
-(define (parse:clauses stx var failid)
+;; Parsing
-  (define clauses-kw-table
-    (list (list '#:literals check-literals-list)))
-  (define-values (chunks clauses-stx) (chunk-kw-seq/no-dups stx clauses-kw-table))
-  (define literals
-    (cond [(assq '#:literals chunks) => caddr]
-          [else null]))
-  (define (clause->pk clause)
-    (syntax-case clause ()
-      [(p . rest)
-       (let-values ([(rest decls _ sides)
-                     (parse-pattern-directives #'rest
-                                               #:sc? #f
-                                               #:literals literals)])
-         (syntax-case rest ()
-           [(b)
-            (let* ([pattern (parse-pattern #'p decls 0)])
-              (make-pk (list pattern)
-                       (expr:convert-sides sides
-                                           (pattern-attrs pattern)
-                                           var
-                                           (lambda (iattrs)
-                                             (wrap-pattern-body/attrs iattrs
-                                                                      0
-                                                                      #'b)))))]
-           [_
-            (wrong-syntax clause "expected single body expression")]))]))
-  (unless (stx-list? clauses-stx)
-    (wrong-syntax clauses-stx "expected sequence of clauses"))
-  (let ([pks (map clause->pk (stx->list clauses-stx))])
-    (if (pair? pks)
-        (parse:pks (list var)
-                   (list (empty-frontier var))
-                   pks
-                   failid)
-        (fail failid var #:fce (empty-frontier var)))))
 
 ;; parse:pks : (listof identifier) (listof FCE) (listof PK) identifier -> stx
 ;; Each PK has a list of |vars| patterns.

collects/stxclass/private/rep-data.ss

@@ -100,7 +100,25 @@
 (define (sattr? a)
   (and (attr? a) (symbol? (attr-name a))))
 
+;; Contracts
+
+;; DeclEnv = [id -> (list* id id (listof stx)) or #t or #f
+;;   #t means literal, #f means undeclared, list means stxclass (w/ args)
+(define DeclEnv/c
+  (-> identifier? 
+      (or/c boolean? (cons/c identifier? (cons/c identifier? (listof syntax?))))))
+
+(define RemapEnv/c
+  (-> identifier? symbol?))
+
+(define SideClause/c (or/c clause:with? clause:when?))
+
+
 (provide/contract
+ [DeclEnv/c contract?]
+ [RemapEnv/c contract?]
+ [SideClause/c contract?]
+
  [make-empty-sc (-> identifier? sc?)]
  [allow-unbound-stxclasses (parameter/c boolean?)]
  [iattr? (any/c . -> . boolean?)]
@@ -324,5 +342,3 @@
   (cond [(null? iattrs) #f]
         [(bound-identifier=? name (attr-name (car iattrs))) (car iattrs)]
         [else (lookup-iattr name (cdr iattrs))]))
-
-

collects/stxclass/private/rep.ss

@@ -1,4 +1,3 @@
-
 #lang scheme
 (require (for-template "kws.ss")
          (for-template scheme/base)
@@ -7,9 +6,15 @@
          syntax/stx
          "../util.ss"
          "rep-data.ss")
-(provide parse-pattern
-         parse-pattern-directives)
 (provide/contract
+ [parse-pattern 
+  (->* [any/c #|syntax?|# DeclEnv/c exact-nonnegative-integer?]
+       [boolean?]
+       pattern?)]
+ [parse-pattern-directives
+  (->* [stx-list?]
+       [#:sc? boolean? #:literals (listof identifier?)]
+       (values stx-list? DeclEnv/c RemapEnv/c (listof SideClause/c)))]
  [parse-rhs (syntax? boolean? syntax? . -> . rhs?)]
  [parse-splice-rhs (syntax? boolean? syntax? . -> . rhs?)])
 
@@ -282,8 +287,7 @@
 
 ;; parse-pattern-directives : stxs(PatternDirective) #:literals (listof id)
 ;;                         -> stx DeclEnv env (listof SideClause)
-;; DeclEnv = bound-id-mapping[id => (list* id id (listof stx)) or #t]
+;;   if decls maps a name to #t, it indicates literal
-;;   if decls maps a name to #f, it indicates literal
 (define (parse-pattern-directives stx
                                   #:sc? [sc? #f]
                                   #:literals [literals null])