improved running time of contracts and moved some provide/contracts to the bottom of files (not necc yet, but may become necc)
svn: r3665
This commit is contained in:
Robby Findler
parent
eb5963905c
commit
49667529da
|
|
@ -11,242 +11,6 @@
|
|||
[(_ (name contract docs ...) ...)
|
||||
(syntax (provide/contract (name contract) ...))]))
|
||||
|
||||
(provide/contract/docs
|
||||
|
||||
(gui-utils:trim-string
|
||||
(string?
|
||||
(and/c number? positive?)
|
||||
. ->d .
|
||||
(λ (str size)
|
||||
(and/c string?
|
||||
(λ (str)
|
||||
((string-length str) . <= . size)))))
|
||||
(str size)
|
||||
"Constructs a string whose size is less"
|
||||
"than \\var{size} by trimming the \\var{str}"
|
||||
"and inserting an ellispses into it.")
|
||||
|
||||
(gui-utils:cancel-on-right?
|
||||
(-> boolean?)
|
||||
()
|
||||
"Returns \\scheme{#t} if cancel should be on the right-hand side (or below)"
|
||||
"in a dialog and \\scheme{#f} otherwise."
|
||||
""
|
||||
"See also"
|
||||
"@flink gui-utils:ok/cancel-buttons %"
|
||||
".")
|
||||
(gui-utils:ok/cancel-buttons
|
||||
(opt->*
|
||||
((is-a?/c area-container<%>)
|
||||
((is-a?/c button%) (is-a?/c event%) . -> . any)
|
||||
((is-a?/c button%) (is-a?/c event%) . -> . any))
|
||||
(string?
|
||||
string?)
|
||||
((is-a?/c button%)
|
||||
(is-a?/c button%)))
|
||||
((parent
|
||||
confirm-callback
|
||||
cancel-callback)
|
||||
((confirm-label (string-constant ok))
|
||||
(cancel-label (string-constant cancel))))
|
||||
"Adds an Ok and a cancel button to a panel, changing the order"
|
||||
"to suit the platform. Under \\MacOSBoth{} and unix, the confirmation action"
|
||||
"is on the right (or bottom) and under Windows, the canceling action is on the"
|
||||
"right (or bottom)."
|
||||
"The confirmation action button has the \\scheme|'(border)| style."
|
||||
"The buttons are also sized to be the same width."
|
||||
""
|
||||
"The first result is be the OK button and the second is"
|
||||
"the cancel button."
|
||||
""
|
||||
"See also"
|
||||
"@flink gui-utils:cancel-on-right? %"
|
||||
".")
|
||||
|
||||
(gui-utils:next-untitled-name
|
||||
(-> string?)
|
||||
()
|
||||
"Returns a name for the next opened untitled frame. The first"
|
||||
"name is ``Untitled'', the second is ``Untitled 2'',"
|
||||
"the third is ``Untitled 3'', and so forth.")
|
||||
(gui-utils:cursor-delay
|
||||
(case->
|
||||
(-> real?)
|
||||
(real? . -> . void?))
|
||||
(() (new-delay))
|
||||
"This function is {\\em not\\/} a parameter."
|
||||
"Instead, the state is just stored in the closure."
|
||||
""
|
||||
"The first case in the case lambda"
|
||||
"returns the current delay in seconds before a watch cursor is shown,"
|
||||
"when either \\iscmprocedure{gui-utils:local-busy-cursor} or"
|
||||
"\\iscmprocedure{gui-utils:show-busy-cursor} is called."
|
||||
|
||||
"The second case in the case lambda"
|
||||
"Sets the delay, in seconds, before a watch cursor is shown, when"
|
||||
"either \\iscmprocedure{gui-utils:local-busy-cursor} or"
|
||||
"\\iscmprocedure{gui-utils:show-busy-cursor} is called.")
|
||||
(gui-utils:show-busy-cursor
|
||||
(opt->
|
||||
((-> any/c))
|
||||
(integer?)
|
||||
any/c)
|
||||
((thunk)
|
||||
((delay (gui-utils:cursor-delay))))
|
||||
"Evaluates \\rawscm{(\\var{thunk})} with a watch cursor. The argument"
|
||||
"\\var{delay} specifies the amount of time before the watch cursor is"
|
||||
"opened. Use \\iscmprocedure{gui-utils:cursor-delay} to set this value"
|
||||
"to all calls."
|
||||
""
|
||||
"This function returns the result of \\var{thunk}.")
|
||||
(gui-utils:delay-action
|
||||
(real?
|
||||
(-> void?)
|
||||
(-> void?)
|
||||
. -> .
|
||||
void?)
|
||||
(delay-time open close)
|
||||
"Use this function to delay an action for some period of time. It also"
|
||||
"supports cancelling the action before the time period elapses. For"
|
||||
"example, if you want to display a watch cursor, but you only want it"
|
||||
"to appear after 2 seconds and the action may or may not take more than"
|
||||
"two seconds, use this pattern:"
|
||||
""
|
||||
"\\begin{schemedisplay}"
|
||||
"(let ([close-down"
|
||||
" (gui-utils:delay-action"
|
||||
" 2"
|
||||
" (λ () .. init watch cursor ...)"
|
||||
" (λ () .. close watch cursor ...))])"
|
||||
" ;; .. do action ..."
|
||||
" (close-down))"
|
||||
"\\end{schemedisplay}"
|
||||
""
|
||||
"Creates a thread that waits \\var{delay-time}. After \\var{delay-time}"
|
||||
"has elapsed, if the result thunk has {\\em not} been called, call"
|
||||
"\\var{open}. Then, when the result thunk is called, call"
|
||||
"\\var{close}. The function \\var{close} will only be called if"
|
||||
"\\var{open} has been called.")
|
||||
|
||||
(gui-utils:local-busy-cursor
|
||||
(opt->
|
||||
((is-a?/c window<%>)
|
||||
(-> any/c))
|
||||
(integer?)
|
||||
any/c)
|
||||
((window thunk)
|
||||
((delay (gui-utils:cursor-delay))))
|
||||
"Evaluates \\rawscm{(\\var{thunk})} with a watch cursor in \\var{window}. If"
|
||||
"\\var{window} is \\rawscm{\\#f}, the watch cursor is turned on globally. The"
|
||||
"argument \\var{delay} specifies the amount of time before the watch"
|
||||
"cursor is opened. Use "
|
||||
"@flink gui-utils:cursor-delay "
|
||||
"to set this value for all uses of this function."
|
||||
""
|
||||
"The result of this function is the result of \\var{thunk}.")
|
||||
|
||||
(gui-utils:unsaved-warning
|
||||
(opt->
|
||||
(string?
|
||||
string?)
|
||||
(boolean?
|
||||
(or/c false/c
|
||||
(is-a?/c frame%)
|
||||
(is-a?/c dialog%)))
|
||||
(symbols 'continue 'save 'cancel))
|
||||
((filename action)
|
||||
((can-save-now? #f)
|
||||
(parent #f)))
|
||||
|
||||
"This displays a dialog that warns the user of a unsaved file."
|
||||
""
|
||||
"The string, \\var{action}, indicates what action is about to"
|
||||
"take place, without saving. For example, if the application"
|
||||
"is about to close a file, a good action is \\rawscm{\"Close"
|
||||
"Anyway\"}. The result symbol indicates the user's choice. If"
|
||||
"\\var{can-save-now?} is \\rawscm{\\#f}, this function does not"
|
||||
"give the user the ``Save'' option and thus will not return"
|
||||
"\\rawscm{'save}.")
|
||||
|
||||
(gui-utils:get-choice
|
||||
(opt->
|
||||
(string?
|
||||
string?
|
||||
string?)
|
||||
(string?
|
||||
any/c
|
||||
(or/c false/c (is-a?/c frame%) (is-a?/c dialog%))
|
||||
(symbols 'app 'caution 'stop)
|
||||
(or/c false/c (case-> (boolean? . -> . void?)
|
||||
(-> boolean?)))
|
||||
string?)
|
||||
any/c)
|
||||
((message true-choice false-choice)
|
||||
((title (string-constant warning))
|
||||
(default-result 'disallow-close)
|
||||
(parent #f)
|
||||
(style 'app)
|
||||
(checkbox-proc #f)
|
||||
(checkbox-label (string-constant dont-ask-again))))
|
||||
|
||||
"Opens a dialog that presents a binary choice to the user. The user is forced"
|
||||
"to choose between these two options, ie cancelling or closing the dialog"
|
||||
"opens a message box asking the user to actually choose one of the two options."
|
||||
""
|
||||
"The dialog will contain the string \\var{message} and two buttons,"
|
||||
"labeled with the \\var{true-choice} and the \\var{false-choice}. If the"
|
||||
"user clicks on \\var{true-choice} \\rawscm{\\#t} is returned. If the user"
|
||||
"clicks on \\var{false-choice}, \\rawscm{\\#f} is returned."
|
||||
""
|
||||
"The argument \\var{default-result} determines how closing the window is"
|
||||
"treated. If the argument is \\rawscm{'disallow-close}, closing the window"
|
||||
"is not allowed. If it is anything else, that value is returned when"
|
||||
"the user closes the window."
|
||||
""
|
||||
"If "
|
||||
"@flink gui-utils:cancel-on-right?"
|
||||
"returns \\scheme|#t|, the false choice is on the right."
|
||||
"Otherwise, the true choice is on the right."
|
||||
""
|
||||
"The \\var{style} parameter is (eventually) passed to"
|
||||
"@link message"
|
||||
"as an icon in the dialog."
|
||||
""
|
||||
"If \\var{checkbox-proc} is given, it should be a procedure that behaves"
|
||||
"like a parameter for getting/setting a boolean value. The intention for"
|
||||
"this value is that it can be used to disable the dialog. When it is"
|
||||
"given, a checkbox will appear with a \\var{checkbox-label} label"
|
||||
"(defaults to the \\rawscm{dont-ask-again} string constant), and that"
|
||||
"checkbox value will be sent to the \\var{checkbox-proc} when the dialog"
|
||||
"is closed. Note that the dialog will always pop-up --- it is the"
|
||||
"caller's responsibility to avoid the dialog if not needed.")
|
||||
|
||||
(gui-utils:get-clicked-clickback-delta
|
||||
(-> (is-a?/c style-delta%))
|
||||
()
|
||||
"This delta is designed for use with"
|
||||
"@link text set-clickback %"
|
||||
". Use it as one of the \\iscmclass{style-delta} argument to"
|
||||
"@link text set-clickback %"
|
||||
"."
|
||||
""
|
||||
"See also"
|
||||
"@flink gui-utils:get-clickback-delta %"
|
||||
".")
|
||||
|
||||
(gui-utils:get-clickback-delta
|
||||
(-> (is-a?/c style-delta%))
|
||||
()
|
||||
"This delta is designed for use with"
|
||||
"@link text set-clickback %"
|
||||
". Use the result of this function as the style"
|
||||
"for the region"
|
||||
"text where the clickback is set."
|
||||
""
|
||||
"See also"
|
||||
"@flink gui-utils:get-clicked-clickback-delta %"
|
||||
"."))
|
||||
|
||||
(define (trim-string str size)
|
||||
(let ([str-size (string-length str)])
|
||||
(cond
|
||||
|
|
@ -497,4 +261,241 @@
|
|||
(define gui-utils:get-clickback-delta get-clickback-delta)
|
||||
(define gui-utils:ok/cancel-buttons ok/cancel-buttons)
|
||||
(define gui-utils:cancel-on-right? cancel-on-right?)
|
||||
(define gui-utils:cursor-delay cursor-delay))
|
||||
(define gui-utils:cursor-delay cursor-delay)
|
||||
|
||||
|
||||
(provide/contract/docs
|
||||
|
||||
(gui-utils:trim-string
|
||||
(string?
|
||||
(and/c number? positive?)
|
||||
. ->d .
|
||||
(λ (str size)
|
||||
(and/c string?
|
||||
(λ (str)
|
||||
((string-length str) . <= . size)))))
|
||||
(str size)
|
||||
"Constructs a string whose size is less"
|
||||
"than \\var{size} by trimming the \\var{str}"
|
||||
"and inserting an ellispses into it.")
|
||||
|
||||
(gui-utils:cancel-on-right?
|
||||
(-> boolean?)
|
||||
()
|
||||
"Returns \\scheme{#t} if cancel should be on the right-hand side (or below)"
|
||||
"in a dialog and \\scheme{#f} otherwise."
|
||||
""
|
||||
"See also"
|
||||
"@flink gui-utils:ok/cancel-buttons %"
|
||||
".")
|
||||
(gui-utils:ok/cancel-buttons
|
||||
(opt->*
|
||||
((is-a?/c area-container<%>)
|
||||
((is-a?/c button%) (is-a?/c event%) . -> . any)
|
||||
((is-a?/c button%) (is-a?/c event%) . -> . any))
|
||||
(string?
|
||||
string?)
|
||||
((is-a?/c button%)
|
||||
(is-a?/c button%)))
|
||||
((parent
|
||||
confirm-callback
|
||||
cancel-callback)
|
||||
((confirm-label (string-constant ok))
|
||||
(cancel-label (string-constant cancel))))
|
||||
"Adds an Ok and a cancel button to a panel, changing the order"
|
||||
"to suit the platform. Under \\MacOSBoth{} and unix, the confirmation action"
|
||||
"is on the right (or bottom) and under Windows, the canceling action is on the"
|
||||
"right (or bottom)."
|
||||
"The confirmation action button has the \\scheme|'(border)| style."
|
||||
"The buttons are also sized to be the same width."
|
||||
""
|
||||
"The first result is be the OK button and the second is"
|
||||
"the cancel button."
|
||||
""
|
||||
"See also"
|
||||
"@flink gui-utils:cancel-on-right? %"
|
||||
".")
|
||||
|
||||
(gui-utils:next-untitled-name
|
||||
(-> string?)
|
||||
()
|
||||
"Returns a name for the next opened untitled frame. The first"
|
||||
"name is ``Untitled'', the second is ``Untitled 2'',"
|
||||
"the third is ``Untitled 3'', and so forth.")
|
||||
(gui-utils:cursor-delay
|
||||
(case->
|
||||
(-> real?)
|
||||
(real? . -> . void?))
|
||||
(() (new-delay))
|
||||
"This function is {\\em not\\/} a parameter."
|
||||
"Instead, the state is just stored in the closure."
|
||||
""
|
||||
"The first case in the case lambda"
|
||||
"returns the current delay in seconds before a watch cursor is shown,"
|
||||
"when either \\iscmprocedure{gui-utils:local-busy-cursor} or"
|
||||
"\\iscmprocedure{gui-utils:show-busy-cursor} is called."
|
||||
|
||||
"The second case in the case lambda"
|
||||
"Sets the delay, in seconds, before a watch cursor is shown, when"
|
||||
"either \\iscmprocedure{gui-utils:local-busy-cursor} or"
|
||||
"\\iscmprocedure{gui-utils:show-busy-cursor} is called.")
|
||||
(gui-utils:show-busy-cursor
|
||||
(opt->
|
||||
((-> any/c))
|
||||
(integer?)
|
||||
any/c)
|
||||
((thunk)
|
||||
((delay (gui-utils:cursor-delay))))
|
||||
"Evaluates \\rawscm{(\\var{thunk})} with a watch cursor. The argument"
|
||||
"\\var{delay} specifies the amount of time before the watch cursor is"
|
||||
"opened. Use \\iscmprocedure{gui-utils:cursor-delay} to set this value"
|
||||
"to all calls."
|
||||
""
|
||||
"This function returns the result of \\var{thunk}.")
|
||||
(gui-utils:delay-action
|
||||
(real?
|
||||
(-> void?)
|
||||
(-> void?)
|
||||
. -> .
|
||||
void?)
|
||||
(delay-time open close)
|
||||
"Use this function to delay an action for some period of time. It also"
|
||||
"supports cancelling the action before the time period elapses. For"
|
||||
"example, if you want to display a watch cursor, but you only want it"
|
||||
"to appear after 2 seconds and the action may or may not take more than"
|
||||
"two seconds, use this pattern:"
|
||||
""
|
||||
"\\begin{schemedisplay}"
|
||||
"(let ([close-down"
|
||||
" (gui-utils:delay-action"
|
||||
" 2"
|
||||
" (λ () .. init watch cursor ...)"
|
||||
" (λ () .. close watch cursor ...))])"
|
||||
" ;; .. do action ..."
|
||||
" (close-down))"
|
||||
"\\end{schemedisplay}"
|
||||
""
|
||||
"Creates a thread that waits \\var{delay-time}. After \\var{delay-time}"
|
||||
"has elapsed, if the result thunk has {\\em not} been called, call"
|
||||
"\\var{open}. Then, when the result thunk is called, call"
|
||||
"\\var{close}. The function \\var{close} will only be called if"
|
||||
"\\var{open} has been called.")
|
||||
|
||||
(gui-utils:local-busy-cursor
|
||||
(opt->
|
||||
((is-a?/c window<%>)
|
||||
(-> any/c))
|
||||
(integer?)
|
||||
any/c)
|
||||
((window thunk)
|
||||
((delay (gui-utils:cursor-delay))))
|
||||
"Evaluates \\rawscm{(\\var{thunk})} with a watch cursor in \\var{window}. If"
|
||||
"\\var{window} is \\rawscm{\\#f}, the watch cursor is turned on globally. The"
|
||||
"argument \\var{delay} specifies the amount of time before the watch"
|
||||
"cursor is opened. Use "
|
||||
"@flink gui-utils:cursor-delay "
|
||||
"to set this value for all uses of this function."
|
||||
""
|
||||
"The result of this function is the result of \\var{thunk}.")
|
||||
|
||||
(gui-utils:unsaved-warning
|
||||
(opt->
|
||||
(string?
|
||||
string?)
|
||||
(boolean?
|
||||
(or/c false/c
|
||||
(is-a?/c frame%)
|
||||
(is-a?/c dialog%)))
|
||||
(symbols 'continue 'save 'cancel))
|
||||
((filename action)
|
||||
((can-save-now? #f)
|
||||
(parent #f)))
|
||||
|
||||
"This displays a dialog that warns the user of a unsaved file."
|
||||
""
|
||||
"The string, \\var{action}, indicates what action is about to"
|
||||
"take place, without saving. For example, if the application"
|
||||
"is about to close a file, a good action is \\rawscm{\"Close"
|
||||
"Anyway\"}. The result symbol indicates the user's choice. If"
|
||||
"\\var{can-save-now?} is \\rawscm{\\#f}, this function does not"
|
||||
"give the user the ``Save'' option and thus will not return"
|
||||
"\\rawscm{'save}.")
|
||||
|
||||
(gui-utils:get-choice
|
||||
(opt->
|
||||
(string?
|
||||
string?
|
||||
string?)
|
||||
(string?
|
||||
any/c
|
||||
(or/c false/c (is-a?/c frame%) (is-a?/c dialog%))
|
||||
(symbols 'app 'caution 'stop)
|
||||
(or/c false/c (case-> (boolean? . -> . void?)
|
||||
(-> boolean?)))
|
||||
string?)
|
||||
any/c)
|
||||
((message true-choice false-choice)
|
||||
((title (string-constant warning))
|
||||
(default-result 'disallow-close)
|
||||
(parent #f)
|
||||
(style 'app)
|
||||
(checkbox-proc #f)
|
||||
(checkbox-label (string-constant dont-ask-again))))
|
||||
|
||||
"Opens a dialog that presents a binary choice to the user. The user is forced"
|
||||
"to choose between these two options, ie cancelling or closing the dialog"
|
||||
"opens a message box asking the user to actually choose one of the two options."
|
||||
""
|
||||
"The dialog will contain the string \\var{message} and two buttons,"
|
||||
"labeled with the \\var{true-choice} and the \\var{false-choice}. If the"
|
||||
"user clicks on \\var{true-choice} \\rawscm{\\#t} is returned. If the user"
|
||||
"clicks on \\var{false-choice}, \\rawscm{\\#f} is returned."
|
||||
""
|
||||
"The argument \\var{default-result} determines how closing the window is"
|
||||
"treated. If the argument is \\rawscm{'disallow-close}, closing the window"
|
||||
"is not allowed. If it is anything else, that value is returned when"
|
||||
"the user closes the window."
|
||||
""
|
||||
"If "
|
||||
"@flink gui-utils:cancel-on-right?"
|
||||
"returns \\scheme|#t|, the false choice is on the right."
|
||||
"Otherwise, the true choice is on the right."
|
||||
""
|
||||
"The \\var{style} parameter is (eventually) passed to"
|
||||
"@link message"
|
||||
"as an icon in the dialog."
|
||||
""
|
||||
"If \\var{checkbox-proc} is given, it should be a procedure that behaves"
|
||||
"like a parameter for getting/setting a boolean value. The intention for"
|
||||
"this value is that it can be used to disable the dialog. When it is"
|
||||
"given, a checkbox will appear with a \\var{checkbox-label} label"
|
||||
"(defaults to the \\rawscm{dont-ask-again} string constant), and that"
|
||||
"checkbox value will be sent to the \\var{checkbox-proc} when the dialog"
|
||||
"is closed. Note that the dialog will always pop-up --- it is the"
|
||||
"caller's responsibility to avoid the dialog if not needed.")
|
||||
|
||||
(gui-utils:get-clicked-clickback-delta
|
||||
(-> (is-a?/c style-delta%))
|
||||
()
|
||||
"This delta is designed for use with"
|
||||
"@link text set-clickback %"
|
||||
". Use it as one of the \\iscmclass{style-delta} argument to"
|
||||
"@link text set-clickback %"
|
||||
"."
|
||||
""
|
||||
"See also"
|
||||
"@flink gui-utils:get-clickback-delta %"
|
||||
".")
|
||||
|
||||
(gui-utils:get-clickback-delta
|
||||
(-> (is-a?/c style-delta%))
|
||||
()
|
||||
"This delta is designed for use with"
|
||||
"@link text set-clickback %"
|
||||
". Use the result of this function as the style"
|
||||
"for the region"
|
||||
"text where the clickback is set."
|
||||
""
|
||||
"See also"
|
||||
"@flink gui-utils:get-clicked-clickback-delta %"
|
||||
".")))
|
||||
|
|
|
|||
|
|
@ -10,207 +10,6 @@
|
|||
[(_ (name contract docs ...) ...)
|
||||
(syntax (provide/contract (name contract) ...))]))
|
||||
|
||||
(provide/contract/docs
|
||||
(test:number-pending-actions
|
||||
(-> number?)
|
||||
()
|
||||
"Returns the number of pending events (those that haven't completed yet)")
|
||||
|
||||
(test:run-interval
|
||||
(case->
|
||||
(number? . -> . void?)
|
||||
(-> number?))
|
||||
((msec) ())
|
||||
"See also"
|
||||
"\\hyperref{Actions and completeness}{Actions and completeness, section~}{}{fw:actions-completeness}."
|
||||
"The first case in the case-lambda sets"
|
||||
"the run interval to \\var{msec} milliseconds and the second"
|
||||
"returns the current setting.")
|
||||
|
||||
(test:reraise-error
|
||||
(-> void?)
|
||||
()
|
||||
"See also"
|
||||
"\\hyperref{Errors}{Errors, section~}{}{fw:test:errors}.")
|
||||
|
||||
(test:run-one
|
||||
((-> void?) . -> . void?)
|
||||
(f)
|
||||
"Runs the function \\var{f} as if it was a simulated event. See also"
|
||||
"\\hyperref{the test section}{section ~}{}{fw:test}.")
|
||||
|
||||
(test:current-get-eventspaces
|
||||
(case->
|
||||
((-> (listof eventspace?)) . -> . void?)
|
||||
(-> (-> (listof eventspace?))))
|
||||
((func) ())
|
||||
|
||||
"This parameter that specifies which "
|
||||
"\\hyperref{eventspaces}{eventspace (see section~}{)}{eventspaceinfo}"
|
||||
"are considered when finding the frontmost frame."
|
||||
|
||||
"The first case"
|
||||
"sets the parameter to \\var{func}. The procedure \\var{func} will be"
|
||||
"invoked with no arguments to determine the eventspaces to consider"
|
||||
"when finding the frontmost frame for simulated user events."
|
||||
|
||||
"The second case"
|
||||
"returns the current value of the parameter. This will be a procedure"
|
||||
"which, when invoked, returns a list of eventspaces.")
|
||||
(test:close-top-level-window
|
||||
((is-a?/c top-level-window<%>) . -> . void?)
|
||||
(tlw)
|
||||
"Use this function to simulate clicking on the close box of a frame."
|
||||
"Closes \\var{tlw} with this expression:"
|
||||
""
|
||||
"\\begin{schemedisplay}"
|
||||
"(when (send tlw can-close?)"
|
||||
" (send tlw on-close)"
|
||||
" (send tlw show #f))"
|
||||
"\\end{schemedisplay}")
|
||||
|
||||
(test:top-level-focus-window-has?
|
||||
(((is-a?/c area<%>) . -> . boolean?) . -> . boolean?)
|
||||
(test)
|
||||
"Calls \\var{test} for each child of the top-level-focus-frame"
|
||||
"and returns \\scheme|#t| if \\var{test} ever does, otherwise"
|
||||
"returns \\scheme|#f|. If there"
|
||||
"is no top-level-focus-window, returns \\scheme|#f|.")
|
||||
|
||||
;; ((frame-has? p) f) =
|
||||
;; f is a frame and it has a child (in it or a subpanel) that responds #t to p
|
||||
(test:button-push
|
||||
((or/c (λ (str)
|
||||
(and (string? str)
|
||||
(test:top-level-focus-window-has?
|
||||
(λ (c)
|
||||
(and (is-a? c button%)
|
||||
(string=? (send c get-label) str)
|
||||
(send c is-enabled?)
|
||||
(send c is-shown?))))))
|
||||
|
||||
(and/c (is-a?/c button%)
|
||||
(λ (btn)
|
||||
(and (send btn is-enabled?)
|
||||
(send btn is-shown?)))
|
||||
(λ (btn)
|
||||
(test:top-level-focus-window-has?
|
||||
(λ (c) (eq? c btn))))))
|
||||
. -> .
|
||||
void?)
|
||||
(button)
|
||||
"Simulates pushing \\var{button}. If a string is supplied, the"
|
||||
"primitive searches for a button labelled with that string in the"
|
||||
"active frame. Otherwise, it pushes the button argument.")
|
||||
|
||||
(test:set-radio-box!
|
||||
((or/c string? (is-a?/c radio-box%)) (or/c string? number?) . -> . void?)
|
||||
(radio-box state)
|
||||
"Sets the radio-box to \\var{state}. If \\var{state} is a"
|
||||
"string, this function finds the choice with that label and"
|
||||
"if it is a number, it uses the number as an index into the"
|
||||
"state. If the number is out of range or if the label isn't"
|
||||
"in the radio box, an exception is raised."
|
||||
""
|
||||
"If \\var{radio-box} is a string, this function searches for a"
|
||||
"\\iscmclass{radio-box} with a label matching that string,"
|
||||
"otherwise it uses \\var{radio-box} itself.")
|
||||
|
||||
(test:set-radio-box-item!
|
||||
(string? . -> . void?)
|
||||
(entry)
|
||||
"Finds a \\iscmclass{radio-box} that has a label \\var{entry}"
|
||||
"and sets the radio-box to \\var{entry}.")
|
||||
(test:set-check-box!
|
||||
((or/c string? (is-a?/c check-box%)) boolean? . -> . void?)
|
||||
(check-box state)
|
||||
"Clears the \\iscmclass{check-box} item if \\var{state} is \\rawscm{\\#f}, and sets it"
|
||||
"otherwise."
|
||||
""
|
||||
"If \\var{check-box} is a string,"
|
||||
"this function searches for a \\iscmclass{check-box} with a label matching that string,"
|
||||
"otherwise it uses \\var{check-box} itself.")
|
||||
|
||||
(test:set-choice!
|
||||
((or/c string? (is-a?/c choice%)) string? . -> . void?)
|
||||
(choice str)
|
||||
"Selects \\var{choice}'s item \\var{str}. If \\var{choice} is a string,"
|
||||
"this function searches for a \\iscmclass{choice} with a label matching"
|
||||
"that string, otherwise it uses \\var{choice} itself.")
|
||||
|
||||
(test:keystroke
|
||||
(opt->
|
||||
((or/c char? symbol?))
|
||||
((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometea 'noshift)))
|
||||
void?)
|
||||
((key)
|
||||
((modifier-list null)))
|
||||
"This function simulates a user pressing a key. The argument, \\var{key},"
|
||||
"is just like the argument to the"
|
||||
"@link key-event get-key-code"
|
||||
"method of the"
|
||||
"@link key-event"
|
||||
"class. "
|
||||
""
|
||||
"{\\it Note:}"
|
||||
"To send the ``Enter'' key, use \\verb|#\return|,"
|
||||
"not \\verb|#\newline|."
|
||||
""
|
||||
"The \\rawscm{'shift} or \\rawscm{'noshift} modifier is implicitly set from \\var{key},"
|
||||
"but is overridden by the argument list. The \\rawscm{'shift} modifier is"
|
||||
"set for any capitol alpha-numeric letters and any of the following characters:"
|
||||
"\\begin{schemedisplay}"
|
||||
"#\\? #\\: #\\~ #\\\\ #\\|"
|
||||
"#\\< #\\> #\\{ #\\} #\\[ #\\] #\\( #\\)"
|
||||
"#\\! #\\@ #\\# #\\$ #\\% #\\^ #\\& #\\* #\\_ #\\+"
|
||||
"\\end{schemedisplay}"
|
||||
""
|
||||
"If conflicting modifiers are provided, the ones later in the list are used.")
|
||||
|
||||
(test:menu-select
|
||||
(string? string? . -> . void?)
|
||||
(menu item)
|
||||
"Selects the menu-item named \\var{item} in the menu named \\var{menu}."
|
||||
""
|
||||
"{\\it Note:}"
|
||||
"The string for the menu item does not include its keyboard equivalent."
|
||||
"For example, to select ``New'' from the ``File'' menu, "
|
||||
"use ``New'', not ``New Ctrl+m n''.")
|
||||
|
||||
(test:mouse-click
|
||||
(opt->
|
||||
((symbols 'left 'middle 'right)
|
||||
(and/c exact? integer?)
|
||||
(and/c exact? integer?))
|
||||
((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometa 'noshift)))
|
||||
void?)
|
||||
((button x y)
|
||||
((modifiers null)))
|
||||
"Simulates a mouse click at the coordinate: $(x,y)$ in the currently"
|
||||
"focused \\iscmintf{window}, assuming that it supports the "
|
||||
"@ilink canvas on-event"
|
||||
"method."
|
||||
"Use"
|
||||
"@flink test:button-push"
|
||||
"to click on a button."
|
||||
""
|
||||
"On the Macintosh, \\rawscm{'right} corresponds to holding down the command"
|
||||
"modifier key while clicking and \\rawscm{'middle} cannot be generated."
|
||||
""
|
||||
"Under Windows, \\rawscm{'middle} can only be generated if the user has a"
|
||||
"three button mouse."
|
||||
""
|
||||
"The modifiers later in the list \\var{modifiers} take precedence over"
|
||||
"ones that appear earlier.")
|
||||
|
||||
(test:new-window
|
||||
((is-a?/c window<%>) . -> . void?)
|
||||
(window)
|
||||
"Moves the keyboard focus to a new window within the currently active"
|
||||
"frame. Unfortunately, neither this function nor any other function in"
|
||||
"the test engine can cause the focus to move from the top-most (active)"
|
||||
"frame. "))
|
||||
|
||||
(define (test:top-level-focus-window-has? pred)
|
||||
(let ([tlw (get-top-level-focus-window)])
|
||||
(and tlw
|
||||
|
|
@ -1036,4 +835,205 @@
|
|||
(define test:keystroke keystroke)
|
||||
(define test:menu-select menu-select)
|
||||
(define test:mouse-click mouse-click)
|
||||
(define test:new-window new-window))
|
||||
(define test:new-window new-window)
|
||||
|
||||
(provide/contract/docs
|
||||
(test:number-pending-actions
|
||||
(-> number?)
|
||||
()
|
||||
"Returns the number of pending events (those that haven't completed yet)")
|
||||
|
||||
(test:run-interval
|
||||
(case->
|
||||
(number? . -> . void?)
|
||||
(-> number?))
|
||||
((msec) ())
|
||||
"See also"
|
||||
"\\hyperref{Actions and completeness}{Actions and completeness, section~}{}{fw:actions-completeness}."
|
||||
"The first case in the case-lambda sets"
|
||||
"the run interval to \\var{msec} milliseconds and the second"
|
||||
"returns the current setting.")
|
||||
|
||||
(test:reraise-error
|
||||
(-> void?)
|
||||
()
|
||||
"See also"
|
||||
"\\hyperref{Errors}{Errors, section~}{}{fw:test:errors}.")
|
||||
|
||||
(test:run-one
|
||||
((-> void?) . -> . void?)
|
||||
(f)
|
||||
"Runs the function \\var{f} as if it was a simulated event. See also"
|
||||
"\\hyperref{the test section}{section ~}{}{fw:test}.")
|
||||
|
||||
(test:current-get-eventspaces
|
||||
(case->
|
||||
((-> (listof eventspace?)) . -> . void?)
|
||||
(-> (-> (listof eventspace?))))
|
||||
((func) ())
|
||||
|
||||
"This parameter that specifies which "
|
||||
"\\hyperref{eventspaces}{eventspace (see section~}{)}{eventspaceinfo}"
|
||||
"are considered when finding the frontmost frame."
|
||||
|
||||
"The first case"
|
||||
"sets the parameter to \\var{func}. The procedure \\var{func} will be"
|
||||
"invoked with no arguments to determine the eventspaces to consider"
|
||||
"when finding the frontmost frame for simulated user events."
|
||||
|
||||
"The second case"
|
||||
"returns the current value of the parameter. This will be a procedure"
|
||||
"which, when invoked, returns a list of eventspaces.")
|
||||
(test:close-top-level-window
|
||||
((is-a?/c top-level-window<%>) . -> . void?)
|
||||
(tlw)
|
||||
"Use this function to simulate clicking on the close box of a frame."
|
||||
"Closes \\var{tlw} with this expression:"
|
||||
""
|
||||
"\\begin{schemedisplay}"
|
||||
"(when (send tlw can-close?)"
|
||||
" (send tlw on-close)"
|
||||
" (send tlw show #f))"
|
||||
"\\end{schemedisplay}")
|
||||
|
||||
(test:top-level-focus-window-has?
|
||||
(((is-a?/c area<%>) . -> . boolean?) . -> . boolean?)
|
||||
(test)
|
||||
"Calls \\var{test} for each child of the top-level-focus-frame"
|
||||
"and returns \\scheme|#t| if \\var{test} ever does, otherwise"
|
||||
"returns \\scheme|#f|. If there"
|
||||
"is no top-level-focus-window, returns \\scheme|#f|.")
|
||||
|
||||
;; ((frame-has? p) f) =
|
||||
;; f is a frame and it has a child (in it or a subpanel) that responds #t to p
|
||||
(test:button-push
|
||||
((or/c (λ (str)
|
||||
(and (string? str)
|
||||
(test:top-level-focus-window-has?
|
||||
(λ (c)
|
||||
(and (is-a? c button%)
|
||||
(string=? (send c get-label) str)
|
||||
(send c is-enabled?)
|
||||
(send c is-shown?))))))
|
||||
|
||||
(and/c (is-a?/c button%)
|
||||
(λ (btn)
|
||||
(and (send btn is-enabled?)
|
||||
(send btn is-shown?)))
|
||||
(λ (btn)
|
||||
(test:top-level-focus-window-has?
|
||||
(λ (c) (eq? c btn))))))
|
||||
. -> .
|
||||
void?)
|
||||
(button)
|
||||
"Simulates pushing \\var{button}. If a string is supplied, the"
|
||||
"primitive searches for a button labelled with that string in the"
|
||||
"active frame. Otherwise, it pushes the button argument.")
|
||||
|
||||
(test:set-radio-box!
|
||||
((or/c string? (is-a?/c radio-box%)) (or/c string? number?) . -> . void?)
|
||||
(radio-box state)
|
||||
"Sets the radio-box to \\var{state}. If \\var{state} is a"
|
||||
"string, this function finds the choice with that label and"
|
||||
"if it is a number, it uses the number as an index into the"
|
||||
"state. If the number is out of range or if the label isn't"
|
||||
"in the radio box, an exception is raised."
|
||||
""
|
||||
"If \\var{radio-box} is a string, this function searches for a"
|
||||
"\\iscmclass{radio-box} with a label matching that string,"
|
||||
"otherwise it uses \\var{radio-box} itself.")
|
||||
|
||||
(test:set-radio-box-item!
|
||||
(string? . -> . void?)
|
||||
(entry)
|
||||
"Finds a \\iscmclass{radio-box} that has a label \\var{entry}"
|
||||
"and sets the radio-box to \\var{entry}.")
|
||||
(test:set-check-box!
|
||||
((or/c string? (is-a?/c check-box%)) boolean? . -> . void?)
|
||||
(check-box state)
|
||||
"Clears the \\iscmclass{check-box} item if \\var{state} is \\rawscm{\\#f}, and sets it"
|
||||
"otherwise."
|
||||
""
|
||||
"If \\var{check-box} is a string,"
|
||||
"this function searches for a \\iscmclass{check-box} with a label matching that string,"
|
||||
"otherwise it uses \\var{check-box} itself.")
|
||||
|
||||
(test:set-choice!
|
||||
((or/c string? (is-a?/c choice%)) string? . -> . void?)
|
||||
(choice str)
|
||||
"Selects \\var{choice}'s item \\var{str}. If \\var{choice} is a string,"
|
||||
"this function searches for a \\iscmclass{choice} with a label matching"
|
||||
"that string, otherwise it uses \\var{choice} itself.")
|
||||
|
||||
(test:keystroke
|
||||
(opt->
|
||||
((or/c char? symbol?))
|
||||
((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometea 'noshift)))
|
||||
void?)
|
||||
((key)
|
||||
((modifier-list null)))
|
||||
"This function simulates a user pressing a key. The argument, \\var{key},"
|
||||
"is just like the argument to the"
|
||||
"@link key-event get-key-code"
|
||||
"method of the"
|
||||
"@link key-event"
|
||||
"class. "
|
||||
""
|
||||
"{\\it Note:}"
|
||||
"To send the ``Enter'' key, use \\verb|#\return|,"
|
||||
"not \\verb|#\newline|."
|
||||
""
|
||||
"The \\rawscm{'shift} or \\rawscm{'noshift} modifier is implicitly set from \\var{key},"
|
||||
"but is overridden by the argument list. The \\rawscm{'shift} modifier is"
|
||||
"set for any capitol alpha-numeric letters and any of the following characters:"
|
||||
"\\begin{schemedisplay}"
|
||||
"#\\? #\\: #\\~ #\\\\ #\\|"
|
||||
"#\\< #\\> #\\{ #\\} #\\[ #\\] #\\( #\\)"
|
||||
"#\\! #\\@ #\\# #\\$ #\\% #\\^ #\\& #\\* #\\_ #\\+"
|
||||
"\\end{schemedisplay}"
|
||||
""
|
||||
"If conflicting modifiers are provided, the ones later in the list are used.")
|
||||
|
||||
(test:menu-select
|
||||
(string? string? . -> . void?)
|
||||
(menu item)
|
||||
"Selects the menu-item named \\var{item} in the menu named \\var{menu}."
|
||||
""
|
||||
"{\\it Note:}"
|
||||
"The string for the menu item does not include its keyboard equivalent."
|
||||
"For example, to select ``New'' from the ``File'' menu, "
|
||||
"use ``New'', not ``New Ctrl+m n''.")
|
||||
|
||||
(test:mouse-click
|
||||
(opt->
|
||||
((symbols 'left 'middle 'right)
|
||||
(and/c exact? integer?)
|
||||
(and/c exact? integer?))
|
||||
((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometa 'noshift)))
|
||||
void?)
|
||||
((button x y)
|
||||
((modifiers null)))
|
||||
"Simulates a mouse click at the coordinate: $(x,y)$ in the currently"
|
||||
"focused \\iscmintf{window}, assuming that it supports the "
|
||||
"@ilink canvas on-event"
|
||||
"method."
|
||||
"Use"
|
||||
"@flink test:button-push"
|
||||
"to click on a button."
|
||||
""
|
||||
"On the Macintosh, \\rawscm{'right} corresponds to holding down the command"
|
||||
"modifier key while clicking and \\rawscm{'middle} cannot be generated."
|
||||
""
|
||||
"Under Windows, \\rawscm{'middle} can only be generated if the user has a"
|
||||
"three button mouse."
|
||||
""
|
||||
"The modifiers later in the list \\var{modifiers} take precedence over"
|
||||
"ones that appear earlier.")
|
||||
|
||||
(test:new-window
|
||||
((is-a?/c window<%>) . -> . void?)
|
||||
(window)
|
||||
"Moves the keyboard focus to a new window within the currently active"
|
||||
"frame. Unfortunately, neither this function nor any other function in"
|
||||
"the test engine can cause the focus to move from the top-most (active)"
|
||||
"frame. ")))
|
||||
|
|
|
|||
|
|
@ -3,10 +3,6 @@
|
|||
(lib "getinfo.ss" "setup")
|
||||
(lib "contract.ss"))
|
||||
|
||||
(provide/contract
|
||||
[colldocs (-> (values (listof (list/c path? path?))
|
||||
(listof string?)))])
|
||||
|
||||
(define (colldocs)
|
||||
(let loop ([dirs (sort (map path->string (find-relevant-directories
|
||||
'(doc.txt) 'all-available))
|
||||
|
|
@ -27,4 +23,8 @@
|
|||
docs)
|
||||
(cons name names))
|
||||
(loop (cdr dirs) docs names)))
|
||||
(loop (cdr dirs) docs names)))]))))
|
||||
(loop (cdr dirs) docs names)))])))
|
||||
|
||||
(provide/contract
|
||||
[colldocs (-> (values (listof (list/c path? path?))
|
||||
(listof string?)))]))
|
||||
|
|
|
|||
|
|
@ -2,10 +2,6 @@
|
|||
(require (lib "list.ss")
|
||||
(lib "contract.ss"))
|
||||
|
||||
(provide/contract
|
||||
[standard-html-doc-position (path? . -> . number?)]
|
||||
[known-docs (listof (cons/c path? string?))])
|
||||
|
||||
;; Define an order on the standard docs.
|
||||
(define (standard-html-doc-position d)
|
||||
(let ([str (path->string d)])
|
||||
|
|
@ -61,4 +57,8 @@
|
|||
("profj-intermediate" "ProfessorJ Intermediate Language" 211)
|
||||
("profj-advanced" "ProfessorJ Advanced Language" 212)))
|
||||
|
||||
(define known-docs (map (lambda (x) (cons (string->path (car x)) (cadr x))) docs-and-positions)))
|
||||
(define known-docs (map (lambda (x) (cons (string->path (car x)) (cadr x))) docs-and-positions))
|
||||
|
||||
(provide/contract
|
||||
[standard-html-doc-position (path? . -> . number?)]
|
||||
[known-docs (listof (cons/c path? string?))]))
|
||||
|
|
|
|||
|
|
@ -8,12 +8,6 @@
|
|||
(lib "config.ss" "planet")
|
||||
(lib "dirs.ss" "setup"))
|
||||
|
||||
(provide/contract (get-help-url
|
||||
(opt->
|
||||
((or/c path? path-string?))
|
||||
(string?)
|
||||
string?)))
|
||||
|
||||
; given a manual path, convert to absolute Web path
|
||||
; manual path is an anchored path to a doc manual, never a servlet
|
||||
(define get-help-url
|
||||
|
|
@ -64,4 +58,10 @@
|
|||
[(null? long) #f]
|
||||
[(equal? (car short) (car long))
|
||||
(loop (cdr short) (cdr long))]
|
||||
[else #f]))))
|
||||
[else #f])))
|
||||
|
||||
(provide/contract (get-help-url
|
||||
(opt->
|
||||
((or/c path? path-string?))
|
||||
(string?)
|
||||
string?))))
|
||||
|
|
|
|||
|
|
@ -17,21 +17,6 @@
|
|||
"../servlets/private/util.ss"
|
||||
"../servlets/private/headelts.ss")
|
||||
|
||||
(provide main-manual-page)
|
||||
(provide finddoc
|
||||
finddoc-page-anchor)
|
||||
|
||||
(provide/contract [manual-entry (string? string? xexpr? . -> . xexpr?)]
|
||||
[finddoc-page (string? string? . -> . string?)]
|
||||
[get-doc-name (path? . -> . string?)]
|
||||
[find-doc-directories (-> (listof path?))]
|
||||
[find-doc-directory (path? . -> . (or/c false/c path?))]
|
||||
[find-doc-names (-> (listof (cons/c path? string?)))]
|
||||
[get-manual-index (-> string? string?)]
|
||||
[get-index-file (path? . -> . (or/c false/c path?))])
|
||||
|
||||
(provide find-manuals)
|
||||
|
||||
;; type sec = (make-sec name regexp (listof regexp))
|
||||
(define-struct sec (name reg seps))
|
||||
|
||||
|
|
@ -380,4 +365,20 @@
|
|||
(if (file-exists? (build-path dir index-file))
|
||||
index-file
|
||||
#f)))
|
||||
(loop (cdr contents))))]))))
|
||||
(loop (cdr contents))))])))
|
||||
|
||||
|
||||
(provide main-manual-page)
|
||||
(provide finddoc
|
||||
finddoc-page-anchor)
|
||||
|
||||
(provide/contract [manual-entry (string? string? xexpr? . -> . xexpr?)]
|
||||
[finddoc-page (string? string? . -> . string?)]
|
||||
[get-doc-name (path? . -> . string?)]
|
||||
[find-doc-directories (-> (listof path?))]
|
||||
[find-doc-directory (path? . -> . (or/c false/c path?))]
|
||||
[find-doc-names (-> (listof (cons/c path? string?)))]
|
||||
[get-manual-index (-> string? string?)]
|
||||
[get-index-file (path? . -> . (or/c false/c path?))])
|
||||
|
||||
(provide find-manuals))
|
||||
|
|
|
|||
|
|
@ -1,11 +1,10 @@
|
|||
(module path mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(provide/contract
|
||||
[servlet-path? (path? . -> . boolean?)])
|
||||
|
||||
(define (servlet-path? path)
|
||||
(if (regexp-match #rx#"^/servlets/"
|
||||
(path->bytes path))
|
||||
#t
|
||||
#f)))
|
||||
#f))
|
||||
(provide/contract
|
||||
[servlet-path? (path? . -> . boolean?)]))
|
||||
|
||||
|
|
|
|||
|
|
@ -15,32 +15,6 @@
|
|||
(define (search-how? x)
|
||||
(member x '("exact-match" "containing-match" "regexp-match")))
|
||||
|
||||
(provide search-type? search-how?)
|
||||
(provide/contract
|
||||
(make-relative-results-url (string?
|
||||
search-type?
|
||||
search-how?
|
||||
any/c
|
||||
(listof path?)
|
||||
any/c
|
||||
(or/c false/c string?) . -> . string?))
|
||||
(make-results-url (string?
|
||||
search-type? search-how? any/c
|
||||
(listof path?)
|
||||
any/c
|
||||
(or/c false/c string?)
|
||||
. -> .
|
||||
string?))
|
||||
(flush-manuals-url string?)
|
||||
(flush-manuals-path string?)
|
||||
(make-missing-manual-url (string? string? string? . -> . string?))
|
||||
(get-hd-location ((lambda (sym) (memq sym hd-location-syms))
|
||||
. -> .
|
||||
string?))
|
||||
[prefix-with-server (string? . -> . string?)]
|
||||
[make-docs-plt-url (string? . -> . string?)]
|
||||
[make-docs-html-url (string? . -> . string?)])
|
||||
|
||||
(define (base-docs-url)
|
||||
(if (repos-or-nightly-build?)
|
||||
"http://pre.plt-scheme.org/docs"
|
||||
|
|
@ -112,4 +86,30 @@
|
|||
|
||||
(define (get-hd-location sym)
|
||||
; the assq is guarded by the contract
|
||||
(cadr (assq sym hd-locations))))
|
||||
(cadr (assq sym hd-locations)))
|
||||
|
||||
(provide search-type? search-how?)
|
||||
(provide/contract
|
||||
(make-relative-results-url (string?
|
||||
search-type?
|
||||
search-how?
|
||||
any/c
|
||||
(listof path?)
|
||||
any/c
|
||||
(or/c false/c string?) . -> . string?))
|
||||
(make-results-url (string?
|
||||
search-type? search-how? any/c
|
||||
(listof path?)
|
||||
any/c
|
||||
(or/c false/c string?)
|
||||
. -> .
|
||||
string?))
|
||||
(flush-manuals-url string?)
|
||||
(flush-manuals-path string?)
|
||||
(make-missing-manual-url (string? string? string? . -> . string?))
|
||||
(get-hd-location ((lambda (sym) (memq sym hd-location-syms))
|
||||
. -> .
|
||||
string?))
|
||||
[prefix-with-server (string? . -> . string?)]
|
||||
[make-docs-plt-url (string? . -> . string?)]
|
||||
[make-docs-html-url (string? . -> . string?)]))
|
||||
|
|
|
|||
|
|
@ -6,28 +6,6 @@
|
|||
(lib "string-constant.ss" "string-constants")
|
||||
(lib "contract.ss"))
|
||||
|
||||
(provide/contract
|
||||
[fold-into-web-path ((listof string?) . -> . string?)])
|
||||
|
||||
(provide get-pref/default
|
||||
get-bool-pref/default
|
||||
put-prefs
|
||||
repos-or-nightly-build?
|
||||
search-height-default
|
||||
search-bg-default
|
||||
search-text-default
|
||||
search-link-default
|
||||
color-highlight
|
||||
color-with
|
||||
collection-doc-link
|
||||
home-page
|
||||
format-collection-message
|
||||
nl
|
||||
plt-version
|
||||
make-javascript
|
||||
redir-javascript
|
||||
onload-redir)
|
||||
|
||||
;; would be nice if this could use version:version from the framework.
|
||||
(define (plt-version)
|
||||
(let ([mz-version (version)]
|
||||
|
|
@ -138,9 +116,26 @@
|
|||
(string-append
|
||||
"setTimeout(\"redir()\","
|
||||
(number->string (* secs 1000))
|
||||
")")))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
")"))
|
||||
|
||||
(provide/contract
|
||||
[fold-into-web-path ((listof string?) . -> . string?)])
|
||||
|
||||
(provide get-pref/default
|
||||
get-bool-pref/default
|
||||
put-prefs
|
||||
repos-or-nightly-build?
|
||||
search-height-default
|
||||
search-bg-default
|
||||
search-text-default
|
||||
search-link-default
|
||||
color-highlight
|
||||
color-with
|
||||
collection-doc-link
|
||||
home-page
|
||||
format-collection-message
|
||||
nl
|
||||
plt-version
|
||||
make-javascript
|
||||
redir-javascript
|
||||
onload-redir))
|
||||
|
|
|
|||
|
|
@ -5,23 +5,6 @@
|
|||
(lib "list.ss")
|
||||
"private/port.ss")
|
||||
|
||||
(provide open-output-nowhere
|
||||
make-pipe-with-specials
|
||||
make-input-port/read-to-peek
|
||||
peeking-input-port
|
||||
relocate-input-port
|
||||
transplant-input-port
|
||||
relocate-output-port
|
||||
transplant-output-port
|
||||
merge-input
|
||||
copy-port
|
||||
input-port-append
|
||||
convert-stream
|
||||
make-limited-input-port
|
||||
reencode-input-port
|
||||
reencode-output-port
|
||||
strip-shell-command-start)
|
||||
|
||||
(define (exact-non-negative-integer? i)
|
||||
(and (number? i) (exact? i) (integer? i) (i . >= . 0)))
|
||||
|
||||
|
|
@ -40,42 +23,6 @@
|
|||
(define (evt?/false v)
|
||||
(or (eq? #f v) (evt? v)))
|
||||
|
||||
(provide/contract (read-bytes-avail!-evt (mutable-bytes? input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
(peek-bytes-avail!-evt (mutable-bytes? exact-non-negative-integer? evt?/false
|
||||
input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
(read-bytes!-evt (mutable-bytes? input-port-with-progress-evts? . -> . evt?))
|
||||
(peek-bytes!-evt (mutable-bytes? exact-non-negative-integer? evt?/false
|
||||
input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
(read-bytes-evt (exact-non-negative-integer? input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
(peek-bytes-evt (exact-non-negative-integer? exact-non-negative-integer? evt?/false
|
||||
input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
(read-string!-evt (mutable-string? input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
(peek-string!-evt (mutable-string? exact-non-negative-integer? evt?/false
|
||||
input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
(read-string-evt (exact-non-negative-integer? input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
(peek-string-evt (exact-non-negative-integer? exact-non-negative-integer? evt?/false
|
||||
input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
(regexp-match-evt ((or/c regexp? byte-regexp? string? bytes?)
|
||||
input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
|
||||
(read-bytes-line-evt (case->
|
||||
(input-port-with-progress-evts? . -> . evt?)
|
||||
(input-port-with-progress-evts? line-mode-symbol? . -> . evt?)))
|
||||
(read-line-evt (case->
|
||||
(input-port-with-progress-evts? . -> . evt?)
|
||||
(input-port-with-progress-evts? line-mode-symbol? . -> . evt?)))
|
||||
(eof-evt (input-port-with-progress-evts? . -> . evt?)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (strip-shell-command-start in)
|
||||
|
|
@ -1535,4 +1482,57 @@
|
|||
(and (eq? old 'line)
|
||||
(memq mode '(none))))
|
||||
;; Flush output
|
||||
(write-it #"" 0 0 #f #f)))]))))))
|
||||
(write-it #"" 0 0 #f #f)))])))))
|
||||
|
||||
(provide open-output-nowhere
|
||||
make-pipe-with-specials
|
||||
make-input-port/read-to-peek
|
||||
peeking-input-port
|
||||
relocate-input-port
|
||||
transplant-input-port
|
||||
relocate-output-port
|
||||
transplant-output-port
|
||||
merge-input
|
||||
copy-port
|
||||
input-port-append
|
||||
convert-stream
|
||||
make-limited-input-port
|
||||
reencode-input-port
|
||||
reencode-output-port
|
||||
strip-shell-command-start)
|
||||
|
||||
(provide/contract (read-bytes-avail!-evt (mutable-bytes? input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
(peek-bytes-avail!-evt (mutable-bytes? exact-non-negative-integer? evt?/false
|
||||
input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
(read-bytes!-evt (mutable-bytes? input-port-with-progress-evts? . -> . evt?))
|
||||
(peek-bytes!-evt (mutable-bytes? exact-non-negative-integer? evt?/false
|
||||
input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
(read-bytes-evt (exact-non-negative-integer? input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
(peek-bytes-evt (exact-non-negative-integer? exact-non-negative-integer? evt?/false
|
||||
input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
(read-string!-evt (mutable-string? input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
(peek-string!-evt (mutable-string? exact-non-negative-integer? evt?/false
|
||||
input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
(read-string-evt (exact-non-negative-integer? input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
(peek-string-evt (exact-non-negative-integer? exact-non-negative-integer? evt?/false
|
||||
input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
(regexp-match-evt ((or/c regexp? byte-regexp? string? bytes?)
|
||||
input-port-with-progress-evts?
|
||||
. -> . evt?))
|
||||
|
||||
(read-bytes-line-evt (case->
|
||||
(input-port-with-progress-evts? . -> . evt?)
|
||||
(input-port-with-progress-evts? line-mode-symbol? . -> . evt?)))
|
||||
(read-line-evt (case->
|
||||
(input-port-with-progress-evts? . -> . evt?)
|
||||
(input-port-with-progress-evts? line-mode-symbol? . -> . evt?)))
|
||||
(eof-evt (input-port-with-progress-evts? . -> . evt?))))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -128,15 +128,11 @@ it around flattened out.
|
|||
(let ([ctc (if (procedure? ctc-field)
|
||||
(ctc-field f-xs ...)
|
||||
ctc-field)])
|
||||
(if (contract/info-pos contract/info)
|
||||
((((pos-proj-get ctc) ctc) (contract/info-pos contract/info)
|
||||
(contract/info-src-info contract/info)
|
||||
(contract/info-orig-str contract/info))
|
||||
ctc-x)
|
||||
((((neg-proj-get ctc) ctc) (contract/info-neg contract/info)
|
||||
(contract/info-src-info contract/info)
|
||||
(contract/info-orig-str contract/info))
|
||||
ctc-x))))] ...)
|
||||
((((proj-get ctc) ctc) (contract/info-pos contract/info)
|
||||
(contract/info-neg contract/info)
|
||||
(contract/info-src-info contract/info)
|
||||
(contract/info-orig-str contract/info))
|
||||
ctc-x)))] ...)
|
||||
(values f-x ...)))
|
||||
|
||||
(define (stronger-lazy-contract? a b)
|
||||
|
|
@ -145,16 +141,16 @@ it around flattened out.
|
|||
(contract-get a selector-indicies)
|
||||
(contract-get b selector-indicies)) ...))
|
||||
|
||||
(define (lazy-contract-pos-proj ctc)
|
||||
(λ (blame src-info orig-str)
|
||||
(let ([contract/info (make-contract/info ctc blame #f src-info orig-str)])
|
||||
(define (lazy-contract-proj ctc)
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([contract/info (make-contract/info ctc pos-blame neg-blame src-info orig-str)])
|
||||
(λ (val)
|
||||
(unless (or (wrap-predicate val)
|
||||
(raw-predicate val))
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
blame
|
||||
pos-blame
|
||||
orig-str
|
||||
"expected <~a>, got ~e" 'name val))
|
||||
(cond
|
||||
|
|
@ -163,16 +159,6 @@ it around flattened out.
|
|||
[else
|
||||
(wrap-maker val contract/info)])))))
|
||||
|
||||
(define (lazy-contract-neg-proj ctc)
|
||||
(λ (blame src-info orig-str)
|
||||
(let ([contract/info (make-contract/info ctc #f blame src-info orig-str)])
|
||||
(λ (val)
|
||||
(cond
|
||||
[(already-there? contract/info val lazy-depth-to-look)
|
||||
val]
|
||||
[else
|
||||
(wrap-maker val contract/info)])))))
|
||||
|
||||
(define (already-there? new-contract/info val depth)
|
||||
(cond
|
||||
[(raw-predicate val) #f]
|
||||
|
|
@ -230,8 +216,7 @@ it around flattened out.
|
|||
field-count
|
||||
0 ;; auto-field-k
|
||||
'() ;; auto-field-v
|
||||
(list (cons pos-proj-prop lazy-contract-pos-proj)
|
||||
(cons neg-proj-prop lazy-contract-neg-proj)
|
||||
(list (cons proj-prop lazy-contract-proj)
|
||||
(cons name-prop lazy-contract-name)
|
||||
(cons first-order-prop (λ (ctc) predicate))
|
||||
(cons stronger-prop stronger-lazy-contract?)))))))]))
|
||||
|
|
|
|||
|
|
@ -25,9 +25,7 @@
|
|||
contract?
|
||||
contract-name
|
||||
contract-proc
|
||||
contract-pos-proc
|
||||
contract-neg-proc
|
||||
make-pair-proj-contract
|
||||
make-proj-contract
|
||||
build-flat-contract
|
||||
|
||||
define-struct/prop
|
||||
|
|
@ -36,15 +34,11 @@
|
|||
|
||||
contract-first-order-passes?
|
||||
|
||||
proj-pred? proj-get
|
||||
pos-proj-prop pos-proj-pred? pos-proj-get
|
||||
neg-proj-prop neg-proj-pred? neg-proj-get
|
||||
proj-prop proj-pred? proj-get
|
||||
name-prop name-pred? name-get
|
||||
stronger-prop stronger-pred? stronger-get
|
||||
flat-prop flat-pred? flat-get
|
||||
any-curried-proj
|
||||
flat-pos-proj
|
||||
|
||||
flat-proj
|
||||
first-order-prop
|
||||
first-order-get)
|
||||
|
||||
|
|
@ -104,11 +98,6 @@
|
|||
(define-values (first-order-prop first-order-pred? first-order-get)
|
||||
(make-struct-type-property 'contract-first-order))
|
||||
|
||||
(define-values (pos-proj-prop pos-proj-pred? pos-proj-get)
|
||||
(make-struct-type-property 'contract-positive-projection))
|
||||
(define-values (neg-proj-prop neg-proj-pred? neg-proj-get)
|
||||
(make-struct-type-property 'contract-negative-projection))
|
||||
|
||||
(define (contract-first-order-passes? c v)
|
||||
(cond
|
||||
[(first-order-pred? c) (((first-order-get c) c) v)]
|
||||
|
|
@ -124,16 +113,6 @@
|
|||
(cond
|
||||
[(proj-pred? ctc)
|
||||
(raw-proj-get ctc)]
|
||||
[(and (neg-proj-pred? ctc)
|
||||
(pos-proj-pred? ctc))
|
||||
(let ([pos-abs ((pos-proj-get ctc) ctc)]
|
||||
[neg-abs ((neg-proj-get ctc) ctc)])
|
||||
(λ (ctc)
|
||||
(λ (pos neg src-info str)
|
||||
(let ([p-proj (pos-abs pos src-info str)]
|
||||
[n-proj (neg-abs neg src-info str)])
|
||||
(lambda (v)
|
||||
(n-proj (p-proj v)))))))]
|
||||
[else (error 'proj-get "unknown ~e" ctc)]))
|
||||
|
||||
;; contract-stronger? : contract contract -> boolean
|
||||
|
|
@ -281,10 +260,10 @@
|
|||
;; (the result function is the projection)
|
||||
;;
|
||||
|
||||
(define (flat-pos-proj ctc)
|
||||
(define (flat-proj ctc)
|
||||
(let ([predicate ((flat-get ctc) ctc)]
|
||||
[name ((name-get ctc) ctc)])
|
||||
(λ (pos src-info orig-str)
|
||||
(λ (pos neg src-info orig-str)
|
||||
(λ (val)
|
||||
(if (predicate val)
|
||||
val
|
||||
|
|
@ -297,29 +276,26 @@
|
|||
name
|
||||
val))))))
|
||||
|
||||
(define (any-curried-proj ctc) any-curred-proj2)
|
||||
(define (any-curred-proj2 pos src-info orig-str) values)
|
||||
(define (double-any-curried-proj ctc) double-any-curred-proj2)
|
||||
(define (double-any-curred-proj2 pos-blame neg-blame src-info orig-str) values)
|
||||
|
||||
|
||||
(define-values (make-flat-contract
|
||||
make-pair-proj-contract)
|
||||
make-proj-contract)
|
||||
(let ()
|
||||
(define-struct/prop pair-proj-contract (the-name pos-proc neg-proc first-order-proc)
|
||||
((pos-proj-prop (λ (ctc) (pair-proj-contract-pos-proc ctc)))
|
||||
(neg-proj-prop (λ (ctc) (pair-proj-contract-neg-proc ctc)))
|
||||
(name-prop (λ (ctc) (pair-proj-contract-the-name ctc)))
|
||||
(first-order-prop (λ (ctc) (or (pair-proj-contract-first-order-proc ctc)
|
||||
(define-struct/prop proj-contract (the-name proj first-order-proc)
|
||||
((proj-prop (λ (ctc) (proj-contract-proj ctc)))
|
||||
(name-prop (λ (ctc) (proj-contract-the-name ctc)))
|
||||
(first-order-prop (λ (ctc) (or (proj-contract-first-order-proc ctc)
|
||||
(λ (x) #t))))
|
||||
(stronger-prop (λ (this that)
|
||||
(and (pair-proj-contract? that)
|
||||
(and (proj-contract? that)
|
||||
(procedure-closure-contents-eq?
|
||||
(pair-proj-contract-pos-proc this)
|
||||
(pair-proj-contract-pos-proc that))
|
||||
(procedure-closure-contents-eq?
|
||||
(pair-proj-contract-neg-proc that)
|
||||
(pair-proj-contract-neg-proc this)))))))
|
||||
(proj-contract-proj this)
|
||||
(proj-contract-proj that)))))))
|
||||
|
||||
(define-struct/prop flat-contract (the-name predicate)
|
||||
((pos-proj-prop flat-pos-proj)
|
||||
(neg-proj-prop any-curried-proj)
|
||||
((proj-prop flat-proj)
|
||||
(stronger-prop (λ (this that)
|
||||
(and (flat-contract? that)
|
||||
(procedure-closure-contents-eq? (flat-contract-predicate this)
|
||||
|
|
@ -327,7 +303,7 @@
|
|||
(name-prop (λ (ctc) (flat-contract-the-name ctc)))
|
||||
(flat-prop (λ (ctc) (flat-contract-predicate ctc)))))
|
||||
(values make-flat-contract
|
||||
make-pair-proj-contract)))
|
||||
make-proj-contract)))
|
||||
|
||||
(define (flat-contract-predicate x)
|
||||
(unless (flat-contract? x)
|
||||
|
|
@ -335,10 +311,8 @@
|
|||
((flat-get x) x))
|
||||
(define (flat-contract? x) (flat-pred? x))
|
||||
(define (contract-name ctc) ((name-get ctc) ctc))
|
||||
(define (contract? x) (or (proj-pred? x) (pos-proj-pred? x)))
|
||||
(define (contract? x) (proj-pred? x))
|
||||
(define (contract-proc ctc) ((proj-get ctc) ctc))
|
||||
(define (contract-pos-proc ctc) ((pos-proj-get ctc) ctc))
|
||||
(define (contract-neg-proc ctc) ((neg-proj-get ctc) ctc))
|
||||
|
||||
(define (flat-contract predicate)
|
||||
(unless (and (procedure? predicate)
|
||||
|
|
@ -374,22 +348,21 @@
|
|||
`(,mk-sub-name ,@(loop (cdr subs))))]
|
||||
[else `(,sub ,@(loop (cdr subs)))]))])))
|
||||
|
||||
(define (make-and-proj proj-get)
|
||||
(λ (ctc)
|
||||
(let ([mk-pos-projs (map (λ (x) ((proj-get x) x)) (and/c-ctcs ctc))])
|
||||
(lambda (pos src-info orig-str)
|
||||
(let ([projs (map (λ (c) (c pos src-info orig-str)) mk-pos-projs)])
|
||||
(let loop ([projs (cdr projs)]
|
||||
[proj (car projs)])
|
||||
(cond
|
||||
[(null? projs) proj]
|
||||
[else (loop (cdr projs)
|
||||
(let ([f (car projs)])
|
||||
(λ (v) (proj (f v)))))])))))))
|
||||
(define (and-proj ctc)
|
||||
(let ([mk-pos-projs (map (λ (x) ((proj-get x) x)) (and/c-ctcs ctc))])
|
||||
(lambda (pos neg src-info orig-str)
|
||||
(let ([projs (map (λ (c) (c pos neg src-info orig-str)) mk-pos-projs)])
|
||||
(let loop ([projs (cdr projs)]
|
||||
[proj (car projs)])
|
||||
(cond
|
||||
[(null? projs) proj]
|
||||
[else (loop (cdr projs)
|
||||
(let ([f (car projs)])
|
||||
(λ (v) (proj (f v)))))]))))))
|
||||
|
||||
|
||||
(define-struct/prop and/c (ctcs)
|
||||
((pos-proj-prop (make-and-proj pos-proj-get))
|
||||
(neg-proj-prop (make-and-proj neg-proj-get))
|
||||
((proj-prop and-proj)
|
||||
(name-prop (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc))))
|
||||
(first-order-prop (λ (ctc)
|
||||
(let ([tests (map (λ (x) ((first-order-get x) x)) (and/c-ctcs ctc))])
|
||||
|
|
@ -438,8 +411,7 @@
|
|||
(make-and/c contracts))]))
|
||||
|
||||
(define-struct/prop any/c ()
|
||||
((pos-proj-prop any-curried-proj)
|
||||
(neg-proj-prop any-curried-proj)
|
||||
((proj-prop double-any-curried-proj)
|
||||
(stronger-prop (λ (this that) (any/c? that)))
|
||||
(name-prop (λ (ctc) 'any/c))
|
||||
(first-order-prop (λ (ctc) (λ (val) #t)))
|
||||
|
|
@ -448,20 +420,19 @@
|
|||
(define any/c (make-any/c))
|
||||
|
||||
(define (none-curried-proj ctc)
|
||||
(λ (pos src-info orig-str)
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(λ (val)
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos
|
||||
pos-blame
|
||||
orig-str
|
||||
"~s accepts no values, given: ~e"
|
||||
(none/c-name ctc)
|
||||
val))))
|
||||
|
||||
(define-struct/prop none/c (name)
|
||||
((pos-proj-prop none-curried-proj)
|
||||
(neg-proj-prop none-curried-proj)
|
||||
((proj-prop none-curried-proj)
|
||||
(stronger-prop (λ (this that) #t))
|
||||
(name-prop (λ (ctc) (none/c-name ctc)))
|
||||
(first-order-prop (λ (ctc) (λ (val) #f)))
|
||||
|
|
|
|||
|
|
@ -10,8 +10,6 @@ add struct contracts for immutable structs?
|
|||
(module contract mzscheme
|
||||
|
||||
(provide (rename -contract contract)
|
||||
(rename -contract/pos contract/pos)
|
||||
(rename -contract/neg contract/neg)
|
||||
recursive-contract
|
||||
provide/contract
|
||||
define/contract)
|
||||
|
|
@ -591,11 +589,12 @@ add struct contracts for immutable structs?
|
|||
(begin
|
||||
(provide (rename id-rename external-name))
|
||||
|
||||
;; unbound id check
|
||||
(if #f id)
|
||||
|
||||
(define pos-module-source (module-source-as-symbol #'pos-stx))
|
||||
(define contract-id ctrct)
|
||||
|
||||
(if #f id)
|
||||
;(check-first-order contract-id id #'pos-stx) ;; we'd like to use this ...
|
||||
|
||||
(define-syntax id-rename
|
||||
(make-provide/contract-transformer (quote-syntax contract-id)
|
||||
(quote-syntax id)
|
||||
|
|
@ -607,6 +606,10 @@ add struct contracts for immutable structs?
|
|||
(begin
|
||||
bodies ...))))]))
|
||||
|
||||
(define (check-first-order ctc val src-info)
|
||||
(-contract ctc val (module-source-as-symbol src-info) 'ignored src-info)
|
||||
(void))
|
||||
|
||||
(define (test-proc/flat-contract f x)
|
||||
(if (flat-contract? f)
|
||||
((flat-contract-predicate f) x)
|
||||
|
|
@ -661,67 +664,15 @@ add struct contracts for immutable structs?
|
|||
(((contract-proc a-contract) pos-blame neg-blame src-info (contract-name a-contract))
|
||||
name)))
|
||||
|
||||
(define-syntax (-contract/pos stx)
|
||||
(syntax-case stx ()
|
||||
[(_ a-contract to-check blame-e)
|
||||
(with-syntax ([src-loc (syntax/loc stx here)])
|
||||
(syntax/loc stx
|
||||
(contract/one/proc contract-pos-proc a-contract to-check blame-e (quote-syntax src-loc))))]
|
||||
[(_ a-contract-e to-check blame-e src-info-e)
|
||||
(syntax/loc stx
|
||||
(contract/one/proc contract-pos-proc a-contract-e to-check blame-e src-info-e))]))
|
||||
|
||||
(define-syntax (-contract/neg stx)
|
||||
(syntax-case stx ()
|
||||
[(_ a-contract to-check blame-e)
|
||||
(with-syntax ([src-loc (syntax/loc stx here)])
|
||||
(syntax/loc stx
|
||||
(contract/one/proc contract-neg-proc a-contract to-check blame-e (quote-syntax src-loc))))]
|
||||
[(_ a-contract-e to-check blame-e src-info-e)
|
||||
(syntax/loc stx
|
||||
(contract/one/proc contract-neg-proc a-contract-e to-check blame-e src-info-e))]))
|
||||
|
||||
(define (contract/one/proc contract-to-proc a-contract-raw name blame src-info)
|
||||
(unless (or (contract? a-contract-raw)
|
||||
(and (procedure? a-contract-raw)
|
||||
(procedure-arity-includes? a-contract-raw 1)))
|
||||
(error 'contract/pos "expected a contract or a procedure of arity 1 as first argument, given: ~e, other args ~e ~e ~e"
|
||||
a-contract-raw
|
||||
name
|
||||
blame
|
||||
src-info))
|
||||
(let ([a-contract (if (contract? a-contract-raw)
|
||||
a-contract-raw
|
||||
(flat-contract a-contract-raw))])
|
||||
(unless (symbol? blame)
|
||||
(error 'contract
|
||||
"expected symbol as name for assigning blame, given: ~e, other args ~e ~e ~e"
|
||||
blame
|
||||
a-contract-raw
|
||||
name
|
||||
src-info))
|
||||
(unless (syntax? src-info)
|
||||
(error 'contract "expected syntax as last argument, given: ~e, other args ~e ~e ~e"
|
||||
src-info
|
||||
blame
|
||||
a-contract-raw
|
||||
name))
|
||||
(((contract-to-proc a-contract) blame src-info (contract-name a-contract))
|
||||
name)))
|
||||
|
||||
(define-syntax (recursive-contract stx)
|
||||
(syntax-case stx ()
|
||||
[(_ arg)
|
||||
(syntax (make-pair-proj-contract
|
||||
(syntax (make-proj-contract
|
||||
'(recursive-contract arg)
|
||||
(λ (blame src str)
|
||||
(let ([proc (contract-pos-proc arg)])
|
||||
(λ (pos-blame neg-blame src str)
|
||||
(let ([proc (contract-proc arg)])
|
||||
(λ (val)
|
||||
((proc blame src str) val))))
|
||||
(λ (blame src str)
|
||||
(let ([proc (contract-neg-proc arg)])
|
||||
(λ (val)
|
||||
((proc blame src str) val))))
|
||||
((proc pos-blame neg-blame src str) val))))
|
||||
#f))]))
|
||||
|
||||
(define (check-contract ctc)
|
||||
|
|
@ -879,31 +830,18 @@ add struct contracts for immutable structs?
|
|||
(make-multi-or/c flat-contracts ho-contracts)])))]))
|
||||
|
||||
(define-struct/prop or/c (flat-ctcs ho-ctc)
|
||||
((pos-proj-prop (λ (ctc)
|
||||
(let ([c-proc ((pos-proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]
|
||||
[predicates (map (λ (x) ((flat-get x) x))
|
||||
(or/c-flat-ctcs ctc))])
|
||||
(λ (pos src-info orig-str)
|
||||
(let ([partial-contract (c-proc pos src-info orig-str)])
|
||||
(λ (val)
|
||||
(cond
|
||||
[(ormap (λ (pred) (pred val)) predicates)
|
||||
val]
|
||||
[else
|
||||
(partial-contract val)])))))))
|
||||
(neg-proj-prop
|
||||
(λ (ctc)
|
||||
(let ([c-proc ((neg-proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]
|
||||
[predicates (map (λ (x) ((flat-get x) x))
|
||||
(or/c-flat-ctcs ctc))])
|
||||
(λ (pos src-info orig-str)
|
||||
(let ([partial-contract (c-proc pos src-info orig-str)])
|
||||
(λ (val)
|
||||
(cond
|
||||
[(ormap (λ (pred) (pred val)) predicates)
|
||||
val]
|
||||
[else
|
||||
(partial-contract val)])))))))
|
||||
((proj-prop (λ (ctc)
|
||||
(let ([c-proc ((proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]
|
||||
[predicates (map (λ (x) ((flat-get x) x))
|
||||
(or/c-flat-ctcs ctc))])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-contract (c-proc pos-blame neg-blame src-info orig-str)])
|
||||
(λ (val)
|
||||
(cond
|
||||
[(ormap (λ (pred) (pred val)) predicates)
|
||||
val]
|
||||
[else
|
||||
(partial-contract val)])))))))
|
||||
|
||||
(name-prop (λ (ctc)
|
||||
(apply build-compound-type-name
|
||||
|
|
@ -972,9 +910,50 @@ add struct contracts for immutable structs?
|
|||
candidate-proc
|
||||
candidate-contract)]))])))))))
|
||||
|
||||
(define (multi-or/c-proj ctc)
|
||||
(let* ([ho-contracts (multi-or/c-ho-ctcs ctc)]
|
||||
[c-procs (map (λ (x) ((proj-get x) x)) ho-contracts)]
|
||||
[first-order-checks (map (λ (x) ((first-order-get x) x)) ho-contracts)]
|
||||
[predicates (map (λ (x) ((flat-get x) x))
|
||||
(multi-or/c-flat-ctcs ctc))])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-contracts (map (λ (c-proc) (c-proc pos-blame neg-blame src-info orig-str)) c-procs)])
|
||||
(λ (val)
|
||||
(cond
|
||||
[(ormap (λ (pred) (pred val)) predicates)
|
||||
val]
|
||||
[else
|
||||
(let loop ([checks first-order-checks]
|
||||
[procs partial-contracts]
|
||||
[contracts ho-contracts]
|
||||
[candidate-proc #f]
|
||||
[candidate-contract #f])
|
||||
(cond
|
||||
[(null? checks)
|
||||
(if candidate-proc
|
||||
(candidate-proc val)
|
||||
(raise-contract-error val src-info pos-blame orig-str
|
||||
"none of the branches of the or/c matched"))]
|
||||
[((car checks) val)
|
||||
(if candidate-proc
|
||||
(error 'or/c "two arguments, ~s and ~s, might both match ~s"
|
||||
(contract-name candidate-contract)
|
||||
(contract-name (car contracts))
|
||||
val)
|
||||
(loop (cdr checks)
|
||||
(cdr procs)
|
||||
(cdr contracts)
|
||||
(car procs)
|
||||
(car contracts)))]
|
||||
[else
|
||||
(loop (cdr checks)
|
||||
(cdr procs)
|
||||
(cdr contracts)
|
||||
candidate-proc
|
||||
candidate-contract)]))]))))))
|
||||
|
||||
(define-struct/prop multi-or/c (flat-ctcs ho-ctcs)
|
||||
((pos-proj-prop (make-multi-or/c-proj pos-proj-get))
|
||||
(neg-proj-prop (make-multi-or/c-proj neg-proj-get))
|
||||
((proj-prop multi-or/c-proj)
|
||||
(name-prop (λ (ctc)
|
||||
(apply build-compound-type-name
|
||||
'or/c
|
||||
|
|
@ -1006,8 +985,7 @@ add struct contracts for immutable structs?
|
|||
that-ctcs))))))))
|
||||
|
||||
(define-struct/prop flat-or/c (flat-ctcs)
|
||||
((pos-proj-prop flat-pos-proj)
|
||||
(neg-proj-prop any-curried-proj)
|
||||
((proj-prop flat-proj)
|
||||
(name-prop (λ (ctc)
|
||||
(apply build-compound-type-name
|
||||
'or/c
|
||||
|
|
@ -1063,8 +1041,7 @@ add struct contracts for immutable structs?
|
|||
(make-one-of/c elems))
|
||||
|
||||
(define-struct/prop one-of/c (elems)
|
||||
((pos-proj-prop flat-pos-proj)
|
||||
(neg-proj-prop any-curried-proj)
|
||||
((proj-prop flat-proj)
|
||||
(name-prop (λ (ctc)
|
||||
(let ([elems (one-of/c-elems ctc)])
|
||||
`(,(cond
|
||||
|
|
@ -1109,8 +1086,7 @@ add struct contracts for immutable structs?
|
|||
(printable? (unbox x))))))))
|
||||
|
||||
(define-struct/prop between/c (low high)
|
||||
((pos-proj-prop flat-pos-proj)
|
||||
(neg-proj-prop any-curried-proj)
|
||||
((proj-prop flat-proj)
|
||||
(name-prop (λ (ctc)
|
||||
(let ([n (between/c-low ctc)]
|
||||
[m (between/c-high ctc)])
|
||||
|
|
@ -1210,27 +1186,22 @@ add struct contracts for immutable structs?
|
|||
(let ([fill-name fill])
|
||||
(λ (input)
|
||||
(let* ([ctc (coerce-contract 'name input)]
|
||||
[p-proj (contract-pos-proc ctc)]
|
||||
[n-proj (contract-neg-proc ctc)])
|
||||
(make-pair-proj-contract
|
||||
[proj (contract-proc ctc)])
|
||||
(make-proj-contract
|
||||
(build-compound-type-name 'name ctc)
|
||||
(λ (blame src-info orig-str)
|
||||
(let ([p-app (p-proj blame src-info orig-str)])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([p-app (proj pos-blame neg-blame src-info orig-str)])
|
||||
(λ (val)
|
||||
(unless (predicate? val)
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
blame
|
||||
pos-blame
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
'type-name
|
||||
val))
|
||||
(fill-name p-app val))))
|
||||
(λ (blame src-info orig-str)
|
||||
(let ([n-app (n-proj blame src-info orig-str)])
|
||||
(λ (val)
|
||||
(fill-name n-app val))))
|
||||
predicate?)))))]))
|
||||
|
||||
(define (map-immutable f lst)
|
||||
|
|
@ -1316,8 +1287,7 @@ add struct contracts for immutable structs?
|
|||
(with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))]
|
||||
[(p-apps ...) (generate-temporaries (syntax (selectors ...)))]
|
||||
[(ctc-x ...) (generate-temporaries (syntax (selectors ...)))]
|
||||
[(pos-procs ...) (generate-temporaries (syntax (selectors ...)))]
|
||||
[(neg-procs ...) (generate-temporaries (syntax (selectors ...)))]
|
||||
[(procs ...) (generate-temporaries (syntax (selectors ...)))]
|
||||
[(selector-names ...) (generate-temporaries (syntax (selectors ...)))])
|
||||
(syntax
|
||||
(let ([predicate?-name predicate?]
|
||||
|
|
@ -1325,13 +1295,11 @@ add struct contracts for immutable structs?
|
|||
[selector-names selectors] ...)
|
||||
(λ (params ...)
|
||||
(let ([ctc-x (coerce-contract 'name params)] ...)
|
||||
(let ([pos-procs (contract-pos-proc ctc-x)]
|
||||
...
|
||||
[neg-procs (contract-neg-proc ctc-x)] ...)
|
||||
(make-pair-proj-contract
|
||||
(let ([procs (contract-proc ctc-x)] ...)
|
||||
(make-proj-contract
|
||||
(build-compound-type-name 'name (proc/ctc->ctc params) ...)
|
||||
(λ (blame src-info orig-str)
|
||||
(let ([p-apps (pos-procs blame src-info orig-str)] ...)
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([p-apps (procs pos-blame neg-blame src-info orig-str)] ...)
|
||||
(λ (v)
|
||||
(if (and (immutable? v)
|
||||
(predicate?-name v))
|
||||
|
|
@ -1339,15 +1307,11 @@ add struct contracts for immutable structs?
|
|||
(raise-contract-error
|
||||
v
|
||||
src-info
|
||||
blame
|
||||
pos-blame
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
'type-name
|
||||
v)))))
|
||||
(λ (blame src-info orig-str)
|
||||
(let ([p-apps (neg-procs blame src-info orig-str)] ...)
|
||||
(λ (v)
|
||||
(constructor-name (p-apps (selector-names v)) ...))))
|
||||
#f)))))))]
|
||||
[(_ predicate? constructor (arb? selector) correct-size type-name name)
|
||||
(eq? #t (syntax-object->datum (syntax arb?)))
|
||||
|
|
@ -1357,12 +1321,11 @@ add struct contracts for immutable structs?
|
|||
[selector-name selector])
|
||||
(λ params
|
||||
(let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)])
|
||||
(let ([pos-procs (map contract-pos-proc ctcs)]
|
||||
[neg-procs (map contract-neg-proc ctcs)])
|
||||
(make-pair-proj-contract
|
||||
(let ([procs (map contract-proc ctcs)])
|
||||
(make-proj-contract
|
||||
(apply build-compound-type-name 'name (map proc/ctc->ctc params))
|
||||
(λ (blame src-info orig-str)
|
||||
(let ([p-apps (map (λ (proc) (proc blame src-info orig-str)) pos-procs)]
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([p-apps (map (λ (proc) (proc pos-blame neg-blame src-info orig-str)) procs)]
|
||||
[count (length params)])
|
||||
(λ (v)
|
||||
(if (and (immutable? v)
|
||||
|
|
@ -1379,22 +1342,11 @@ add struct contracts for immutable structs?
|
|||
(raise-contract-error
|
||||
v
|
||||
src-info
|
||||
blame
|
||||
pos-blame
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
'type-name
|
||||
v)))))
|
||||
(λ (blame src-info orig-str)
|
||||
(let ([p-apps (map (λ (proc) (proc blame src-info orig-str)) neg-procs)])
|
||||
(λ (v)
|
||||
(apply constructor-name
|
||||
(let loop ([p-apps p-apps]
|
||||
[i 0])
|
||||
(cond
|
||||
[(null? p-apps) null]
|
||||
[else (let ([p-app (car p-apps)])
|
||||
(cons (p-app (selector-name v i))
|
||||
(loop (cdr p-apps) (+ i 1))))]))))))
|
||||
#f))))))]))
|
||||
|
||||
(define cons-immutable/c (*-immutable/c pair? cons-immutable (#f car cdr) immutable-cons cons-immutable/c))
|
||||
|
|
@ -1451,27 +1403,22 @@ add struct contracts for immutable structs?
|
|||
(define promise/c
|
||||
(λ (ctc-in)
|
||||
(let* ([ctc (coerce-contract 'promise/c ctc-in)]
|
||||
[pos-ctc-proc (contract-pos-proc ctc)]
|
||||
[neg-ctc-proc (contract-neg-proc ctc)])
|
||||
(make-pair-proj-contract
|
||||
[ctc-proc (contract-proc ctc)])
|
||||
(make-proj-contract
|
||||
(build-compound-type-name 'promise/c ctc)
|
||||
(λ (blame src-info orig-str)
|
||||
(let ([p-app (pos-ctc-proc blame src-info orig-str)])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([p-app (ctc-proc pos-blame neg-blame src-info orig-str)])
|
||||
(λ (val)
|
||||
(unless (promise? val)
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
blame
|
||||
pos-blame
|
||||
'ignored
|
||||
orig-str
|
||||
"expected <promise>, given: ~e"
|
||||
val))
|
||||
(delay (p-app (force val))))))
|
||||
(λ (blame src-info orig-str)
|
||||
(let ([p-app (neg-ctc-proc blame src-info orig-str)])
|
||||
(λ (val)
|
||||
(delay (p-app (force val))))))
|
||||
promise?))))
|
||||
|
||||
#|
|
||||
|
|
|
|||
|
|
@ -12,15 +12,6 @@
|
|||
(define info? (opt-> (symbol?) ((-> any/c)) any/c))
|
||||
(define path-or-string? (lambda (x) (or (path? x) (string? x))))
|
||||
|
||||
(provide/contract
|
||||
(get-info ((listof path-or-string?) . -> . (or/c info? boolean?)))
|
||||
(get-info/full (path? . -> . (or/c info? boolean?)))
|
||||
(find-relevant-directories (opt-> ((listof symbol?))
|
||||
((lambda (x) (or (eq? x 'preferred)
|
||||
(eq? x 'all-available))))
|
||||
(listof path?))))
|
||||
|
||||
|
||||
|
||||
;; in addition to infodomain/compiled/cache.ss, getinfo will look in this
|
||||
;; file to find mappings. PLaneT uses this to put info about installed
|
||||
|
|
@ -175,4 +166,12 @@
|
|||
(define (compare-directories a b)
|
||||
(let-values ([(base1 name1 dir?1) (split-path a)]
|
||||
[(base2 name2 dir?2) (split-path b)])
|
||||
(bytes<? (path->bytes name1) (path->bytes name2)))))
|
||||
(bytes<? (path->bytes name1) (path->bytes name2))))
|
||||
|
||||
(provide/contract
|
||||
(get-info ((listof path-or-string?) . -> . (or/c info? boolean?)))
|
||||
(get-info/full (path? . -> . (or/c info? boolean?)))
|
||||
(find-relevant-directories (opt-> ((listof symbol?))
|
||||
((lambda (x) (or (eq? x 'preferred)
|
||||
(eq? x 'all-available))))
|
||||
(listof path?)))))
|
||||
|
|
|
|||
|
|
@ -5,12 +5,6 @@
|
|||
"stx.ss")
|
||||
(require-for-template mzscheme)
|
||||
|
||||
(provide/contract
|
||||
[build-struct-names
|
||||
(opt-> (identifier? (listof identifier?) boolean? boolean?)
|
||||
((union false/c syntax?))
|
||||
(listof identifier?))])
|
||||
|
||||
(provide parse-define-struct
|
||||
|
||||
build-struct-generation
|
||||
|
|
@ -326,4 +320,10 @@
|
|||
(syntax-property result
|
||||
'disappeared-use
|
||||
(syntax-local-introduce super-id))
|
||||
result))))))
|
||||
result)))))
|
||||
|
||||
(provide/contract
|
||||
[build-struct-names
|
||||
(opt-> (identifier? (listof identifier?) boolean? boolean?)
|
||||
((union false/c syntax?))
|
||||
(listof identifier?))]))
|
||||
|
|
|
|||
|
|
@ -2,9 +2,6 @@
|
|||
(require (lib "contract.ss")
|
||||
(lib "stx.ss" "syntax"))
|
||||
|
||||
(provide/contract [syntax->string (-> (and/c syntax? stx-list?)
|
||||
string?)])
|
||||
|
||||
(require (lib "list.ss"))
|
||||
|
||||
(define (syntax->string c)
|
||||
|
|
@ -69,4 +66,7 @@
|
|||
(set! col (+ col (string-length s)))
|
||||
(display s))])))
|
||||
(for-each (loop (lambda () (set! col init-col))) l))
|
||||
(get-output-string s))))
|
||||
(get-output-string s)))
|
||||
|
||||
(provide/contract [syntax->string (-> (and/c syntax? stx-list?)
|
||||
string?)]))
|
||||
|
|
@ -1505,271 +1505,6 @@
|
|||
x))
|
||||
(eval '(require contract-test-suite-define1))))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract1
|
||||
'(let ()
|
||||
(eval '(module contract-test-suite1 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define x 1)
|
||||
(provide/contract (x integer?))))
|
||||
(eval '(require contract-test-suite1))
|
||||
(eval 'x)))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract2
|
||||
'(let ()
|
||||
(eval '(module contract-test-suite2 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(provide/contract)))
|
||||
(eval '(require contract-test-suite2))))
|
||||
|
||||
(test/spec-failed
|
||||
'provide/contract3
|
||||
'(let ()
|
||||
(eval '(module contract-test-suite3 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define x #f)
|
||||
(provide/contract (x integer?))))
|
||||
(eval '(require contract-test-suite3))
|
||||
(eval 'x))
|
||||
"contract-test-suite3")
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract4
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module contract-test-suite4 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct s (a))
|
||||
(provide/contract (struct s ((a any/c))))))
|
||||
(eval '(require contract-test-suite4))
|
||||
(eval '(list (make-s 1)
|
||||
(s-a (make-s 1))
|
||||
(s? (make-s 1))
|
||||
(set-s-a! (make-s 1) 2)))))
|
||||
|
||||
(test/spec-passed/result
|
||||
'provide/contract4-b
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module contract-test-suite4-b mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct s (a b))
|
||||
(provide/contract (struct s ((a any/c) (b any/c))))))
|
||||
(eval '(require contract-test-suite4-b))
|
||||
(eval '(let ([an-s (make-s 1 2)])
|
||||
(list (s-a an-s)
|
||||
(s-b an-s)
|
||||
(begin (set-s-a! an-s 3)
|
||||
(s-a an-s))
|
||||
(begin (set-s-b! an-s 4)
|
||||
(s-b an-s))))))
|
||||
|
||||
(list 1 2 3 4))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract5
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module contract-test-suite5 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct s (a))
|
||||
(define-struct t (a))
|
||||
(provide/contract (struct s ((a any/c)))
|
||||
(struct t ((a any/c))))))
|
||||
(eval '(require contract-test-suite5))
|
||||
(eval '(list (make-s 1)
|
||||
(s-a (make-s 1))
|
||||
(s? (make-s 1))
|
||||
(set-s-a! (make-s 1) 2)
|
||||
(make-t 1)
|
||||
(t-a (make-t 1))
|
||||
(t? (make-t 1))
|
||||
(set-t-a! (make-t 1) 2)))))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract6
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module contract-test-suite6 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct s (a))
|
||||
(provide/contract (struct s ((a any/c))))))
|
||||
(eval '(require contract-test-suite6))
|
||||
(eval '(define-struct (t s) ()))))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract6
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module contract-test-suite6 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct s (a))
|
||||
(provide/contract (struct s ((a any/c))))))
|
||||
(eval '(require contract-test-suite6))
|
||||
(eval '(define-struct (t s) ()))))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract6b
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module contract-test-suite6b mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct s_ (a))
|
||||
(provide/contract (struct s_ ((a any/c))))))
|
||||
(eval '(require contract-test-suite6b))
|
||||
(eval '(module contract-test-suite6b2 mzscheme
|
||||
(require contract-test-suite6b)
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct (t_ s_) (b))
|
||||
(provide s_-a)
|
||||
(provide/contract (struct (t_ s_) ((a any/c) (b any/c))))))
|
||||
(eval '(require contract-test-suite6b2))
|
||||
(eval '(define-struct (u_ t_) ()))
|
||||
(eval '(s_-a (make-u_ 1 2)))))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract7
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module contract-test-suite7 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct s (a b))
|
||||
(define-struct (t s) (c d))
|
||||
(provide/contract
|
||||
(struct s ((a any/c) (b any/c)))
|
||||
(struct (t s) ((a any/c) (b any/c) (c any/c) (d any/c))))))
|
||||
(eval '(require contract-test-suite7))
|
||||
(eval '(let ([x (make-t 1 2 3 4)])
|
||||
(s-a x)
|
||||
(s-b x)
|
||||
(t-c x)
|
||||
(t-d x)
|
||||
(void)))))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract8
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module contract-test-suite8 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct i-s (contents))
|
||||
(define (w-f-s? x) #t)
|
||||
(provide/contract
|
||||
(struct i-s ((contents (flat-named-contract "integer-set-list" w-f-s?)))))))
|
||||
(eval '(require contract-test-suite8))
|
||||
(eval '(i-s-contents (make-i-s 1)))))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract9
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module contract-test-suite9 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define the-internal-name 1)
|
||||
(provide/contract (rename the-internal-name the-external-name integer?))
|
||||
(+ the-internal-name 1)))
|
||||
(eval '(require contract-test-suite9))
|
||||
(eval '(+ the-external-name 1))))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract10
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module m mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct s (a b) (make-inspector))
|
||||
(provide/contract (struct s ((a number?) (b number?))))))
|
||||
(eval '(module n mzscheme
|
||||
(require (lib "struct.ss")
|
||||
m)
|
||||
(print-struct #t)
|
||||
(copy-struct s
|
||||
(make-s 1 2)
|
||||
[s-a 3])))
|
||||
(eval '(require n))))
|
||||
|
||||
;; this test is broken, not sure why
|
||||
#|
|
||||
(test/spec-failed
|
||||
'provide/contract11
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module m mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct s (a b) (make-inspector))
|
||||
(provide/contract (struct s ((a number?) (b number?))))))
|
||||
(eval '(module n mzscheme
|
||||
(require (lib "struct.ss")
|
||||
m)
|
||||
(print-struct #t)
|
||||
(copy-struct s
|
||||
(make-s 1 2)
|
||||
[s-a #f])))
|
||||
(eval '(require n)))
|
||||
'n)
|
||||
|#
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract12
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module m mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct (exn2 exn) ())
|
||||
(provide/contract (struct (exn2 exn) ((message any/c) (continuation-marks any/c))))))
|
||||
(eval '(require m))))
|
||||
|
||||
(test/spec-passed/result
|
||||
'provide/contract13
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module common-msg-structs mzscheme
|
||||
(require (lib "contract.ss" "mzlib"))
|
||||
(define-struct register (name type) (make-inspector))
|
||||
(provide/contract (struct register ([name any/c] [type any/c])))))
|
||||
|
||||
(eval '(require common-msg-structs))
|
||||
(eval '(require (lib "plt-match.ss")))
|
||||
(eval '(match (make-register 1 2)
|
||||
[(struct register (name type))
|
||||
(list name type)])))
|
||||
(list 1 2))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract14
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module test1 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
|
||||
(define-struct type (flags))
|
||||
(define-struct (type:ptr type) (type))
|
||||
|
||||
(provide/contract
|
||||
(struct type
|
||||
([flags (listof string?)]))
|
||||
|
||||
(struct (type:ptr type)
|
||||
([flags (listof string?)] [type type?])))))
|
||||
|
||||
(eval '(module test2 mzscheme
|
||||
(require (lib "plt-match.ss"))
|
||||
(require test1)
|
||||
(match (make-type:ptr '() (make-type '()))
|
||||
[(struct type:ptr (flags type)) #f])))
|
||||
(eval '(require test2))))
|
||||
|
||||
|
||||
;; provide/contract should signal errors without requiring a reference to the variable
|
||||
;; this test is bogus, because provide/contract'd variables can be set!'d.
|
||||
#;
|
||||
(test/pos-blame
|
||||
'provide/contract15
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module pos mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define i #f)
|
||||
(provide/contract [i integer?])))
|
||||
(eval '(require pos))))
|
||||
|
||||
;; this is really a positive violation, but name the module `neg' just for an addl test
|
||||
#;
|
||||
(test/neg-blame
|
||||
'provide/contract16
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module neg mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define i #f)
|
||||
(provide/contract [i integer?])))
|
||||
(eval '(require neg))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -4481,7 +4216,286 @@
|
|||
(test-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?)
|
||||
(or/c boolean? (-> (>=/c 5) (>=/c 5))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; provide/contract tests
|
||||
;; (at the end, becuase they are slow w/out .zo files)
|
||||
;;
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract1
|
||||
'(let ()
|
||||
(eval '(module contract-test-suite1 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define x 1)
|
||||
(provide/contract (x integer?))))
|
||||
(eval '(require contract-test-suite1))
|
||||
(eval 'x)))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract2
|
||||
'(let ()
|
||||
(eval '(module contract-test-suite2 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(provide/contract)))
|
||||
(eval '(require contract-test-suite2))))
|
||||
|
||||
(test/spec-failed
|
||||
'provide/contract3
|
||||
'(let ()
|
||||
(eval '(module contract-test-suite3 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define x #f)
|
||||
(provide/contract (x integer?))))
|
||||
(eval '(require contract-test-suite3))
|
||||
(eval 'x))
|
||||
"contract-test-suite3")
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract4
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module contract-test-suite4 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct s (a))
|
||||
(provide/contract (struct s ((a any/c))))))
|
||||
(eval '(require contract-test-suite4))
|
||||
(eval '(list (make-s 1)
|
||||
(s-a (make-s 1))
|
||||
(s? (make-s 1))
|
||||
(set-s-a! (make-s 1) 2)))))
|
||||
|
||||
(test/spec-passed/result
|
||||
'provide/contract4-b
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module contract-test-suite4-b mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct s (a b))
|
||||
(provide/contract (struct s ((a any/c) (b any/c))))))
|
||||
(eval '(require contract-test-suite4-b))
|
||||
(eval '(let ([an-s (make-s 1 2)])
|
||||
(list (s-a an-s)
|
||||
(s-b an-s)
|
||||
(begin (set-s-a! an-s 3)
|
||||
(s-a an-s))
|
||||
(begin (set-s-b! an-s 4)
|
||||
(s-b an-s))))))
|
||||
|
||||
(list 1 2 3 4))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract5
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module contract-test-suite5 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct s (a))
|
||||
(define-struct t (a))
|
||||
(provide/contract (struct s ((a any/c)))
|
||||
(struct t ((a any/c))))))
|
||||
(eval '(require contract-test-suite5))
|
||||
(eval '(list (make-s 1)
|
||||
(s-a (make-s 1))
|
||||
(s? (make-s 1))
|
||||
(set-s-a! (make-s 1) 2)
|
||||
(make-t 1)
|
||||
(t-a (make-t 1))
|
||||
(t? (make-t 1))
|
||||
(set-t-a! (make-t 1) 2)))))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract6
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module contract-test-suite6 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct s (a))
|
||||
(provide/contract (struct s ((a any/c))))))
|
||||
(eval '(require contract-test-suite6))
|
||||
(eval '(define-struct (t s) ()))))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract6
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module contract-test-suite6 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct s (a))
|
||||
(provide/contract (struct s ((a any/c))))))
|
||||
(eval '(require contract-test-suite6))
|
||||
(eval '(define-struct (t s) ()))))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract6b
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module contract-test-suite6b mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct s_ (a))
|
||||
(provide/contract (struct s_ ((a any/c))))))
|
||||
(eval '(require contract-test-suite6b))
|
||||
(eval '(module contract-test-suite6b2 mzscheme
|
||||
(require contract-test-suite6b)
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct (t_ s_) (b))
|
||||
(provide s_-a)
|
||||
(provide/contract (struct (t_ s_) ((a any/c) (b any/c))))))
|
||||
(eval '(require contract-test-suite6b2))
|
||||
(eval '(define-struct (u_ t_) ()))
|
||||
(eval '(s_-a (make-u_ 1 2)))))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract7
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module contract-test-suite7 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct s (a b))
|
||||
(define-struct (t s) (c d))
|
||||
(provide/contract
|
||||
(struct s ((a any/c) (b any/c)))
|
||||
(struct (t s) ((a any/c) (b any/c) (c any/c) (d any/c))))))
|
||||
(eval '(require contract-test-suite7))
|
||||
(eval '(let ([x (make-t 1 2 3 4)])
|
||||
(s-a x)
|
||||
(s-b x)
|
||||
(t-c x)
|
||||
(t-d x)
|
||||
(void)))))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract8
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module contract-test-suite8 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct i-s (contents))
|
||||
(define (w-f-s? x) #t)
|
||||
(provide/contract
|
||||
(struct i-s ((contents (flat-named-contract "integer-set-list" w-f-s?)))))))
|
||||
(eval '(require contract-test-suite8))
|
||||
(eval '(i-s-contents (make-i-s 1)))))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract9
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module contract-test-suite9 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define the-internal-name 1)
|
||||
(provide/contract (rename the-internal-name the-external-name integer?))
|
||||
(+ the-internal-name 1)))
|
||||
(eval '(require contract-test-suite9))
|
||||
(eval '(+ the-external-name 1))))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract10
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module m mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct s (a b) (make-inspector))
|
||||
(provide/contract (struct s ((a number?) (b number?))))))
|
||||
(eval '(module n mzscheme
|
||||
(require (lib "struct.ss")
|
||||
m)
|
||||
(print-struct #t)
|
||||
(copy-struct s
|
||||
(make-s 1 2)
|
||||
[s-a 3])))
|
||||
(eval '(require n))))
|
||||
|
||||
;; this test is broken, not sure why
|
||||
#|
|
||||
(test/spec-failed
|
||||
'provide/contract11
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module m mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct s (a b) (make-inspector))
|
||||
(provide/contract (struct s ((a number?) (b number?))))))
|
||||
(eval '(module n mzscheme
|
||||
(require (lib "struct.ss")
|
||||
m)
|
||||
(print-struct #t)
|
||||
(copy-struct s
|
||||
(make-s 1 2)
|
||||
[s-a #f])))
|
||||
(eval '(require n)))
|
||||
'n)
|
||||
|#
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract12
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module m mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define-struct (exn2 exn) ())
|
||||
(provide/contract (struct (exn2 exn) ((message any/c) (continuation-marks any/c))))))
|
||||
(eval '(require m))))
|
||||
|
||||
(test/spec-passed/result
|
||||
'provide/contract13
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module common-msg-structs mzscheme
|
||||
(require (lib "contract.ss" "mzlib"))
|
||||
(define-struct register (name type) (make-inspector))
|
||||
(provide/contract (struct register ([name any/c] [type any/c])))))
|
||||
|
||||
(eval '(require common-msg-structs))
|
||||
(eval '(require (lib "plt-match.ss")))
|
||||
(eval '(match (make-register 1 2)
|
||||
[(struct register (name type))
|
||||
(list name type)])))
|
||||
(list 1 2))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract14
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module test1 mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
|
||||
(define-struct type (flags))
|
||||
(define-struct (type:ptr type) (type))
|
||||
|
||||
(provide/contract
|
||||
(struct type
|
||||
([flags (listof string?)]))
|
||||
|
||||
(struct (type:ptr type)
|
||||
([flags (listof string?)] [type type?])))))
|
||||
|
||||
(eval '(module test2 mzscheme
|
||||
(require (lib "plt-match.ss"))
|
||||
(require test1)
|
||||
(match (make-type:ptr '() (make-type '()))
|
||||
[(struct type:ptr (flags type)) #f])))
|
||||
(eval '(require test2))))
|
||||
|
||||
;; make sure unbound identifier exception is raised.
|
||||
(error-test
|
||||
#'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module pos mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(provide/contract [i any/c]))))
|
||||
exn:fail:syntax?)
|
||||
|
||||
;; provide/contract should signal errors without requiring a reference to the variable
|
||||
;; this test is bogus, because provide/contract'd variables can be set!'d.
|
||||
#;
|
||||
(test/pos-blame
|
||||
'provide/contract15
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module pos mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define i #f)
|
||||
(provide/contract [i integer?])))
|
||||
(eval '(require pos))))
|
||||
|
||||
;; this is really a positive violation, but name the module `neg' just for an addl test
|
||||
#;
|
||||
(test/neg-blame
|
||||
'provide/contract16
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module neg mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define i #f)
|
||||
(provide/contract [i integer?])))
|
||||
(eval '(require neg))))
|
||||
|
||||
|
||||
|
||||
))
|
||||
(report-errs)
|
||||
|
|
|
|||
|
|
@ -3,9 +3,6 @@
|
|||
(require "xml.ss"
|
||||
(lib "contract.ss"))
|
||||
|
||||
(provide read-plist)
|
||||
(provide/contract [write-plist (xexpr? output-port? . -> . void?)])
|
||||
|
||||
; a dict is (list 'dict assoc-pair ...)
|
||||
; an assoc-pair is (list 'assoc-pair key value)
|
||||
; a key is a string
|
||||
|
|
@ -193,8 +190,6 @@
|
|||
'(equal? new-dict my-dict)
|
||||
|
||||
;; END OF TEST
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
(provide read-plist)
|
||||
(provide/contract [write-plist (xexpr? output-port? . -> . void?)]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user