suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

I've been working on the model

Browse Source 
all the live long day
I've been working on the model
just to pass the time away

svn: r11863
This commit is contained in:
Stevie Strickland 2008-09-25 03:25:14 +00:00
commit 6fe4471733
18 changed files with 661 additions and 590 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/handin-server/checker.ss
View File

@ -180,10 +180,10 @@
(let-values ([(defs inters) (unpack-submission submission)])
(parameterize ([current-input-port
(if textualize?
(input-port->text-input-port (open-input-text-editor
defs 0 'end snip->text))
(input-port->text-input-port
(open-input-text-editor defs 0 'end snip->text))
(open-input-text-editor defs))]
[current-output-port (open-output-string)])
[current-output-port (open-output-bytes)])
(input->process->output maxwidth textualize? untabify? bad-re)
(get-output-bytes (current-output-port)))))
@ -345,14 +345,15 @@
[keyvals '()]
[got null])
(define (get key . default)
(cond [(assq key keyvals) => (lambda (x) (set! got (cons x got)) (caddr x))]
(cond [(assq key keyvals)
=> (lambda (x) (set! got (cons x got)) (caddr x))]
[(pair? default) (car default)]
[else #f]))
(syntax-case stx ()
[(key val x ...)
(and (identifier? #'key)
(regexp-match? #rx"^:" (symbol->string (syntax-e #'key))))
(loop #'(x ...)
(loop #'(x ...)
(cons (list (syntax-e #'key) #'key #'val) keyvals)
(cons (syntax-e #'key) got))]
[(body ...)

65
collects/handin-server/scribblings/checker.scrbl
View File

@ -1,6 +1,9 @@
#lang scribble/doc
@(require "common.ss")
@define[textoption]{(Effective only when saving a textual version of
the submission files: when @scheme[:create-text?] is on.)}
@title{checker}
@defmodulelang[handin-server/checker]{
@ -28,10 +31,15 @@ language module---a typical checker that uses it looks like this:
(code:line :key val keys-n-vals)])]{
Constructs (and provides) an appropriate checker function, using
keywords for features that you want, the body of the checker can
contain arbitrary code, using all utilities from
@schememodname[handin-server/utils], as well as additional ones (see
below).}
keywords to customize features that you want it to have. The body of
the checker (following the keywords) can contain arbitrary code, using
utility functions from @schememodname[handin-server/utils], as well as
additional ones that are defined below. Submission files are arriving
to the handin server in binary form (in the MrEd format that is used
to store text and other objects like images), and a number of these
options involve genrating a textual version of this file. The purpose
of these options is to have these text files integrate easily into a
course framework for grading, based on these text files.}
Keywords for configuring @scheme[check:]:
@ -71,29 +79,47 @@ Keywords for configuring @scheme[check:]:
printouts and grading, and is in a subdirectory so students will not
see it on the status web server. Defaults to @scheme[#t].}
@item{@indexed-scheme[:textualize?]---if true, then all submissions
are converted to text, trying to convert objects like images and
comment boxes to some form of text. Defaults to @scheme[#f],
meaning that an exception is raised for submissions that are not all
text. @textoption
This flag is effective only when saving a textual version of the
submission files --- when @scheme[:create-text?] is on. The
possible configurations are:
@itemize[
@item{@scheme[:create-text?] is on and @scheme[:textualize?] is off
(the default) --- in this case a text version of submissions is
created, and submissions must contain only plain text. The text
file has the same semantics of the submission and can be used to
run student code.}
@item{@scheme[:create-text?] is off --- allowing submissions that
contain non-textual objects, but no text file is created so
grading and testing must be done using DrScheme (because the saved
submission is always in binary format).}
@item{Both flags are on --- allowing submission with non-textual
objects and generating text files, but these files will not be
usable as code since objects like images cannot be represented in
plain text.}]}
@item{@indexed-scheme[:untabify?]---if true, then tabs are converted
to spaces, assuming a standard tab width of 8 places. This is
needed for a correct computation of line lengths, but note that
DrScheme does not insert tabs in Scheme mode. Defaults to
@scheme[#t].}
@item{@indexed-scheme[:textualize?]---if true, then all submissions
are converted to text, trying to convert objects like comment boxes
and test cases to some form of text. Defaults to @scheme[#f],
meaning that an exception is raised for submissions that are not all
text.}
@scheme[#t]. @textoption}
@item{@indexed-scheme[:maxwidth]---a number that specifies maximum
line lengths for submissions (a helpful feature for reading student
code). Defaults to 79. This feature can be disabled if set to
@scheme[#f]. (This is effective only when saving a textual version
of the submission files.)}
@scheme[#f]. @textoption}
@item{@indexed-scheme[:output]---the name of the original handin file
(unrelated to the text-converted files). Defaults to
@filepath{hw.scm}. (The suffix changes the defaults of
@scheme[:markup-prefix] and @scheme[:prefix-re].) Can be
@scheme[#f] for removing the original file after processing.}
@scheme[#f] for removing the original file after processing. The
file is always stored in MrEd's binary format.}
@item{@indexed-scheme[:multi-file]---by default, this is set to
@scheme[#f], which means that only DrScheme is used to send
@ -106,13 +132,14 @@ Keywords for configuring @scheme[check:]:
@item{@indexed-scheme[:markup-prefix]---used as the prefix for
@scheme[:student-lines] and @scheme[:extra-lines] below. The
default is @scheme[";;> "] or @scheme["//> "], depending on the
suffix of @scheme[:output] above. (Note: if you change this, make
sure to change @scheme[:prefix-re] too.)}
suffix of @scheme[:output] above. Note: if you change this, make
sure to change @scheme[:prefix-re] too. @textoption}
@item{@indexed-scheme[:prefix-re]---used to identify lines with markup
(@scheme[";>"] or @scheme["//>"] etc), so students cannot fool the
system by writing marked-up code. The default is @scheme[";>"] or
@scheme["//>"], depending on the suffix of :output above.}
@scheme["//>"], depending on the suffix of :output above.
@textoption}
@item{@indexed-scheme[:student-line]---when a submission is converted
to text, it begins with lines describing the students that have
@ -122,14 +149,14 @@ Keywords for configuring @scheme[check:]:
which requires @scheme["Full Name"] and @scheme["Email"] entries in
the server's extra-fields configuration. These lines are prefixed
with @scheme[";;> "] or the prefix specified by
@scheme[:makup-prefix] above.}
@scheme[:makup-prefix] above. @textoption}
@item{@indexed-scheme[:extra-lines]---a list of lines to add after the
student lines, all with a @scheme[";;> "] or :markup-prefix too.
Defaults to a single line:
@scheme["Maximum points for this assignment: <+100>"]. (Can use
@scheme["{submission}"] for the submission directory.) See also
@scheme[add-header-line!].}
@scheme[add-header-line!]. @textoption}
@item{@indexed-scheme[:user-error-message]---a string that is used to
report an error that occurred during evaluation of the submitted

2
collects/handin-server/scribblings/quick-start.scrbl
View File

@ -29,7 +29,7 @@
@schemeblock[((active-dirs ("test"))
(https-port-number 9780))]}
@item{In your new directory, run @commandline{mred -l handin-server}}
@item{In your new directory, run @commandline{mred-text -l handin-server}}
@item{In the @filepath{handin-client} collection, edit
@filepath{info.ss} and uncomment the lines that define

2
collects/handin-server/utils.ss
View File

@ -167,7 +167,7 @@
(eq? lang 'beginner-abbr)))])
(reraise-exn-as-submission-problem
(lambda ()
(let ([e (make-evaluator lang teachpacks program-port)])
(let ([e (make-evaluator lang #:requires teachpacks program-port)])
(set-run-status "executing your code")
(go e))))))

1
collects/mzlib/pconvert.ss
View File

@ -363,6 +363,7 @@
`(,(recur k) ,(recur v)))))]
[(vector? expr) `(vector ,@(map recur (vector->list expr)))]
[(symbol? expr) `',expr]
[(keyword? expr) `',expr]
[(string? expr) expr]
[(primitive? expr) (object-name expr)]
[(procedure? expr)

2
collects/repos-time-stamp/stamp.ss
View File

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

2
collects/scribble/text/syntax-utils.ss
View File

@ -163,7 +163,7 @@
(define-syntax (begin/text stx)
(syntax-case stx ()
[(begin/text expr ...)
#'(process-begin/text begin/collect values expr ...)]))
#'(process-begin/text begin/collect begin expr ...)]))
;; include for templates
(require (for-syntax scheme/base (prefix-in scribble: "../reader.ss"))

2
collects/tests/typed-scheme/fail/back-and-forth.ss
View File

@ -1,5 +1,5 @@
#;
(exn-pred exn:fail:contract? #rx".*contract \\(-> number\\? number\\?\\).*")
(exn-pred exn:fail:contract? #rx".*contract.*\\(-> number\\? number\\?\\).*")
#lang scheme/load

2
collects/tests/typed-scheme/fail/cnt-err1.ss
View File

@ -1,5 +1,5 @@
#;
(exn-pred exn:fail:contract? ".*expected <T.*" #rx".*contract \\(->.*")
(exn-pred exn:fail:contract? ".*expected <T.*" #rx".*contract.*\\(->.*")
#lang scheme/load

3
collects/tests/typed-scheme/main.ss
View File

@ -55,8 +55,7 @@
(parameterize ([read-accept-reader #t]
[current-load-relative-directory path]
[current-directory path])
(with-output-to-file "/dev/null" #:exists 'append
(lambda () (loader p)))))))))
(loader p)))))))
(apply test-suite dir
tests)))

8
collects/tests/typed-scheme/succeed/kw.ss Normal file
View File

@ -0,0 +1,8 @@
#lang typed-scheme
(lambda ()
(open-input-file "foo" #:mode 'binary)
(open-input-file "foo" #:mode 'text)
(open-input-file "foo"))

4
collects/typed-scheme/main.ss
View File

@ -1,10 +1,12 @@
#lang s-exp "minimal.ss"
(providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app)
(except "private/prims.ss"))
(basics #%module-begin
#%top-interaction
lambda
#%app))
(require "private/base-env.ss" "private/base-special-env.ss")
(provide (rename-out [with-handlers: with-handlers]))

2
collects/typed-scheme/minimal.ss
View File

@ -5,7 +5,7 @@
(require (for-syntax scheme/base))
(define-for-syntax ts-mod "typed-scheme.ss")
(define-for-syntax ts-mod 'typed-scheme/typed-scheme)
(define-syntax (providing stx)
(syntax-case stx (libs from basics except)

1017
collects/typed-scheme/private/base-env.ss
View File

File diff suppressed because it is too large Load Diff

83
collects/typed-scheme/private/base-special-env.ss Normal file
View File

@ -0,0 +1,83 @@
#lang scheme/base
;; these are libraries providing functions we add types to that are not in scheme/base
(require
"extra-procs.ss"
"../utils/utils.ss"
(only-in scheme/list cons? take drop add-between last filter-map)
(only-in rnrs/lists-6 fold-left)
'#%paramz
(only-in scheme/match/runtime match:error)
scheme/promise
string-constants/string-constant)
;; these are all for constructing the types given to variables
(require (for-syntax
scheme/base
(env init-envs)
(except-in (rep effect-rep type-rep) make-arr)
"type-effect-convenience.ss"
(only-in "type-effect-convenience.ss" [make-arr* make-arr])
"union.ss"
(typecheck tc-structs)))
(define-for-syntax (initialize-others)
(d-s date
([second : N] [minute : N] [hour : N] [day : N] [month : N]
[year : N] [weekday : N] [year-day : N] [dst? : B] [time-zone-offset : N])
())
(d-s exn ([message : -String] [continuation-marks : Univ]) ())
(d-s (exn:fail exn) () (-String Univ))
(d-s (exn:fail:read exn:fail) ([srclocs : (-lst Univ)]) (-String Univ))
)
(provide (for-syntax initial-env/special-case initialize-others initialize-type-env)
define-initial-env)
(define-syntax (define-initial-env stx)
(syntax-case stx ()
[(_ initial-env make-promise-ty language-ty qq-append-ty [id ty] ...)
(with-syntax ([(_ make-promise . _)
(local-expand #'(delay 3)
'expression
null)]
[language
(local-expand #'(this-language)
'expression
null)]
[(_ qq-append . _)
(local-expand #'`(,@'() 1)
'expression
null)])
#`(define-for-syntax initial-env
(make-env
[make-promise make-promise-ty]
[language language-ty]
[qq-append qq-append-ty]
[id ty] ...)))]))
(define-initial-env initial-env/special-case
;; make-promise
(-poly (a) (-> (-> a) (-Promise a)))
;; language
Sym
;; qq-append
(-poly (a b)
(cl->*
(-> (-lst a) (-val '()) (-lst a))
(-> (-lst a) (-lst b) (-lst (*Un a b))))))
(begin-for-syntax
(initialize-type-env initial-env/special-case)
(initialize-others))

34
collects/typed-scheme/private/env-lang.ss Normal file
View File

@ -0,0 +1,34 @@
#lang scheme/base
(require "../utils/utils.ss")
(require (for-syntax (private type-effect-convenience)
(env init-envs)
scheme/base
(except-in (rep effect-rep type-rep) make-arr)
"type-effect-convenience.ss"
(only-in "type-effect-convenience.ss" [make-arr* make-arr])
"union.ss"))
(define-syntax (#%module-begin stx)
(syntax-case stx (require)
[(mb (require . args) [id ty] ...)
(begin
(unless (andmap identifier? (syntax->list #'(id ...)))
(raise-syntax-error #f "not all ids"))
#'(#%plain-module-begin
(begin
(require . args)
(define-for-syntax e
(make-env [id ty] ...))
(begin-for-syntax
(initialize-type-env e)))))]
[(mb . rest)
#'(mb (require) . rest)]))
(provide #%module-begin
require
(all-from-out scheme/base)
(for-syntax
(all-from-out scheme/base
"type-effect-convenience.ss"
"union.ss")))

9
collects/typed-scheme/private/type-effect-convenience.ss
View File

@ -13,7 +13,12 @@
(for-syntax macro-debugger/stxclass/stxclass)
(for-syntax scheme/base))
(provide (all-defined-out))
(provide (all-defined-out)
;; these should all eventually go away
make-Name make-ValuesDots make-Function make-top-arr make-Latent-Restrict-Effect make-Latent-Remove-Effect)
(define (one-of/c . args)
(apply Un (map -val args)))
(define (-vet id) (make-Var-True-Effect id))
(define (-vef id) (make-Var-False-Effect id))
@ -206,6 +211,8 @@
(define (-Tuple l)
(foldr -pair (-val '()) l))
(define -box make-Box)
(define -vec make-Vector)
(define Any-Syntax
(-mu x

2
collects/typed-scheme/typed-scheme.ss
View File

@ -2,7 +2,7 @@
(require (rename-in "utils/utils.ss" [infer r:infer]))
(require (private base-env base-types)
(require (private #;base-env base-types)
(for-syntax
scheme/base
(private type-utils type-contract type-effect-convenience)