Adding doc based contracts

svn: r15707

collects/scribble/base.ss

@@ -146,10 +146,12 @@
 
 ;; ----------------------------------------
 
+; XXX unknown contracts
 (provide intern-taglet
          module-path-index->taglet
-         module-path-prefix->string
          doc-prefix)
+(provide/contract
+ [module-path-prefix->string (module-path? . -> . string?)])
 
 (require syntax/modcollapse
          ;; Needed to normalize planet version numbers:
@@ -242,7 +244,8 @@
             () 
             #:rest (listof pre-flow?)
             item?)])
-(provide item?)
+(provide/contract
+ [item? (any/c . -> . boolean?)])
 
 (define (itemlist #:style [style plain] . items)
   (let ([flows (map an-item-flow items)])
@@ -557,8 +560,15 @@
 
 ;; ----------------------------------------
 
-(provide section-index index index* as-index index-section
+; XXX unknown contract
-         get-index-entries index-block)
+(provide get-index-entries)
+(provide/contract
+ [index-block (-> delayed-block?)]
+ [index (((or/c string? (listof string?))) ()  #:rest (listof any/c) . ->* . index-element?)] ; XXX pre-content docs
+ [index* (((listof string?) (listof any/c)) ()  #:rest (listof any/c) . ->* . index-element?)] ; XXX pre-content docs and first any/c wrong in docs 
+ [as-index (() () #:rest (listof any/c) . ->* . index-element?)] ; XXX pre-content docs
+ [section-index (() () #:rest (listof string?) . ->* . part-index-decl?)]
+ [index-section (() (#:tag (or/c false/c string?)) . ->* . part?)])
 
 (define (section-index . elems)
   (make-part-index-decl (map content->string elems) elems))
@@ -730,8 +740,10 @@
 
 ;; ----------------------------------------
 
-(provide table-of-contents
+(provide/contract
-         local-table-of-contents)
+ [table-of-contents (-> delayed-block?)]
+ ; XXX Should have a style/c contract
+ [local-table-of-contents (() (#:style any/c) . ->* . delayed-block?)])
 
 (define (table-of-contents)
   (make-delayed-block

collects/scribble/private/manual-bib.ss

@@ -1,14 +1,21 @@
 #lang scheme/base
-(require "../decode.ss"
+(require scheme/contract
+         "../decode.ss"
          "../struct.ss"
          "../basic.ss"
          "manual-utils.ss"
          "manual-style.ss")
 
-(provide cite
+(define-struct a-bib-entry (key val))
-         bib-entry
+
-         (rename-out [a-bib-entry? bib-entry?])
+(provide/contract
-         bibliography)
+ [cite ((string?) () #:rest (listof string?) . ->* . element?)] ; XXX docs wrong
+ [bib-entry ((#:key string? #:title any/c) ; XXX bad contracts
+             (#:is-book? any/c #:author any/c #:location any/c #:date any/c #:url any/c)
+             . ->* .
+             a-bib-entry?)]
+ [rename a-bib-entry? bib-entry? (any/c . -> . boolean?)]
+ [bibliography (() (#:tag string?) #:rest (listof a-bib-entry?) . ->* . part?)]) 
 
 (define (cite key . keys)
   (make-element
@@ -27,8 +34,6 @@
                     (loop (cdr keys))))))
          "]")))
 
-(define-struct a-bib-entry (key val))
-
 (define (bib-entry #:key key
                    #:title title
                    #:is-book? [is-book? #f]

collects/scribble/private/manual-bind.ss

@@ -7,6 +7,7 @@
          "../manual-struct.ss"
          "manual-ex.ss"
          scheme/string
+         scheme/contract
          scheme/list
          scheme/class
          scheme/stxparam
@@ -25,12 +26,15 @@
          with-exporting-libraries
          id-to-target-maker
          id-to-form-target-maker
-         defidentifier
          *sig-elem
          (struct-out sig)
          ;; public:
+         ; XXX unknown contract
          make-binding-redirect-elements
          sigelem)
+(provide/contract
+ ; XXX any/c should be boolean?
+ [defidentifier ((identifier?) (#:form? any/c #:index? any/c #:show-libs? any/c) . ->* . element?)])
 
 (define (gen-absolute-tag)
   `(abs ,(make-generated-tag)))

collects/scribble/private/manual-ex.ss

@@ -1,6 +1,7 @@
 #lang scheme/base
 (require "../struct.ss")
 
+; XXX unknown contracts
 (provide (struct-out exporting-libraries)
          current-signature)
 

collects/scribble/private/manual-form.ss

@@ -18,6 +18,7 @@
          (for-syntax scheme/base)
          (for-label scheme/base))
 
+
 (provide defform defform* defform/subs defform*/subs defform/none
          defidform
          specform specform/subs

collects/scribble/private/manual-method.ss

@@ -6,11 +6,12 @@
          "manual-scheme.ss"
          (for-syntax scheme/base))
 
+(provide ;; public:
+         method xmethod)
+; XXX unknown contracts
 (provide *method **method
          method-tag
-         name-this-object
+         name-this-object)
-         ;; public:
-         method xmethod)
 
 (define-syntax-rule (method a b)
   (*method 'b (quote-syntax a)))

collects/scribble/private/manual-proc.ss

@@ -21,9 +21,10 @@
 
 (provide defproc defproc* defstruct
          defparam defparam* defboolparam
-         defthing defthing* defthing/proc
+         defthing defthing* 
+         defthing/proc ; XXX unknown contract
          ;; private:
-         *defthing)
+         *defthing) ; XXX unknown contract
 
 (define dots0
   (make-element meta-color (list "...")))

collects/scribble/private/manual-scheme.ss

@@ -16,8 +16,9 @@
          schemeinput
          schememod
          scheme SCHEME scheme/form schemeresult schemeid 
-         schememodname schememodlink
+         schememodname
-         indexed-scheme
+         schememodlink indexed-scheme
+         ; XXX doc says this is function
          schemelink)
 
 (define-code schemeblock0 to-paragraph)

collects/scribble/private/manual-style.ss

@@ -7,35 +7,47 @@
          (only-in "../core.ss" make-style plain)
          "manual-utils.ss"
          scheme/list
+         scheme/contract
          scheme/string)
 
-(provide PLaneT etc
+(provide (rename-out [hyperlink link])
-         litchar
-         image (rename-out [image image/plain]) onscreen menuitem defterm
-         schemefont schemevalfont schemeresultfont schemeidfont schemevarfont
-         schemeparenfont schemekeywordfont schememetafont schememodfont
-         schemeerror schemeoutput
-         filepath exec envvar Flag DFlag PFlag DPFlag
-         indexed-file indexed-envvar
-         (rename-out [hyperlink link])
          (rename-out [other-doc other-manual])
          (rename-out [centered centerline])
+         image
+         (rename-out [image image/plain])
          itemize
-         procedure
+         aux-elem)
-         idefterm
+
-         t inset-flow
+; XXX pre-content
-         pidefterm
+(define styling-f/c
-         hash-lang
+  (() () #:rest (listof any/c) . ->* . element?))
-         commandline         
+(define-syntax-rule (provide-styling id ...)
-         void-const undefined-const
+  (provide/contract [id styling-f/c] ...))
-         aux-elem
+(provide-styling onscreen defterm
-         math)
+                 schememodfont schemeoutput ; XXX no docs
+                 schemeerror schemefont schemevalfont schemeresultfont schemeidfont schemevarfont
+                 schemeparenfont schemekeywordfont schememetafont
+                 filepath exec envvar Flag DFlag PFlag DPFlag math
+                 procedure
+                 indexed-file indexed-envvar idefterm pidefterm)
+(provide/contract
+ [PLaneT element?]
+ [void-const element?]
+ [undefined-const element?]
+ [hash-lang (-> element?)]
+ [etc string?]
+ [inset-flow (() () #:rest (listof any/c) . ->* . any/c)] ; XXX no docs and bad return contract
+ [litchar (() () #:rest (listof string?) . ->* . element?)] ; XXX docs wrong
+ [t (() () #:rest (listof any/c) . ->* . paragraph?)] ; XXX pre-content
+ [commandline (() () #:rest (listof any/c) . ->* . paragraph?)] ; XXX pre-content
+ [menuitem (string? string? . -> . element?)]) 
 
 (define PLaneT (make-element "planetName" '("PLaneT")))
 
 (define etc "etc.") ; so we can fix the latex space, one day
 
 (define (litchar . strs)
+  ; XXX Remove not-contract
   (unless (andmap string? strs)
     (raise-type-error 'litchar "strings" strs))
   (let ([s (string-append* (map (lambda (s) (regexp-replace* "\n" s " "))

collects/scribble/private/manual-tech.ss

@@ -1,11 +1,16 @@
 #lang scheme/base
-(require "../decode.ss"
+(require scheme/contract
+         "../decode.ss"
          "../struct.ss"
          "../basic.ss"
          "manual-utils.ss"
          "manual-style.ss")
 
-(provide deftech tech techlink)
+(provide/contract
+ ; XXX boolean? and precontent?
+ [deftech (() (#:style? any/c) #:rest (listof any/c) . ->* . element?)]
+ [tech (() (#:doc (or/c module-path? false/c) #:tag-prefixes (or/c (listof string?) false/c)) #:rest (listof any/c) . ->* . element?)]
+ [techlink (() (#:doc (or/c module-path? false/c) #:tag-prefixes (or/c (listof string?) false/c)) #:rest (listof any/c) . ->* . element?)])
 
 (define (*tech make-elem style doc prefix s)
   (let* ([c (decode-content s)]

collects/scribble/private/manual-unit.ss

@@ -11,12 +11,12 @@
          "manual-bind.ss"
          "manual-ex.ss"
          "manual-proc.ss"
+         scheme/contract
          (for-syntax scheme/base)
          (for-label scheme/base))
 
 (provide defsignature
          defsignature/splice
-         signature-desc
          sigelem)
 
 (define-syntax-rule (defsignature name (super ...) body ...)
@@ -41,6 +41,10 @@
 (define (signature-desc . l)
   (make-sig-desc l))
 
+(provide/contract
+ ; XXX preflow & docs
+ [signature-desc (() () #:rest (listof any/c) . ->* . sig-desc?)])
+
 (define (*defsignature stx-id supers body-thunk indent?)
   (*defthing
    (list stx-id)

collects/scribble/private/manual-utils.ss

@@ -2,13 +2,17 @@
 (require "../struct.ss"
          "../decode.ss"
          "../base.ss"
+         scheme/contract
          scheme/list)
 
-(provide spacer doc-prefix
+(provide doc-prefix)
-         to-flow
+(provide/contract
-         flow-spacer flow-empty-line
+ [spacer element?]
-         make-table-if-necessary
+ [to-flow (any/c . -> . flow?)] ; XXX element?
-         max-proto-width)
+ [flow-spacer flow?]
+ [flow-empty-line flow?]
+ [make-table-if-necessary (any/c list? . -> . (list/c (or/c omitable-paragraph? table?)))] ; XXX element?
+ [max-proto-width exact-nonnegative-integer?])
 
 (define spacer (hspace 1))
 

collects/scribble/private/manual-vars.ss

@@ -3,18 +3,20 @@
          "../scheme.ss"
          "../struct.ss"
          (only-in "../core.ss" style-name)
+         scheme/contract
          (for-syntax scheme/base
                      syntax/kerncase
                      syntax/boundmap)
          (for-label scheme/base
                     scheme/class))
 
+(define-struct (box-splice splice) ())
+
+(provide/contract
+ [struct (box-splice splice) ([run list?])]) ; XXX ugly copying
 (provide deftogether
          with-scheme-variables
-         with-togetherable-scheme-variables
+         with-togetherable-scheme-variables)
-         (struct-out box-splice))
-
-(define-struct (box-splice splice) ())
 
 (begin-for-syntax (define-struct deftogether-tag () #:omit-define-syntaxes))