I already know the feature
it's the part that makes your code implode I don't know what makes your code implode but that's the way that mzscheme is Yeah! You're all gonna be in this experimental branch and even though I can't explain it I already know how great it is svn: r11799
This commit is contained in:
commit
3a0e996414
|
@ -395,7 +395,8 @@ This directory contains the following files and sub-directories:
|
|||
"course-staff@university.edu"
|
||||
(format "[server] ~a (~a)" what session)
|
||||
'("course-staff@university.edu") '() '()
|
||||
(map (lambda (key+val) (apply format "~a: ~s" key+val))
|
||||
(map (lambda (key+val)
|
||||
(apply format "~a: ~s" key+val))
|
||||
alist))))]}}}
|
||||
|
||||
Changes to @filepath{config.ss} are detected, the file will be
|
||||
|
@ -416,14 +417,14 @@ This directory contains the following files and sub-directories:
|
|||
(actually the MD5 hash of the password), and extra string fields as
|
||||
specified by the 'extra-fields configuration entry (in the same
|
||||
order). The file format is
|
||||
@schemeblock{
|
||||
@schemeblock[
|
||||
((<username-sym> (<pw-md5-str> <extra-field> ...))
|
||||
...)}
|
||||
...)]
|
||||
|
||||
For example, the default @scheme['extra-field] setting will make this:
|
||||
@schemeblock{
|
||||
@schemeblock[
|
||||
((<username-sym> (<pw-md5-str> <full-name> <id> <email>))
|
||||
...)}
|
||||
...)]
|
||||
|
||||
Usernames that begin with ``solution'' are special. They are used
|
||||
by the HTTPS status server. Independent of the
|
||||
|
|
|
@ -4,40 +4,40 @@ import geometry.*;
|
|||
import colors.*;
|
||||
|
||||
public class SillyCanvas extends Canvas {
|
||||
private int x = 20;
|
||||
private int y = 20;
|
||||
|
||||
private boolean warning() {
|
||||
return super.drawString(new Posn(x,y),"This is a Dummy Canvas.");
|
||||
}
|
||||
|
||||
SillyCanvas(int w, int h) {
|
||||
super(w,h);
|
||||
if ((w < x) || (h < y))
|
||||
throw new RuntimeException("SillyCanvas: bad size");
|
||||
}
|
||||
|
||||
public boolean drawCircle(Posn p, int r, IColor c) {
|
||||
return super.drawCircle(p,r,c) && warning();
|
||||
}
|
||||
|
||||
public boolean drawDisk(Posn p, int r, IColor c) {
|
||||
return super.drawDisk(p,r,c) && warning();
|
||||
}
|
||||
|
||||
public boolean drawRect(Posn p, int width, int height, IColor c) {
|
||||
return super.drawRect(p,width,height,c) && warning();
|
||||
}
|
||||
|
||||
public boolean drawLine(Posn p0, Posn p1, IColor c) {
|
||||
return super.drawLine(p0,p1,c) && warning();
|
||||
}
|
||||
|
||||
public boolean drawString(Posn p, String s) {
|
||||
return super.drawString(p,s) && warning();
|
||||
}
|
||||
|
||||
public boolean show() {
|
||||
return super.show() && warning();
|
||||
}
|
||||
private int x = 20;
|
||||
private int y = 20;
|
||||
|
||||
private boolean warning() {
|
||||
return super.drawString(new Posn(x,y),"This is a Dummy Canvas.");
|
||||
}
|
||||
|
||||
SillyCanvas(int w, int h) {
|
||||
super(w,h);
|
||||
if ((w < x) || (h < y))
|
||||
throw new RuntimeException("SillyCanvas: bad size");
|
||||
}
|
||||
|
||||
public boolean drawCircle(Posn p, int r, IColor c) {
|
||||
return super.drawCircle(p,r,c) && warning();
|
||||
}
|
||||
|
||||
public boolean drawDisk(Posn p, int r, IColor c) {
|
||||
return super.drawDisk(p,r,c) && warning();
|
||||
}
|
||||
|
||||
public boolean drawRect(Posn p, int width, int height, IColor c) {
|
||||
return super.drawRect(p,width,height,c) && warning();
|
||||
}
|
||||
|
||||
public boolean drawLine(Posn p0, Posn p1, IColor c) {
|
||||
return super.drawLine(p0,p1,c) && warning();
|
||||
}
|
||||
|
||||
public boolean drawString(Posn p, String s) {
|
||||
return super.drawString(p,s) && warning();
|
||||
}
|
||||
|
||||
public boolean show() {
|
||||
return super.show() && warning();
|
||||
}
|
||||
}
|
||||
|
|
|
@ -93,12 +93,12 @@
|
|||
(let ((names (compilation-unit-contains dependents))
|
||||
(syntaxes (compilation-unit-code dependents))
|
||||
(locations (compilation-unit-locations dependents)))
|
||||
;(print-struct #t)
|
||||
;(printf "names ~a~n" names)
|
||||
;(printf "depends ~a~n~n" (compilation-unit-depends dependents))
|
||||
(print-struct #t)
|
||||
#;(printf "names ~a~n" names)
|
||||
#;(printf "depends ~a~n~n" (compilation-unit-depends dependents))
|
||||
(unless (= (length names) (length syntaxes))
|
||||
;(printf "Writing a composite file out~n")
|
||||
;(printf "~a~n~n" (syntax-object->datum (car syntaxes)))
|
||||
#;(printf "Writing a composite file out~n")
|
||||
#;(printf "~a~n~n" (syntax->datum (car syntaxes)))
|
||||
(call-with-output-zo-file* location
|
||||
(build-path (send type-recs get-compilation-location)
|
||||
(file-name-from-path
|
||||
|
@ -108,7 +108,8 @@
|
|||
(unless (= (length names) (length syntaxes) (length locations))
|
||||
(error 'compile-to-file "Internal error: compilation unit not represented as expected"))
|
||||
(for-each (lambda (name code location)
|
||||
;(printf "~a~n~n" (syntax-object->datum code))
|
||||
#;(printf "writing out ~a~n" name)
|
||||
#;(printf "~a~n~n" (syntax->datum code))
|
||||
(send type-recs set-location! location)
|
||||
(let ((directory (send type-recs get-compilation-location)))
|
||||
(unless (directory-exists? directory) (make-directory directory))
|
||||
|
|
|
@ -863,8 +863,10 @@
|
|||
(lambda (input)
|
||||
(and (= (length input) type-length)
|
||||
(equal? type-version (list-ref input 9))
|
||||
(or (equal? (version) (list-ref input 10))
|
||||
(equal? "ignore" (list-ref input 10)))
|
||||
(or (equal? "ignore" (list-ref input 10))
|
||||
(and (equal? (version) (list-ref input 10))
|
||||
(>= (file-or-directory-modify-seconds (build-path filename))
|
||||
(file-or-directory-modify-seconds (build-path (collection-path "mzlib") "contract.ss")))))
|
||||
(make-class-record (list-ref input 1)
|
||||
(list-ref input 2)
|
||||
(symbol=? 'class (car input))
|
||||
|
@ -904,7 +906,10 @@
|
|||
(make-array-type (parse-type (cadr input)) (car input)))
|
||||
(else
|
||||
(make-ref-type (car input) (cdr input)))))))
|
||||
(parse-class/iface (call-with-input-file filename read))))
|
||||
#;(printf "~a ~a ~n" filename
|
||||
(>= (file-or-directory-modify-seconds (build-path filename))
|
||||
(file-or-directory-modify-seconds (build-path (collection-path "mzlib") "contract.ss"))))
|
||||
(parse-class/iface (call-with-input-file filename read))))
|
||||
|
||||
;; write-record: class-record port->
|
||||
(define (write-record rec port)
|
||||
|
|
|
@ -546,6 +546,9 @@
|
|||
'((..._1 . ..._3) (..._2 . ..._3) (..._4 . ..._3)))
|
||||
(test (hash-map (class-reassignments (parse-pattern '(x_1 ... x_1 ..._!_1 x_1 ..._1)))
|
||||
(λ (_ cls) cls))
|
||||
'(..._1 ..._1)))
|
||||
'(..._1 ..._1))
|
||||
(test-class-reassignments
|
||||
'((3 ..._1) ..._2 (4 ..._1) ..._3)
|
||||
'((..._2 . ..._3))))
|
||||
|
||||
(print-tests-passed 'rg-test.ss)
|
||||
|
|
|
@ -500,22 +500,28 @@ To do a better job of not generating programs with free variables,
|
|||
(if (and par (not (eq? chd par))) (recur par (hash-ref sets par #f)) chd)))
|
||||
|
||||
(let* ([last-contexts (make-hasheq)]
|
||||
[record-binder
|
||||
(λ (pat under assignments)
|
||||
(if (null? under)
|
||||
assignments
|
||||
(let ([last (hash-ref last-contexts pat #f)])
|
||||
(if last
|
||||
(foldl (λ (cur last asgns) (union cur last asgns)) assignments under last)
|
||||
(begin
|
||||
(hash-set! last-contexts pat under)
|
||||
assignments)))))]
|
||||
[assignments
|
||||
(let recur ([pat pattern] [under null] [assignments #hasheq()])
|
||||
(match pat
|
||||
;; `(name ,id ,sub-pat) not considered, since bindings introduced
|
||||
;; by name must be unique.
|
||||
[(and (? symbol?) (app symbol->string (regexp named-nt-rx)))
|
||||
(if (null? under)
|
||||
assignments
|
||||
(let ([last (hash-ref last-contexts pat #f)])
|
||||
(if last
|
||||
(foldl (λ (cur last asgns) (union cur last asgns)) assignments under last)
|
||||
(begin
|
||||
(hash-set! last-contexts pat under)
|
||||
assignments))))]
|
||||
[(struct ellipsis (_ sub-pat (struct class (cls)) _))
|
||||
(recur sub-pat (cons cls under) assignments)]
|
||||
(record-binder pat under assignments)]
|
||||
[(struct ellipsis (name sub-pat (struct class (cls)) _))
|
||||
(recur sub-pat (cons cls under)
|
||||
(if (and (symbol? name) (regexp-match named-ellipsis-rx (symbol->string name)))
|
||||
(record-binder name under assignments)
|
||||
assignments))]
|
||||
[(? list?)
|
||||
(foldl (λ (pat asgns) (recur pat under asgns)) assignments pat)]
|
||||
[_ assignments]))])
|
||||
|
|
|
@ -1 +1 @@
|
|||
#lang scheme/base (provide stamp) (define stamp "17sep2008")
|
||||
#lang scheme/base (provide stamp) (define stamp "18sep2008")
|
||||
|
|
|
@ -82,8 +82,8 @@
|
|||
(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"))
|
||||
(regexp-match? #rx"^i[0-9]+\\.ss$" ifile)))
|
||||
(define ofile (regexp-replace #rx"^i([0-9]+)\\..*$" ifile "o\\1.txt"))
|
||||
(define expected (call-with-input-file ofile
|
||||
(lambda (i) (read-bytes (file-size ofile) i))))
|
||||
(define o (open-output-bytes))
|
||||
|
|
11
collects/web-server/formlets.ss
Normal file
11
collects/web-server/formlets.ss
Normal file
|
@ -0,0 +1,11 @@
|
|||
#lang scheme
|
||||
(require web-server/formlets/syntax
|
||||
web-server/formlets/input
|
||||
web-server/formlets/servlet
|
||||
web-server/formlets/lib)
|
||||
(provide (all-from-out web-server/formlets/servlet)
|
||||
(all-from-out web-server/formlets/input)
|
||||
(all-from-out web-server/formlets/syntax)
|
||||
formlet/c
|
||||
formlet-display
|
||||
formlet-process)
|
|
@ -1,5 +1,5 @@
|
|||
#lang scheme
|
||||
(require web-server/formlets/formlets)
|
||||
(require web-server/formlets)
|
||||
|
||||
(define-struct date (month day))
|
||||
(define (date->xml d)
|
||||
|
@ -54,8 +54,6 @@
|
|||
(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
|
||||
|
|
32
collects/web-server/formlets/input.ss
Normal file
32
collects/web-server/formlets/input.ss
Normal file
|
@ -0,0 +1,32 @@
|
|||
#lang scheme
|
||||
(require web-server/private/request-structs
|
||||
"lib.ss")
|
||||
|
||||
(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)))
|
||||
|
||||
(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))
|
||||
|
||||
(provide/contract
|
||||
[input-string (formlet/c string?)]
|
||||
[input-int (formlet/c integer?)]
|
||||
[input-symbol (formlet/c symbol?)])
|
|
@ -58,14 +58,6 @@
|
|||
(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)])
|
||||
|
@ -75,23 +67,6 @@
|
|||
(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?))
|
||||
|
@ -119,8 +94,5 @@
|
|||
[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)])
|
|
@ -48,5 +48,4 @@
|
|||
(cross (pure (match-lambda [#,(cross-of #'q) e]))
|
||||
#,(circ-of #'q)))]))
|
||||
|
||||
(provide (all-defined-out)
|
||||
(all-from-out "lib.ss"))
|
||||
(provide formlet)
|
Loading…
Reference in New Issue
Block a user