Mergin', get back

I'm all right, jack, keep your hands off of my branch...

svn: r11790

collects/drscheme/private/debug.ss

@@ -816,9 +816,10 @@ profile todo:
           (or (send editor get-filename) 
               untitled))))
   
-  ;; open-and-highlight-in-file : srcloc -> void
-  (define (open-and-highlight-in-file srclocs)
-    (let ([sources (filter values (map srcloc-source srclocs))])
+  ;; open-and-highlight-in-file : (or/c srcloc (listof srcloc)) -> void
+  (define (open-and-highlight-in-file raw-srcloc)
+    (let* ([srclocs (if (srcloc? raw-srcloc) (list raw-srcloc) raw-srcloc)]
+           [sources (filter values (map srcloc-source srclocs))])
       (unless (null? sources)
         (let* ([debug-source (car sources)]
                [same-src-srclocs

collects/drscheme/tool-lib.ss

@@ -382,7 +382,7 @@ all of the names in the tools library, for use defining keybindings
   
   (proc-doc/names
    drscheme:debug:open-and-highlight-in-file
-   (srcloc? . -> . void?)
+   ((or/c srcloc? (listof srcloc?)) . -> . void?)
    (debug-info)
    @{This function opens a DrScheme to display
      @scheme[debug-info]. Only the src the position

collects/lang/private/imageeq.ss

@@ -32,9 +32,13 @@
     (let ([a (coerce-to-cache-image-snip a-raw)]
           [b (coerce-to-cache-image-snip b-raw)])
       (let-values ([(aw ah) (snip-size a)]
-                   [(bw bh) (snip-size b)])
+                   [(bw bh) (snip-size b)]
+                   [(apx apy) (send a get-pinhole)]
+                   [(bpx bpy) (send b get-pinhole)])
         (and (= aw bw)
              (= ah bh)
+             (= apx bpx)
+             (= apy bpy)
              (same/alpha? (argb-vector (send a get-argb))
                           (argb-vector (send b get-argb)))))))
   

collects/repos-time-stamp/stamp.ss

@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "14sep2008")
+#lang scheme/base (provide stamp) (define stamp "17sep2008")

collects/syntax/scribblings/module-reader.scrbl

@@ -34,7 +34,7 @@ That is, a module @scheme[_something]@scheme[/lang/reader] implemented
 as
 
 @schemeblock[
-(module reader module-syntax/module-reader
+(module reader syntax/module-reader
   module-path)
 ]
 
@@ -52,7 +52,7 @@ the reader.
 For example, @scheme[scheme/base/lang/reader] is implemented as
 
 @schemeblock[
-(module reader module-syntax/module-reader
+(module reader syntax/module-reader
   scheme/base)
 ]
 
@@ -65,7 +65,7 @@ reading.  For example, you can implement a
 using:
 
 @schemeblock[
-(module reader module-syntax/module-reader
+(module reader syntax/module-reader
   honu
   #:read read-honu
   #:read-syntax read-honu-syntax)

collects/tests/mzscheme/htdp-image.ss

@@ -181,25 +181,25 @@
 (test (list blue blue blue
             blue white blue
             blue blue blue)
-      'color-list2
+      'color-list3
       (image->color-list (rectangle 3 3 "outline" 'blue)))
 
 (test #t
-      'color-list
+      'color-list4
       (image=? (color-list->image (list blue blue blue blue) 2 2 0 0)
-               (rectangle 2 2 'solid 'blue)))
+               (p00 (rectangle 2 2 'solid 'blue))))
 (test #f
-      'color-list
+      'color-list5
       (image=? (color-list->image (list blue blue blue blue) 2 2 0 0)
                (rectangle 1 4 'solid 'blue)))
 (test #t
-      'color-list
+      'color-list6
       (image=? (color-list->image (list blue blue blue blue) 1 4 0 0)
-               (rectangle 1 4 'solid 'blue)))
+               (p00 (rectangle 1 4 'solid 'blue))))
 (test #t
-      'color-list
+      'color-list7
       (image=? (color-list->image (list 'blue 'blue 'blue 'blue) 2 2 0 0)
-               (rectangle 2 2 'solid 'blue)))
+               (p00 (rectangle 2 2 'solid 'blue))))
 
 (test #t
       'alpha-color-list1
@@ -283,6 +283,17 @@
       (image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1 0 0)
                (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1 0 0)))
 
+;; different pinholes => different images
+(test #f
+      'image=?1b
+      (image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1 1 0)
+               (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1 0 0)))
+
+(test #f
+      'image=?1c
+      (image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1 0 0)
+               (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1 0 1)))
+
 (test #t
       'image=?2
       (image=? (alpha-color-list->image (list (make-alpha-color 255 100 100 100)) 1 1 0 0)
@@ -364,9 +375,9 @@
 (test #t
       'overlay/xy4
       (image=? (color-list->image (list blue blue red red) 2 2 0 0)
-               (overlay/xy (p00 (rectangle 2 1 'solid 'red))
-                           0 -1
-                           (p00 (rectangle 2 1 'solid 'blue)))))
+               (p00 (overlay/xy (p00 (rectangle 2 1 'solid 'red))
+                                0 -1
+                                (p00 (rectangle 2 1 'solid 'blue))))))
 
 (test #t
       'overlay/xy/white
@@ -539,7 +550,7 @@
 ;; I developed them under macos x. -robby
 (test #t
       'triangle1
-      (image=? (triangle 3 'outline 'red)
+      (image=? (p00 (triangle 3 'outline 'red))
                (color-list->image 
                 (list white red   white
                       white red   white
@@ -552,7 +563,7 @@
 
 (test #t
       'triangle2
-      (image=? (triangle 3 'solid 'red)
+      (image=? (p00 (triangle 3 'solid 'red))
                (color-list->image 
                 (list white red   white
                       white red   white
@@ -595,19 +606,19 @@
       'add-line1
       (image=? (overlay (p00 (rectangle 5 4 'solid 'black))
                         (p00 (rectangle 1 4 'solid 'red)))
-               (add-line (p00 (rectangle 4 4 'solid 'black))
-                         -1 0
-                         -1 3
-                         'red)))
+               (p00 (add-line (p00 (rectangle 4 4 'solid 'black))
+                              -1 0
+                              -1 3
+                              'red))))
 
 (test #t
       'add-line2
       (image=? (overlay (p00 (rectangle 4 5 'solid 'black))
                         (p00 (rectangle 4 1 'solid 'red)))
-               (add-line (p00 (rectangle 4 4 'solid 'black))
-                         0 -1
-                         3 -1
-                         'red)))
+               (p00 (add-line (p00 (rectangle 4 4 'solid 'black))
+                              0 -1
+                              3 -1
+                              'red))))
 
 (test 7
       'add-line3

collects/tests/scribble/main.ss

@@ -1,6 +1,8 @@
 #lang scheme/base
 
-(require tests/eli-tester scribble/text/syntax-utils)
+(require tests/eli-tester scribble/text/syntax-utils scheme/runtime-path)
+
+(define-runtime-path text-dir "text")
 
 (test
 
@@ -76,4 +78,17 @@
                 (f 3 #:> "]" #:< "["))
  => '(1 ("<" 1 ">") ("[" 2 ">") ("[" 3 "]"))
 
+ ;; preprocessor functionality
+ (parameterize ([current-directory text-dir])
+   (for ([ifile (map path->string (directory-list))]
+         #:when (and (file-exists? ifile)
+                     (regexp-match? #rx"^i[0-9]+$" ifile)))
+     (define ofile (regexp-replace #rx"^i" ifile "o"))
+     (define expected (call-with-input-file ofile
+                        (lambda (i) (read-bytes (file-size ofile) i))))
+     (define o (open-output-bytes))
+     (parameterize ([current-output-port o])
+       (dynamic-require (path->complete-path ifile) #f))
+     (test (get-output-bytes o) => expected)))
+
  )

collects/tests/scribble/text/i1

@@ -0,0 +1,3 @@
+#lang scribble/text
+
+foo

collects/tests/scribble/text/i2

@@ -0,0 +1,25 @@
+#lang scribble/text
+
+@define[name]{PLT Scheme}
+
+Suggested price list for "@name"
+
+@; test mutual recursion, throwing away inter-definition spaces
+@; <-- this is needed to get one line of space only
+@(define (items-num)
+   (length items))
+
+@(define average
+   (delay (/ (apply + (map car items)) (length items))))
+
+@(define items
+   (list @list[99]{Home}
+         @list[149]{Professional}
+         @list[349]{Enterprize}))
+
+@(for/list ([i items] [n (in-naturals)])
+   @list{@|n|. @name @cadr[i] edition: $@car[i].99
+         @||})@; <-- also needed
+
+Total: @items-num items
+Average price: $@|average|.99

collects/tests/scribble/text/i3

@@ -0,0 +1,18 @@
+#lang scribble/text
+
+---***---
+@(define (angled . body) (list "<" body ">"))
+ @(define (shout . body) @angled[(map string-upcase body)])
+  @define[z]{blah}
+
+blah @angled{blah @shout{@z} blah} blah
+
+@(define-syntax-rule @twice[x]
+   (list x ", " x))
+
+@twice{@twice{blah}}
+
+@include{i3a}
+
+@(let ([name "Eli"]) (let ([foo (include "i3b")]) (list foo "\n" foo)))
+Repeating yourself much?

collects/tests/scribble/text/i3a

@@ -0,0 +1 @@
+Warning: blah overdose might be fatal

collects/tests/scribble/text/i3b

@@ -0,0 +1,12 @@
+@(define (foo . xs) (bar xs))
+@(begin (define (isname) @list{is @foo{@name}})
+        (define-syntax-rule (DEF x y) (define x y)))
+@(DEF (bar x) (list z " " x))
+@(define-syntax-rule (BEG x ...) (begin x ...))
+@(BEG (define z "zee"))
+
+My name @isname
+@DEF[x]{Foo!}
+
+  ... and to that I say "@x", I think.
+

collects/tests/scribble/text/o1

@@ -0,0 +1 @@
+foo

collects/tests/scribble/text/o2

@@ -0,0 +1,8 @@
+Suggested price list for "PLT Scheme"
+
+0. PLT Scheme Home edition: $99.99
+1. PLT Scheme Professional edition: $149.99
+2. PLT Scheme Enterprize edition: $349.99
+
+Total: 3 items
+Average price: $199.99

collects/tests/scribble/text/o3

@@ -0,0 +1,14 @@
+---***---
+blah <blah <BLAH> blah> blah
+
+blah, blah, blah, blah
+
+Warning: blah overdose might be fatal
+
+My name is zee Eli
+  ... and to that I say "Foo!", I think.
+
+My name is zee Eli
+  ... and to that I say "Foo!", I think.
+
+Repeating yourself much?

collects/typed-scheme/typed-scheme.scrbl

@@ -428,6 +428,9 @@ The following base types are parameteric in their type arguments.
 @defform[(Boxof t)]{A @gtech{box} of @scheme[t]}
 @defform[(Vectorof t)]{Homogenous @gtech{vectors} of @scheme[t]}
 @defform[(Option t)]{Either @scheme[t] of @scheme[#f]}
+@defform*[[(Parameter t)
+           (Parameter s t)]]{A @rtech{parameter} of @scheme[t].  If two type arguments are supplied, 
+                               the first is the type the parameter accepts, and the second is the type returned.}
 @defform[(Pair s t)]{is the pair containing @scheme[s] as the @scheme[car]
   and @scheme[t] as the @scheme[cdr]}
 
@@ -520,6 +523,10 @@ types.  In most cases, use of @scheme[:] is preferred to use of @scheme[define:]
 (define-struct: (name parent) ([f : t] ...))
 (define-struct: (v ...) name ([f : t] ...))
 (define-struct: (v ...) (name parent) ([f : t] ...))]]
+{Defines a @rtech{structure} with the name @scheme[name], where the fields 
+         @scheme[f] have types @scheme[t].  The second and fourth forms define @scheme[name]
+         to be a substructure of @scheme[parent].  The last two forms define structures that 
+         are polymorphic in the type variables @scheme[v].}
 
 @subsection{Type Aliases}
 @defform*[[(define-type-alias name t)

collects/web-server/formlets/date.ss

@@ -0,0 +1,63 @@
+#lang scheme
+(require web-server/formlets/formlets)
+
+(define-struct date (month day))
+(define (date->xml d)
+  (format "~a/~a"
+          (date-month d)
+          (date-day d)))
+
+(define (submit t)
+  `(input ([type "submit"]) ,t))
+
+(define date-formlet
+  (formlet
+   (div
+    "Month:" ,{input-int . => . month}
+    "Day:" ,{input-int . => . day})
+   (make-date month day)))
+
+(formlet-display date-formlet)
+
+(define travel-formlet
+  (formlet
+   (#%#
+    "Name:" ,{input-string . => . name}
+    (div
+     "Arrive:" ,{date-formlet . => . arrive}
+     "Depart:" ,{date-formlet . => . depart})
+    ,@(list "1" "2" "3")
+    ,(submit "Submit"))
+   (list name arrive depart)))
+
+(formlet-display travel-formlet)
+
+(define display-itinernary
+  (match-lambda
+    [(list name arrive depart)
+     `(html
+       (head (title "Itinerary"))
+       (body
+        "Itinerary for: " ,name
+        "Arriving:" ,(date->xml arrive)
+        "Departing:" ,(date->xml depart)))]))
+
+(require net/url
+         web-server/servlet)
+(formlet-process travel-formlet
+                 (make-request 'get (string->url "http://test.com")
+                               empty
+                               (list (make-binding:form #"input_0" #"Jay")
+                                     (make-binding:form #"input_1" #"10")
+                                     (make-binding:form #"input_2" #"6")
+                                     (make-binding:form #"input_3" #"10")
+                                     (make-binding:form #"input_4" #"8"))
+                               #f "127.0.0.1" 80 "127.0.0.1"))
+
+(require web-server/formlets/servlet)
+
+(define (start request)
+  (display-itinernary
+   (send/formlet
+    travel-formlet)))
+

collects/web-server/formlets/formlets.ss

@@ -0,0 +1,52 @@
+#lang scheme
+(require (for-syntax scheme)
+         "lib.ss"
+         (for-syntax "lib.ss"))
+
+(define-for-syntax (cross-of stx)
+  (syntax-case stx (unquote unquote-splicing => #%#)
+    [s (string? (syntax->datum #'s))
+       (syntax/loc stx empty)]
+    [,(formlet . => . name) (syntax/loc stx name)]
+    [,e (syntax/loc stx empty)]
+    [,@e (syntax/loc stx empty)]
+    [(#%# n ...)
+     (quasisyntax/loc stx (list #,@(map cross-of (syntax->list #'(n ...)))))]
+    [(t ([k v] ...) n ...)
+     (quasisyntax/loc stx (list #,@(map cross-of (syntax->list #'(n ...)))))]
+    [(t n ...)
+     (quasisyntax/loc stx (list #,@(map cross-of (syntax->list #'(n ...)))))]))
+
+(define-for-syntax (circ-of stx)
+  (syntax-case stx (unquote unquote-splicing => #%#)
+    [s (string? (syntax->datum #'s))
+       (syntax/loc stx (text s))]
+    [,(formlet . => . name) (syntax/loc stx formlet)]
+    [,e (syntax/loc stx (xml e))]
+    [,@e (syntax/loc stx (xml-forest e))]
+    [(#%# n ...)
+     (let ([n-cross (map cross-of (syntax->list #'(n ...)))])
+       (quasisyntax/loc stx
+         (cross*
+          (pure (match-lambda*
+                  [(list #,@n-cross)
+                   (list #,@n-cross)]))
+          #,@(map circ-of (syntax->list #'(n ...))))))]
+    [(t ([k v] ...) n ...)
+     (quasisyntax/loc stx
+       (tag-xexpr 't '([k v] ...)
+                 #,(circ-of (syntax/loc stx (#%# n ...)))))]
+    [(t n ...)
+     (quasisyntax/loc stx
+       (tag-xexpr 't empty
+                 #,(circ-of (syntax/loc stx (#%# n ...)))))]))
+
+(define-syntax (formlet stx)
+  (syntax-case stx ()
+    [(_ q e)
+     (quasisyntax/loc stx
+       (cross (pure (match-lambda [#,(cross-of #'q) e]))
+              #,(circ-of #'q)))]))
+
+(provide (all-defined-out)
+         (all-from-out "lib.ss"))

collects/web-server/formlets/lib.ss

@@ -0,0 +1,126 @@
+#lang scheme
+(require web-server/private/request-structs
+         xml)
+
+; Combinators
+(define (const x) (lambda _ x))
+(define (id x) x)
+
+; Formlets
+(define (pure x)
+  (lambda (i)
+    (values empty (const x) i)))
+
+(define (cross f p)
+  (lambda (i)
+    (let*-values ([(x1 g i) (f i)]
+                  [(x2 q i) (p i)])
+      (values (append x1 x2)
+              (lambda (env)
+                (let ([ge (g env)]
+                      [qe (q env)])
+                  (ge qe)))
+              i))))
+
+;; This is gross because OCaml auto-curries
+(define (cross* f . gs)
+  (lambda (i)
+    (let*-values ([(fx fp fi) (f i)]
+                  [(gs-x gs-p gs-i)
+                   (let loop ([gs gs]
+                              [xs empty]
+                              [ps empty]
+                              [i fi])
+                     (if (empty? gs)
+                         (values (reverse xs) (reverse ps) i)
+                         (let-values ([(gx gp gi) ((first gs) i)])
+                           (loop (rest gs) (list* gx xs) (list* gp ps) gi))))])
+      (values (apply append fx gs-x)
+              (lambda (env)
+                (let ([fe (fp env)]
+                      [gs-e (map (lambda (g) (g env)) gs-p)])
+                  (apply fe gs-e)))
+              gs-i))))
+
+(define (xml x)
+  (lambda (i)
+    (values (list x) (const id) i)))
+
+(define (xml-forest x)
+  (lambda (i)
+    (values x (const id) i)))
+
+(define (text x)
+  (xml x))
+
+(define (tag-xexpr t ats f)
+  (lambda (i)
+    (let-values ([(x p i) (f i)])
+      (values (list (list* t ats x))  p i))))
+
+(define (next-name i)
+  (values (format "input_~a" i) (add1 i)))
+(define (input i)
+  (let-values ([(w i) (next-name i)])
+    (values (list `(input ([name ,w])))
+            (lambda (env) (bindings-assq (string->bytes/utf-8 w) env))
+            i)))
+
+; Helpers
+(define (formlet-display f)
+  (let-values ([(x p i) (f 0)])
+    x))
+
+(define (formlet-process f r)
+  (let-values ([(x p i) (f 0)])
+    (p (request-bindings/raw r))))
+
+; Input Formlets
+(define input-string
+  (cross 
+   (pure (lambda (bf)
+           (bytes->string/utf-8 (binding:form-value bf))))
+   input))
+         
+(define input-int
+  (cross
+   (pure string->number)
+   input-string))
+
+(define input-symbol
+  (cross
+   (pure string->symbol)
+   input-string))
+
+; Contracts
+(define xexpr-forest/c
+  (listof xexpr?))
+
+(define (formlet/c c)
+  (integer? . -> . 
+            (values xexpr-forest/c
+                    ((listof binding?) . -> . (coerce-contract 'formlet/c c))
+                    integer?)))
+
+(define alpha any/c)
+(define beta any/c)
+
+(provide/contract
+ [formlet/c (any/c . -> . contract?)]
+ [pure (alpha
+        . -> . (formlet/c alpha))]
+ [cross ((formlet/c (alpha . -> . beta))
+         (formlet/c alpha)
+         . -> . (formlet/c beta))]
+ [cross* (((formlet/c (() () #:rest (listof alpha) . ->* . beta)))
+          () #:rest (listof (formlet/c alpha))
+          . ->* . (formlet/c beta))]
+ [xml (xexpr? . -> . (formlet/c procedure?))]
+ [xml-forest (xexpr-forest/c . -> . (formlet/c procedure?))]
+ [text (string? . -> . (formlet/c procedure?))]
+ [tag-xexpr (symbol? (listof (list/c symbol? string?)) (formlet/c alpha) . -> . (formlet/c alpha))]
+ [input-string (formlet/c string?)]
+ [input-int (formlet/c integer?)]
+ [input-symbol (formlet/c symbol?)]
+ [formlet-display ((formlet/c alpha) . -> . xexpr-forest/c)]
+ [formlet-process ((formlet/c alpha) request? . -> . alpha)])

collects/web-server/formlets/servlet.ss

@@ -0,0 +1,24 @@
+#lang scheme
+(require web-server/servlet
+         xml
+         "lib.ss")
+
+(provide/contract
+ [send/formlet ((formlet/c any/c) . -> . any/c)])
+
+(define (send/formlet f)
+  (formlet-process 
+   f
+   (send/suspend
+    (lambda (k-url)
+      `(form ([action ,k-url])
+             ,@(formlet-display f))))))
+
+(provide/contract
+ [embed-formlet (embed/url/c (formlet/c any/c) . -> . xexpr?)])
+
+(define (embed-formlet embed/url f)
+  `(form ([action ,(embed/url
+                    (lambda (r)
+                      (formlet-process f r)))])
+         ,@(formlet-display f)))

src/mzscheme/include/mzscheme3m.exp

@@ -202,7 +202,6 @@ GC_resolve
 GC_mark
 GC_fixup
 GC_fixup_self
-GC_resolve
 scheme_malloc_immobile_box
 scheme_free_immobile_box
 scheme_make_bucket_table

src/mzscheme/include/mzwin3m.def

@@ -194,7 +194,6 @@ EXPORTS
  GC_mark
  GC_fixup
  GC_fixup_self
- GC_resolve
  scheme_malloc_immobile_box
  scheme_free_immobile_box
  scheme_make_bucket_table

src/mzscheme/src/schemef.h

@@ -397,7 +397,6 @@ MZ_EXTERN void *GC_resolve(void *p);
 MZ_EXTERN void GC_mark(const void *p);
 MZ_EXTERN void GC_fixup(void *p);
 MZ_EXTERN void *GC_fixup_self(void *p);
-MZ_EXTERN void *GC_resolve(void *p);
 #endif
 
 MZ_EXTERN void **scheme_malloc_immobile_box(void *p);

src/mzscheme/src/schemex.h

@@ -323,7 +323,6 @@ void *(*GC_resolve)(void *p);
 void (*GC_mark)(const void *p);
 void (*GC_fixup)(void *p);
 void *(*GC_fixup_self)(void *p);
-void *(*GC_resolve)(void *p);
 #endif
 void **(*scheme_malloc_immobile_box)(void *p);
 void (*scheme_free_immobile_box)(void **b);

src/mzscheme/src/schemex.inc

@@ -222,7 +222,6 @@
   scheme_extension_table->GC_mark = GC_mark;
   scheme_extension_table->GC_fixup = GC_fixup;
   scheme_extension_table->GC_fixup_self = GC_fixup_self;
-  scheme_extension_table->GC_resolve = GC_resolve;
 #endif
   scheme_extension_table->scheme_malloc_immobile_box = scheme_malloc_immobile_box;
   scheme_extension_table->scheme_free_immobile_box = scheme_free_immobile_box;

src/mzscheme/src/schemexm.h

@@ -222,7 +222,6 @@
 #define GC_mark (scheme_extension_table->GC_mark)
 #define GC_fixup (scheme_extension_table->GC_fixup)
 #define GC_fixup_self (scheme_extension_table->GC_fixup_self)
-#define GC_resolve (scheme_extension_table->GC_resolve)
 #endif
 #define scheme_malloc_immobile_box (scheme_extension_table->scheme_malloc_immobile_box)
 #define scheme_free_immobile_box (scheme_extension_table->scheme_free_immobile_box)