Export racket/draw's helper contracts and document them

collects/plot/common/contract.rkt

@@ -12,6 +12,7 @@
           plot-colors/c pen-widths/c plot-pen-styles/c plot-brush-styles/c alphas/c
           labels/c)
          (rename-out [natural-number/c nat/c])
+         font-family/c
          truth/c)
 
 ;; ===================================================================================================
@@ -36,9 +37,6 @@
                                                 'bdiagonal-hatch  'fdiagonal-hatch 'crossdiag-hatch
                                                 'horizontal-hatch 'vertical-hatch  'cross-hatch)))
 
-(defcontract font-family/c (one-of/c 'default 'decorative 'roman  'script 'swiss
-                                     'modern  'symbol     'system))
-
 (defthing known-point-symbols (listof symbol?) #:document-value
   (list 'dot               'point            'pixel
         'plus              'times            'asterisk

collects/plot/scribblings/contracts.scrbl

@@ -1,6 +1,7 @@
 #lang scribble/manual
 
-@(require "common.rkt")
+@(require "common.rkt"
+          (for-label (rename-in racket/draw [font-family/c ff/c])))
 
 @declare-exporting[plot/utils]
 
@@ -48,8 +49,18 @@ The contract for @(racket #:style) arguments (when they refer to fills), and par
 For the meaning of integer brush styles, see @(racket ->brush-style).
 }
 
-@doc-apply[font-family/c]{
+@;; This is to let me link to a different font-family/c
-Identifies legal font family values. See @(racket plot-font-family).
+@;; Builds an element inside the submodule that links to the
+@;; right identifier and exports it.
+@(module id-holder racket/base
+   (require scribble/manual (for-label racket/draw))
+   (provide ff/c-element)
+   (define ff/c-element (racket font-family/c)))
+@(require 'id-holder)
+
+@defthing[font-family/c flat-contract?]{
+Identifies legal font family values. The same as @ff/c-element
+from @racketmodname[racket/draw].
 }
 
 @doc-apply[point-sym/c]{

collects/racket/draw.rkt

@@ -6,6 +6,7 @@
          "draw/private/point.rkt"
          "draw/private/font.rkt"
          "draw/private/font-dir.rkt"
+         "draw/private/font-syms.rkt"
          "draw/private/pen.rkt"
          "draw/private/brush.rkt"
          "draw/private/gradient.rkt"
@@ -36,7 +37,18 @@
          make-bitmap
          make-platform-bitmap
          read-bitmap
-         make-monochrome-bitmap)
+         make-monochrome-bitmap
+
+         ;; predicates/contracts
+         brush-style/c
+         pen-cap-style/c
+         pen-join-style/c
+         pen-style/c
+         font-family/c
+         font-weight/c
+         font-style/c
+         font-smoothing/c
+         font-hinting/c)
 
 (provide/contract [color%            color%/c]
                   [point%            point%/c]
@@ -59,3 +71,4 @@
                   [make-color        make-color/c]
                   [make-pen          make-pen/c]
                   [make-brush        make-brush/c])
+

collects/racket/draw/private/contract.rkt

@@ -8,6 +8,7 @@
          "point.rkt"
          "font.rkt"
          "font-dir.rkt"
+         "font-syms.rkt"
          "pen.rkt"
          "brush.rkt"
          "gradient.rkt"
@@ -74,16 +75,6 @@
         'xor-dot 'xor-long-dash 'xor-short-dash
         'xor-dot-dash))
 
-(define font-family/c
-  (or/c 'default 'decorative 'roman 'script
-        'swiss 'modern 'symbol 'system))
-
-(define font-weight/c    (or/c 'normal 'bold 'light))
-(define font-style/c     (or/c 'normal 'italic 'slant))
-(define font-smoothing/c (or/c 'default 'partly-smoothed
-                               'smoothed 'unsmoothed))
-(define font-hinting/c   (or/c 'aligned 'unaligned))
-
 (define transformation-vector/c
   (vector/c (vector/c real? real? real? real? real? real?)
             real? real? real? real? real?))

collects/racket/draw/private/font-syms.rkt

@@ -6,7 +6,8 @@
 
 (provide family-symbol? style-symbol? weight-symbol? 
          smoothing-symbol? hinting-symbol?
-         font-family/c font-weight/c font-style/c)
+         font-family/c font-weight/c font-style/c
+         font-smoothing/c font-hinting/c)
 
 (define (family-symbol? s)
   (memq s '(default decorative roman script
@@ -26,10 +27,12 @@
 
 ;; TODO: eventually once all old checks are converted to
 ;;       contracts, the above can be removed
-(define font-family/c
+(define font-family/c (or/c 'default 'decorative 'roman 'script 'swiss
-  (or/c 'default 'decorative 'roman 'script
+                            'modern 'symbol 'system))
-        'swiss 'modern 'symbol 'system))
 
 (define font-weight/c (or/c 'normal 'bold 'light))
 (define font-style/c  (or/c 'normal 'italic 'slant))
+(define font-smoothing/c (or/c 'default 'partly-smoothed
+                               'smoothed 'unsmoothed))
+(define font-hinting/c   (or/c 'aligned 'unaligned))
 

collects/racket/snip/private/contract.rkt

@@ -36,19 +36,6 @@
            any/c))))
 
 ;; contract utilities:
-(define font-family/c
-  (or/c 'base 'default 'decorative 'roman 'script
-        'swiss 'modern 'symbol 'system))
-
-(define font-smoothing/c
-  (or/c 'base 'default 'partly-smoothed 'smoothed 'unsmoothed))
-
-(define font-style/c
-  (or/c 'base 'normal 'italic 'slant))
-
-(define font-weight/c
-  (or/c 'base 'normal 'bold 'light))
-
 (define alignment/c
   (or/c 'base 'top 'center 'bottom))
 
@@ -68,7 +55,7 @@
     (get-background-add (->m (is-a?/c add-color<%>)))
     (get-background-mult (->m (is-a?/c mult-color<%>)))
     (get-face (->m (or/c string? false/c)))
-    (get-family (->m font-family/c))
+    (get-family (->m (or/c 'base font-family/c)))
     (get-foreground-add  (->m (is-a?/c add-color<%>)))
     (get-foreground-mult (->m (is-a?/c mult-color<%>)))
     (get-size-add (->m byte?))
@@ -113,25 +100,26 @@
                      (is-a?/c style-delta%))))
     (set-delta-background (->m (or/c string? (is-a?/c color%))
                                (is-a?/c style-delta%)))
-    (set-delta-face (->*m (string?) (font-family/c) (is-a?/c style-delta%)))
+    (set-delta-face (->*m (string?) ((or/c 'base font-family/c))
+                          (is-a?/c style-delta%)))
     (set-delta-foreground (->m (or/c string? (is-a?/c color%))
                                (is-a?/c style-delta%)))
     (set-face (->m (or/c string? false/c) void?))
-    (set-family (->m font-family/c void?))
+    (set-family (->m (or/c 'base font-family/c) void?))
     (set-size-add (->m byte? void?))
     (set-size-in-pixels-off (->m any/c void?))
     (set-size-in-pixels-on  (->m any/c void?))
     (set-size-mult (->m real? void?))
-    (set-smoothing-off (->m font-smoothing/c void?))
+    (set-smoothing-off (->m (or/c 'base font-smoothing/c) void?))
-    (set-smoothing-on  (->m font-smoothing/c void?))
+    (set-smoothing-on  (->m (or/c 'base font-smoothing/c) void?))
-    (set-style-off (->m font-style/c void?))
+    (set-style-off (->m (or/c 'base font-style/c) void?))
-    (set-style-on  (->m font-style/c void?))
+    (set-style-on  (->m (or/c 'base font-style/c) void?))
     (set-transparent-text-backing-off (->m any/c void?))
     (set-transparent-text-backing-on  (->m any/c void?))
     (set-underlined-off (->m any/c void?))
     (set-underlined-on  (->m any/c void?))
-    (set-weight-off (->m font-weight/c void?))
+    (set-weight-off (->m (or/c 'base font-weight/c) void?))
-    (set-weight-on  (->m font-weight/c void?))))
+    (set-weight-on  (->m (or/c 'base font-weight/c) void?))))
 
 (define (arity-1-procedure? x)
   (and (procedure? x)

collects/scribblings/draw/draw-contracts.scrbl

@@ -0,0 +1,101 @@
+#lang scribble/doc
+@(require "common.rkt"
+          unstable/latent-contract)
+
+@title{Drawing Contracts}
+
+@local-table-of-contents[]
+
+This page documents the contracts that are used to describe
+the specification of @racketmodname[racket/draw] objects
+and functions.
+
+@defthing[font-family/c flat-contract?]{
+  Recognizes font designations. Corresponds to the @racket[_family]
+  initialization argument of the @racket[font%] class.
+
+  Equivalent to the following definition:
+  @racketblock[
+    (or/c 'default 'decorative 'roman 'script 'swiss
+          'modern 'symbol 'system)]
+}
+
+@defthing[font-style/c flat-contract?]{
+  Recognizes font styles. Corresponds to the @racket[_style]
+  initialization argument of the @racket[font%] class.
+
+  Equivalent to the following definition:
+  @racketblock[(or/c 'normal 'italic 'slant)]
+}
+
+@defthing[font-weight/c flat-contract?]{
+  Recognizes font weights. Corresponds to the @racket[_weight]
+  initialization argument of the @racket[font%] class.
+
+  Equivalent to the following definition:
+  @racketblock[(or/c 'normal 'bold 'light)]
+}
+
+@defthing[font-smoothing/c flat-contract?]{
+  Recognizes a font smoothing amount.
+  Corresponds to the @racket[_smoothing]
+  initialization argument of the @racket[font%] class.
+
+  Equivalent to the following definition:
+  @racketblock[(or/c 'default 'partly-smoothed
+                     'smoothed 'unsmoothed)]
+}
+
+@defthing[font-hinting/c flat-contract?]{
+  Recognizes font hinting modes. Corresponds to the @racket[_hinting]
+  initialization argument of the @racket[font%] class.
+
+  Equivalent to the following definition:
+  @racketblock[(or/c 'aligned 'unaligned)]
+}
+
+@defthing[pen-style/c flat-contract?]{
+  Recognizes pen styles. Corresponds
+  to the @racket[_style] initialization argument of the
+  @racket[pen%] class.
+
+  Equivalent to the following definition:
+  @racketblock[
+  (or/c 'transparent 'solid 'xor 'hilite
+        'dot 'long-dash 'short-dash 'dot-dash
+        'xor-dot 'xor-long-dash 'xor-short-dash
+        'xor-dot-dash)]
+}
+
+@defthing[pen-cap-style/c flat-contract?]{
+  Recognizes pen cap styles. Corresponds
+  to the @racket[_cap] initialization argument of the
+  @racket[pen%] class.
+
+  Equivalent to the following definition:
+  @racketblock[(or/c 'round 'projecting 'butt)]
+}
+
+@defthing[pen-join-style/c flat-contract?]{
+  Recognizes pen join styles. Corresponds
+  to the @racket[_join] initialization argument of the
+  @racket[pen%] class.
+
+  Equivalent to the following definition:
+  @racketblock[(or/c 'round 'bevel 'miter)]
+}
+
+@defthing[brush-style/c flat-contract?]{
+  Recognizes brush styles. Corresponds
+  to the @racket[_style] initialization argument of the
+  @racket[brush%] class.
+
+  Equivalent to the following definition:
+  @racketblock[
+  (or/c 'transparent 'solid 'opaque
+        'xor 'hilite 'panel
+        'bdiagonal-hatch 'crossdiag-hatch
+        'fdiagonal-hatch 'cross-hatch
+        'horizontal-hatch 'vertical-hatch)]
+}
+

collects/scribblings/draw/draw.scrbl

@@ -41,6 +41,7 @@ interface, and procedure bindings defined in this manual.}
 @include-section["region-class.scrbl"]
 @include-section["svg-dc-class.scrbl"]
 @include-section["draw-funcs.scrbl"]
+@include-section["draw-contracts.scrbl"]
 @include-section["draw-unit.scrbl"]
 @include-section["unsafe.scrbl"]
 @include-section["libs.scrbl"]