diff --git a/.mailmap b/.mailmap index ac4210bdd8..c5e6f1401e 100644 --- a/.mailmap +++ b/.mailmap @@ -11,6 +11,7 @@ Matthew Flatt Matthew Flatt Matthew Flatt Matthew Flatt +Matthew Flatt Kathy Gray Kathy Gray Matthias Felleisen diff --git a/collects/2htdp/batch-io.rkt b/collects/2htdp/batch-io.rkt index e55a9f59d4..0d0f9d922f 100644 --- a/collects/2htdp/batch-io.rkt +++ b/collects/2htdp/batch-io.rkt @@ -1,7 +1,12 @@ -#lang racket +#lang racket/base -(require (for-syntax syntax/parse) - srfi/13 htdp/error +(require racket/function + racket/file + racket/string + racket/local + (for-syntax racket/base + syntax/parse) + htdp/error (rename-in lang/prim (first-order->higher-order f2h)) "private/csv/csv.rkt") @@ -163,10 +168,13 @@ ;; split : String [Regexp] -> [Listof String] ;; splits a string into a list of substrings using the given delimiter ;; (white space by default) +;;ELI: This shouldn't be needed now, it can use `string-split' as is +;; (also, the trimming doesn't make sense if the pattern is not a +;; space--?) (define (split str [ptn #rx"[ ]+"]) - (regexp-split ptn (string-trim-both str))) + (regexp-split ptn (string-trim str))) ;; split-lines : String -> Listof[String] ;; splits a string with newlines into a list of lines (define (split-lines str) - (map string-trim-both (split str "\r*\n"))) + (map string-trim (split str "\r*\n"))) diff --git a/collects/2htdp/private/check-aux.rkt b/collects/2htdp/private/check-aux.rkt index 851b125799..c65e2e6818 100644 --- a/collects/2htdp/private/check-aux.rkt +++ b/collects/2htdp/private/check-aux.rkt @@ -1,6 +1,10 @@ -#lang racket +#lang racket/base -(require htdp/error) +(require racket/class + racket/list + racket/bool + racket/match + htdp/error) (provide (all-defined-out)) diff --git a/collects/2htdp/private/clauses-spec-and-process.rkt b/collects/2htdp/private/clauses-spec-and-process.rkt index a031791162..1f130d718a 100644 --- a/collects/2htdp/private/clauses-spec-and-process.rkt +++ b/collects/2htdp/private/clauses-spec-and-process.rkt @@ -1,9 +1,9 @@ -#lang racket +#lang racket/base ;; --------------------------------------------------------------------------------------------------- ;; provides functions for specifying the shape of big-bang and universe clauses: -(provide function-with-arity expr-with-check except err) +(provide function-with-arity expr-with-check err) ;; ... and for checking and processing them @@ -12,9 +12,13 @@ ->args contains-clause?) -(require - (for-syntax syntax/parse) - (for-template "clauses-spec-aux.rkt" racket (rename-in lang/prim (first-order->higher-order f2h)))) +(require racket/function + racket/list + racket/bool + (for-syntax racket/base syntax/parse) + (for-template "clauses-spec-aux.rkt" + racket + (rename-in lang/prim (first-order->higher-order f2h)))) ;; --------------------------------------------------------------------------------------------------- ;; specifying the shape of clauses @@ -28,15 +32,15 @@ [(_ x) #`(check> #,tag x)] [_ (err tag p msg)])))])) -(define-syntax function-with-arity - (syntax-rules (except) +(define-syntax function-with-arity + (syntax-rules () [(_ arity) (lambda (tag) (lambda (p) (syntax-case p () [(_ x) #`(proc> #,tag (f2h x) arity)] [_ (err tag p)])))] - [(_ arity except extra ...) + [(_ arity #:except extra ...) (lambda (tag) (lambda (p) (syntax-case p () diff --git a/collects/2htdp/private/clauses-spec-aux.rkt b/collects/2htdp/private/clauses-spec-aux.rkt index 28487df29a..b3837451e0 100644 --- a/collects/2htdp/private/clauses-spec-aux.rkt +++ b/collects/2htdp/private/clauses-spec-aux.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang racket/base ;; --------------------------------------------------------------------------------------------------- ;; provides constants and functions for specifying the shape of clauses in big-bang and universe @@ -6,7 +6,7 @@ (provide nat> nat? proc> bool> num> ip> string> symbol> string-or-symbol> any> K False True) (require htdp/error "check-aux.rkt") - + (define (K w . r) w) (define (False w) #f) (define (True w) #t) diff --git a/collects/2htdp/private/define-keywords.rkt b/collects/2htdp/private/define-keywords.rkt index 7a59aa2da8..c0cdd4fa36 100644 --- a/collects/2htdp/private/define-keywords.rkt +++ b/collects/2htdp/private/define-keywords.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang racket/base ;; --------------------------------------------------------------------------------------------------- ;; provide a mechanism for defining the shape of big-bang and universe clauses @@ -6,7 +6,8 @@ (provide define-keywords DEFAULT) -(require (for-syntax syntax/parse)) +(require racket/class + (for-syntax racket/base syntax/parse)) (define-syntax (DEFAULT stx) (raise-syntax-error 'DEFAULT "used out of context" stx)) diff --git a/collects/2htdp/private/design.txt b/collects/2htdp/private/design.txt index 838f645f01..a9d7c6b259 100644 --- a/collects/2htdp/private/design.txt +++ b/collects/2htdp/private/design.txt @@ -1,17 +1,15 @@ +Files for constructing universe.rkt: -Files for constructing universe.rkt: + world.rkt the old world + world% = (clock-mixin ...) -- the basic world + aworld% = (class world% ...) -- the world with recording - world.rkt the old world - world% = (clock-mixin ...) -- the basic world - aworld% = (class world% ...) -- the world with recording - - universe.rkt the universe server - universe% = (clock-mixin ...) -- the basic universe + universe.rkt the universe server + universe% = (clock-mixin ...) -- the basic universe timer.rkt the clock-mixin - check-aux.rkt common primitives - image.rkt the world image functions - clauses-spec-and-process.rkt syntactic auxiliaries - clauses-spec-aux.rkt auxiliaries to the syntactic auxiliaries - + check-aux.rkt common primitives + image.rkt the world image functions + clauses-spec-and-process.rkt syntactic auxiliaries + clauses-spec-aux.rkt auxiliaries to the syntactic auxiliaries diff --git a/collects/2htdp/private/launch-many-worlds.rkt b/collects/2htdp/private/launch-many-worlds.rkt index 1ecbb1d032..88da624f20 100644 --- a/collects/2htdp/private/launch-many-worlds.rkt +++ b/collects/2htdp/private/launch-many-worlds.rkt @@ -1,6 +1,7 @@ -#lang racket +#lang racket/base -(require mred/mred mzlib/etc htdp/error) +(require racket/list racket/function racket/gui + mzlib/etc htdp/error) (provide ;; (launch-many-worlds e1 ... e2) diff --git a/collects/2htdp/private/utilities.rkt b/collects/2htdp/private/utilities.rkt index 5d03ab6e22..2c2f04b1fc 100644 --- a/collects/2htdp/private/utilities.rkt +++ b/collects/2htdp/private/utilities.rkt @@ -1,4 +1,6 @@ -#lang racket +#lang racket/base + +(require racket/contract) (provide/contract ;; like the unix debugging facility diff --git a/collects/2htdp/uchat/chatter.rkt b/collects/2htdp/uchat/chatter.rkt index bfefc0a6a2..2ca1f4c1a8 100644 --- a/collects/2htdp/uchat/chatter.rkt +++ b/collects/2htdp/uchat/chatter.rkt @@ -8,15 +8,15 @@ #| +------------------------------------------------------------------+ - | from: text text text text text text | - | from*: text text text text text text | - | ... | - | ... | + | from: text text text text text text | + | from*: text text text text text text | + | ... | + | ... | +------------------------------------------------------------------+ - | to: text text text text text text | - | *: text text text text text text | - | to2: text blah text[] | - | ... | + | to: text text text text text text | + | *: text text text text text text | + | to2: text blah text[] | + | ... | +------------------------------------------------------------------+ Convention: the names of participants may not contain ":". @@ -88,11 +88,11 @@ ;; World -> Scene ;; render the world as a scene (define (render w) - (local ((define fr (line*-render (world-from w))) + (local [(define fr (line*-render (world-from w))) (define t1 (line*-render (world-to w))) (define last-to-line - (line-render-cursor (world-todraft w) (world-mmdraft w))) - (define tt (image-stack t1 last-to-line))) + (line-render-cursor (world-todraft w) (world-mmdraft w))) + (define tt (image-stack t1 last-to-line))] (place-image fr 1 1 (place-image tt 1 MID MT)))) ;; ----------------------------------------------------------------------------- @@ -355,7 +355,7 @@ [(too-wide? to-new mm) (send to "" from* to*)] [else (world-todraft! w to-new)]))] ; [(and (boolean? to) (string? mm)) (error 'react "can't happen")] - [else ; (and (string? to) (string? mm)) + [else ; (and (string? to) (string? mm)) ;; the key belongs into the message text (local ((define new-mm (string-append mm key))) (cond @@ -483,7 +483,7 @@ (on-receive receive) (check-with world?) (name n) - (state true) + (state true) (register LOCALHOST))) (define (run* _) diff --git a/collects/2htdp/uchat/readme b/collects/2htdp/uchat/readme index 1ab168baa9..ea76213edb 100644 --- a/collects/2htdp/uchat/readme +++ b/collects/2htdp/uchat/readme @@ -1,5 +1,5 @@ - Chit Chat - --------- + Chit Chat + --------- Design and implement a universe program that allows people to chat with each other, using short messages. @@ -11,13 +11,13 @@ A participant uses a chat space, which is a window divided into two spaces: The two halves display the messages in historical order, with the most recent message received/sent at the bottom. When either half is full of - messages, drop the least recent lines. + messages, drop the least recent lines. Each message is at most one line of text, which is the width of the window. Use 400 pixels for the width of a window, and use 11 point text - fonts to render lines. A line consists of two pieces: + fonts to render lines. A line consists of two pieces: - -- an address + -- an address -- a message where the address is separated from the message with a ":". The user sends @@ -28,29 +28,29 @@ Each message is at most one line of text, which is the width of the Editing is just entering keys. Ignore all those key strokes that aren't one-character strings and of the remaining strings ignore backspace and delete. (Of course, if you are ambitious you may wish to assign meaning to - some of those keys so that chatters can edit a bit.) + some of those keys so that chatters can edit a bit.) A message whose recipient is "*" is broadcast to every current participant. Otherwise a message is sent to the designated recipient, if the string is the valid name of a current participant; all other messages disappear in - the big empty void. + the big empty void. Each received message is displayed like those that are sent, with an sender followed by ":" and the text of the message. If the message went to all - participants, the sender's name is followed by an asterisk "*". + participants, the sender's name is followed by an asterisk "*". As you work on this project, you will encounter questions for which this problem statement doesn't provide enough information to make decisions. You -must make the decisions on your own, following this procedure: - -- do not opt for answers that render the project trivial - -- document all non-trivial answers and the answer you chose - -- provide a reason for your choice -Be concise. +must make the decisions on your own, following this procedure: + -- do not opt for answers that render the project trivial + -- document all non-trivial answers and the answer you chose + -- provide a reason for your choice +Be concise. ;; ----------------------------------------------------------------------------- protocol: -Sending and receiving message occur without any synchronization. +Sending and receiving message occur without any synchronization. Clients send messages of the form (list String String) to the server. The first string designates the recipient of the message, the second string @@ -63,24 +63,24 @@ The Chat Server swaps the name of the recipient of a message with that of current participants. - SERVER CLIENT (name1) CLIENT (name2) - | | | - | name1 | % name by which client is known | - | <-------------------- | | - | | | - | (list name2 txt) | | - | <-------------------- | | - | | | - | | (list name1 txt) | + SERVER CLIENT (name1) CLIENT (name2) + | | | + | name1 | % name by which client is known | + | <-------------------- | | + | | | + | (list name2 txt) | | + | <-------------------- | | + | | | + | | (list name1 txt) | | --------------------------------------------------------> | - | | | - | | | + | | | + | | | ;; Client2ServerMsg = (list String String) -;; interp. recipient followed by message text +;; interp. recipient followed by message text ;; Server2ClientMsg = (list String String) -;; interp. sender followed by message text. +;; interp. sender followed by message text. ;; ----------------------------------------------------------------------------- @@ -88,14 +88,14 @@ chat server: receive message, swap recipient for sender & send message(s) ;; ----------------------------------------------------------------------------- -chat world: +chat world: +------------------------------------------------------------------+ - | from: text text text text text text | - | from*: text text text text text text | - | ... | + | from: text text text text text text | + | from*: text text text text text text | + | ... | +------------------------------------------------------------------+ - | to: text text text text text text | - | *: text text text text text text | - | ... | + | to: text text text text text text | + | *: text text text text text text | + | ... | +------------------------------------------------------------------+ diff --git a/collects/2htdp/universe.rkt b/collects/2htdp/universe.rkt index da91b81a1b..52d64dfbb8 100644 --- a/collects/2htdp/universe.rkt +++ b/collects/2htdp/universe.rkt @@ -56,15 +56,15 @@ ;; it may specify a clock-tick rate [on-tick DEFAULT #'#f (function-with-arity - 1 - except - [(_ f rate) - #'(list + 1 + #:except + [(_ f rate) + #'(list (proc> 'on-tick (f2h f) 1) (num> 'on-tick rate (lambda (x) (and (real? x) (positive? x))) "positive number" "rate"))] [(_ f rate limit) - #'(list + #'(list (proc> 'on-tick (f2h f) 1) (num> 'on-tick rate (lambda (x) (and (real? x) (positive? x))) "positive number" "rate") @@ -82,11 +82,11 @@ ;; on-draw must specify a rendering function; ;; it may specify dimensions [on-draw to-draw DEFAULT #'#f - (function-with-arity - 1 - except + (function-with-arity + 1 + #:except [(_ f width height) - #'(list (proc> 'to-draw (f2h f) 1) + #'(list (proc> 'to-draw (f2h f) 1) (nat> 'to-draw width "width") (nat> 'to-draw height "height"))])] ;; World Nat Nat MouseEvent -> World @@ -107,9 +107,9 @@ ;; World -> Boolean ;; -- stop-when must specify a predicate; it may specify a rendering function [stop-when DEFAULT #'False - (function-with-arity + (function-with-arity 1 - except + #:except [(_ stop? last-picture) #'(list (proc> 'stop-when (f2h stop?) 1) (proc> 'stop-when (f2h last-picture) 1))])] diff --git a/collects/browser/private/html.rkt b/collects/browser/private/html.rkt index b897eca2b0..a68a9efc4f 100644 --- a/collects/browser/private/html.rkt +++ b/collects/browser/private/html.rkt @@ -529,7 +529,7 @@ v))) (define html-convert - (lambda (a-port a-text) + (lambda (a-port a-text) (let ([content (parse-html a-port)]) (with-method ([a-text-insert (a-text insert)] [current-pos (a-text last-position)] diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 1411e6d50f..2217060f65 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -78,7 +78,20 @@ (let-values ([(n b) (module-path-index-split modidx)]) (and (not n) (not b)))) (string->symbol (format "_~a" sym)) - (string->symbol (format "_~s@~s~a" sym (mpi->string modidx) + (string->symbol (format "_~s~a@~s~a" + sym + (match constantness + ['constant ":c"] + ['fixed ":f"] + [(function-shape a pm?) + (if pm? ":P" ":p")] + [(struct-type-shape c) ":t"] + [(constructor-shape a) ":mk"] + [(predicate-shape) ":?"] + [(accessor-shape c) ":ref"] + [(mutator-shape c) ":set!"] + [else ""]) + (mpi->string modidx) (if (zero? phase) "" (format "/~a" phase)))))] diff --git a/collects/compiler/demodularizer/alpha.rkt b/collects/compiler/demodularizer/alpha.rkt index 9b459b6ca3..2f3c71398d 100644 --- a/collects/compiler/demodularizer/alpha.rkt +++ b/collects/compiler/demodularizer/alpha.rkt @@ -1,5 +1,6 @@ -#lang racket -(require compiler/zo-parse) +#lang racket/base + +(require racket/match racket/contract compiler/zo-parse) (define (alpha-vary-ctop top) (match top diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index afb495a473..bd98894ad3 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -1,4 +1,5 @@ -#lang racket +#lang racket/base + #| Here's the idea: @@ -40,6 +41,7 @@ Here's the idea: (require racket/pretty racket/system + racket/cmdline "mpi.rkt" "util.rkt" "nodep.rkt" diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index aa6b780389..ad8c74faee 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -1,5 +1,10 @@ -#lang racket -(require compiler/zo-parse +#lang racket/base + +(require racket/match + racket/list + racket/dict + racket/contract + compiler/zo-parse "util.rkt") ; XXX Use efficient set structure @@ -150,21 +155,20 @@ (match (dict-ref g n) [(struct refs (n-tls n-stxs)) (hash-set! visited? n #t) - (local - [(define-values (new-tls1 new-stxs1) - (for/fold ([new-tls tls] - [new-stxs stxs]) - ([tl (in-list n-tls)]) - (visit-tl tl new-tls new-stxs))) - (define new-stxs2 - (for/fold ([new-stxs new-stxs1]) - ([stx (in-list n-stxs)]) - (define this-stx (visit-stx stx)) - (if this-stx - (list* this-stx new-stxs) - new-stxs)))] - (values (list* n new-tls1) - new-stxs2))]))) + (define-values (new-tls1 new-stxs1) + (for/fold ([new-tls tls] + [new-stxs stxs]) + ([tl (in-list n-tls)]) + (visit-tl tl new-tls new-stxs))) + (define new-stxs2 + (for/fold ([new-stxs new-stxs1]) + ([stx (in-list n-stxs)]) + (define this-stx (visit-stx stx)) + (if this-stx + (list* this-stx new-stxs) + new-stxs))) + (values (list* n new-tls1) + new-stxs2)]))) (define stx-visited? (make-hasheq)) (define (visit-stx n) (if (hash-has-key? stx-visited? n) diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index 5b087e257f..f118e6b9e4 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -1,5 +1,9 @@ -#lang racket -(require compiler/zo-parse +#lang racket/base + +(require racket/list + racket/match + racket/contract + compiler/zo-parse "util.rkt" "mpi.rkt" "nodep.rkt" @@ -156,12 +160,12 @@ (cond [(mod-lift-start . <= . n) ; This is a lift - (local [(define which-lift (- n mod-lift-start)) - (define lift-tl (+ top-lift-start lift-offset which-lift))] - (when (lift-tl . >= . max-toplevel) - (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" - name n which-lift num-mod-toplevels mod-num-lifts lift-tl)) - lift-tl)] + (define which-lift (- n mod-lift-start)) + (define lift-tl (+ top-lift-start lift-offset which-lift)) + (when (lift-tl . >= . max-toplevel) + (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" + name n which-lift num-mod-toplevels mod-num-lifts lift-tl)) + lift-tl] [else (list-ref toplevel-remap n)])) (lambda (n) diff --git a/collects/compiler/demodularizer/module.rkt b/collects/compiler/demodularizer/module.rkt index 9c907a5153..dca4498fec 100644 --- a/collects/compiler/demodularizer/module.rkt +++ b/collects/compiler/demodularizer/module.rkt @@ -1,5 +1,9 @@ -#lang racket -(require compiler/zo-parse +#lang racket/base + +(require racket/list + racket/match + racket/contract + compiler/zo-parse "util.rkt") (define (->module-path-index s) diff --git a/collects/compiler/demodularizer/mpi.rkt b/collects/compiler/demodularizer/mpi.rkt index 10f8cd23a5..bb430570dc 100644 --- a/collects/compiler/demodularizer/mpi.rkt +++ b/collects/compiler/demodularizer/mpi.rkt @@ -1,5 +1,7 @@ -#lang racket -(require syntax/modresolve) +#lang racket/base + +(require racket/contract + syntax/modresolve) (define current-module-path (make-parameter #f)) diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index 60afbaf7ec..4e55b46545 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -1,5 +1,9 @@ -#lang racket -(require compiler/zo-parse +#lang racket/base + +(require racket/list + racket/match + racket/contract + compiler/zo-parse "util.rkt" "mpi.rkt" racket/set) @@ -92,7 +96,8 @@ (define (nodep-form form phase) (if (mod? form) - (local [(define-values (modvar-rewrite lang-info mods) (nodep-module form phase))] + (let-values ([(modvar-rewrite lang-info mods) + (nodep-module form phase)]) (values modvar-rewrite lang-info (make-splice mods))) (error 'nodep-form "Doesn't support non mod forms"))) diff --git a/collects/compiler/demodularizer/replace-modidx.rkt b/collects/compiler/demodularizer/replace-modidx.rkt index 7ad45cbc56..f470e2b8f1 100644 --- a/collects/compiler/demodularizer/replace-modidx.rkt +++ b/collects/compiler/demodularizer/replace-modidx.rkt @@ -1,6 +1,10 @@ -#lang racket -(require unstable/struct +#lang racket/base + +(require racket/match + racket/vector + unstable/struct "util.rkt") + (provide replace-modidx) (define (replace-modidx expr self-modidx) diff --git a/collects/compiler/demodularizer/update-toplevels.rkt b/collects/compiler/demodularizer/update-toplevels.rkt index 3cc4ef9e14..6c1c83704e 100644 --- a/collects/compiler/demodularizer/update-toplevels.rkt +++ b/collects/compiler/demodularizer/update-toplevels.rkt @@ -1,5 +1,8 @@ -#lang racket -(require compiler/zo-structs +#lang racket/base + +(require racket/match + racket/contract + compiler/zo-structs "util.rkt") (define (update-toplevels toplevel-updater topsyntax-updater topsyntax-new-midpt) diff --git a/collects/compiler/demodularizer/util.rkt b/collects/compiler/demodularizer/util.rkt index 1865bc133f..e18966798e 100644 --- a/collects/compiler/demodularizer/util.rkt +++ b/collects/compiler/demodularizer/util.rkt @@ -1,5 +1,7 @@ -#lang racket -(require compiler/zo-parse) +#lang racket/base + +(require racket/contract + compiler/zo-parse) (define (prefix-syntax-start pre) (length (prefix-toplevels pre))) diff --git a/collects/compiler/embed.rkt b/collects/compiler/embed.rkt index 0a5d9c04d4..f0f36b7181 100644 --- a/collects/compiler/embed.rkt +++ b/collects/compiler/embed.rkt @@ -36,25 +36,25 @@ (list/c (or/c symbol? #f #t) (or/c path? module-path?) (listof symbol?)))) - #:configure-via-first-module? any/c - #:literal-files (listof path-string?) - #:literal-expression any/c - #:literal-expressions (listof any/c) + #:configure-via-first-module? any/c + #:literal-files (listof path-string?) + #:literal-expression any/c + #:literal-expressions (listof any/c) #:cmdline (listof string?) #:gracket? any/c - #:mred? any/c - #:variant (or/c '3m 'cgc) + #:mred? any/c + #:variant (or/c '3m 'cgc) #:aux (listof (cons/c symbol? any/c)) #:collects-path (or/c #f path-string? (listof path-string?)) #:collects-dest (or/c #f path-string?) - #:launcher? any/c - #:verbose? any/c - #:compiler (-> any/c compiled-expression?) + #:launcher? any/c + #:verbose? any/c + #:compiler (-> any/c compiled-expression?) #:expand-namespace namespace? #:src-filter (-> path? any) - #:on-extension (or/c #f (-> path-string? boolean? any)) + #:on-extension (or/c #f (-> path-string? boolean? any)) #:get-extra-imports (-> path? compiled-module-expression? (listof module-path?))) void?)]) @@ -63,4 +63,3 @@ embedding-executable-is-actually-directory? embedding-executable-put-file-extension+style+filters embedding-executable-add-suffix) - diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 9f39c208ad..b9e1333a99 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -604,13 +604,51 @@ [(? void?) (out-byte CPT_VOID out)] [(struct module-variable (modidx sym pos phase constantness)) + (define (to-sym n) (string->symbol (format "struct~a" n))) (out-byte CPT_MODULE_VAR out) (out-anything modidx out) (out-anything sym out) + (out-anything (cond + [(function-shape? constantness) + (let ([a (function-shape-arity constantness)]) + (cond + [(arity-at-least? a) + (bitwise-ior (arithmetic-shift (- (add1 (arity-at-least-value a))) 1) + (if (function-shape-preserves-marks? constantness) 1 0))] + [(list? a) + (string->symbol (apply + string-append + (add-between + (for/list ([a (in-list a)]) + (define n (if (arity-at-least? a) + (- (add1 (arity-at-least-value a))) + a)) + (number->string n)) + ":")))] + [else + (bitwise-ior (arithmetic-shift a 1) + (if (function-shape-preserves-marks? constantness) 1 0))]))] + [(struct-type-shape? constantness) + (to-sym (arithmetic-shift (struct-type-shape-field-count constantness) + 4))] + [(constructor-shape? constantness) + (to-sym (bitwise-ior 1 (arithmetic-shift (constructor-shape-arity constantness) + 4)))] + [(predicate-shape? constantness) (to-sym 2)] + [(accessor-shape? constantness) + (to-sym (bitwise-ior 3 (arithmetic-shift (accessor-shape-field-count constantness) + 4)))] + [(mutator-shape? constantness) + (to-sym (bitwise-ior 4 (arithmetic-shift (mutator-shape-field-count constantness) + 4)))] + [(struct-other-shape? constantness) + (to-sym 5)] + [else #f]) + out) (case constantness - [(constant) (out-number -4 out)] + [(#f) (void)] [(fixed) (out-number -5 out)] - [else (void)]) + [else (out-number -4 out)]) (unless (zero? phase) (out-number -2 out) (out-number phase out)) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 13856e48e0..18e7426b01 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -856,6 +856,7 @@ [(module-var) (let ([mod (read-compact cp)] [var (read-compact cp)] + [shape (read-compact cp)] [pos (read-compact-number cp)]) (let-values ([(flags mod-phase pos) (let loop ([pos pos]) @@ -869,6 +870,33 @@ [else (values 0 0 pos)]))]) (make-module-variable mod var pos mod-phase (cond + [shape + (cond + [(number? shape) + (define n (arithmetic-shift shape -1)) + (make-function-shape (if (negative? n) + (make-arity-at-least (sub1 (- n))) + n) + (odd? shape))] + [(and (symbol? shape) + (regexp-match? #rx"^struct" (symbol->string shape))) + (define n (string->number (substring (symbol->string shape) 6))) + (case (bitwise-and n #x7) + [(0) (make-struct-type-shape (arithmetic-shift n -3))] + [(1) (make-constructor-shape (arithmetic-shift n -3))] + [(2) (make-predicate-shape)] + [(3) (make-accessor-shape (arithmetic-shift n -3))] + [(4) (make-mutator-shape (arithmetic-shift n -3))] + [else (make-struct-other-shape)])] + [else + ;; parse symbol as ":"-separated sequence of arities + (make-function-shape + (for/list ([s (regexp-split #rx":" (symbol->string shape))]) + (define i (string->number s)) + (if (negative? i) + (make-arity-at-least (sub1 (- i))) + i)) + #f)])] [(not (zero? (bitwise-and #x1 flags))) 'constant] [(not (zero? (bitwise-and #x2 flags))) 'fixed] [else #f]))))] diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 3fc6b2c11d..a2aa9c284b 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -38,13 +38,26 @@ [(_ id . rest) (define-form-struct* id (id zo) . rest)])) +(define-form-struct function-shape ([arity procedure-arity?] + [preserves-marks? boolean?])) + +(define-form-struct struct-shape ()) +(define-form-struct (constructor-shape struct-shape) ([arity exact-nonnegative-integer?])) +(define-form-struct (predicate-shape struct-shape) ()) +(define-form-struct (accessor-shape struct-shape) ([field-count exact-nonnegative-integer?])) +(define-form-struct (mutator-shape struct-shape) ([field-count exact-nonnegative-integer?])) +(define-form-struct (struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?])) +(define-form-struct (struct-other-shape struct-shape) ()) + ;; In toplevels of resove prefix: (define-form-struct global-bucket ([name symbol?])) ; top-level binding (define-form-struct module-variable ([modidx module-path-index?] [sym symbol?] [pos exact-integer?] [phase exact-nonnegative-integer?] - [constantness (or/c #f 'constant 'fixed)])) + [constantness (or/c #f 'constant 'fixed + function-shape? + struct-shape?)])) ;; Syntax object (define ((alist/c k? v?) l) diff --git a/collects/data/heap.rkt b/collects/data/heap.rkt index 49dcfbc965..7cf3d81254 100644 --- a/collects/data/heap.rkt +++ b/collects/data/heap.rkt @@ -160,13 +160,14 @@ (in-heap/consume! (heap-copy h))) (define (in-heap/consume! h) - (lambda () - (values (lambda () (heap-min h)) - (lambda () (heap-remove-min! h) #t) - #t - (lambda (_) (> (heap-count h) 0)) - (lambda _ #t) - (lambda _ #t)))) + (make-do-sequence + (lambda () + (values (lambda (_) (heap-min h)) + (lambda (_) (heap-remove-min! h) #t) + #t + (lambda (_) (> (heap-count h) 0)) + (lambda _ #t) + (lambda _ #t))))) ;; -------- @@ -204,4 +205,7 @@ [heap->vector (-> heap? vector?)] [heap-copy (-> heap? heap?)] - [heap-sort! (-> procedure? vector? void?)]) + [heap-sort! (-> procedure? vector? void?)] + + [in-heap (-> heap? sequence?)] + [in-heap/consume! (-> heap? sequence?)]) diff --git a/collects/data/order.rkt b/collects/data/order.rkt index 1847590105..15ad6d68e6 100644 --- a/collects/data/order.rkt +++ b/collects/data/order.rkt @@ -16,6 +16,7 @@ ;; generated hidden property. (define-generics (ordered-dict gen:ordered-dict prop:ordered-dict ordered-dict? #:defined-table dict-def-table + #:defaults () ;; private version needs all kw args, in order #:prop-defined-already? #f #:define-contract #f) diff --git a/collects/data/scribblings/gvector.scrbl b/collects/data/scribblings/gvector.scrbl index 4446345b99..70f6d18a3d 100644 --- a/collects/data/scribblings/gvector.scrbl +++ b/collects/data/scribblings/gvector.scrbl @@ -123,3 +123,6 @@ Unlike @racket[for/list], the @racket[body] may return zero or multiple values; all returned values are added to the gvector, in order, on each iteration. } + + +@close-eval[the-eval] diff --git a/collects/data/scribblings/heap.scrbl b/collects/data/scribblings/heap.scrbl index 1bcffc8480..9f10378e1c 100644 --- a/collects/data/scribblings/heap.scrbl +++ b/collects/data/scribblings/heap.scrbl @@ -19,62 +19,176 @@ Binary heaps are a simple implementation of priority queues. heap?]{ Makes a new empty heap using @racket[<=?] to order elements. + +@examples[#:eval the-eval + (define a-heap-of-strings (make-heap string<=?)) + a-heap-of-strings + @code:comment{With structs:} + (struct node (name val)) + (define (node<=? x y) + (<= (node-val x) (node-val y))) + (define a-heap-of-nodes (make-heap node<=?)) + a-heap-of-nodes] } @defproc[(heap? [x any/c]) boolean?]{ Returns @racket[#t] if @racket[x] is a heap, @racket[#f] otherwise. + +@examples[#:eval the-eval + (heap? (make-heap <=)) + (heap? "I am not a heap")] } @defproc[(heap-count [h heap?]) exact-nonnegative-integer?]{ Returns the number of elements in the heap. +@examples[#:eval the-eval + (define a-heap (make-heap <=)) + (heap-add-all! a-heap '(7 3 9 1 13 21 15 31)) + (heap-count a-heap) +] } @defproc[(heap-add! [h heap?] [v any/c] ...) void?]{ Adds each @racket[v] to the heap. + +@examples[#:eval the-eval + (define a-heap (make-heap <=)) + (heap-add! a-heap 2009 1009)] } + @defproc[(heap-add-all! [h heap?] [v (or/c list? vector? heap?)]) void?]{ Adds each element contained in @racket[v] to the heap, leaving @racket[v] unchanged. + +@examples[#:eval the-eval + (define heap-1 (make-heap <=)) + (define heap-2 (make-heap <=)) + (define heap-12 (make-heap <=)) + (heap-add-all! heap-1 '(3 1 4 1 5 9 2 6)) + (heap-add-all! heap-2 #(2 7 1 8 2 8 1 8)) + (heap-add-all! heap-12 heap-1) + (heap-add-all! heap-12 heap-2) + (heap-count heap-12)] } @defproc[(heap-min [h heap?]) any/c]{ Returns the least element in the heap @racket[h], according to the heap's ordering. If the heap is empty, an exception is raised. + +@examples[#:eval the-eval + (define a-heap (make-heap string<=?)) + (heap-add! a-heap "sneezy" "sleepy" "dopey" "doc" + "happy" "bashful" "grumpy") + (heap-min a-heap) + + @code:comment{Taking the min of the empty heap is an error:} + (heap-min (make-heap <=)) +] } @defproc[(heap-remove-min! [h heap?]) void?]{ Removes the least element in the heap @racket[h]. If the heap is empty, an exception is raised. + +@examples[#:eval the-eval + (define a-heap (make-heap string<=?)) + (heap-add! a-heap "fili" "fili" "oin" "gloin" "thorin" + "dwalin" "balin" "bifur" "bofur" + "bombur" "dori" "nori" "ori") + (heap-min a-heap) + (heap-remove-min! a-heap) + (heap-min a-heap)] } @defproc[(vector->heap [<=? (-> any/c any/c any/c)] [items vector?]) heap?]{ Builds a heap with the elements from @racket[items]. The vector is not modified. +@examples[#:eval the-eval + (struct item (val frequency)) + (define (item<=? x y) + (<= (item-frequency x) (item-frequency y))) + (define some-sample-items + (vector (item #\a 17) (item #\b 12) (item #\c 19))) + (define a-heap (vector->heap item<=? some-sample-items)) +] } @defproc[(heap->vector [h heap?]) vector?]{ Returns a vector containing the elements of heap @racket[h] in the heap's order. The heap is not modified. + +@examples[#:eval the-eval + (define word-heap (make-heap string<=?)) + (heap-add! word-heap "pile" "mound" "agglomerate" "cumulation") + (heap->vector word-heap) +] } @defproc[(heap-copy [h heap?]) heap?]{ Makes a copy of heap @racket[h]. +@examples[#:eval the-eval + (define word-heap (make-heap string<=?)) + (heap-add! word-heap "pile" "mound" "agglomerate" "cumulation") + (define a-copy (heap-copy word-heap)) + (heap-remove-min! a-copy) + (heap-count word-heap) + (heap-count a-copy) +] } @;{--------} -@defproc[(heap-sort! [<=? (-> any/c any/c any/c)] [v vector?]) void?]{ +@defproc[(heap-sort! [<=? (-> any/c any/c any/c)] [v (and/c vector? (not/c immutable?))]) void?]{ Sorts vector @racket[v] using the comparison function @racket[<=?]. + +@examples[#:eval the-eval + (define terms (vector "batch" "deal" "flock" "good deal" "hatful" "lot")) + (heap-sort! string<=? terms) + terms +] } + + +@defproc[(in-heap/consume! [heap heap?]) sequence?]{ +Returns a sequence equivalent to @racket[heap], maintaining the heap's ordering. +The heap is consumed in the process. Equivalent to repeated calling +@racket[heap-min], then @racket[heap-remove-min!]. + + @examples[#:eval the-eval + (define h (make-heap <=)) + (heap-add-all! h '(50 40 10 20 30)) + + (for ([x (in-heap/consume! h)]) + (displayln x)) + + (heap-count h)] +} + +@defproc[(in-heap [heap heap?]) sequence?]{ +Returns a sequence equivalent to @racket[heap], maintaining the heap's ordering. +Equivalent to @racket[in-heap/consume!] except the heap is copied first. + + @examples[#:eval the-eval + (define h (make-heap <=)) + (heap-add-all! h '(50 40 10 20 30)) + + (for ([x (in-heap h)]) + (displayln x)) + + (heap-count h)] +} + + +@close-eval[the-eval] diff --git a/collects/data/scribblings/integer-set.scrbl b/collects/data/scribblings/integer-set.scrbl index b994220b9a..c618397bbe 100644 --- a/collects/data/scribblings/integer-set.scrbl +++ b/collects/data/scribblings/integer-set.scrbl @@ -151,3 +151,6 @@ Returns the number of integers in the given integer set.} Returns true if every integer in @racket[x] is also in @racket[y], otherwise @racket[#f].} + + +@close-eval[the-eval] diff --git a/collects/data/scribblings/interval-map.scrbl b/collects/data/scribblings/interval-map.scrbl index aeca9a7496..c220d6e753 100644 --- a/collects/data/scribblings/interval-map.scrbl +++ b/collects/data/scribblings/interval-map.scrbl @@ -167,3 +167,6 @@ Implementations of @racket[dict-iterate-first], Returns @racket[#t] if @racket[v] represents a position in an interval-map, @racket[#f] otherwise. } + + +@close-eval[the-eval] diff --git a/collects/data/scribblings/order.scrbl b/collects/data/scribblings/order.scrbl index 38c4810109..a77d1dce9c 100644 --- a/collects/data/scribblings/order.scrbl +++ b/collects/data/scribblings/order.scrbl @@ -251,3 +251,6 @@ a single execution of a program: (datum-order (make-fish 'alewife) (make-fowl 'dodo)) ] } + + +@close-eval[the-eval] diff --git a/collects/data/scribblings/queue.scrbl b/collects/data/scribblings/queue.scrbl index ed11262a66..65e5a7572e 100644 --- a/collects/data/scribblings/queue.scrbl +++ b/collects/data/scribblings/queue.scrbl @@ -94,3 +94,6 @@ Returns a sequence whose elements are the elements of These contracts recognize queues; the latter requires the queue to contain at least one value. } + + +@close-eval[qeval] diff --git a/collects/data/scribblings/skip-list.scrbl b/collects/data/scribblings/skip-list.scrbl index f55c919e9a..ae65895ac2 100644 --- a/collects/data/scribblings/skip-list.scrbl +++ b/collects/data/scribblings/skip-list.scrbl @@ -171,3 +171,6 @@ skip-list, @racket[#f] otherwise. Returns an association list with the keys and values of @racket[skip-list], in order. } + + +@close-eval[the-eval] diff --git a/collects/data/scribblings/splay-tree.scrbl b/collects/data/scribblings/splay-tree.scrbl index f653d543ea..20dacf5570 100644 --- a/collects/data/scribblings/splay-tree.scrbl +++ b/collects/data/scribblings/splay-tree.scrbl @@ -174,3 +174,6 @@ splay-tree, @racket[#f] otherwise. Returns an association list with the keys and values of @racket[s], in order. } + + +@close-eval[the-eval] diff --git a/collects/db/private/odbc/connection.rkt b/collects/db/private/odbc/connection.rkt index 30414008f9..5f23a1c5c2 100644 --- a/collects/db/private/odbc/connection.rkt +++ b/collects/db/private/odbc/connection.rkt @@ -656,7 +656,14 @@ #:on-notice add-notice!))) (super-new) - (register-finalizer this (lambda (obj) (send obj disconnect))))) + (register-finalizer this + (lambda (obj) + ;; Keep a reference to the class to keep all FFI callout objects + ;; (eg, SQLDisconnect) used by its methods from being finalized. + (let ([dont-gc this%]) + (send obj disconnect) + ;; Dummy result to prevent reference from being optimized away + dont-gc))))) ;; ---------------------------------------- diff --git a/collects/db/private/odbc/ffi-constants.rkt b/collects/db/private/odbc/ffi-constants.rkt index b7f96712be..0975e5c02c 100644 --- a/collects/db/private/odbc/ffi-constants.rkt +++ b/collects/db/private/odbc/ffi-constants.rkt @@ -24,7 +24,7 @@ (define SQL_ATTR_ODBC_VERSION 200) (define SQL_OV_ODBC2 2) -(define SQL_OV_ODBC3 3) +(define SQL_OV_ODBC3 3) (define SQL_SUCCESS 0) (define SQL_SUCCESS_WITH_INFO 1) diff --git a/collects/db/private/sqlite3/connection.rkt b/collects/db/private/sqlite3/connection.rkt index 5a716249cc..6cd800e641 100644 --- a/collects/db/private/sqlite3/connection.rkt +++ b/collects/db/private/sqlite3/connection.rkt @@ -206,7 +206,7 @@ (let loop () (let ([stmt (sqlite3_next_stmt db #f)]) (when stmt - (HANDLE 'disconnect (sqlite3_finalize stmt)) + (sqlite3_finalize stmt) (loop)))) (HANDLE 'disconnect (sqlite3_close db)) (void)))))) @@ -225,7 +225,7 @@ (let ([stmt (send pst get-handle)]) (send pst set-handle #f) (when (and stmt -db) - (HANDLE fsym (sqlite3_finalize stmt))) + (sqlite3_finalize stmt)) (void))))) ;; Internal query @@ -316,7 +316,14 @@ ;; ---- (super-new) - (register-finalizer this (lambda (obj) (send obj disconnect))))) + (register-finalizer this + (lambda (obj) + ;; Keep a reference to the class to keep all FFI callout objects + ;; (eg, sqlite3_close) used by its methods from being finalized. + (let ([dont-gc this%]) + (send obj disconnect) + ;; Dummy result to prevent reference from being optimized away + dont-gc))))) ;; ---------------------------------------- diff --git a/collects/db/private/sqlite3/ffi.rkt b/collects/db/private/sqlite3/ffi.rkt index af7260cfbb..fa6baa0cb5 100644 --- a/collects/db/private/sqlite3/ffi.rkt +++ b/collects/db/private/sqlite3/ffi.rkt @@ -58,7 +58,10 @@ (define-sqlite sqlite3_finalize (_fun _sqlite3_statement - -> _int)) + -> _int + ;; sqlite3_finalize returns error code of last stmt execution, + ;; not of finalization; so just ignore + -> (void))) (define-sqlite sqlite3_bind_parameter_count (_fun _sqlite3_statement diff --git a/collects/deinprogramm/DMdA.rkt b/collects/deinprogramm/DMdA.rkt index 4080de3245..36cc91fbfc 100644 --- a/collects/deinprogramm/DMdA.rkt +++ b/collects/deinprogramm/DMdA.rkt @@ -247,7 +247,7 @@ ((DMdA-cons cons) (%a (list-of %a) -> (list-of %a)) "erzeuge ein Paar aus Element und Liste") (pair? (any -> boolean) - "feststellen, ob ein Wert ein Paar ist") + "feststellen, ob ein Wert ein Paar ist") (cons? (any -> boolean) "feststellen, ob ein Wert ein Paar ist") (empty? (any -> boolean) diff --git a/collects/deinprogramm/run-dmda-code.rkt b/collects/deinprogramm/run-dmda-code.rkt index f0a958a91f..9bbb0825ad 100644 --- a/collects/deinprogramm/run-dmda-code.rkt +++ b/collects/deinprogramm/run-dmda-code.rkt @@ -41,7 +41,7 @@ (close-input-port p) (open-input-text-editor t 0 'end values filename))] [else p])]) - (port-count-lines! p) ; in case it's new + (port-count-lines! p) ; in case it's new (values p filename)))) (define (open-input-graphical-file/fixed filename) diff --git a/collects/deinprogramm/world.rkt b/collects/deinprogramm/world.rkt index d5be3eaea5..fb7ec97718 100644 --- a/collects/deinprogramm/world.rkt +++ b/collects/deinprogramm/world.rkt @@ -20,8 +20,8 @@ (provide (all-from-out "image.rkt")) (provide ;; forall(World): - big-bang ;; Number Number Number World -> true - end-of-time ;; String u Symbol -> World + big-bang ;; Number Number Number World -> true + end-of-time ;; String u Symbol -> World ) (provide-higher-order-primitive diff --git a/collects/drracket/private/app.rkt b/collects/drracket/private/app.rkt index 8590b0cae1..8c5b628651 100644 --- a/collects/drracket/private/app.rkt +++ b/collects/drracket/private/app.rkt @@ -187,11 +187,6 @@ (insert ".\n\nBased on:\n ") (insert (banner))) - (when (or (eq? (system-type) 'macos) - (eq? (system-type) 'macosx)) - (send* e - (insert " The A List (c) 1997-2001 Kyle Hammond\n"))) - (let ([tools (sort (drracket:tools:get-successful-tools) (lambda (a b) (stringstring (drracket:tools:successful-tool-spec a)) diff --git a/collects/drracket/private/colored-errors.rkt b/collects/drracket/private/colored-errors.rkt index 8f0f884447..33eabce707 100644 --- a/collects/drracket/private/colored-errors.rkt +++ b/collects/drracket/private/colored-errors.rkt @@ -1,13 +1,18 @@ -#lang racket +#lang racket/base -(define-syntax (test stx) #'(begin)) ;; TODO: convert my test into DrRacket's test framework -(require ; gmarceau/test - parser-tools/lex +(require (for-syntax racket/base) + racket/list + racket/string + racket/contract + racket/match + parser-tools/lex (prefix-in : parser-tools/lex-sre) (rename-in srfi/26 [cut //]) (only-in srfi/1 break) unstable/contract) +(define-syntax (test stx) #'(begin)) ;; TODO: convert my test into DrRacket's test framework + ;; An error message has many fragments. The fragments will be concatenated ;; before being presented to the user. Some fragment are simply string. (struct msg-fragment:str (str) #:transparent) diff --git a/collects/drracket/private/drracket-normal.rkt b/collects/drracket/private/drracket-normal.rkt index 45008d4ff1..ab946ca7e1 100644 --- a/collects/drracket/private/drracket-normal.rkt +++ b/collects/drracket/private/drracket-normal.rkt @@ -15,34 +15,35 @@ (define files-to-open (command-line #:args filenames filenames)) -(define the-date (seconds->date - (let ([ssec (getenv "PLTDREASTERSECONDS")]) - (if ssec - (string->number ssec) - (current-seconds))))) +(define startup-date + (seconds->date + (let ([ssec (getenv "PLTDREASTERSECONDS")]) + (if ssec + (string->number ssec) + (current-seconds))))) ;; updates the command-line-arguments with only the files ;; to open. See also main.rkt. (current-command-line-arguments (apply vector files-to-open)) -(define (currently-the-weekend?) - (define dow (date-week-day the-date)) +(define (weekend-date? date) + (define dow (date-week-day date)) (or (= dow 6) (= dow 0))) -(define (valentines-day?) - (and (= 2 (date-month the-date)) - (= 14 (date-day the-date)))) +(define (valentines-date? date) + (and (= 2 (date-month date)) + (= 14 (date-day date)))) -(define (current-icon-state) +(define (icon-state date) (cond - [(valentines-day?) 'valentines] - [(currently-the-weekend?) 'weekend] + [(valentines-date? date) 'valentines] + [(weekend-date? date) 'weekend] [else 'normal])) (define-values (texas-independence-day? prince-kuhio-day? kamehameha-day? halloween?) - (let* ([month (date-month the-date)] - [day (date-day the-date)] - [dow (date-week-day the-date)]) + (let* ([month (date-month startup-date)] + [day (date-day startup-date)] + [dow (date-week-day startup-date)]) (values (and (= 3 month) (= 2 day)) (and (= 3 month) (= 26 day)) (and (= 6 month) (= 11 day)) @@ -119,7 +120,7 @@ (define the-bitmap-spec (cond - [(valentines-day?) + [(valentines-date? startup-date) valentines-days-spec] [(or prince-kuhio-day? kamehameha-day?) (set-splash-progress-bar?! #f) @@ -131,7 +132,7 @@ (collection-file-path "texas-plt-bw.gif" "icons")] [halloween? (collection-file-path "PLT-pumpkin.png" "icons")] - [(currently-the-weekend?) + [(weekend-date? startup-date) weekend-bitmap-spec] [else normal-bitmap-spec])) @@ -139,7 +140,7 @@ (set-splash-char-observer drracket-splash-char-observer) (when (eq? (system-type) 'macosx) - (define initial-state (current-icon-state)) + (define initial-state (icon-state startup-date)) (define weekend-bitmap (if (equal? the-bitmap-spec weekend-bitmap-spec) the-splash-bitmap #f)) @@ -167,7 +168,7 @@ (λ () (let loop ([last-state initial-state]) (sleep 10) - (define next-state (current-icon-state)) + (define next-state (icon-state (seconds->date (current-seconds)))) (unless (equal? last-state next-state) (set-icon next-state)) (loop next-state)))))) diff --git a/collects/drracket/private/get-extend.rkt b/collects/drracket/private/get-extend.rkt index 91f3814cf0..1b25d367b4 100644 --- a/collects/drracket/private/get-extend.rkt +++ b/collects/drracket/private/get-extend.rkt @@ -1,7 +1,8 @@ #lang racket/unit (require racket/class - "drsig.rkt") + "drsig.rkt" + framework/private/logging-timer) (import [prefix drracket:unit: drracket:unit^] [prefix drracket:frame: drracket:frame^] @@ -13,7 +14,7 @@ (export drracket:get/extend^) (define make-extender - (λ (get-base% name) + (λ (get-base% name [final-mixin values]) (let ([extensions (λ (x) x)] [built-yet? #f] [built #f] @@ -42,7 +43,7 @@ (λ () (unless built-yet? (set! built-yet? #t) - (set! built (extensions (get-base%)))) + (set! built (final-mixin (extensions (get-base%))))) built))))) (define (get-base-tab%) @@ -93,4 +94,14 @@ (drracket:unit:get-definitions-text%))))))) (define-values (extend-definitions-text get-definitions-text) - (make-extender get-base-definitions-text% 'definitions-text%)) + (make-extender get-base-definitions-text% + 'definitions-text% + (let ([add-on-paint-logging + (λ (%) + (class % + (define/override (on-paint before? dc left top right bottom dx dy draw-caret) + (log-timeline + (format "on-paint method of ~a area: ~a" (object-name this) (* (- right left) (- bottom top))) + (super on-paint before? dc left top right bottom dx dy draw-caret))) + (super-new)))]) + add-on-paint-logging))) diff --git a/collects/drracket/private/insert-large-letters.rkt b/collects/drracket/private/insert-large-letters.rkt index 7bdbc81a1d..8bcde0a4ee 100644 --- a/collects/drracket/private/insert-large-letters.rkt +++ b/collects/drracket/private/insert-large-letters.rkt @@ -7,7 +7,7 @@ (define-type-alias Bitmap-Message% (Class () - ([parent Any]) + ([parent (Instance Horizontal-Panel%)]) ([set-bm ((Instance Bitmap%) -> Void)]))) @@ -16,7 +16,7 @@ (provide insert-large-letters) -(: insert-large-letters (String Char (Instance Racket:Text%) Any -> Void)) +(: insert-large-letters (String Char (Instance Text:Basic%) Any -> Void)) (define (insert-large-letters comment-prefix comment-character edit parent) (let ([str (make-large-letters-dialog comment-prefix comment-character #f)]) (when (and str @@ -90,7 +90,7 @@ (: pane2 (Instance Horizontal-Pane%)) (define pane2 (new horizontal-pane% (parent info-bar))) - (: txt (Instance Racket:Text%)) + (: txt (Instance Text:Basic%)) (define txt (new racket:text%)) (: ec (Instance Editor-Canvas%)) (define ec (new editor-canvas% [parent dlg] [editor txt])) @@ -145,7 +145,7 @@ (format " (~a)" (floor (inexact->exact w)))))) -(: get-max-line-width ((Instance Racket:Text%) -> Real)) +(: get-max-line-width ((Instance Text:Basic%) -> Real)) (define (get-max-line-width txt) (let loop ([i (+ (send txt last-paragraph) 1)] [#{m : Integer} 0]) @@ -156,7 +156,7 @@ (send txt paragraph-start-position (- i 1)))))]))) -(: render-large-letters (String Char (Instance Font%) String (Instance Racket:Text%) -> (Instance Bitmap%))) +(: render-large-letters (String Char (Instance Font%) String (Instance Text:Basic%) -> (Instance Bitmap%))) (define (render-large-letters comment-prefix comment-character the-font str edit) (define bdc (make-object bitmap-dc% (make-object bitmap% 1 1 #t))) (define-values (tw raw-th td ta) (send bdc get-text-extent str the-font)) diff --git a/collects/drracket/private/language-configuration.rkt b/collects/drracket/private/language-configuration.rkt index f577a46ff9..f748bfdc43 100644 --- a/collects/drracket/private/language-configuration.rkt +++ b/collects/drracket/private/language-configuration.rkt @@ -1,5 +1,5 @@ #lang racket/base - (require (prefix-in : mred/mred) ;; ensure that this module is always loaded since it is shared below for pretty big +(require (prefix-in : mred/mred) ;; ensure that this module is always loaded since it is shared below for pretty big racket/unit mrlib/hierlist racket/class @@ -11,13 +11,17 @@ string-constants framework setup/getinfo + setup/xref + scribble/xref + net/url syntax/toplevel + browser/external (only-in mzlib/struct make-->vector)) (define original-output (current-output-port)) (define (oprintf . args) (apply fprintf original-output args)) - (define-values (sc-use-language-in-source sc-choose-a-language mouse-event-uses-shortcut-prefix?) + (define-values (sc-use-language-in-source sc-use-teaching-language sc-choose-a-language mouse-event-uses-shortcut-prefix?) (let* ([shortcut-prefix (get-default-shortcut-prefix)] [menukey-string (apply string-append @@ -38,14 +42,14 @@ [(shift) (send evt get-shiftdown)] [(option) (send evt get-alt-down)])) shortcut-prefix)) - (values (string-append (string-constant use-language-in-source) - (format " (~aU)" menukey-string)) - (string-append (string-constant choose-a-language) - (format " (~aC)" menukey-string)) + (values (string-append (string-constant the-racket-language) + (format " (~aR)" menukey-string)) + (string-append (string-constant teaching-languages) + (format " (~aT)" menukey-string)) + (string-append (string-constant other-languages) + (format " (~aO)" menukey-string)) mouse-event-uses-shortcut-prefix?))) - (define sc-lang-in-source-discussion (string-constant lang-in-source-discussion)) - (provide language-configuration@) (define-unit language-configuration@ @@ -56,7 +60,8 @@ [prefix drracket:app: drracket:app^] [prefix drracket:tools: drracket:tools^] [prefix drracket:help-desk: drracket:help-desk^] - [prefix drracket:module-language: drracket:module-language/int^]) + [prefix drracket:module-language: drracket:module-language/int^] + [prefix drracket: drracket:interface^]) (export drracket:language-configuration/internal^) ;; settings-preferences-symbol : symbol @@ -242,7 +247,9 @@ button-panel language-settings-to-show #f - ok-handler)) + ok-handler + (and (is-a? parent drracket:unit:frame<%>) + (send parent get-definitions-text)))) ;; create ok/cancel buttons (make-object horizontal-pane% button-panel) @@ -257,7 +264,7 @@ (add-welcome dialog welcome-before-panel welcome-after-panel)) (send dialog stretchable-width #f) - (send dialog stretchable-height #t) + (send dialog stretchable-height #f) (unless parent (send dialog center 'both)) @@ -276,8 +283,9 @@ ;; if re-center is a dialog, when the show details button is clicked, the dialog is recenterd. (define fill-language-dialog (λ (parent show-details-parent language-settings-to-show - [re-center #f] - [ok-handler void]) ; en/disable button, execute it + [re-center #f] + [ok-handler void] + [definitions-text #f]) ; en/disable button, execute it (define-values (language-to-show settings-to-show) (let ([request-lang-to-show (language-settings-language language-settings-to-show)]) @@ -376,9 +384,13 @@ (cond [(and i (is-a? i hieritem-language<%>)) (define pos (send (send i get-language) get-language-position)) - (preferences:set 'drracket:language-dialog:hierlist-default pos) - (set! most-recent-languages-hier-list-selection pos) - (something-selected i)] + (if (eq? this teaching-languages-hier-list) + (preferences:set 'drracket:language-dialog:teaching-hierlist-default pos) + (preferences:set 'drracket:language-dialog:hierlist-default pos)) + (if (eq? this teaching-languages-hier-list) + (set! most-recent-teaching-languages-hier-list-selection pos) + (set! most-recent-languages-hier-list-selection pos)) + (something-selected this i)] [else (non-language-selected)])) ;; this is used only because we set `on-click-always' @@ -388,7 +400,7 @@ ;; double-click selects a language (define/override (on-double-select i) (when (and i (is-a? i hieritem-language<%>)) - (something-selected i) + (something-selected this i) (ok-handler 'execute))) (super-new [parent parent]) ;; do this so we can expand/collapse languages on a single click @@ -396,9 +408,12 @@ (on-click-always #t) (allow-deselect #t))) - (define outermost-panel (new horizontal-pane% [parent parent])) + (define outermost-panel (new horizontal-panel% + [parent parent] + [alignment '(left top)])) (define languages-choice-panel (new vertical-panel% [parent outermost-panel] + [stretchable-height #f] [alignment '(left top)])) (define use-language-in-source-rb @@ -411,7 +426,8 @@ (use-language-in-source-rb-callback))])) (define (use-language-in-source-rb-callback) (module-language-selected) - (send use-chosen-language-rb set-selection #f)) + (send use-chosen-language-rb set-selection #f) + (send use-teaching-language-rb set-selection #f)) (define in-source-discussion-panel (new horizontal-panel% [parent languages-choice-panel] [stretchable-height #f])) @@ -419,8 +435,41 @@ [parent in-source-discussion-panel] [stretchable-width #f] [min-width 32])) - (define in-source-discussion-editor-canvas (add-discussion in-source-discussion-panel)) + (define in-source-discussion-editor-canvas (add-discussion in-source-discussion-panel definitions-text use-language-in-source-rb-callback)) (define most-recent-languages-hier-list-selection (preferences:get 'drracket:language-dialog:hierlist-default)) + (define most-recent-teaching-languages-hier-list-selection (preferences:get 'drracket:language-dialog:teaching-hierlist-default)) + + (define use-teaching-language-rb + (new radio-box% + [label #f] + [choices (list sc-use-teaching-language)] + [parent languages-choice-panel] + [callback + (λ (rb evt) + (use-teaching-language-rb-callback))])) + (define (use-teaching-language-rb-callback) + (when most-recent-teaching-languages-hier-list-selection + (select-a-language-in-hierlist teaching-languages-hier-list + (cdr most-recent-teaching-languages-hier-list-selection))) + (send use-chosen-language-rb set-selection #f) + (send use-language-in-source-rb set-selection #f) + (send use-teaching-language-rb set-selection 0) + (send other-languages-hier-list select #f) + (send teaching-languages-hier-list focus)) + + (define teaching-languages-hier-list-panel + (new horizontal-panel% [parent languages-choice-panel] [stretchable-height #f])) + (define teaching-languages-hier-list-spacer + (new horizontal-panel% + [parent teaching-languages-hier-list-panel] + [stretchable-width #f] + [min-width 16])) + + (define teaching-languages-hier-list + (new selectable-hierlist% + [parent teaching-languages-hier-list-panel] + [style '(no-border no-hscroll auto-vscroll transparent)])) + (define use-chosen-language-rb (new radio-box% [label #f] @@ -430,19 +479,54 @@ (λ (this-rb evt) (use-chosen-language-rb-callback))])) (define (use-chosen-language-rb-callback) + (show-other-languages) (when most-recent-languages-hier-list-selection - (select-a-language-in-hierlist most-recent-languages-hier-list-selection)) + (select-a-language-in-hierlist other-languages-hier-list + most-recent-languages-hier-list-selection)) (send use-language-in-source-rb set-selection #f) - (send languages-hier-list focus)) - (define languages-hier-list-panel (new horizontal-panel% [parent languages-choice-panel])) + (send use-teaching-language-rb set-selection #f) + (send teaching-languages-hier-list select #f) + (send other-languages-hier-list focus)) + (define (show-other-languages) + (when (member ellipsis-spacer-panel (send languages-hier-list-panel get-children)) + (send languages-hier-list-panel change-children + (λ (l) + (list languages-hier-list-spacer other-languages-hier-list))))) + + (define languages-hier-list-panel (new horizontal-panel% + [parent languages-choice-panel] + [stretchable-height #f])) + (define ellipsis-spacer-panel (new horizontal-panel% + [parent languages-hier-list-panel] + [stretchable-width #f] + [min-width 32])) + (define ellipsis-message (new (class canvas% + (define/override (on-paint) + (define dc (get-dc)) + (send dc set-font normal-control-font) + (send dc draw-text "..." 0 0)) + (define/override (on-event evt) + (when (send evt button-up?) + (show-other-languages))) + (inherit get-dc min-width min-height) + (super-new [style '(transparent)] + [parent languages-hier-list-panel] + [stretchable-width #f] + [stretchable-height #t]) + (let () + (define dc (get-dc)) + (define-values (w h _1 _2) (send dc get-text-extent "..." normal-control-font)) + (min-width (inexact->exact (ceiling w))) + (min-height (inexact->exact (ceiling h))))))) + (define languages-hier-list-spacer (new horizontal-panel% [parent languages-hier-list-panel] [stretchable-width #f] [min-width 16])) - (define languages-hier-list (new selectable-hierlist% - [parent languages-hier-list-panel] - [style '(no-border no-hscroll auto-vscroll transparent)])) + (define other-languages-hier-list (new selectable-hierlist% + [parent languages-hier-list-panel] + [style '(no-border no-hscroll auto-vscroll transparent)])) (define details-outer-panel (make-object vertical-pane% outermost-panel)) (define details/manual-parent-panel (make-object vertical-panel% details-outer-panel)) (define details-panel (make-object panel:single% details/manual-parent-panel)) @@ -493,9 +577,11 @@ (define (module-language-selected) ;; need to deselect things in the languages-hier-list at this point. - (send languages-hier-list select #f) - (send use-chosen-language-rb set-selection #f) + (send other-languages-hier-list select #f) + (send teaching-languages-hier-list select #f) (send use-language-in-source-rb set-selection 0) + (send use-chosen-language-rb set-selection #f) + (send use-teaching-language-rb set-selection #f) (ok-handler 'enable) (send details-button enable #t) (update-gui-based-on-selected-language module-language*language @@ -504,12 +590,14 @@ ;; no-language-selected : -> void ;; updates the GUI for the situation where no language at all selected, and - ;; and thus neither of the radio buttons should be selected. + ;; and thus none of the radio buttons should be selected. ;; this generally happens when there is no preference setting for the language ;; (ie the user has just started drracket for the first time) (define (no-language-selected) (non-language-selected) - (send use-chosen-language-rb set-selection #f)) + (send use-language-in-source-rb set-selection #f) + (send use-chosen-language-rb set-selection #f) + (send use-teaching-language-rb set-selection #f)) (define module-language*language 'module-language*-not-yet-set) (define module-language*get-language-details-panel 'module-language*-not-yet-set) @@ -519,8 +607,6 @@ ;; updates the GUI and selected-language and get/set-selected-language-settings ;; for when some non-language is selected in the hierlist (define (non-language-selected) - (send use-chosen-language-rb set-selection 0) - (send use-language-in-source-rb set-selection #f) (send revert-to-defaults-button enable #f) (send details-panel active-child no-details-panel) (send one-line-summary-message set-label "") @@ -530,10 +616,18 @@ (send details-button enable #f)) ;; something-selected : item -> void - (define (something-selected item) - (send use-chosen-language-rb set-selection 0) + (define (something-selected hierlist item) (send use-language-in-source-rb set-selection #f) - (ok-handler 'enable) + (cond + [(eq? hierlist other-languages-hier-list) + (send use-teaching-language-rb set-selection #f) + (send use-chosen-language-rb set-selection 0) + (send teaching-languages-hier-list select #f)] + [else + (send use-teaching-language-rb set-selection 0) + (send use-chosen-language-rb set-selection #f) + (send other-languages-hier-list select #f)]) + (ok-handler 'enable) (send details-button enable #t) (send item selected)) @@ -546,34 +640,38 @@ ;; when `language' matches language-to-show, update the settings ;; panel to match language-to-show, otherwise set to defaults. (define (add-language-to-dialog language) - (let ([positions (send language get-language-position)] - [numbers (send language get-language-numbers)]) + (define positions (send language get-language-position)) + (define numbers (send language get-language-numbers)) + (define teaching-language? (and (pair? positions) + (equal? (car positions) + (string-constant teaching-languages)))) + + ;; don't show the initial language ... + (unless (equal? positions initial-language-position) + (unless (and (list? positions) + (list? numbers) + (pair? positions) + (pair? numbers) + (andmap number? numbers) + (andmap string? positions) + (= (length positions) (length numbers)) + ((length numbers) . >= . 1)) + (error 'drracket:language + (string-append + "languages position and numbers must be lists of strings and numbers," + " respectively, must have the same length, and must each contain at" + " least one element, got: ~e ~e") + positions numbers)) - ;; don't show the initial language ... - (unless (equal? positions initial-language-position) - (unless (and (list? positions) - (list? numbers) - (pair? positions) - (pair? numbers) - (andmap number? numbers) - (andmap string? positions) - (= (length positions) (length numbers)) - ((length numbers) . >= . 1)) + (when (null? (cdr positions)) + (unless (equal? positions (list (string-constant module-language-name))) (error 'drracket:language - (string-append - "languages position and numbers must be lists of strings and numbers," - " respectively, must have the same length, and must each contain at" - " least one element, got: ~e ~e") - positions numbers)) - - (when (null? (cdr positions)) - (unless (equal? positions (list (string-constant module-language-name))) - (error 'drracket:language - "Only the module language may be at the top level. Other languages must have at least two levels"))) - - (send languages-hier-list clear-fringe-cache) - - #| + "Only the module language may be at the top level. Other languages must have at least two levels"))) + + (send other-languages-hier-list clear-fringe-cache) + (send teaching-languages-hier-list clear-fringe-cache) + + #| inline the first level of the tree into just items in the hierlist keep track of the starting (see call to sort method below) by @@ -581,67 +679,72 @@ what the sorting number is for its level above (in the second-number mixin) |# - - (let add-sub-language ([ht languages-table] - [hier-list languages-hier-list] - [positions positions] - [numbers numbers] - [first? #t] - [second-number #f]) ;; only non-#f during the second iteration in which case it is the first iterations number - (cond - [(null? (cdr positions)) - (let* ([language-details-panel #f] - [real-get/set-settings - (case-lambda - [() - (cond - [(and language-to-show - settings-to-show - (equal? (send language-to-show get-language-position) - (send language get-language-position))) - settings-to-show] - [else - (send language default-settings)])] - [(x) (void)])] - [get-language-details-panel (lambda () language-details-panel)] - [get/set-settings (lambda x (apply real-get/set-settings x))] - [position (car positions)] - [number (car numbers)]) - - (set! construct-details - (let ([old construct-details]) - (lambda () - (old) - (let-values ([(language-details-panel-real get/set-settings) - (make-details-panel language)]) - (set! language-details-panel language-details-panel-real) - (set! real-get/set-settings get/set-settings)) - - (let-values ([(vis-lang vis-settings) - (cond - [(and (not selected-language) - (eq? language-to-show language)) - (values language-to-show settings-to-show)] - [(eq? selected-language language) - (values language - (if (eq? language language-to-show) - settings-to-show - (send language default-settings)))] - [else (values #f #f)])]) - (cond - [(and vis-lang - (equal? (send vis-lang get-language-position) - (send language get-language-position))) - (get/set-settings vis-settings) - (send details-panel active-child language-details-panel)] - [else - (get/set-settings (send language default-settings))]))))) - - (cond - [(equal? positions (list (string-constant module-language-name))) - (set! module-language*language language) - (set! module-language*get-language-details-panel get-language-details-panel) - (set! module-language*get/set-settings get/set-settings)] + (let add-sub-language ([ht languages-table] + [hier-list (if teaching-language? + teaching-languages-hier-list + other-languages-hier-list)] + [positions (if teaching-language? + (cdr positions) + positions)] + [numbers (if teaching-language? + (cdr numbers) + numbers)] + [first? #t] + [second-number #f]) ;; only non-#f during the second iteration in which case it is the first iterations number + (cond + [(null? (cdr positions)) + (let* ([language-details-panel #f] + [real-get/set-settings + (case-lambda + [() + (cond + [(and language-to-show + settings-to-show + (equal? (send language-to-show get-language-position) + (send language get-language-position))) + settings-to-show] + [else + (send language default-settings)])] + [(x) (void)])] + [get-language-details-panel (lambda () language-details-panel)] + [get/set-settings (lambda x (apply real-get/set-settings x))] + [position (car positions)] + [number (car numbers)]) + + (set! construct-details + (let ([old construct-details]) + (lambda () + (old) + (let-values ([(language-details-panel-real get/set-settings) + (make-details-panel language)]) + (set! language-details-panel language-details-panel-real) + (set! real-get/set-settings get/set-settings)) + + (let-values ([(vis-lang vis-settings) + (cond + [(and (not selected-language) + (eq? language-to-show language)) + (values language-to-show settings-to-show)] + [(eq? selected-language language) + (values language + (if (eq? language language-to-show) + settings-to-show + (send language default-settings)))] + [else (values #f #f)])]) + (cond + [(and vis-lang + (equal? (send vis-lang get-language-position) + (send language get-language-position))) + (get/set-settings vis-settings) + (send details-panel active-child language-details-panel)] + [else + (get/set-settings (send language default-settings))]))))) + + (cond + [(equal? positions (list (string-constant module-language-name))) + (set! module-language*language language) + (set! module-language*get-language-details-panel get-language-details-panel) + (set! module-language*get/set-settings get/set-settings)] [else (let* ([mixin (compose number-mixin @@ -671,61 +774,62 @@ (send language get-style-delta) 0 (send text last-position))])))]))] - [else (let* ([position (car positions)] - [number (car numbers)] - [sub-ht/sub-hier-list - (hash-ref - ht - (string->symbol position) - (λ () - (if first? - (let* ([item (send hier-list new-item number-mixin)] - [x (list (make-hasheq) hier-list item)]) - (hash-set! ht (string->symbol position) x) - (send item set-number number) - (send item set-allow-selection #f) - (let* ([editor (send item get-editor)] - [pos (send editor last-position)]) - (send editor insert "\n") - (send editor insert position) - (send editor change-style small-size-delta pos (+ pos 1)) - (send editor change-style section-style-delta - (+ pos 1) (send editor last-position))) - x) - (let* ([new-list (send hier-list new-list - (if second-number - (compose second-number-mixin number-mixin) - number-mixin))] - [x (list (make-hasheq) new-list #f)]) - (send new-list set-number number) - (when second-number - (send new-list set-second-number second-number)) - (send new-list set-allow-selection #t) - (send new-list open) - (send (send new-list get-editor) insert position) - (hash-set! ht (string->symbol position) x) - x))))]) - (cond - [first? - (unless (= number (send (caddr sub-ht/sub-hier-list) get-number)) - (error 'add-language "language ~s; expected number for ~e to be ~e, got ~e" - (send language get-language-name) - position - (send (caddr sub-ht/sub-hier-list) get-number) - number))] - [else - (unless (= number (send (cadr sub-ht/sub-hier-list) get-number)) - (error 'add-language "language ~s; expected number for ~e to be ~e, got ~e" - (send language get-language-name) - position - (send (cadr sub-ht/sub-hier-list) get-number) - number))]) - (add-sub-language (car sub-ht/sub-hier-list) - (cadr sub-ht/sub-hier-list) - (cdr positions) - (cdr numbers) - #f - (if first? number #f)))]))))) + [else + (let* ([position (car positions)] + [number (car numbers)] + [sub-ht/sub-hier-list + (hash-ref + ht + (string->symbol position) + (λ () + (if first? + (let* ([item (send hier-list new-item number-mixin)] + [x (list (make-hasheq) hier-list item)]) + (hash-set! ht (string->symbol position) x) + (send item set-number number) + (send item set-allow-selection #f) + (let* ([editor (send item get-editor)] + [pos (send editor last-position)]) + (send editor insert "\n") + (send editor insert position) + (send editor change-style small-size-delta pos (+ pos 1)) + (send editor change-style section-style-delta + (+ pos 1) (send editor last-position))) + x) + (let* ([new-list (send hier-list new-list + (if second-number + (compose second-number-mixin number-mixin) + number-mixin))] + [x (list (make-hasheq) new-list #f)]) + (send new-list set-number number) + (when second-number + (send new-list set-second-number second-number)) + (send new-list set-allow-selection #t) + (send new-list open) + (send (send new-list get-editor) insert position) + (hash-set! ht (string->symbol position) x) + x))))]) + (cond + [first? + (unless (= number (send (caddr sub-ht/sub-hier-list) get-number)) + (error 'add-language "language ~s; expected number for ~e to be ~e, got ~e" + (send language get-language-name) + position + (send (caddr sub-ht/sub-hier-list) get-number) + number))] + [else + (unless (= number (send (cadr sub-ht/sub-hier-list) get-number)) + (error 'add-language "language ~s; expected number for ~e to be ~e, got ~e" + (send language get-language-name) + position + (send (cadr sub-ht/sub-hier-list) get-number) + number))]) + (add-sub-language (car sub-ht/sub-hier-list) + (cadr sub-ht/sub-hier-list) + (cdr positions) + (cdr numbers) + #f + (if first? number #f)))])))) (define number<%> (interface () @@ -779,35 +883,59 @@ (send item close) (close-children item)] [else (void)])) - (close-children languages-hier-list)) + (close-children other-languages-hier-list) + (close-children teaching-languages-hier-list)) ;; open-current-language : -> void ;; opens the tabs that lead to the current language ;; and selects the current language (define (open-current-language) + + ;; set the initial selection in the hierlists + (let ([hier-default (preferences:get 'drracket:language-dialog:hierlist-default)]) + (when hier-default + (select-a-language-in-hierlist other-languages-hier-list hier-default))) + (let ([hier-default (preferences:get 'drracket:language-dialog:teaching-hierlist-default)]) + (when hier-default + (select-a-language-in-hierlist teaching-languages-hier-list (cdr hier-default)))) + + (send languages-hier-list-panel change-children + (λ (l) + (list ellipsis-spacer-panel ellipsis-message))) + (cond [(not (and language-to-show settings-to-show)) (no-language-selected)] [(is-a? language-to-show drracket:module-language:module-language<%>) - (let ([hier-default (preferences:get 'drracket:language-dialog:hierlist-default)]) - (when hier-default - (select-a-language-in-hierlist hier-default))) ;; the above changes the radio button selections, so do it before calling module-language-selected (module-language-selected)] [else - (send languages-hier-list focus) ;; only focus when the module language isn't selected - (send use-chosen-language-rb set-selection 0) - (send use-language-in-source-rb set-selection #f) - (select-a-language-in-hierlist (send language-to-show get-language-position))])) + (define position (send language-to-show get-language-position)) + (cond + [(and (pair? position) + (equal? (car position) + (string-constant teaching-languages))) + (select-a-language-in-hierlist teaching-languages-hier-list (cdr position)) + (send use-teaching-language-rb set-selection 0) + (send use-chosen-language-rb set-selection #f) + (send teaching-languages-hier-list focus)] + [else + (send languages-hier-list-panel change-children + (λ (l) + (list languages-hier-list-spacer other-languages-hier-list))) + (select-a-language-in-hierlist other-languages-hier-list position) + (send use-teaching-language-rb set-selection #f) + (send use-chosen-language-rb set-selection 0) + (send other-languages-hier-list focus)]) + (send use-language-in-source-rb set-selection #f)])) - (define (select-a-language-in-hierlist language-position) + (define (select-a-language-in-hierlist hier-list language-position) (cond [(null? (cdr language-position)) ;; nothing to open here - (send (car (send languages-hier-list get-items)) select #t) - (void)] + (send (car (send hier-list get-items)) select #t)] [else - (let loop ([hi languages-hier-list] + (let loop ([hi hier-list] ;; skip the first position, since it is flattened into the dialog [first-pos (cadr language-position)] @@ -819,8 +947,6 @@ (send hi get-items))]) (cond [(null? matching-children) - ;; just give up here. probably this means that a bad preference was saved - ;; and we're being called from the module-language case in 'open-current-language' (void)] [else (let ([child (car matching-children)]) @@ -828,8 +954,9 @@ [(null? position) (send child select #t)] [else - (send child open) - (loop child (car position) (cdr position))]))])))])) + (when (is-a? child hierarchical-list-compound-item<%>) ;; test can fail when prefs are bad + (send child open) + (loop child (car position) (cdr position)))]))])))])) ;; docs-callback : -> void (define (docs-callback) @@ -901,46 +1028,47 @@ (send revert-to-defaults-outer-panel stretchable-width #f) (send revert-to-defaults-outer-panel stretchable-height #f) - (send outermost-panel set-alignment 'center 'center) (for-each add-language-to-dialog languages) - (send languages-hier-list sort - (λ (x y) - (cond - [(and (x . is-a? . second-number<%>) - (y . is-a? . second-number<%>)) - (cond - [(= (send x get-second-number) - (send y get-second-number)) - (< (send x get-number) (send y get-number))] - [else - (< (send x get-second-number) - (send y get-second-number))])] - [(and (x . is-a? . number<%>) - (y . is-a? . second-number<%>)) - (cond - [(= (send x get-number) - (send y get-second-number)) - #t] - [else - (< (send x get-number) - (send y get-second-number))])] - [(and (x . is-a? . second-number<%>) - (y . is-a? . number<%>)) - (cond - [(= (send x get-second-number) - (send y get-number)) - #f] - [else (< (send x get-second-number) - (send y get-number))])] - [(and (x . is-a? . number<%>) - (y . is-a? . number<%>)) - (< (send x get-number) (send y get-number))] - [else #f]))) + (define (hier-list-sort-predicate x y) + (cond + [(and (x . is-a? . second-number<%>) + (y . is-a? . second-number<%>)) + (cond + [(= (send x get-second-number) + (send y get-second-number)) + (< (send x get-number) (send y get-number))] + [else + (< (send x get-second-number) + (send y get-second-number))])] + [(and (x . is-a? . number<%>) + (y . is-a? . second-number<%>)) + (cond + [(= (send x get-number) + (send y get-second-number)) + #t] + [else + (< (send x get-number) + (send y get-second-number))])] + [(and (x . is-a? . second-number<%>) + (y . is-a? . number<%>)) + (cond + [(= (send x get-second-number) + (send y get-number)) + #f] + [else (< (send x get-second-number) + (send y get-number))])] + [(and (x . is-a? . number<%>) + (y . is-a? . number<%>)) + (< (send x get-number) (send y get-number))] + [else #f])) + (send other-languages-hier-list sort hier-list-sort-predicate) + (send teaching-languages-hier-list sort hier-list-sort-predicate) ;; remove the newline at the front of the first inlined category (if there) ;; it won't be there if the module language is at the top. - (let ([t (send (car (send languages-hier-list get-items)) get-editor)]) + (for ([hier-list (in-list (list other-languages-hier-list teaching-languages-hier-list))]) + (define t (send (car (send hier-list get-items)) get-editor)) (when (equal? "\n" (send t get-text 0 1)) (send t delete 0 1))) @@ -949,15 +1077,21 @@ (λ (l) (list details-panel))) - (send languages-hier-list stretchable-width #t) - (send languages-hier-list stretchable-height #t) - (send languages-hier-list accept-tab-focus #t) - (send languages-hier-list allow-tab-exit #t) + (define (config-hier-list hier-list) + (send hier-list stretchable-width #t) + (send hier-list stretchable-height #t) + (send hier-list accept-tab-focus #t) + (send hier-list allow-tab-exit #t)) + (config-hier-list other-languages-hier-list) + (config-hier-list teaching-languages-hier-list) (send parent reflow-container) (close-all-languages) (open-current-language) - (send languages-hier-list min-client-width (text-width (send languages-hier-list get-editor))) - (send languages-hier-list min-client-height (text-height (send languages-hier-list get-editor))) + (define (set-min-sizes hier-list) + (send hier-list min-client-width (text-width (send hier-list get-editor))) + (send hier-list min-client-height (text-height (send hier-list get-editor)))) + (set-min-sizes other-languages-hier-list) + (set-min-sizes teaching-languages-hier-list) (when details-shown? (do-construct-details)) (update-show/hide-details) @@ -979,7 +1113,14 @@ (use-language-in-source-rb-callback) #t) #f)] - [(#\c) + [(#\t) + (if (mouse-event-uses-shortcut-prefix? evt) + (begin + (send use-teaching-language-rb set-selection 0) + (use-teaching-language-rb-callback) + #t) + #f)] + [(#\o) (if (mouse-event-uses-shortcut-prefix? evt) (begin (send use-chosen-language-rb set-selection 0) @@ -988,56 +1129,199 @@ #f)] [else #f]))))) - (define (add-discussion p) - (let* ([t (new text:standard-style-list%)] - [c (new editor-canvas% + (define (add-discussion p definitions-text use-language-in-source-rb-callback) + (define t (new (text:hide-caret/selection-mixin text:standard-style-list%))) + (define c (new editor-canvas% [stretchable-width #t] [horizontal-inset 0] [vertical-inset 0] [parent p] [style '(no-border no-vscroll no-hscroll transparent)] - [editor t])]) - (send t set-styles-sticky #f) - (send t set-autowrap-bitmap #f) - (let* ([size-sd (make-object style-delta% 'change-size (send normal-control-font get-point-size))] - [do-insert - (λ (str tt-style?) - (let ([before (send t last-position)]) - (send t insert str before before) - (cond - [tt-style? - (send t change-style - (send (send t get-style-list) find-named-style "Standard") - before (send t last-position))] - [else - (send t change-style - (send (send t get-style-list) basic-style) - before (send t last-position))]) - (send t change-style size-sd before (send t last-position))))]) - (when (send normal-control-font get-size-in-pixels) - (send size-sd set-size-in-pixels-on #t)) - (let loop ([strs (regexp-split #rx"#lang" sc-lang-in-source-discussion)]) - (do-insert (car strs) #f) - (unless (null? (cdr strs)) - (do-insert "#lang" #t) - (loop (cdr strs))))) - (send t hide-caret #t) - - (send t auto-wrap #t) - (send t lock #t) - (send c accept-tab-focus #f) - (send c allow-tab-exit #t) - c)) + [editor t])) + (send t set-styles-sticky #f) + (send t set-autowrap-bitmap #f) + (define size-sd (make-object style-delta% 'change-size (send normal-control-font get-point-size))) + (define (do-insert str tt-style?) + (define before (send t last-position)) + (send t insert str before before) + (cond + [tt-style? + (send t change-style + (send (send t get-style-list) find-named-style "Standard") + before (send t last-position))] + [else + (send t change-style + (send (send t get-style-list) basic-style) + before (send t last-position))]) + (send t change-style size-sd before (send t last-position))) + (when (send normal-control-font get-size-in-pixels) + (send size-sd set-size-in-pixels-on #t)) + (let loop ([strs (regexp-split #rx"#lang" (string-constant racket-language-discussion))]) + (do-insert (car strs) #f) + (unless (null? (cdr strs)) + (do-insert "#lang" #t) + (loop (cdr strs)))) + + (define xref-chan (make-channel)) + (thread + (λ () + (define xref (load-collections-xref)) + (let loop () + (channel-put xref-chan xref) + (loop)))) + + (define spacer-snips '()) + (define spacer-poses '()) + + (for ([lang (in-list '(racket racket/base typed/racket scribble/base))]) + (define the-lang-line (format "#lang ~a" lang)) + (do-insert " " #t) + (define before-lang (send t last-position)) + (do-insert the-lang-line #t) + (define after-lang (send t last-position)) + (define spacer (new spacer-snip%)) + (define spacer-pos (send t last-position)) + (set! spacer-snips (cons spacer spacer-snips)) + (set! spacer-poses (cons spacer-pos spacer-poses)) + (send t insert spacer spacer-pos spacer-pos) + (do-insert " [" #f) + (define before-docs (send t last-position)) + (do-insert "docs" #f) + (define after-docs (send t last-position)) + (do-insert "]\n" #f) + (send t set-clickback before-lang after-lang + (λ (t start end) + (use-language-in-source-rb-callback) + (define-values (current-line-start current-line-end) + (if definitions-text + (find-language-position definitions-text) + (values #f #f))) + (define existing-lang-line (and current-line-start + (send definitions-text get-text current-line-start current-line-end))) + (case (message-box/custom + (string-constant drscheme) + (string-append + (string-constant racket-dialect-in-buffer-message) + "\n\n" + (cond + [(and existing-lang-line + (equal? existing-lang-line the-lang-line)) + (format (string-constant racket-dialect-already-same-#lang-line) + existing-lang-line)] + [existing-lang-line + (format (string-constant racket-dialect-replace-#lang-line) + existing-lang-line + the-lang-line)] + [else + (format (string-constant racket-dialect-add-new-#lang-line) the-lang-line)])) + (cond + [(and existing-lang-line + (equal? existing-lang-line the-lang-line)) + (string-constant ok)] + [existing-lang-line + (string-constant replace-#lang-line)] + [else + (string-constant add-#lang-line)]) + (and (not (equal? existing-lang-line the-lang-line)) + (string-constant cancel)) + #f #f + '(default=1)) + [(1) + (cond + [current-line-start + (send definitions-text begin-edit-sequence) + (send definitions-text delete current-line-start current-line-end) + (send definitions-text insert the-lang-line current-line-start current-line-start) + (send definitions-text end-edit-sequence)] + [else + (send definitions-text begin-edit-sequence) + (send definitions-text insert "\n" 0 0) + (send definitions-text insert the-lang-line 0 0) + (send definitions-text end-edit-sequence)])] + [else (void)]))) + (send t set-clickback before-docs after-docs + (λ (t start end) + (define-values (path tag) (xref-tag->path+anchor (channel-get xref-chan) `(mod-path ,(symbol->string lang)))) + (define url (path->url path)) + (define url2 (if tag + (make-url (url-scheme url) + (url-user url) + (url-host url) + (url-port url) + (url-path-absolute? url) + (url-path url) + (url-query url) + tag) + url)) + (send-url (url->string url2))))) + + (do-insert (string-constant racket-language-discussion-end) #f) + + (define kmp (send t set-keymap (keymap:get-editor))) + + (send (send c get-parent) reflow-container) + + (define xb (box 0)) + (define max-spacer-pos + (for/fold ([m 0]) ([spacer-pos (in-list spacer-poses)]) + (send t position-location spacer-pos xb #f) + (max m (unbox xb)))) + (for ([spacer-pos (in-list spacer-poses)] + [spacer-snip (in-list spacer-snips)]) + (send t position-location spacer-pos xb #f) + (send spacer-snip set-width (- max-spacer-pos (unbox xb)))) + + (send t hide-caret #t) + (send t auto-wrap #t) + (send t lock #t) + (send c accept-tab-focus #f) + (send c allow-tab-exit #t) + + c) + + (define (find-language-position definitions-text) + (define prt (open-input-text-editor definitions-text)) + (port-count-lines! prt) + (define l (with-handlers ((exn:fail? (λ (x) #f))) + (read-language prt))) + (cond + [l + (define-values (line col pos) (port-next-location prt)) + (define hash-lang-start (send definitions-text find-string "#lang" 'backward pos 0 #f)) + (if hash-lang-start + (values hash-lang-start (- pos 1)) + (values #f #f))] + [else + (values #f #f)])) + + (define spacer-snip% + (class snip% + (inherit get-admin) + (define width 0) + (define/public (set-width w) + (set! width w) + (define admin (get-admin)) + (when admin + (send admin resized this #t))) + (define/override (get-text [start 0] [end 'eof] [flattened? #f] [force-cr? #f]) + "") + (define/override (get-extent dc x y wb hb db ab lb sp) + (super get-extent dc x y wb hb db ab lb sp) + (when (box? wb) (set-box! wb width))) + (super-new))) + (define spacer-sc (new snip-class%)) + (send spacer-sc set-classname "drracket:spacer-snipclass") + (send spacer-sc set-version 0) + (send (get-the-snip-class-list) add spacer-sc) (define (size-discussion-canvas canvas) - (let ([t (send canvas get-editor)]) - - (let ([by (box 0)]) - (send t position-location - (send t line-end-position (send t last-line)) - #f - by) - (send canvas min-height (+ (ceiling (inexact->exact (unbox by))) 24))))) + (define t (send canvas get-editor)) + (define by (box 0)) + (send t position-location + (send t line-end-position (send t last-line)) + #f + by) + (send canvas min-height (+ (ceiling (inexact->exact (unbox by))) 24))) (define section-style-delta (make-object style-delta% 'change-bold)) (send section-style-delta set-delta-foreground "medium blue") @@ -1178,7 +1462,7 @@ #f #f #t) - (+ 10 ;; upper bound on some platform specific space I don't know how to get. + (+ 16 ;; upper bound on some space I don't know how to get. (floor (inexact->exact (unbox y-box)))))) diff --git a/collects/drracket/private/local-member-names.rkt b/collects/drracket/private/local-member-names.rkt index 68fb3f23f0..e9c883ad9e 100644 --- a/collects/drracket/private/local-member-names.rkt +++ b/collects/drracket/private/local-member-names.rkt @@ -11,11 +11,11 @@ insert-auto-text) ;; from module-language-tools.rkt -(define-local-member-name +(define-local-member-name when-initialized - ;move-to-new-language + ;move-to-new-language get-in-module-language?) - + ;; for keybindings (otherwise private) (define-local-member-name jump-to-previous-error-loc @@ -24,3 +24,8 @@ ;; defined in module-language.rkt (define-local-member-name set-lang-wants-big-defs/ints-labels?) + +;; used by the test suite to tell when the +;; online check syntax has finished +(define-local-member-name + get-online-expansion-colors) diff --git a/collects/drracket/private/main.rkt b/collects/drracket/private/main.rkt index 0fd6472ece..1ace972f97 100644 --- a/collects/drracket/private/main.rkt +++ b/collects/drracket/private/main.rkt @@ -72,6 +72,7 @@ (preferences:set-default 'drracket:defs/ints-labels #t boolean?) (drr:set-default 'drracket:language-dialog:hierlist-default #f (λ (x) (or (not x) (and (list? x) (andmap string? x))))) +(preferences:set-default 'drracket:language-dialog:teaching-hierlist-default #f (λ (x) (or (not x) (and (list? x) (andmap string? x))))) (drr:set-default 'drracket:create-executable-gui-type 'stand-alone (λ (x) (memq x '(launcher stand-alone distribution)))) (drr:set-default 'drracket:create-executable-gui-base 'racket (λ (x) (memq x '(racket gracket)))) diff --git a/collects/drracket/private/module-language-tools.rkt b/collects/drracket/private/module-language-tools.rkt index 748c7e6b5f..3ca2998d8f 100644 --- a/collects/drracket/private/module-language-tools.rkt +++ b/collects/drracket/private/module-language-tools.rkt @@ -8,7 +8,8 @@ racket/class racket/gui/base "drsig.rkt" - "local-member-names.rkt") + "local-member-names.rkt" + framework/private/logging-timer) (define op (current-output-port)) (define (oprintf . args) (apply fprintf op args)) @@ -136,7 +137,7 @@ (<= start hash-lang-last-location)) (unless timer - (set! timer (new timer% + (set! timer (new logging-timer% [notify-callback (λ () (when in-module-language? diff --git a/collects/drracket/private/module-language.rkt b/collects/drracket/private/module-language.rkt index 4adb99cc4b..7ce9dbc8ba 100644 --- a/collects/drracket/private/module-language.rkt +++ b/collects/drracket/private/module-language.rkt @@ -25,7 +25,9 @@ "rep.rkt" "eval-helpers.rkt" "local-member-names.rkt" - "rectangle-intersect.rkt") + "rectangle-intersect.rkt" + + framework/private/logging-timer) (define-runtime-path expanding-place.rkt "expanding-place.rkt") @@ -145,29 +147,31 @@ (inherit get-language-name) (define/public (get-users-language-name defs-text) - (let* ([defs-port (open-input-text-editor defs-text)] - [read-successfully? - (with-handlers ((exn:fail? (λ (x) #f))) - (read-language defs-port (λ () #f)) - #t)]) - (cond - [read-successfully? - (let* ([str (send defs-text get-text 0 (file-position defs-port))] - [pos (regexp-match-positions #rx"#(?:!|lang )" str)]) - (cond - [(not pos) - (get-language-name)] - [else - ;; newlines can break things (ie the language text won't - ;; be in the right place in the interactions window, which - ;; at least makes the test suites unhappy), so get rid of - ;; them from the name. Otherwise, if there is some weird formatting, - ;; so be it. - (regexp-replace* #rx"[\r\n]+" - (substring str (cdr (car pos)) (string-length str)) - " ")]))] - [else - (get-language-name)]))) + (define defs-port (open-input-text-editor defs-text)) + (port-count-lines! defs-port) + (define read-successfully? + (with-handlers ((exn:fail? (λ (x) #f))) + (read-language defs-port (λ () #f)) + #t)) + (cond + [read-successfully? + (define-values (_line _col port-pos) (port-next-location defs-port)) + (define str (send defs-text get-text 0 (- port-pos 1))) + (define pos (regexp-match-positions #rx"#(?:!|lang )" str)) + (cond + [(not pos) + (get-language-name)] + [else + ;; newlines can break things (ie the language text won't + ;; be in the right place in the interactions window, which + ;; at least makes the test suites unhappy), so get rid of + ;; them from the name. Otherwise, if there is some weird formatting, + ;; so be it. + (regexp-replace* #rx"[\r\n]+" + (substring str (cdr (car pos)) (string-length str)) + " ")])] + [else + (get-language-name)])) (define/override (use-namespace-require/copy?) #f) @@ -933,6 +937,7 @@ ;; colors : (or/c #f (listof string?) 'parens) (define colors #f) (define tooltip-labels #f) + (define/public (get-online-expansion-colors) colors) (super-new) @@ -1310,11 +1315,12 @@ (inherit last-position find-first-snip get-top-level-window get-filename get-tab get-canvas invalidate-bitmap-cache set-position get-start-position get-end-position - highlight-range dc-location-to-editor-location) + highlight-range dc-location-to-editor-location + begin-edit-sequence end-edit-sequence) (define compilation-out-of-date? #f) - (define tmr (new timer% [notify-callback (lambda () (send-off))])) + (define tmr (new logging-timer% [notify-callback (lambda () (send-off))])) (define cb-proc (λ (sym new-val) (when new-val @@ -1502,6 +1508,7 @@ (reset-frame-expand-error #f)) (define/private (show-error-in-margin res) + (begin-edit-sequence #f #f) (define tlw (send (get-tab) get-frame)) (send (get-tab) show-bkg-running 'nothing #f) (set! error/status-message-str (vector-ref res 1)) @@ -1516,7 +1523,8 @@ (set-error-ranges-from-online-error-ranges (vector-ref res 2)) (invalidate-online-error-ranges) (set! error/status-message-hidden? #f) - (update-frame-expand-error)) + (update-frame-expand-error) + (end-edit-sequence)) (define/private (show-error-as-highlighted-regions res) (define tlw (send (get-tab) get-frame)) @@ -1551,6 +1559,7 @@ (send (send (get-tab) get-ints) set-error-ranges srclocs)) (define/private (clear-old-error) + (begin-edit-sequence #f #f) (for ([cleanup-thunk (in-list online-highlighted-errors)]) (cleanup-thunk)) (for ([an-error-range (in-list online-error-ranges)]) @@ -1558,7 +1567,8 @@ ((error-range-clear-highlight an-error-range)) (set-error-range-clear-highlight! an-error-range #f))) (invalidate-online-error-ranges) - (set-online-error-ranges '())) + (set-online-error-ranges '()) + (end-edit-sequence)) (define/private (invalidate-online-error-ranges) (when (get-admin) @@ -1781,7 +1791,7 @@ (define lang-wants-big-defs/ints-labels? #f) (define recently-typed-timer - (new timer% + (new logging-timer% [notify-callback (λ () (update-recently-typed #f) @@ -1809,7 +1819,9 @@ (update-recently-typed #t) (set! fade-amount 0) (send recently-typed-timer stop) - (send recently-typed-timer start 10000 #t)) + (when (and lang-wants-big-defs/ints-labels? + (preferences:get 'drracket:defs/ints-labels)) + (send recently-typed-timer start 10000 #t))) (super on-char evt)) (define/private (update-recently-typed nv) @@ -1824,7 +1836,8 @@ [else (preferences:get 'drracket:defs/ints-labels)])) (unless (equal? new-inside? inside?) (set! inside? new-inside?) - (invalidate-bitmap-cache 0 0 'display-end 'display-end)) + (when lang-wants-big-defs/ints-labels? + (invalidate-bitmap-cache 0 0 'display-end 'display-end))) (cond [(and lang-wants-big-defs/ints-labels? (preferences:get 'drracket:defs/ints-labels) diff --git a/collects/drracket/private/rep.rkt b/collects/drracket/private/rep.rkt index b10234d420..c15af7a6db 100644 --- a/collects/drracket/private/rep.rkt +++ b/collects/drracket/private/rep.rkt @@ -434,7 +434,6 @@ TODO insert insert-before insert-between - invalidate-bitmap-cache is-locked? last-position line-location @@ -472,9 +471,9 @@ TODO (define/public (get-context) context) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;; ;;; + ;;; ;;; ;;; User -> Kernel ;;; - ;;; ;;; + ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; =User= (probably doesn't matter) @@ -775,8 +774,8 @@ TODO (unless inserting-prompt? (reset-highlighting)) (when (and prompt-position - (ormap (λ (start) (< start prompt-position)) - starts)) + (ormap (λ (start) (< start prompt-position)) + starts)) (set! prompt-position (get-unread-start-point)) (reset-regions (append (all-but-last (get-regions)) (list (list prompt-position 'end)))))) @@ -1265,6 +1264,7 @@ TODO (thread (λ () + (struct gui-event (start? msec name) #:prefab) ;; forward system events the user's logger, and record any ;; events that happen on the user's logger to show in the GUI (let ([sys-evt (make-log-receiver drracket:init:system-logger 'debug)] @@ -1274,16 +1274,18 @@ TODO (handle-evt sys-evt (λ (logged) - (log-message user-logger - (vector-ref logged 0) - (vector-ref logged 1) - (vector-ref logged 2)) + (unless (gui-event? (vector-ref logged 2)) + (log-message user-logger + (vector-ref logged 0) + (vector-ref logged 1) + (vector-ref logged 2))) (loop))) (handle-evt user-evt (λ (vec) - (parameterize ([current-eventspace drracket:init:system-eventspace]) - (queue-callback (λ () (new-log-message vec)))) + (unless (gui-event? (vector-ref vec 2)) + (parameterize ([current-eventspace drracket:init:system-eventspace]) + (queue-callback (λ () (new-log-message vec))))) (loop)))))))) (initialize-parameters snip-classes) diff --git a/collects/drracket/private/syncheck/blueboxes-gui.rkt b/collects/drracket/private/syncheck/blueboxes-gui.rkt index e8d1bfcf24..d0d1480033 100644 --- a/collects/drracket/private/syncheck/blueboxes-gui.rkt +++ b/collects/drracket/private/syncheck/blueboxes-gui.rkt @@ -8,7 +8,8 @@ setup/dirs images/icons/misc "../rectangle-intersect.rkt" - string-constants) + string-constants + framework/private/logging-timer) (provide docs-text-mixin docs-editor-canvas-mixin syncheck:add-docs-range @@ -376,7 +377,7 @@ [else (super on-event evt)])) - (define timer (new timer% + (define timer (new logging-timer% [notify-callback (λ () (set! timer-running? #f) diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt index 7d3b1464bd..c18fb6f83b 100644 --- a/collects/drracket/private/syncheck/gui.rkt +++ b/collects/drracket/private/syncheck/gui.rkt @@ -48,7 +48,8 @@ If the namespace does not, they are colored the unbound color. "traversals.rkt" "annotate.rkt" "../tooltip.rkt" - "blueboxes-gui.rkt") + "blueboxes-gui.rkt" + framework/private/logging-timer) (provide tool@) (define orig-output-port (current-output-port)) @@ -969,7 +970,7 @@ If the namespace does not, they are colored the unbound color. ;; Starts or restarts a one-shot arrow draw timer (define/private (start-arrow-draw-timer delay-ms) (unless arrow-draw-timer - (set! arrow-draw-timer (make-object timer% (λ () (maybe-update-drawn-arrows))))) + (set! arrow-draw-timer (make-object logging-timer% (λ () (maybe-update-drawn-arrows))))) (send arrow-draw-timer start delay-ms #t)) ;; this will be set to a time in the future if arrows shouldn't be drawn until then @@ -1581,6 +1582,7 @@ If the namespace does not, they are colored the unbound color. (send (send defs-text get-tab) add-bkg-running-color 'syncheck "orchid" cs-syncheck-running) (send defs-text syncheck:init-arrows) (let loop ([val val] + [start-time (current-inexact-milliseconds)] [i 0]) (cond [(null? val) @@ -1588,40 +1590,42 @@ If the namespace does not, they are colored the unbound color. (send defs-text syncheck:update-drawn-arrows) (send (send defs-text get-tab) remove-bkg-running-color 'syncheck) (set-syncheck-running-mode #f)] - [(= i 500) + [(and (i . > . 0) ;; check i just in case things are really strange + (20 . <= . (- (current-inexact-milliseconds) start-time))) (queue-callback (λ () (when (unbox bx) - (loop val 0))) + (log-timeline "continuing replay-compile-comp-trace" + (loop val (current-inexact-milliseconds) 0)))) #f)] [else (process-trace-element defs-text (car val)) - (loop (cdr val) (+ i 1))])))) + (loop (cdr val) start-time (+ i 1))])))) (define/private (process-trace-element defs-text x) ;; using 'defs-text' all the time is wrong in the case of embedded editors, ;; but they already don't work and we've arranged for them to not appear here .... (match x - [`(syncheck:add-arrow ,start-text ,start-pos-left ,start-pos-right - ,end-text ,end-pos-left ,end-pos-right - ,actual? ,level) + [`#(syncheck:add-arrow ,start-pos-left ,start-pos-right + ,end-pos-left ,end-pos-right + ,actual? ,level) (send defs-text syncheck:add-arrow defs-text start-pos-left start-pos-right defs-text end-pos-left end-pos-right actual? level)] - [`(syncheck:add-tail-arrow ,from-text ,from-pos ,to-text ,to-pos) + [`#(syncheck:add-tail-arrow ,from-pos ,to-pos) (send defs-text syncheck:add-tail-arrow defs-text from-pos defs-text to-pos)] - [`(syncheck:add-mouse-over-status ,text ,pos-left ,pos-right ,str) + [`#(syncheck:add-mouse-over-status ,pos-left ,pos-right ,str) (send defs-text syncheck:add-mouse-over-status defs-text pos-left pos-right str)] - [`(syncheck:add-background-color ,text ,color ,start ,fin) + [`#(syncheck:add-background-color ,color ,start ,fin) (send defs-text syncheck:add-background-color defs-text color start fin)] - [`(syncheck:add-jump-to-definition ,text ,start ,end ,id ,filename) + [`#(syncheck:add-jump-to-definition ,start ,end ,id ,filename) (send defs-text syncheck:add-jump-to-definition defs-text start end id filename)] - [`(syncheck:add-require-open-menu ,text ,start-pos ,end-pos ,file) + [`#(syncheck:add-require-open-menu ,start-pos ,end-pos ,file) (send defs-text syncheck:add-require-open-menu defs-text start-pos end-pos file)] - [`(syncheck:add-docs-menu ,text ,start-pos ,end-pos ,key ,the-label ,path ,definition-tag ,tag) + [`#(syncheck:add-docs-menu,start-pos ,end-pos ,key ,the-label ,path ,definition-tag ,tag) (send defs-text syncheck:add-docs-menu defs-text start-pos end-pos key the-label path definition-tag tag)] - [`(syncheck:add-rename-menu ,id-as-sym ,to-be-renamed/poss ,name-dup-pc ,name-dup-id) + [`#(syncheck:add-rename-menu ,id-as-sym ,to-be-renamed/poss ,name-dup-pc ,name-dup-id) (define other-side-dead? #f) (define (name-dup? name) (cond @@ -1639,7 +1643,7 @@ If the namespace does not, they are colored the unbound color. #f])])) (define to-be-renamed/poss/fixed (for/list ([lst (in-list to-be-renamed/poss)]) - (list defs-text (list-ref lst 1) (list-ref lst 2)))) + (list defs-text (list-ref lst 0) (list-ref lst 1)))) (send defs-text syncheck:add-rename-menu id-as-sym to-be-renamed/poss/fixed name-dup?)])) @@ -2066,9 +2070,12 @@ If the namespace does not, they are colored the unbound color. (drracket:module-language-tools:add-online-expansion-handler online-comp.rkt 'go - (λ (defs-text val) (send (send (send defs-text get-canvas) get-top-level-window) - replay-compile-comp-trace - defs-text - val))))) + (λ (defs-text val) + (log-timeline + "replace-compile-comp-trace" + (send (send (send defs-text get-canvas) get-top-level-window) + replay-compile-comp-trace + defs-text + val)))))) (define-runtime-path online-comp.rkt "online-comp.rkt") diff --git a/collects/drracket/private/syncheck/online-comp.rkt b/collects/drracket/private/syncheck/online-comp.rkt index 0cd315ba1a..4101e6e1fd 100644 --- a/collects/drracket/private/syncheck/online-comp.rkt +++ b/collects/drracket/private/syncheck/online-comp.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/class racket/place + (for-syntax racket/base) "../../private/eval-helpers.rkt" "traversals.rkt" "local-member-names.rkt" @@ -34,26 +35,35 @@ (define/override (syncheck:find-source-object stx) (and (equal? src (syntax-source stx)) src)) - (define-syntax-rule - (log name) - (define/override (name . args) - (set! trace (cons (cons 'name args) trace)))) + + ;; send over the non _ variables in the message to the main drracket place + (define-syntax (log stx) + (syntax-case stx () + [(_ name args ...) + (with-syntax ([(wanted-args ...) + (filter (λ (x) (not (regexp-match #rx"^_" (symbol->string (syntax-e x))))) + (syntax->list #'(args ...)))]) + #'(define/override (name args ...) + (add-to-trace (vector 'name wanted-args ...))))])) - ; (log syncheck:color-range) ;; we don't want log these as they are too distracting to keep popping up - (log syncheck:add-mouse-over-status) - (log syncheck:add-arrow) - (log syncheck:add-tail-arrow) - (log syncheck:add-background-color) - (log syncheck:add-require-open-menu) - (log syncheck:add-docs-menu) - (log syncheck:add-jump-to-definition) + (log syncheck:add-arrow + _start-text start-pos-left start-pos-right + _end-text end-pos-left end-pos-right + actual? level) + (log syncheck:add-tail-arrow _from-text from-pos _to-text to-pos) + (log syncheck:add-mouse-over-status _text pos-left pos-right str) + (log syncheck:add-background-color _text color start fin) + (log syncheck:add-jump-to-definition _text start end id filename) + (log syncheck:add-require-open-menu _text start-pos end-pos file) + (log syncheck:add-docs-menu _text start-pos end-pos key the-label path definition-tag tag) (define/override (syncheck:add-rename-menu id-as-sym to-be-renamed/poss dup-name?) (define id (hash-count table)) (hash-set! table id dup-name?) - (set! trace (cons (list 'syncheck:add-rename-menu id-as-sym to-be-renamed/poss remote id) - trace))) + (add-to-trace (vector 'syncheck:add-rename-menu id-as-sym (map cdr to-be-renamed/poss) remote id))) (define/public (get-trace) (reverse trace)) + (define/private (add-to-trace thing) + (set! trace (cons thing trace))) (super-new))) (define (go expanded path the-source orig-cust) diff --git a/collects/drracket/private/syncheck/traversals.rkt b/collects/drracket/private/syncheck/traversals.rkt index abcb575df8..7675316bb6 100644 --- a/collects/drracket/private/syncheck/traversals.rkt +++ b/collects/drracket/private/syncheck/traversals.rkt @@ -1134,10 +1134,22 @@ (for/or ([(level id-set) (in-hash phase-to-map)]) (get-ids id-set new-id)))))))) #t)) - (send defs-text syncheck:add-rename-menu - id-as-sym - loc-lst - name-dup?))))))) + (define max-to-send-at-once 30) + (let loop ([loc-lst loc-lst] + [len (length loc-lst)]) + (cond + [(<= len max-to-send-at-once) + (send defs-text syncheck:add-rename-menu + id-as-sym + loc-lst + name-dup?)] + [else + (send defs-text syncheck:add-rename-menu + id-as-sym + (take loc-lst max-to-send-at-once) + name-dup?) + (loop (drop loc-lst max-to-send-at-once) + (- len max-to-send-at-once))])))))))) ;; remove-duplicates-stx : (listof syntax[original]) -> (listof syntax[original]) ;; removes duplicates, based on the source locations of the identifiers diff --git a/collects/drracket/private/text.rkt b/collects/drracket/private/text.rkt index 14b0baa0d1..a0bb52bf73 100644 --- a/collects/drracket/private/text.rkt +++ b/collects/drracket/private/text.rkt @@ -17,17 +17,17 @@ (define/public (is-printing-on?) printing?) (define/public (printing-on) (set! printing? #t)) (define/public (printing-off) (set! printing? #f)) - ; (rename [super-on-paint on-paint]) - ; (inherit get-filename) - ; (override - ; [on-paint - ; (λ (before? dc left top right bottom dx dy draw-caret) - ; (super-on-paint before? dc left top right bottom dx dy draw-caret) - ; (let ([str (string-append - ; (mzlib:date:date->string (seconds->date (current-seconds))) - ; " " - ; (if (string? (get-filename)) - ; (get-filename) - ; "Untitled"))]) - ; (send dc draw-text str dx dy)))]) + ; (rename [super-on-paint on-paint]) + ; (inherit get-filename) + ; (override + ; [on-paint + ; (λ (before? dc left top right bottom dx dy draw-caret) + ; (super-on-paint before? dc left top right bottom dx dy draw-caret) + ; (let ([str (string-append + ; (mzlib:date:date->string (seconds->date (current-seconds))) + ; " " + ; (if (string? (get-filename)) + ; (get-filename) + ; "Untitled"))]) + ; (send dc draw-text str dx dy)))]) (super-new))) diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 6f51d1c35f..b7e1ecb2ea 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -44,7 +44,8 @@ module browser threading seems wrong. mzlib/date - framework/private/aspell) + framework/private/aspell + framework/private/logging-timer) (provide unit@) @@ -4544,7 +4545,7 @@ module browser threading seems wrong. (define num-running-frames (vector-length running-frames)) (define is-running? #f) (define frame 0) - (define timer (make-object timer% (λ () (refresh) (yield)) #f)) + (define timer (make-object logging-timer% (λ () (refresh) (yield)) #f)) (define/public (set-running r?) (cond [r? (unless is-running? (set! frame 4)) diff --git a/collects/dynext/link-unit.rkt b/collects/dynext/link-unit.rkt index d06b4c9f67..85496ce7ae 100644 --- a/collects/dynext/link-unit.rkt +++ b/collects/dynext/link-unit.rkt @@ -195,7 +195,7 @@ (make-parameter (case (system-type) [(unix macosx) - (case (string->symbol (path->string (system-library-subpath #f))) + (case (string->symbol (path->string (system-library-subpath #f))) [(i386-cygwin) win-gcc-link-output-strings] [else (lambda (s) (list "-o" (path-string->string s)))])] [(windows) (cond @@ -239,7 +239,7 @@ (list (wrap-xxxxxxx dllfile (wrap-3m "libracket~a~~a.dll")) (wrap-xxxxxxx dllfile (drop-3m "libmzgc~a.dll")))) (list - (mzdyn-maybe (filethunk (wrap-3m "mzdyn~a.exp"))) + (mzdyn-maybe (filethunk (wrap-3m "mzdyn~a.exp"))) (mzdyn-maybe (filethunk (wrap-3m ;; mzdyn.o is for Unix build, mzdynw.o for Windows (format "mzdyn~a~~a.o" diff --git a/collects/eopl/eopl.rkt b/collects/eopl/eopl.rkt index 9fe60fb335..b466444649 100644 --- a/collects/eopl/eopl.rkt +++ b/collects/eopl/eopl.rkt @@ -1,10 +1,12 @@ -#lang racket +#lang racket/base (require "datatype.rkt" "private/sllgen.rkt" + racket/promise mzlib/trace mzlib/pretty) -(require (for-syntax "private/slldef.rkt")) +(require (for-syntax racket/base + "private/slldef.rkt")) (provide define-datatype cases) diff --git a/collects/ffi/unsafe.rkt b/collects/ffi/unsafe.rkt index 43a6b225ae..37ffc7c12b 100644 --- a/collects/ffi/unsafe.rkt +++ b/collects/ffi/unsafe.rkt @@ -1702,6 +1702,7 @@ (cweh (lambda (exn) (log-message logger + 'error (if (exn? exn) (exn-message exn) (format "~s" exn)) diff --git a/collects/ffi/unsafe/atomic.rkt b/collects/ffi/unsafe/atomic.rkt index 30144685cf..daef99fdb3 100644 --- a/collects/ffi/unsafe/atomic.rkt +++ b/collects/ffi/unsafe/atomic.rkt @@ -112,7 +112,7 @@ break-paramz (lambda () (dynamic-wind - (lambda () + (lambda () (set! monitor-owner #f) (set! extra-atomic-depth 0) (end-breakable-atomic) diff --git a/collects/ffi/unsafe/com.rkt b/collects/ffi/unsafe/com.rkt index 152aede0c5..d5d08b0722 100644 --- a/collects/ffi/unsafe/com.rkt +++ b/collects/ffi/unsafe/com.rkt @@ -1,12 +1,12 @@ #lang racket/base (require ffi/unsafe ffi/unsafe/alloc - ffi/winapi + ffi/winapi ffi/unsafe/atomic ffi/unsafe/custodian racket/date racket/runtime-path - racket/list + racket/list (for-syntax racket/base) "private/win32.rkt") @@ -126,15 +126,15 @@ (define (_system-string/utf-16 mode) (make-ctype _pointer - (lambda (s) - (and s + (lambda (s) + (and s (let ([c (string->pointer s)]) (register-cleanup! (lambda () (SysFreeString c))) c))) - (lambda (p) - (begin0 - (cast p _pointer _string/utf-16) - (when (memq 'out mode) (SysFreeString p)))))) + (lambda (p) + (begin0 + (cast p _pointer _string/utf-16) + (when (memq 'out mode) (SysFreeString p)))))) (define current-cleanup (make-parameter #f)) (define current-commit (make-parameter #f)) @@ -464,8 +464,8 @@ (define-com-interface (_IClassFactory _IUnknown) ([CreateInstance/factory (_hmfun _IUnknown-pointer/null _REFIID - (p : (_ptr o _ISink-pointer/null)) - -> CreateInstance p)] + (p : (_ptr o _ISink-pointer/null)) + -> CreateInstance p)] [LockServer _fpointer])) @@ -595,17 +595,17 @@ (bitwise-ior CLSCTX_LOCAL_SERVER CLSCTX_INPROC_SERVER) IID_IUnknown)] [else - (define cleanup (box null)) + (define cleanup (box null)) (define csi (parameterize ([current-cleanup cleanup]) - (make-COSERVERINFO 0 machine #f 0))) + (make-COSERVERINFO 0 machine #f 0))) (define mqi (make-MULTI_QI IID_IUnknown #f 0)) (define unknown - (dynamic-wind - void - (lambda () - (CoCreateInstanceEx clsid #f CLSCTX_REMOTE_SERVER (and machine csi) 1 mqi)) - (lambda () - (for ([proc (in-list (unbox cleanup))]) (proc))))) + (dynamic-wind + void + (lambda () + (CoCreateInstanceEx clsid #f CLSCTX_REMOTE_SERVER (and machine csi) 1 mqi)) + (lambda () + (for ([proc (in-list (unbox cleanup))]) (proc))))) (unless (and (zero? (MULTI_QI-hr mqi)) unknown) (error who "unable to obtain IUnknown interface for remote server")) @@ -643,7 +643,7 @@ (let ([mref (com-impl-mref impl)]) (when mref (set-com-impl-mref! impl #f) - (unregister-custodian-shutdown impl mref))) + (unregister-custodian-shutdown impl mref))) (release-type-types (com-impl-type-info impl)) (define (bye! sel st!) (when (sel impl) @@ -669,7 +669,7 @@ (when (zero? (type-ref-count type)) (when (positive? (hash-count (type-types type))) (for ([td (in-hash-values (type-types type))]) - (release-type-desc td)) + (release-type-desc td)) (set-type-types! type (make-hash))) (hash-remove! types type-info))))) @@ -736,23 +736,23 @@ dispatch))) (struct type (type-info [types #:mutable] - scheme-types - [ref-count #:mutable])) + scheme-types + [ref-count #:mutable])) (define types (make-weak-hash)) (define (intern-type-info type-info) ;; called in atomic mode (let ([ti-e (hash-ref types type-info #f)]) (if ti-e - (let* ([t (ephemeron-value ti-e)] - [ti (type-type-info t)]) - (set-type-ref-count! t (add1 (type-ref-count t))) - (Release type-info) - (AddRef ti) - t) - (let ([t (type type-info (make-hash) (make-hash) 1)]) - (hash-set! types type-info (make-ephemeron type-info t)) - t)))) + (let* ([t (ephemeron-value ti-e)] + [ti (type-type-info t)]) + (set-type-ref-count! t (add1 (type-ref-count t))) + (Release type-info) + (AddRef ti) + t) + (let ([t (type type-info (make-hash) (make-hash) 1)]) + (hash-set! types type-info (make-ephemeron type-info t)) + t)))) (define (type-info-type type-info) (ephemeron-value (hash-ref types type-info))) @@ -766,18 +766,18 @@ (error "COM object does not expose type information") #f) (let ([type-info (GetTypeInfo - dispatch - 0 - LOCALE_SYSTEM_DEFAULT)]) - (unless type-info - (error "Error getting COM type information")) - (let* ([type (intern-type-info type-info)] - [type-info (type-type-info type)] - [impl (com-object-impl obj)]) - (set-com-impl-type-info! impl type-info) - (set-com-impl-types! impl (type-types type)) - (set-com-impl-scheme-types! impl (type-scheme-types type)) - type-info)))))) + dispatch + 0 + LOCALE_SYSTEM_DEFAULT)]) + (unless type-info + (error "Error getting COM type information")) + (let* ([type (intern-type-info type-info)] + [type-info (type-type-info type)] + [impl (com-object-impl obj)]) + (set-com-impl-type-info! impl type-info) + (set-com-impl-types! impl (type-types type)) + (set-com-impl-scheme-types! impl (type-scheme-types type)) + type-info)))))) (define (com-object-type obj) (check-com-obj 'com-object-type obj) @@ -1003,7 +1003,7 @@ var-desc] [else (ReleaseVarDesc type-info var-desc) - #f]))) + #f]))) ;; search in inherited interfaces (for/or ([i (in-range (TYPEATTR-cImplTypes type-attr))]) (define ref-type (GetRefTypeOfImplType type-info i)) @@ -1084,20 +1084,20 @@ (event-type-info-from-com-object obj)] [else (type-info-from-com-object obj exn?)])]) - (and type-info + (and type-info (let ([mx-type-desc (type-desc-from-type-info name inv-kind type-info)]) (when mx-type-desc (hash-set! (com-object-types obj) (cons name inv-kind) mx-type-desc)) mx-type-desc))))) (define (get-var-type-from-elem-desc elem-desc - #:keep-safe-array? [keep-safe-array? #f]) + #:keep-safe-array? [keep-safe-array? #f]) ;; hack: allow elem-desc as a TYPEDESC (define param-desc (and (ELEMDESC? elem-desc) - (union-ref (ELEMDESC-u elem-desc) 1))) + (union-ref (ELEMDESC-u elem-desc) 1))) (define flags (if param-desc - (PARAMDESC-wParamFlags param-desc) - 0)) + (PARAMDESC-wParamFlags param-desc) + 0)) (define (fixup-vt vt) (cond [(= vt (bitwise-ior VT_USERDEFINED VT_BYREF)) @@ -1105,12 +1105,12 @@ [(= vt VT_USERDEFINED) VT_INT] [(and (= vt VT_SAFEARRAY) - (not keep-safe-array?)) + (not keep-safe-array?)) (bitwise-ior VT_ARRAY VT_VARIANT)] [else vt])) (define type-desc (if (ELEMDESC? elem-desc) - (ELEMDESC-tdesc elem-desc) - elem-desc)) + (ELEMDESC-tdesc elem-desc) + elem-desc)) (cond [(and (bit-and? flags PARAMFLAG_FOPT) (bit-and? flags PARAMFLAG_FHASDEFAULT)) @@ -1119,9 +1119,9 @@ [(= (TYPEDESC-vt type-desc) VT_PTR) (fixup-vt (bitwise-ior VT_BYREF - (TYPEDESC-vt (cast (union-ref (TYPEDESC-u type-desc) 0) - _pointer - _TYPEDESC-pointer))))] + (TYPEDESC-vt (cast (union-ref (TYPEDESC-u type-desc) 0) + _pointer + _TYPEDESC-pointer))))] [else (fixup-vt (TYPEDESC-vt type-desc))])) @@ -1145,7 +1145,7 @@ (define (elem-desc-to-scheme-type elem-desc ignore-by-ref? is-opt? internal?) (define vt (let ([vt (get-var-type-from-elem-desc elem-desc #:keep-safe-array? #t)]) (if (and ignore-by-ref? - (not (= vt (bitwise-ior VT_USERDEFINED VT_BYREF)))) + (not (= vt (bitwise-ior VT_USERDEFINED VT_BYREF)))) (- vt (bitwise-and vt VT_BYREF)) vt))) (cond @@ -1171,12 +1171,12 @@ [else (define as-iunk? (= vt (bitwise-ior VT_USERDEFINED VT_BYREF))) (define base (vt-to-scheme-type (if as-iunk? - vt - (- vt (bitwise-and vt VT_BYREF))))) + vt + (- vt (bitwise-and vt VT_BYREF))))) (define new-base (if (and (not as-iunk?) - (bit-and? vt VT_BYREF)) - `(box ,base) + (bit-and? vt VT_BYREF)) + `(box ,base) base)) (if is-opt? `(opt ,new-base) @@ -1232,12 +1232,12 @@ [(type-described? arg) (type-described-description arg)] [(vector? arg) `(array ,(vector-length arg) - ,(if (zero? (vector-length arg)) - 'int - (for/fold ([t (arg-to-type (vector-ref arg 0))]) ([v (in-vector arg)]) - (if (equal? t (arg-to-type v)) - t - 'any))))] + ,(if (zero? (vector-length arg)) + 'int + (for/fold ([t (arg-to-type (vector-ref arg 0))]) ([v (in-vector arg)]) + (if (equal? t (arg-to-type v)) + t + 'any))))] [(in-array . > . 1) 'any] [(boolean? arg) 'boolean] [(signed-int? arg 32) 'int] @@ -1282,25 +1282,25 @@ (call-as-atomic (lambda () (or (and (com-object? obj) - (hash-ref (com-object-scheme-types obj) (cons name inv-kind) #f)) - (let ([t (get-uncached-method-type who obj name inv-kind internal?)]) - (when (com-object? obj) - (hash-set! (com-object-scheme-types obj) (cons name inv-kind) t)) - t))))) + (hash-ref (com-object-scheme-types obj) (cons name inv-kind) #f)) + (let ([t (get-uncached-method-type who obj name inv-kind internal?)]) + (when (com-object? obj) + (hash-set! (com-object-scheme-types obj) (cons name inv-kind) t)) + t))))) (define (get-uncached-method-type who obj name inv-kind internal?) (define type-info (extract-type-info who obj (not internal?))) (when (and (= inv-kind INVOKE_FUNC) - (is-dispatch-name? name)) - (error who "IDispatch methods not available")) + (is-dispatch-name? name)) + (error who "IDispatch methods not available")) (define mx-type-desc (cond [(com-object? obj) (get-method-type obj name inv-kind (not internal?))] [else (define x-type-info - (if (= inv-kind INVOKE_EVENT) - (event-type-info-from-com-type obj) - type-info)) - (type-desc-from-type-info name inv-kind x-type-info)])) + (if (= inv-kind INVOKE_EVENT) + (event-type-info-from-com-type obj) + type-info)) + (type-desc-from-type-info name inv-kind x-type-info)])) (cond [(not mx-type-desc) ;; there is no type info @@ -1309,60 +1309,60 @@ (define-values (args ret) (cond [(function-type-desc? mx-type-desc) - (define func-desc (car (mx-com-type-desc-desc mx-type-desc))) - (define num-actual-params (FUNCDESC-cParams func-desc)) - (cond - [(= -1 (FUNCDESC-cParamsOpt func-desc)) - ;; all args > pFuncDesc->cParams - 1 get packaged into SAFEARRAY, - ;; but that is handled by COM automation; we just pass "any"s - (values - (append - (for/list ([i (in-range (sub1 num-actual-params))]) - (elem-desc-to-scheme-type (elem-desc-ref func-desc i) - #f - #f - internal?)) - '(any ...)) - (elem-desc-to-scheme-type (FUNCDESC-elemdescFunc func-desc) - #f - #f - internal?))] - [else - (define last-is-retval? - (is-last-param-retval? inv-kind func-desc)) - (define num-params (- num-actual-params (if last-is-retval? 1 0))) - ;; parameters that are optional with a default value in IDL are not - ;; counted in pFuncDesc->cParamsOpt, so look for default bit flag - (define num-opt-params (get-opt-param-count func-desc num-params)) - (define first-opt-arg (- num-params num-opt-params)) - (values - (for/list ([i (in-range num-params)]) - (elem-desc-to-scheme-type (elem-desc-ref func-desc i) - #f - (i . >= . first-opt-arg) - internal?)) - (elem-desc-to-scheme-type (if last-is-retval? - (elem-desc-ref func-desc num-params) - (FUNCDESC-elemdescFunc func-desc)) - #t - #f - internal?))])] + (define func-desc (car (mx-com-type-desc-desc mx-type-desc))) + (define num-actual-params (FUNCDESC-cParams func-desc)) + (cond + [(= -1 (FUNCDESC-cParamsOpt func-desc)) + ;; all args > pFuncDesc->cParams - 1 get packaged into SAFEARRAY, + ;; but that is handled by COM automation; we just pass "any"s + (values + (append + (for/list ([i (in-range (sub1 num-actual-params))]) + (elem-desc-to-scheme-type (elem-desc-ref func-desc i) + #f + #f + internal?)) + '(any ...)) + (elem-desc-to-scheme-type (FUNCDESC-elemdescFunc func-desc) + #f + #f + internal?))] + [else + (define last-is-retval? + (is-last-param-retval? inv-kind func-desc)) + (define num-params (- num-actual-params (if last-is-retval? 1 0))) + ;; parameters that are optional with a default value in IDL are not + ;; counted in pFuncDesc->cParamsOpt, so look for default bit flag + (define num-opt-params (get-opt-param-count func-desc num-params)) + (define first-opt-arg (- num-params num-opt-params)) + (values + (for/list ([i (in-range num-params)]) + (elem-desc-to-scheme-type (elem-desc-ref func-desc i) + #f + (i . >= . first-opt-arg) + internal?)) + (elem-desc-to-scheme-type (if last-is-retval? + (elem-desc-ref func-desc num-params) + (FUNCDESC-elemdescFunc func-desc)) + #t + #f + internal?))])] [(= inv-kind INVOKE_PROPERTYGET) - (define var-desc (mx-com-type-desc-desc mx-type-desc)) - (values null - (elem-desc-to-scheme-type (VARDESC-elemdescVar var-desc) - #f - #f - internal?))] + (define var-desc (mx-com-type-desc-desc mx-type-desc)) + (values null + (elem-desc-to-scheme-type (VARDESC-elemdescVar var-desc) + #f + #f + internal?))] [(= inv-kind INVOKE_PROPERTYPUT) - (define var-desc (mx-com-type-desc-desc mx-type-desc)) - (values (list (elem-desc-to-scheme-type (VARDESC-elemdescVar var-desc) - #f - #f - internal?)) - 'void)] + (define var-desc (mx-com-type-desc-desc mx-type-desc)) + (values (list (elem-desc-to-scheme-type (VARDESC-elemdescVar var-desc) + #f + #f + internal?)) + 'void)] [(= inv-kind INVOKE_EVENT) - (values null 'void)])) + (values null 'void)])) `(-> ,args ,ret)])) (define (com-method-type obj name) @@ -1506,8 +1506,8 @@ (ok-argument? (unbox arg) (cadr type)))] [(eq? 'array (car type)) (and (vector? arg) - (or (eq? (cadr type) '?) - (= (vector-length arg) (cadr type))) + (or (eq? (cadr type) '?) + (= (vector-length arg) (cadr type))) (for/and ([v (in-vector arg)]) (ok-argument? v (caddr type))))] [(eq? 'variant (car type)) @@ -1609,8 +1609,8 @@ (variant-set! var (to-ctype scheme-type #:mode mode) a)] [else (define use-scheme-type (if (any-type? scheme-type) - (arg-to-type a) - scheme-type)) + (arg-to-type a) + scheme-type)) (set-VARIANT-vt! var (to-vt use-scheme-type)) (variant-set! var (to-ctype use-scheme-type #:mode mode) a)])) @@ -1628,33 +1628,33 @@ (define (_box/permanent _t) (define (extract p) (if (eq? _t _VARIANT) - (variant-to-scheme (cast p _pointer _VARIANT-pointer) #:mode '(in out)) - (ptr-ref p _t))) + (variant-to-scheme (cast p _pointer _VARIANT-pointer) #:mode '(in out)) + (ptr-ref p _t))) (make-ctype _pointer (lambda (v) (define p (malloc 'raw 1 _t)) (if (eq? _t _VARIANT) - (let ([p (cast p _pointer _VARIANT-pointer)] - [v (unbox v)]) - (VariantInit p) - (scheme-to-variant! p v #f (arg-to-type v) #:mode '(in out))) - (ptr-set! p _t (unbox v))) - (register-cleanup! + (let ([p (cast p _pointer _VARIANT-pointer)] + [v (unbox v)]) + (VariantInit p) + (scheme-to-variant! p v #f (arg-to-type v) #:mode '(in out))) + (ptr-set! p _t (unbox v))) + (register-cleanup! (lambda () (set-box! v (extract p)) (free p))) p) (lambda (p) - ;; We box the value, but we don't support reflecting box - ;; changes back to changes of the original reference: + ;; We box the value, but we don't support reflecting box + ;; changes back to changes of the original reference: (box (extract p))))) (define (make-a-VARIANT [mode 'atomic-interior]) (define var (cast (malloc _VARIANT mode) - _pointer - (if (eq? mode 'raw) - _VARIANT-pointer - (_gcable _VARIANT-pointer)))) + _pointer + (if (eq? mode 'raw) + _VARIANT-pointer + (_gcable _VARIANT-pointer)))) (VariantInit var) var) @@ -1670,44 +1670,44 @@ (define (_safe-array/vectors given-dims base mode) (make-ctype _pointer - (lambda (v) - (define base-vt (to-vt base)) - (define dims (if (equal? given-dims '(?)) - (list (vector-length v)) - given-dims)) - (define sa (SafeArrayCreate base-vt - (length dims) - (for/list ([d (in-list dims)]) - (make-SAFEARRAYBOUND d 0)))) - (register-cleanup! - (lambda () (SafeArrayDestroy sa))) - (let loop ([v v] [index null] [dims dims]) - (for ([v (in-vector v)] - [i (in-naturals)]) - (define idx (cons i index)) - (if (null? (cdr dims)) - (let ([var (make-a-VARIANT)]) - (scheme-to-variant! var v #f base #:mode mode) - (SafeArrayPutElement sa (reverse idx) - (extract-variant-pointer var #f base-vt))) - (loop v idx (cdr dims))))) - sa) - (lambda (_sa) - (define sa (cast _sa _pointer _SAFEARRAY-pointer)) - (define dims (for/list ([i (in-range (SafeArrayGetDim sa))]) - (- (add1 (SafeArrayGetUBound sa (add1 i))) - (SafeArrayGetLBound sa (add1 i))))) - (define vt (SafeArrayGetVartype sa)) - (let loop ([dims dims] [level 1] [index null]) - (define lb (SafeArrayGetLBound sa level)) - (for/vector ([i (in-range (car dims))]) - (if (null? (cdr dims)) - (let ([var (make-a-VARIANT)]) - (set-VARIANT-vt! var vt) - (SafeArrayGetElement sa (reverse (cons i index)) - (extract-variant-pointer var #t)) - (variant-to-scheme var #:mode mode)) - (loop (cdr dims) (add1 level) (cons i index)))))))) + (lambda (v) + (define base-vt (to-vt base)) + (define dims (if (equal? given-dims '(?)) + (list (vector-length v)) + given-dims)) + (define sa (SafeArrayCreate base-vt + (length dims) + (for/list ([d (in-list dims)]) + (make-SAFEARRAYBOUND d 0)))) + (register-cleanup! + (lambda () (SafeArrayDestroy sa))) + (let loop ([v v] [index null] [dims dims]) + (for ([v (in-vector v)] + [i (in-naturals)]) + (define idx (cons i index)) + (if (null? (cdr dims)) + (let ([var (make-a-VARIANT)]) + (scheme-to-variant! var v #f base #:mode mode) + (SafeArrayPutElement sa (reverse idx) + (extract-variant-pointer var #f base-vt))) + (loop v idx (cdr dims))))) + sa) + (lambda (_sa) + (define sa (cast _sa _pointer _SAFEARRAY-pointer)) + (define dims (for/list ([i (in-range (SafeArrayGetDim sa))]) + (- (add1 (SafeArrayGetUBound sa (add1 i))) + (SafeArrayGetLBound sa (add1 i))))) + (define vt (SafeArrayGetVartype sa)) + (let loop ([dims dims] [level 1] [index null]) + (define lb (SafeArrayGetLBound sa level)) + (for/vector ([i (in-range (car dims))]) + (if (null? (cdr dims)) + (let ([var (make-a-VARIANT)]) + (set-VARIANT-vt! var vt) + (SafeArrayGetElement sa (reverse (cons i index)) + (extract-variant-pointer var #t)) + (variant-to-scheme var #:mode mode)) + (loop (cdr dims) (add1 level) (cons i index)))))))) (define (_IUnknown-pointer-or-com-object mode) (make-ctype @@ -1722,12 +1722,12 @@ p) (lambda (p) (if p - (begin - (if (memq 'out mode) - (((allocator Release) (lambda () p))) - (AddRef p)) - (make-com-object p #f)) - p)))) + (begin + (if (memq 'out mode) + (((allocator Release) (lambda () p))) + (AddRef p)) + (make-com-object p #f)) + p)))) (define (_com-object mode) (_IUnknown-pointer-or-com-object mode)) @@ -1766,14 +1766,14 @@ [(eq? 'array (car type)) (define-values (dims base) (let loop ([t type] [?-ok? #t]) - (cond - [(and (pair? t) (eq? 'array (car t)) (or ?-ok? (number? (cadr t)))) - (define-values (d b) (if (number? (cadr t)) + (cond + [(and (pair? t) (eq? 'array (car t)) (or ?-ok? (number? (cadr t)))) + (define-values (d b) (if (number? (cadr t)) (loop (caddr t) #f) (values null (cadr t)))) - (values (cons (cadr t) d) b)] - [else - (values null t)]))) + (values (cons (cadr t) d) b)] + [else + (values null t)]))) (_safe-array/vectors dims base mode)] [(eq? 'variant (car type)) (to-ctype (cadr type) #:mode mode)] @@ -1803,38 +1803,38 @@ [(com-enumeration) VT_INT] [else (case (and (pair? type) - (car type)) + (car type)) [(array) (bitwise-ior VT_ARRAY (to-vt (caddr type)))] [(opt) (to-vt (cadr type))] [(variant) VT_VARIANT] [(box) (bitwise-ior VT_BYREF (to-vt (cadr type)))] [else - (error 'to-vt "internal error: unsupported type ~s" type)])])) + (error 'to-vt "internal error: unsupported type ~s" type)])])) (define (build-method-arguments-using-function-desc func-desc scheme-types inv-kind args) (define lcid-index (and func-desc (get-lcid-param-index func-desc))) (define last-is-retval? (and func-desc (is-last-param-retval? inv-kind func-desc))) (define last-is-repeat-any? (and func-desc (= -1 (FUNCDESC-cParamsOpt func-desc)))) (define base-count (if func-desc - (- (FUNCDESC-cParams func-desc) - (if lcid-index 1 0) - (if last-is-retval? 1 0)) - (length scheme-types))) + (- (FUNCDESC-cParams func-desc) + (if lcid-index 1 0) + (if last-is-retval? 1 0)) + (length scheme-types))) (define count (if last-is-repeat-any? - (if (or lcid-index - last-is-retval?) - (error "cannot handle combination of `any ...' and lcid/retval") - (length scheme-types)) - base-count)) + (if (or lcid-index + last-is-retval?) + (error "cannot handle combination of `any ...' and lcid/retval") + (length scheme-types)) + base-count)) (build-method-arguments-from-desc count - (lambda (i) - (and func-desc - (or (not last-is-repeat-any?) - (i . < . (sub1 base-count))) - (elem-desc-ref func-desc i))) - scheme-types - inv-kind - args)) + (lambda (i) + (and func-desc + (or (not last-is-repeat-any?) + (i . < . (sub1 base-count))) + (elem-desc-ref func-desc i))) + scheme-types + inv-kind + args)) (define (build-method-arguments-from-desc count get-elem-desc scheme-types inv-kind args) (define vars (if (zero? count) @@ -1853,12 +1853,12 @@ (define var (ptr-ref vars _VARIANT (- count i 1))) ; reverse order (VariantInit var) (scheme-to-variant! var - a - (get-elem-desc i) - scheme-type))) + a + (get-elem-desc i) + scheme-type))) (define disp-params (cast (malloc _DISPPARAMS 'raw) - _pointer - _DISPPARAMS-pointer)) + _pointer + _DISPPARAMS-pointer)) (memcpy disp-params (make-DISPPARAMS vars (if (= inv-kind INVOKE_PROPERTYPUT) @@ -1868,21 +1868,21 @@ (if (= inv-kind INVOKE_PROPERTYPUT) count 0)) - (ctype-sizeof _DISPPARAMS)) + (ctype-sizeof _DISPPARAMS)) (values count - disp-params + disp-params (cons (lambda () (free disp-params)) (unbox cleanup)) (unbox commit))) (define (build-method-arguments-using-var-desc var-desc scheme-types inv-kind args) (build-method-arguments-from-desc (if (= inv-kind INVOKE_PROPERTYPUT) - 1 - 0) - (lambda (i) - (VARDESC-elemdescVar var-desc)) - scheme-types - inv-kind - args)) + 1 + 0) + (lambda (i) + (VARDESC-elemdescVar var-desc)) + scheme-types + inv-kind + args)) (define (variant-to-scheme var #:mode [mode '(out)]) (define _t (to-ctype (vt-to-scheme-type (VARIANT-vt var)) #:mode mode)) @@ -1902,8 +1902,8 @@ inv-kind args)] [else (build-method-arguments-using-var-desc (mx-com-type-desc-desc type-desc) - scheme-types - inv-kind args)])) + scheme-types + inv-kind args)])) (define (find-memid who obj name) (define-values (r memid) @@ -1919,29 +1919,29 @@ (define ta (cadr t)) (define len (length ta)) (if (and (len . >= . 2) - ((length args) . >= . (- len 2)) - (eq? '... (list-ref ta (sub1 len))) - (eq? 'any (list-ref ta (- len 2)))) + ((length args) . >= . (- len 2)) + (eq? '... (list-ref ta (sub1 len))) + (eq? 'any (list-ref ta (- len 2)))) ;; Replace `any ...' with the right number of `any's `(,(car t) ,(append (take ta (- len 2)) - (make-list (- (length args) (- len 2)) 'any)) - . ,(cddr t)) + (make-list (- (length args) (- len 2)) 'any)) + . ,(cddr t)) t)) (define (do-com-invoke who obj name args inv-kind) (check-com-obj who obj) (unless (string? name) (raise-type-error who "string" name)) (let* ([t (or (do-get-method-type who obj name inv-kind #t) - ;; wing it by inferring types from the arguments: - `(-> ,(map arg-to-type args) any))] - [t (adjust-any-... args t)]) + ;; wing it by inferring types from the arguments: + `(-> ,(map arg-to-type args) any))] + [t (adjust-any-... args t)]) (unless (<= (for/fold ([n 0]) ([v (in-list (cadr t))]) - (if (and (pair? v) (eq? (car v) 'opt)) - (add1 n) - n)) + (if (and (pair? v) (eq? (car v) 'opt)) + (add1 n) + n)) (length args) (length (cadr t))) - (error 'com-invoke "bad argument count for ~s" name)) + (error 'com-invoke "bad argument count for ~s" name)) (for ([arg (in-list args)] [type (in-list (cadr t))]) (check-argument 'com-invoke name arg type)) @@ -1968,26 +1968,26 @@ (variant-to-scheme (ptr-ref (DISPPARAMS-rgvarg method-arguments) _VARIANT i) - #:mode '()))))) - (define exn-info-ptr (malloc 'atomic-interior _EXCEPINFO)) + #:mode '()))))) + (define exn-info-ptr (malloc 'atomic-interior _EXCEPINFO)) (define-values (method-result cleanups) (if (= inv-kind INVOKE_PROPERTYPUT) (values #f arg-cleanups) (let ([r (make-a-VARIANT 'raw)]) - (values r (cons (lambda () (free r)) - arg-cleanups))))) + (values r (cons (lambda () (free r)) + arg-cleanups))))) (for ([proc (in-list commits)]) (proc)) (define hr - ;; Note that all arguments to `Invoke' should - ;; not be movable by a GC. A call to `Invoke' - ;; may use the Windows message queue, and other - ;; libraries (notably `racket/gui') may have - ;; callbacks triggered via messages. + ;; Note that all arguments to `Invoke' should + ;; not be movable by a GC. A call to `Invoke' + ;; may use the Windows message queue, and other + ;; libraries (notably `racket/gui') may have + ;; callbacks triggered via messages. (Invoke (com-object-get-dispatch obj) memid IID_NULL LOCALE_SYSTEM_DEFAULT inv-kind method-arguments method-result - exn-info-ptr error-index-ptr)) + exn-info-ptr error-index-ptr)) (cond [(zero? hr) (begin0 @@ -1997,7 +1997,7 @@ (for ([proc (in-list cleanups)]) (proc)))] [(= hr DISP_E_EXCEPTION) (for ([proc (in-list cleanups)]) (proc)) - (define exn-info (cast exn-info-ptr _pointer _EXCEPINFO-pointer)) + (define exn-info (cast exn-info-ptr _pointer _EXCEPINFO-pointer)) (define has-error-code? (positive? (EXCEPINFO-wCode exn-info))) (define desc (EXCEPINFO-bstrDescription exn-info)) (windows-error @@ -2174,8 +2174,8 @@ (define sink-factory (myssink-DllGetClassObject CLSID_Sink IID_IClassFactory)) (define sink-unknown - ;; This primitive method doesn't AddRef the object, - ;; so don't Release it: + ;; This primitive method doesn't AddRef the object, + ;; so don't Release it: (CreateInstance/factory sink-factory #f CLSID_Sink)) (define sink (QueryInterface sink-unknown IID_ISink _ISink-pointer)) (set_myssink_table sink myssink-table) @@ -2235,10 +2235,10 @@ ;; Initialize (define-ole CoInitialize (_wfun (_pointer = #f) -> (r : _HRESULT) - -> (cond - [(= r 0) (void)] ; ok - [(= r 1) (void)] ; already initialized - [else (windows-error (format "~a: failed" 'CoInitialize) r)]))) + -> (cond + [(= r 0) (void)] ; ok + [(= r 1) (void)] ; already initialized + [else (windows-error (format "~a: failed" 'CoInitialize) r)]))) (define inited? #f) (define (init!) diff --git a/collects/ffi/unsafe/objc.rkt b/collects/ffi/unsafe/objc.rkt index d47187de97..8eb3fd0295 100644 --- a/collects/ffi/unsafe/objc.rkt +++ b/collects/ffi/unsafe/objc.rkt @@ -93,8 +93,8 @@ [method_count _int] ; 1 [method _objc_method])) -(define CLS_CLASS #x1) -(define CLS_META #x2) +(define CLS_CLASS #x1) +(define CLS_META #x2) (define (strcpy s) (let* ([n (cast s _string _bytes)] diff --git a/collects/ffi/unsafe/private/win32.rkt b/collects/ffi/unsafe/private/win32.rkt index 548af4a2ab..5a5827428b 100644 --- a/collects/ffi/unsafe/private/win32.rkt +++ b/collects/ffi/unsafe/private/win32.rkt @@ -1,7 +1,7 @@ #lang racket/base (require ffi/unsafe ffi/unsafe/define - ffi/winapi) + ffi/winapi) (provide (protect-out (all-defined-out))) ;; Win32 type and structure declarations. @@ -25,14 +25,14 @@ #:default-make-fail make-not-available) ;; for functions that use the Windows stdcall ABI: -(define-syntax-rule (_wfun type ...) +(define-syntax-rule (_wfun type ...) (_fun #:abi winapi type ...)) ;; for functions that return HRESULTs (define-syntax _hfun (syntax-rules (->) [(_ type ... -> who res) - (_wfun type ... + (_wfun type ... -> (r : _HRESULT) -> (if (positive? r) (windows-error (format "~a: failed" 'who) r) @@ -108,7 +108,7 @@ (define _VVAL (_union _double _intptr ;; etc. - (_array _pointer 2) + (_array _pointer 2) )) (define-cstruct _VARIANT ([vt _VARTYPE] @@ -179,7 +179,7 @@ raw-scode)) (define len (FormatMessageW FORMAT_MESSAGE_FROM_SYSTEM #f scode 0 buf (quotient size 2))) (if (positive? len) - (error (format "~a (~x; ~a)" str scode (regexp-replace #rx"[\r\n]+$" + (error (format "~a (~x; ~a)" str scode (regexp-replace #rx"[\r\n]+$" (cast buf _pointer _string/utf-16) ""))) (error (format "~a (~x)" str scode)))))) @@ -222,18 +222,18 @@ (define FUNC_VIRTUAL 0) (define FUNC_PUREVIRTUAL 1) -(define FUNC_NONVIRTUAL 2) +(define FUNC_NONVIRTUAL 2) (define FUNC_STATIC 3) (define FUNC_DISPATCH 4) -(define PARAMFLAG_NONE 0) -(define PARAMFLAG_FIN #x1) -(define PARAMFLAG_FOUT #x2) -(define PARAMFLAG_FLCID #x4) -(define PARAMFLAG_FRETVAL #x8) -(define PARAMFLAG_FOPT #x10) -(define PARAMFLAG_FHASDEFAULT #x20) -(define PARAMFLAG_FHASCUSTDATA #x40) +(define PARAMFLAG_NONE 0) +(define PARAMFLAG_FIN #x1) +(define PARAMFLAG_FOUT #x2) +(define PARAMFLAG_FLCID #x4) +(define PARAMFLAG_FRETVAL #x8) +(define PARAMFLAG_FOPT #x10) +(define PARAMFLAG_FHASDEFAULT #x20) +(define PARAMFLAG_FHASCUSTDATA #x40) (define VT_EMPTY 0) (define VT_NULL 1) @@ -288,7 +288,7 @@ (define VT_ILLEGALMASKED #xfff) (define VT_TYPEMASK #xfff) -(define DISPID_PROPERTYPUT -3) +(define DISPID_PROPERTYPUT -3) (define DISP_E_PARAMNOTFOUND #x80020004) (define DISP_E_EXCEPTION #x80020009) @@ -307,13 +307,13 @@ (set-GUID-s2! guid (bitwise-and #xFFFF (arithmetic-shift n (* -8 8)))) (set-GUID-c! guid (for/list ([i (in-range 8)]) (bitwise-and #xFF (arithmetic-shift n (* (- -7 i))))))))) - + (define-ole StringFromIID(_hfun _GUID-pointer (p : (_ptr o _pointer)) -> StringFromIID p)) (define (string->guid s [stay-put? #f]) - (define guid + (define guid (if stay-put? (cast (malloc _GUID 'atomic-interior) _pointer (_gcable _GUID-pointer)) (make-GUID 0 0 0 (list 0 0 0 0 0 0 0 0)))) @@ -354,30 +354,30 @@ (define _SAFEARRAY-pointer (_cpointer 'SAFEARRAY)) -(define-oleaut SafeArrayCreate (_wfun _VARTYPE - _UINT - (dims : (_list i _SAFEARRAYBOUND)) - -> _SAFEARRAY-pointer)) +(define-oleaut SafeArrayCreate (_wfun _VARTYPE + _UINT + (dims : (_list i _SAFEARRAYBOUND)) + -> _SAFEARRAY-pointer)) (define-oleaut SafeArrayDestroy (_hfun _SAFEARRAY-pointer - -> SafeArrayDestroy (void))) + -> SafeArrayDestroy (void))) (define-oleaut SafeArrayGetVartype (_hfun _SAFEARRAY-pointer - (vt : (_ptr o _VARTYPE)) - -> SafeArrayGetVartype vt)) + (vt : (_ptr o _VARTYPE)) + -> SafeArrayGetVartype vt)) (define-oleaut SafeArrayGetLBound (_hfun _SAFEARRAY-pointer - _UINT - (v : (_ptr o _LONG)) - -> SafeArrayGetLBound v)) + _UINT + (v : (_ptr o _LONG)) + -> SafeArrayGetLBound v)) (define-oleaut SafeArrayGetUBound (_hfun _SAFEARRAY-pointer - _UINT - (v : (_ptr o _LONG)) - -> SafeArrayGetUBound v)) + _UINT + (v : (_ptr o _LONG)) + -> SafeArrayGetUBound v)) (define-oleaut SafeArrayPutElement (_hfun _SAFEARRAY-pointer - (_list i _LONG) - _pointer - -> SafeArrayPutElement (void))) + (_list i _LONG) + _pointer + -> SafeArrayPutElement (void))) (define-oleaut SafeArrayGetElement (_hfun _SAFEARRAY-pointer - (_list i _LONG) - _pointer - -> SafeArrayGetElement (void))) + (_list i _LONG) + _pointer + -> SafeArrayGetElement (void))) (define-oleaut SafeArrayGetDim (_wfun _SAFEARRAY-pointer - -> _UINT)) + -> _UINT)) diff --git a/collects/file/gunzip.rkt b/collects/file/gunzip.rkt index 5fa4b7aea8..396afe9fa3 100644 --- a/collects/file/gunzip.rkt +++ b/collects/file/gunzip.rkt @@ -927,5 +927,5 @@ (dynamic-wind void (lambda () (do-gunzip in #f name-filter)) - (lambda () (close-input-port in))))])) + (lambda () (close-input-port in))))])) diff --git a/collects/file/scribblings/md5.scrbl b/collects/file/scribblings/md5.scrbl index 4645c10fa9..c4e470ca82 100644 --- a/collects/file/scribblings/md5.scrbl +++ b/collects/file/scribblings/md5.scrbl @@ -20,3 +20,6 @@ that is the MD5 hash of the given input stream or byte string. (md5 #"abc") (md5 #"abc" #f) ]} + + +@close-eval[md5-eval] diff --git a/collects/file/scribblings/sha1.scrbl b/collects/file/scribblings/sha1.scrbl index fcd264556b..6863d57f48 100644 --- a/collects/file/scribblings/sha1.scrbl +++ b/collects/file/scribblings/sha1.scrbl @@ -40,3 +40,6 @@ until an end-of-file. Converts the given byte string to a string representation, where each byte in @racket[bstr] is converted to its two-digit hexadecimal representation in the resulting string.} + + +@close-eval[sha1-eval] diff --git a/collects/file/sha1.rkt b/collects/file/sha1.rkt index 0ee4bc636f..0e88822d2a 100644 --- a/collects/file/sha1.rkt +++ b/collects/file/sha1.rkt @@ -269,7 +269,7 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (define (hash-value->bytes int) (let* ((len (vector-length hash-as-bytes-masks)) - (bv (make-bytes len 0))) + (bv (make-bytes len 0))) (do ((i 0 (+ i 1))) ((>= i len) bv) (bytes-set! diff --git a/collects/framework/main.rkt b/collects/framework/main.rkt index c55824aebd..c383944b42 100644 --- a/collects/framework/main.rkt +++ b/collects/framework/main.rkt @@ -72,6 +72,12 @@ in a GUI, and the color to use. The colors are used to show the nesting structure in the parens.}) + (thing-doc + color:misspelled-text-color-style-name + string? + @{The name of the style used to color misspelled words. See also + @method[color:text<%> get-spell-check-strings].}) + (proc-doc/names text:range? (-> any/c boolean?) (arg) @{Determines if @racket[arg] is an instance of the @tt{range} struct.}) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index ed3196efd9..1879642e2a 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -6,9 +6,8 @@ added reset-regions added get-regions |# -(require mzlib/class - mzlib/thread - mred +(require racket/class + racket/gui/base syntax-color/token-tree syntax-color/paren-tree syntax-color/default-lexer @@ -237,13 +236,11 @@ added get-regions (start-colorer token-sym->style get-token pairs))) ;; ---------------------- Multi-threading --------------------------- - ;; A list of (vector style number number) that indicate how to color the buffer - (define colorings null) - ;; The coroutine object for tokenizing the buffer - (define tok-cor #f) - ;; The editor revision when tok-cor was created - (define rev #f) - + ;; The editor revision when the last coloring was started + (define revision-when-started-parsing #f) + + ;; The editor revision when after the last edit to the buffer + (define revision-after-last-edit #f) (inherit change-style begin-edit-sequence end-edit-sequence highlight-range get-style-list in-edit-sequence? get-start-position get-end-position @@ -275,17 +272,7 @@ added get-regions (update-lexer-state-observers) (set! restart-callback #f) (set! force-recolor-after-freeze #f) - (set! colorings null) - (when tok-cor - (coroutine-kill tok-cor)) - (set! tok-cor #f) - (set! rev #f)) - - ;; Actually color the buffer. - (define/private (color) - (for ([clr (in-list colorings)]) - (change-style (vector-ref clr 0) (vector-ref clr 1) (vector-ref clr 2) #f)) - (set! colorings '())) + (set! revision-when-started-parsing #f)) ;; Discard extra tokens at the first of invalid-tokens (define/private (sync-invalid ls) @@ -302,60 +289,83 @@ added get-regions (set-lexer-state-invalid-tokens-mode! ls mode)) (sync-invalid ls)))) - (define/private (re-tokenize ls in in-start-pos in-lexer-mode enable-suspend) - (enable-suspend #f) - ;(define-values (_line1 _col1 pos-before) (port-next-location in)) - (define-values (lexeme type data new-token-start new-token-end backup-delta new-lexer-mode) - (get-token in in-start-pos in-lexer-mode)) - ;(define-values (_line2 _col2 pos-after) (port-next-location in)) - (enable-suspend #t) - (unless (eq? 'eof type) - (unless (exact-nonnegative-integer? new-token-start) - (error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start)) - (unless (exact-nonnegative-integer? new-token-end) - (error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end)) - (unless (exact-nonnegative-integer? backup-delta) - (error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta)) - (unless (0 . < . (- new-token-end new-token-start)) - (error 'color:text<%> "expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e" new-token-start new-token-end)) - (enable-suspend #f) - #; (printf "~s at ~a to ~a\n" lexeme (+ in-start-pos (sub1 new-token-start)) - (+ in-start-pos (sub1 new-token-end))) - (let ((len (- new-token-end new-token-start))) - #; - (unless (= len (- pos-after pos-before)) - ;; this check requires the two calls to port-next-location to be also uncommented - ;; when this check fails, bad things can happen non-deterministically later on - (eprintf "pos changed bad ; len ~s pos-before ~s pos-after ~s (token ~s mode ~s)\n" - len pos-before pos-after lexeme new-lexer-mode)) - (set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls))) - (set-lexer-state-current-lexer-mode! ls new-lexer-mode) - (sync-invalid ls) - (when (and should-color? (should-color-type? type) (not frozen?)) - (add-colorings type in-start-pos new-token-start new-token-end)) - ;; Using the non-spec version takes 3 times as long as the spec - ;; version. In other words, the new greatly outweighs the tree - ;; operations. - ;;(insert-last! tokens (new token-tree% (length len) (data type))) - (insert-last-spec! (lexer-state-tokens ls) len (make-data type new-lexer-mode backup-delta)) - #; (show-tree (lexer-state-tokens ls)) - (send (lexer-state-parens ls) add-token data len) - (cond - [(and (not (send (lexer-state-invalid-tokens ls) is-empty?)) - (= (lexer-state-invalid-tokens-start ls) - (lexer-state-current-pos ls)) - (equal? new-lexer-mode - (lexer-state-invalid-tokens-mode ls))) - (send (lexer-state-invalid-tokens ls) search-max!) - (send (lexer-state-parens ls) merge-tree - (send (lexer-state-invalid-tokens ls) get-root-end-position)) - (insert-last! (lexer-state-tokens ls) - (lexer-state-invalid-tokens ls)) - (set-lexer-state-invalid-tokens-start! ls +inf.0) - (enable-suspend #t)] - [else - (enable-suspend #t) - (re-tokenize ls in in-start-pos new-lexer-mode enable-suspend)])))) + (define/private (re-tokenize-move-to-next-ls start-time did-something?) + (cond + [(null? re-tokenize-lses) + ;; done: return #t + #t] + [else + (define ls (car re-tokenize-lses)) + (set! re-tokenize-lses (cdr re-tokenize-lses)) + (define in + (open-input-text-editor this + (lexer-state-current-pos ls) + (lexer-state-end-pos ls) + (λ (x) #f))) + (port-count-lines! in) + (continue-re-tokenize start-time did-something? ls in + (lexer-state-current-pos ls) + (lexer-state-current-lexer-mode ls))])) + + (define re-tokenize-lses #f) + + (define/private (continue-re-tokenize start-time did-something? ls in in-start-pos lexer-mode) + (cond + [(and did-something? ((+ start-time 20.0) . <= . (current-inexact-milliseconds))) + #f] + [else + ;(define-values (_line1 _col1 pos-before) (port-next-location in)) + (define-values (lexeme type data new-token-start new-token-end backup-delta new-lexer-mode) + (get-token in in-start-pos lexer-mode)) + ;(define-values (_line2 _col2 pos-after) (port-next-location in)) + (cond + [(eq? 'eof type) + (re-tokenize-move-to-next-ls start-time #t)] + [else + (unless (exact-nonnegative-integer? new-token-start) + (error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start)) + (unless (exact-nonnegative-integer? new-token-end) + (error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end)) + (unless (exact-nonnegative-integer? backup-delta) + (error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta)) + (unless (new-token-start . < . new-token-end) + (error 'color:text<%> + "expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e" + new-token-start new-token-end)) + (let ((len (- new-token-end new-token-start))) + #; + (unless (= len (- pos-after pos-before)) + ;; this check requires the two calls to port-next-location to be also uncommented + ;; when this check fails, bad things can happen non-deterministically later on + (eprintf "pos changed bad ; len ~s pos-before ~s pos-after ~s (token ~s mode ~s)\n" + len pos-before pos-after lexeme new-lexer-mode)) + (set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls))) + (set-lexer-state-current-lexer-mode! ls new-lexer-mode) + (sync-invalid ls) + (when (and should-color? (should-color-type? type) (not frozen?)) + (add-colorings type in-start-pos new-token-start new-token-end)) + ;; Using the non-spec version takes 3 times as long as the spec + ;; version. In other words, the new greatly outweighs the tree + ;; operations. + ;;(insert-last! tokens (new token-tree% (length len) (data type))) + (insert-last-spec! (lexer-state-tokens ls) len (make-data type new-lexer-mode backup-delta)) + #; (show-tree (lexer-state-tokens ls)) + (send (lexer-state-parens ls) add-token data len) + (cond + [(and (not (send (lexer-state-invalid-tokens ls) is-empty?)) + (= (lexer-state-invalid-tokens-start ls) + (lexer-state-current-pos ls)) + (equal? new-lexer-mode + (lexer-state-invalid-tokens-mode ls))) + (send (lexer-state-invalid-tokens ls) search-max!) + (send (lexer-state-parens ls) merge-tree + (send (lexer-state-invalid-tokens ls) get-root-end-position)) + (insert-last! (lexer-state-tokens ls) + (lexer-state-invalid-tokens ls)) + (set-lexer-state-invalid-tokens-start! ls +inf.0) + (re-tokenize-move-to-next-ls start-time #t)] + [else + (continue-re-tokenize start-time #t ls in in-start-pos new-lexer-mode)]))])])) (define/private (add-colorings type in-start-pos new-token-start new-token-end) (define sp (+ in-start-pos (sub1 new-token-start))) @@ -376,22 +386,23 @@ added get-regions [lp 0]) (cond [(null? spellos) - (set! colorings (cons (vector color (+ sp lp) (+ sp (string-length str))) - colorings))] + (add-coloring color (+ sp lp) (+ sp (string-length str)))] [else (define err (car spellos)) (define err-start (list-ref err 0)) (define err-len (list-ref err 1)) - (set! colorings (list* (vector color (+ pos lp) (+ pos err-start)) - (vector misspelled-color (+ pos err-start) (+ pos err-start err-len)) - colorings)) + (add-coloring misspelled-color (+ pos err-start) (+ pos err-start err-len)) + (add-coloring color (+ pos lp) (+ pos err-start)) (loop (cdr spellos) (+ err-start err-len))])) (loop (cdr strs) (+ pos (string-length str) 1))))] [else - (set! colorings (cons (vector color sp ep) colorings))])] + (add-coloring color sp ep)])] [else - (set! colorings (cons (vector color sp ep) colorings))])) + (add-coloring color sp ep)])) + + (define/private (add-coloring color sp ep) + (change-style color sp ep #f)) (define/private (show-tree t) (printf "Tree:\n") @@ -486,52 +497,19 @@ added get-regions (define/private (colorer-driver) (unless (andmap lexer-state-up-to-date? lexer-states) - #;(printf "revision ~a\n" (get-revision-number)) - (unless (and tok-cor (= rev (get-revision-number))) - (when tok-cor - (coroutine-kill tok-cor)) - #;(printf "new coroutine\n") - (set! tok-cor - (coroutine - (λ (enable-suspend) - (parameterize ((port-count-lines-enabled #t)) - (for-each - (lambda (ls) - (re-tokenize ls - (begin - (enable-suspend #f) - (begin0 - (open-input-text-editor this - (lexer-state-current-pos ls) - (lexer-state-end-pos ls) - (λ (x) #f)) - (enable-suspend #t))) - (lexer-state-current-pos ls) - (lexer-state-current-lexer-mode ls) - enable-suspend)) - lexer-states))))) - (set! rev (get-revision-number))) - (with-handlers ((exn:fail? - (λ (exn) - (parameterize ((print-struct #t)) - ((error-display-handler) - (format "exception in colorer thread: ~s" exn) - exn)) - (set! tok-cor #f)))) - #;(printf "begin lexing\n") - (when (coroutine-run 10 tok-cor) - (for-each (lambda (ls) - (set-lexer-state-up-to-date?! ls #t)) - lexer-states) - (update-lexer-state-observers))) - #;(printf "end lexing\n") - #;(printf "begin coloring\n") - ;; This edit sequence needs to happen even when colors is null - ;; for the paren highlighter. (begin-edit-sequence #f #f) - (color) + (c-log "starting to color") + (set! re-tokenize-lses lexer-states) + (define finished? (re-tokenize-move-to-next-ls (current-inexact-milliseconds) #f)) + (c-log (format "coloring stopped ~a" (if finished? "because it finished" "with more to do"))) + (when finished? + (for ([ls (in-list lexer-states)]) + (set-lexer-state-up-to-date?! ls #t)) + (update-lexer-state-observers) + (c-log "updated observers")) + (c-log "starting end-edit-sequence") (end-edit-sequence) - #;(printf "end coloring\n"))) + (c-log "finished end-edit-sequence"))) (define/private (colorer-callback) (cond @@ -1148,3 +1126,9 @@ added get-regions (define text-mode% (text-mode-mixin mode:surrogate-text%)) (define misspelled-text-color-style-name "Misspelled Text") + +(define logger (make-logger 'framework/colorer (current-logger))) +(define-syntax-rule + (c-log exp) + (when (log-level? logger 'debug) + (log-message logger 'debug exp (current-inexact-milliseconds)))) diff --git a/collects/framework/private/follow-log.rkt b/collects/framework/private/follow-log.rkt new file mode 100644 index 0000000000..fbf4f7a0dc --- /dev/null +++ b/collects/framework/private/follow-log.rkt @@ -0,0 +1,225 @@ +#lang racket/base + +(require racket/list + racket/class + racket/match + racket/pretty + racket/gui/base + framework/private/logging-timer) + +#| + +This file sets up a log receiver and then +starts up DrRacket. It catches log messages and +organizes them on event boundaries, printing +out the ones that take the longest +(possibly dropping those where a gc occurs) + +The result shows, for each gui event, the +log messages that occured during its dynamic +extent as well as the number of milliseconds +from the start of the gui event before the +log message was reported. + +|# + + +(define lr (make-log-receiver (current-logger) + 'debug 'racket/engine + 'debug 'GC + 'debug 'gui-event + 'debug 'framework/colorer + 'debug 'timeline)) + +(define top-n-events 50) +(define drop-gc? #t) +(define start-right-away? #f) + +(define log-done-chan (make-channel)) +(define bt-done-chan (make-channel)) + +(define start-log-chan (make-channel)) +(void + (thread + (λ () + (let loop () + (sync start-log-chan) + (let loop ([events '()]) + (sync + (handle-evt + lr + (λ (info) + (loop (cons info events)))) + (handle-evt + log-done-chan + (λ (resp-chan) + (channel-put resp-chan events))))) + (loop))))) + +(define thread-to-watch (current-thread)) +(let ([win (get-top-level-windows)]) + (unless (null? win) + (define fr-thd (eventspace-handler-thread (send (car win) get-eventspace))) + (unless (eq? thread-to-watch fr-thd) + (eprintf "WARNING: current-thread and eventspace thread aren't the same thread\n")))) +(define start-bt-chan (make-channel)) +(void + (thread + (λ () + (let loop () + (sync start-bt-chan) + (let loop ([marks '()]) + (sync + (handle-evt + (alarm-evt (+ (current-inexact-milliseconds) 10)) + (λ (_) + (loop (cons (continuation-marks thread-to-watch) + marks)))) + (handle-evt + bt-done-chan + (λ (resp-chan) + (define stacks (map continuation-mark-set->context marks)) + (channel-put resp-chan stacks))))) + (loop))))) + +(define controller-frame-eventspace (make-eventspace)) +(define f (parameterize ([current-eventspace controller-frame-eventspace]) + (new frame% [label "Log Follower"]))) +(define sb (new button% [label "Start Following Log"] [parent f] + [callback + (λ (_1 _2) + (sb-callback))])) +(define sb2 (new button% [label "Start Collecting Backtraces"] [parent f] + [callback + (λ (_1 _2) + (start-bt-callback))])) +(define db (new button% [label "Stop && Dump"] [parent f] [enabled #f] + [callback + (λ (_1 _2) + (cond + [following-log? + (define resp (make-channel)) + (channel-put log-done-chan resp) + (show-results (channel-get resp)) + (send db enable #f) + (send sb enable #t) + (send sb2 enable #t) + (set! following-log? #f)] + [following-bt? + (define resp (make-channel)) + (channel-put bt-done-chan resp) + (define stacks (channel-get resp)) + (show-bt-results stacks) + (send db enable #f) + (send sb enable #t) + (send sb2 enable #t) + (set! following-bt? #f)]))])) + +(define following-log? #f) +(define following-bt? #f) + +(define (sb-callback) + (set! following-log? #t) + (send sb enable #f) + (send sb2 enable #f) + (send db enable #t) + (channel-put start-log-chan #t)) + +(define (start-bt-callback) + (set! following-bt? #t) + (send sb enable #f) + (send sb2 enable #f) + (send db enable #t) + (channel-put start-bt-chan #t)) + +(send f show #t) + +(define (show-bt-results stacks) + (define top-frame (make-hash)) + (for ([stack (in-list stacks)]) + (unless (null? stack) + (define k (car stack)) + (hash-set! top-frame k (cons stack (hash-ref top-frame k '()))))) + (define sorted (sort (hash-map top-frame (λ (x y) y)) > #:key length)) + (printf "top 10: ~s\n" (map length (take sorted (min (length sorted) 10)))) + (define most-popular (cadr sorted)) + (for ([x (in-range 10)]) + (printf "---- next stack\n") + (pretty-print (list-ref most-popular (random (length most-popular)))) + (printf "\n")) + (void)) + +(struct gui-event (start end name) #:prefab) + +(define (show-results evts) + (define gui-events (filter (λ (x) + (define i (vector-ref x 2)) + (and (gui-event? i) + (number? (gui-event-end i)))) + evts)) + (define interesting-gui-events + (take (sort gui-events > #:key (λ (x) + (define i (vector-ref x 2)) + (- (gui-event-end i) + (gui-event-start i)))) + top-n-events)) + + (define with-other-events + (for/list ([gui-evt (in-list interesting-gui-events)]) + (match (vector-ref gui-evt 2) + [(gui-event start end name) + (define in-the-middle + (append (map (λ (x) (list (list 'δ (- (get-start-time x) start)) x)) + (sort + (filter (λ (x) (and (not (gui-event? (vector-ref x 2))) + (<= start (get-start-time x) end))) + evts) + < + #:key get-start-time)) + (list (list (list 'δ (- end start)) 'end-of-gui-event)))) + (list* (- end start) + gui-evt + in-the-middle)]))) + + (define (has-a-gc-event? x) + (define in-the-middle (cddr x)) + (ormap (λ (x) + (and (vector? (list-ref x 1)) + (gc-info? (vector-ref (list-ref x 1) 2)))) + in-the-middle)) + + (pretty-print + (if drop-gc? + (filter (λ (x) (not (has-a-gc-event? x))) + with-other-events) + with-other-events))) + +(struct gc-info (major? pre-amount pre-admin-amount code-amount + post-amount post-admin-amount + start-process-time end-process-time + start-time end-time) + #:prefab) +(struct engine-info (msec name) #:prefab) + +(define (get-start-time x) + (cond + [(gc-info? (vector-ref x 2)) + (gc-info-start-time (vector-ref x 2))] + [(engine-info? (vector-ref x 2)) + (engine-info-msec (vector-ref x 2))] + [(regexp-match #rx"framework" (vector-ref x 1)) + (vector-ref x 2)] + [(timeline-info? (vector-ref x 2)) + (timeline-info-milliseconds (vector-ref x 2))] + [else + (unless (regexp-match #rx"^GC: 0:MST @" (vector-ref x 1)) + (eprintf "unk: ~s\n" x)) + 0])) + + +(module+ main + (when start-right-away? + (parameterize ([current-eventspace controller-frame-eventspace]) + (queue-callback sb-callback))) + (dynamic-require 'drracket #f)) + diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index 215dab0786..1464406f3a 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -796,9 +796,14 @@ [ec (new position-canvas% [parent panel] [button-up - (λ () - (collect-garbage) - (update-memory-text))] + (λ (evt) + (cond + [(or (send evt get-alt-down) + (send evt get-control-down)) + (dynamic-require 'framework/private/follow-log #f)] + [else + (collect-garbage) + (update-memory-text)]))] [init-width "99.99 MB"])]) (set! memory-canvases (cons ec memory-canvases)) (update-memory-text) @@ -890,6 +895,7 @@ (inherit min-client-height min-client-width get-dc get-client-size refresh) (init init-width) (init-field [button-up #f]) + (init-field [char-typed void]) (define str "") (define/public (set-str _str) (set! str _str) @@ -913,7 +919,11 @@ (let-values ([(cw ch) (get-client-size)]) (when (and (<= (send evt get-x) cw) (<= (send evt get-y) ch)) - (button-up)))))) + (if (procedure-arity-includes? button-up 1) + (button-up evt) + (button-up))))))) + (define/override (on-char evt) + (char-typed evt)) (super-new (style '(transparent no-focus))) (let ([dc (get-dc)]) (let-values ([(_1 th _2 _3) (send dc get-text-extent str)]) diff --git a/collects/framework/private/keymap.rkt b/collects/framework/private/keymap.rkt index 4c9fdd0e63..21042cdac1 100644 --- a/collects/framework/private/keymap.rkt +++ b/collects/framework/private/keymap.rkt @@ -337,7 +337,7 @@ [mouse-popup-menu (λ (edit event) - (when (send event button-down?) + (when (send event button-up?) (let ([a (send edit get-admin)]) (when a (let ([m (make-object popup-menu%)]) @@ -739,7 +739,7 @@ (send edit on-char event) (loop (sub1 n))))) (λ () - (send edit end-edit-sequence))))))) + (send edit end-edit-sequence))))))) #t)) (send km set-break-sequence-callback done) #t))] @@ -823,7 +823,7 @@ (λ (edit event) (when building-macro (set! current-macro (reverse building-macro)) - (set! build-protect? #f) + (set! build-protect? #f) (send build-macro-km break-sequence)) #t)] [delete-key diff --git a/collects/framework/private/logging-timer.rkt b/collects/framework/private/logging-timer.rkt new file mode 100644 index 0000000000..0c9ad724e2 --- /dev/null +++ b/collects/framework/private/logging-timer.rkt @@ -0,0 +1,66 @@ +#lang racket/base + +(require racket/gui/base + racket/class + (for-syntax racket/base)) + +(define timeline-logger (make-logger 'timeline (current-logger))) + +(provide logging-timer% + (struct-out timeline-info) + log-timeline) + +(define logging-timer% + (class timer% + (init notify-callback) + (define name (object-name notify-callback)) + (define wrapped-notify-callback + (λ () + (log-timeline + (format "~a timer fired" name) + (notify-callback)))) + (super-new [notify-callback wrapped-notify-callback]) + (define/override (start msec [just-once? #f]) + (log-timeline (format "~a timer started; msec ~s just-once? ~s" name msec just-once?)) + (super start msec just-once?)))) + + +(define-syntax (log-timeline stx) + (syntax-case stx () + [(_ info-string expr) + #'(log-timeline/proc + (and (log-level? timeline-logger 'debug) + info-string) + (λ () expr))] + [(_ info-string) + #'(log-timeline/proc + (and (log-level? timeline-logger 'debug) + info-string) + #f)])) + +(define (log-timeline/proc info expr) + (define start-time (current-inexact-milliseconds)) + (when info + (log-message timeline-logger 'debug + (format "~a start" info) + (timeline-info (if expr 'start 'once) + (current-process-milliseconds) + start-time))) + (when expr + (begin0 + (expr) + (when info + (define end-time (current-inexact-milliseconds)) + (log-message timeline-logger 'debug + (format "~a end; delta ms ~a" info (- end-time start-time)) + (timeline-info start-time + end-time + (current-inexact-milliseconds))))))) + + +;; what : (or/c 'start 'once flonum) +;; flonum means that this is an 'end' event and there should be +;; a start event corresponding to it with that milliseconds +;; process-milliseconds : fixnum +;; milliseconds : flonum -- time of this event +(struct timeline-info (what process-milliseconds milliseconds) #:transparent) diff --git a/collects/framework/private/racket.rkt b/collects/framework/private/racket.rkt index 92f1af6683..12bc13888f 100644 --- a/collects/framework/private/racket.rkt +++ b/collects/framework/private/racket.rkt @@ -538,7 +538,7 @@ #f)] [last-para (and last (position-paragraph last))]) - (letrec + (letrec ([find-offset (λ (start-pos) (define tab-char? #f) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 9e8d8d7aa1..0ed3367508 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -11,7 +11,8 @@ "autocomplete.rkt" mred/mred-sig mrlib/interactive-value-port - racket/list) + racket/list + "logging-timer.rkt") (require setup/xref scribble/xref scribble/manual-struct) @@ -1063,7 +1064,7 @@ (when searching-str (unless timer (set! timer - (new timer% + (new logging-timer% [notify-callback (λ () (run-after-edit-sequence @@ -1536,7 +1537,7 @@ ;; have not yet been propogated to the delegate (define todo '()) - (define timer (new timer% + (define timer (new logging-timer% [notify-callback (λ () ;; it should be the case that todo is always '() when the delegate is #f @@ -3854,7 +3855,9 @@ designates the character that triggers autocompletion ;; draws line numbers on the left hand side of a text% object (define line-numbers-mixin (mixin ((class->interface text%) editor:standard-style-list<%>) (line-numbers<%>) - (inherit get-visible-line-range + (inherit begin-edit-sequence + end-edit-sequence + get-visible-line-range get-visible-position-range last-line line-location @@ -4193,6 +4196,7 @@ designates the character that triggers autocompletion (when (showing-line-numbers?) (define dc (get-dc)) (when dc + (begin-edit-sequence #f #f) (define bx (box 0)) (define by (box 0)) (define tw (text-width dc (number-space+1))) @@ -4208,7 +4212,8 @@ designates the character that triggers autocompletion tw th) (unless (= line (last-line)) - (loop (+ line 1)))))))) + (loop (+ line 1))))) + (end-edit-sequence)))) (super-new) (setup-padding))) diff --git a/collects/framework/test.rkt b/collects/framework/test.rkt index 87845539c9..855cac0269 100644 --- a/collects/framework/test.rkt +++ b/collects/framework/test.rkt @@ -253,22 +253,26 @@ (define object-tag 'test:find-object) -;; find-object : class (union string (object -> boolean)) -> object +;; find-object : class (union string regexp (object -> boolean)) -> object (define (find-object obj-class b-desc) (λ () (cond [(or (string? b-desc) + (regexp? b-desc) (procedure? b-desc)) (let* ([active-frame (test:get-active-top-level-window)] [_ (unless active-frame (error object-tag - "could not find object: ~a, no active frame" + "could not find object: ~e, no active frame" b-desc))] [child-matches? (λ (child) (cond [(string? b-desc) (equal? (send child get-label) b-desc)] + [(regexp? b-desc) + (and (send child get-label) + (regexp-match? b-desc (send child get-label)))] [(procedure? b-desc) (b-desc child)]))] [found @@ -287,13 +291,13 @@ (send panel get-children)))]) (or found (error object-tag - "no object of class ~a named ~e in active frame" + "no object of class ~e named ~e in active frame" obj-class b-desc)))] [(is-a? b-desc obj-class) b-desc] [else (error object-tag - "expected either a string or an object of class ~a as input, received: ~a" + "expected either a string or an object of class ~e as input, received: ~e" obj-class b-desc)]))) @@ -317,7 +321,7 @@ [else (update-control ctrl) (send ctrl command event) - (void)])))))) + (void)])))))) ;; ;; BUTTON @@ -936,7 +940,8 @@ (proc-doc/names test:keystroke (->* ((or/c char? symbol?)) - ((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometea 'noshift))) + ((listof (or/c 'alt 'control 'meta 'shift + 'noalt 'nocontrol 'nometea 'noshift))) void?) ((key) ((modifier-list null))) @@ -973,10 +978,11 @@ (proc-doc/names test:mouse-click (->* - ((symbols 'left 'middle 'right) + ((or/c 'left 'middle 'right) (and/c exact? integer?) (and/c exact? integer?)) - ((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometa 'noshift))) + ((listof (or/c 'alt 'control 'meta 'shift 'noalt + 'nocontrol 'nometa 'noshift))) void?) ((button x y) ((modifiers null))) @@ -985,7 +991,7 @@ @method[canvas<%> on-event] method. Use @racket[test:button-push] to click on a button. - On the Macintosh, @racket['right] corresponds to holding down the command + Under Mac OS X, @racket['right] corresponds to holding down the command modifier key while clicking and @racket['middle] cannot be generated. Under Windows, @racket['middle] can only be generated if the user has a diff --git a/collects/frtime/animation/graphics-sig.rkt b/collects/frtime/animation/graphics-sig.rkt index d7cc99d319..20cb989db4 100644 --- a/collects/frtime/animation/graphics-sig.rkt +++ b/collects/frtime/animation/graphics-sig.rkt @@ -1,4 +1,5 @@ -#lang racket +#lang racket/base + (require racket/unit) (provide graphics^ graphics:posn-less^ graphics:posn^) diff --git a/collects/frtime/animation/graphics-unit.rkt b/collects/frtime/animation/graphics-unit.rkt index d7753a4cdd..d5839d0b18 100644 --- a/collects/frtime/animation/graphics-unit.rkt +++ b/collects/frtime/animation/graphics-unit.rkt @@ -1,4 +1,5 @@ -#lang racket +#lang racket/base + (require racket/unit mred/mred-sig "graphics-sig.rkt" diff --git a/collects/frtime/animation/graphics.rkt b/collects/frtime/animation/graphics.rkt index 89dc677b8e..0f61b8d078 100644 --- a/collects/frtime/animation/graphics.rkt +++ b/collects/frtime/animation/graphics.rkt @@ -1,4 +1,5 @@ -#lang racket +#lang racket/base + (require racket/unit mred/mred-sig mred diff --git a/collects/frtime/core/contract.rkt b/collects/frtime/core/contract.rkt index b97b17cd7c..3d97d9b3d6 100644 --- a/collects/frtime/core/contract.rkt +++ b/collects/frtime/core/contract.rkt @@ -1,8 +1,9 @@ -#lang racket +#lang racket/base + +#;(require (for-syntax racket/contract)) (define-syntax-rule (provide/contract* [id ctrct] ...) #;(provide/contract [id ctrct] ...) (provide id ...)) -(provide - provide/contract*) +(provide provide/contract*) diff --git a/collects/frtime/core/dv.rkt b/collects/frtime/core/dv.rkt index 4b9ba467b6..b80fa42fa1 100644 --- a/collects/frtime/core/dv.rkt +++ b/collects/frtime/core/dv.rkt @@ -1,5 +1,7 @@ -#lang racket -(require "contract.rkt") +#lang racket/base + +(require racket/match + "contract.rkt") (define-struct dv (vec-length next-avail-pos vec) #:mutable) diff --git a/collects/frtime/core/erl.rkt b/collects/frtime/core/erl.rkt index 2849650c2d..1496b4a97a 100644 --- a/collects/frtime/core/erl.rkt +++ b/collects/frtime/core/erl.rkt @@ -1,5 +1,8 @@ -#lang racket -(require "match.rkt" +#lang racket/base + +(require racket/bool + racket/match + "match.rkt" "contract.rkt" #;"sema-mailbox.rkt" "mailbox.rkt") diff --git a/collects/frtime/core/frp.rkt b/collects/frtime/core/frp.rkt index 39d1375db1..f9e126e848 100644 --- a/collects/frtime/core/frp.rkt +++ b/collects/frtime/core/frp.rkt @@ -1,5 +1,10 @@ -#lang racket -(require "contract.rkt" +#lang racket/base + +(require racket/function + racket/list + racket/match + racket/contract + "contract.rkt" "erl.rkt" "heap.rkt") diff --git a/collects/frtime/core/heap.rkt b/collects/frtime/core/heap.rkt index 0f23a7feb3..9ec64ba06e 100644 --- a/collects/frtime/core/heap.rkt +++ b/collects/frtime/core/heap.rkt @@ -1,5 +1,9 @@ -#lang racket -(require "dv.rkt" +#lang racket/base + +(require racket/bool + racket/match + racket/contract + "dv.rkt" "contract.rkt") (define-struct t (sorter equality data)) diff --git a/collects/frtime/core/mailbox.rkt b/collects/frtime/core/mailbox.rkt index 228fd94360..a22a6fb1ca 100644 --- a/collects/frtime/core/mailbox.rkt +++ b/collects/frtime/core/mailbox.rkt @@ -1,5 +1,9 @@ -#lang racket -(require "contract.rkt" +#lang racket/base + +(require racket/bool + racket/list + racket/match + "contract.rkt" "match.rkt" racket/async-channel) diff --git a/collects/frtime/core/match.rkt b/collects/frtime/core/match.rkt index a2b6d71741..ac3808c9d7 100644 --- a/collects/frtime/core/match.rkt +++ b/collects/frtime/core/match.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang racket/base (define-struct a-match-fail ()) (define match-fail (make-a-match-fail)) diff --git a/collects/frtime/core/sema-mailbox.rkt b/collects/frtime/core/sema-mailbox.rkt index 44b1e72e75..d3d88e8f59 100644 --- a/collects/frtime/core/sema-mailbox.rkt +++ b/collects/frtime/core/sema-mailbox.rkt @@ -1,5 +1,9 @@ -#lang racket -(require "match.rkt" +#lang racket/base + +(require racket/list + racket/bool + racket/match + "match.rkt" "contract.rkt") (define (call-with-semaphore s thunk) diff --git a/collects/frtime/develop-frtime.rkt b/collects/frtime/develop-frtime.rkt index 25cce1fc7f..979e304dbb 100644 --- a/collects/frtime/develop-frtime.rkt +++ b/collects/frtime/develop-frtime.rkt @@ -1,6 +1,6 @@ -#lang racket -(require setup/link) +#lang racket/base +(require setup/link) #|Update this to point to your racket installation directory|# (define install-path "C:/Program Files/Racket/collects/frtime") @@ -9,20 +9,16 @@ (define dev-path "C:/Users/user/Documents/GitHub/racket/collects/frtime") #|Then call one of these functions to begin developing frtime, or to halt development.|# -(define start-developing-frtime - (lambda () - (start-developing-collection dev-path install-path))) +(define (start-developing-frtime) + (start-developing-collection dev-path install-path)) -(define stop-developing-frtime - (lambda () - (stop-developing-collection dev-path install-path))) +(define (stop-developing-frtime) + (stop-developing-collection dev-path install-path)) -(define start-developing-collection - (lambda (dev-coll-path install-coll-path) - (links install-coll-path #:remove? #t) - (links dev-coll-path))) +(define (start-developing-collection dev-coll-path install-coll-path) + (links install-coll-path #:remove? #t) + (links dev-coll-path)) -(define stop-developing-collection - (lambda (dev-coll-path install-coll-path) - (start-developing-collection install-coll-path dev-coll-path))) +(define (stop-developing-collection dev-coll-path install-coll-path) + (start-developing-collection install-coll-path dev-coll-path)) diff --git a/collects/frtime/frlibs/date.rkt b/collects/frtime/frlibs/date.rkt index 55fbcee54d..6cc4a870e0 100644 --- a/collects/frtime/frlibs/date.rkt +++ b/collects/frtime/frlibs/date.rkt @@ -1,6 +1,7 @@ -#lang racket -(require (rename-in (only-in frtime/frtime provide) - [provide frtime:provide])) +#lang racket/base + +(require racket/promise + (only-in frtime/frtime [provide frtime:provide])) (frtime:provide (lifted date->string date-display-format diff --git a/collects/frtime/opt/lowered-equivs.rkt b/collects/frtime/opt/lowered-equivs.rkt index 1702f2a97f..d017785393 100644 --- a/collects/frtime/opt/lowered-equivs.rkt +++ b/collects/frtime/opt/lowered-equivs.rkt @@ -1,10 +1,10 @@ ;; This module defines all the logic necessary for working with lowered ;; equivalents at the syntactic level. That is, it treats functions simply ;; as syntactic identifiers. -#lang racket +#lang racket/base + (provide (except-out (all-defined-out) module-identifier=?)) -(require (only-in srfi/1 any)) (define module-identifier=? free-identifier=?) diff --git a/collects/future-visualizer/private/graph-drawing.rkt b/collects/future-visualizer/private/graph-drawing.rkt index ee4f6963df..a95662ad16 100644 --- a/collects/future-visualizer/private/graph-drawing.rkt +++ b/collects/future-visualizer/private/graph-drawing.rkt @@ -1,13 +1,17 @@ -#lang racket -(require rackunit +#lang racket/base + +(require racket/list + racket/contract + ;; rackunit "constants.rkt") -(provide (struct-out point) - (struct-out node) - (struct-out drawable-node) - (struct-out graph-layout) + +(provide (struct-out point) + (struct-out node) + (struct-out drawable-node) + (struct-out graph-layout) (struct-out attributed-node) draw-tree - drawable-node-center + drawable-node-center build-attr-tree) (define-struct/contract point ([x integer?] [y integer?]) #:transparent) diff --git a/collects/future-visualizer/scribblings/common.rkt b/collects/future-visualizer/scribblings/common.rkt index e445f288ea..8dd07868b8 100644 --- a/collects/future-visualizer/scribblings/common.rkt +++ b/collects/future-visualizer/scribblings/common.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang racket/base (require (for-label racket/base) scribble/manual diff --git a/collects/future-visualizer/scribblings/futures-trace.scrbl b/collects/future-visualizer/scribblings/futures-trace.scrbl index b934d98782..00d002d456 100644 --- a/collects/future-visualizer/scribblings/futures-trace.scrbl +++ b/collects/future-visualizer/scribblings/futures-trace.scrbl @@ -1,5 +1,7 @@ #lang scribble/doc -@(require "common.rkt" (for-label racket/future future-visualizer/trace)) +@(require "common.rkt" + (for-label racket/future + future-visualizer/trace)) @title[#:tag "futures-trace"]{Futures Tracing} @@ -63,10 +65,11 @@ the execution of parallel programs written using @racket[future]. } @defstruct[indexed-future-event ([index exact-nonnegative-integer?] - [event (or future-event? gc-info?)])]{ + [event any])]{ Represents an individual log message in a program trace. In addition to future events, the tracing code also records garbage collection events; hence - the @racket[event] field may contain either a @racket[future-event] or @racket[gc-info], + the @racket[event] field may contain either a @racket[future-event] or gc-info + @(tech "prefab" #:doc '(lib "scribblings/reference/reference.scrbl")) struct (see @refsecref["garbagecollection"]), where the latter describes a GC operation. Because multiple @racket[future-event] structures may contain identical timestamps, the @racket[index] field ranks them in the order in which they were recorded @@ -82,19 +85,3 @@ the execution of parallel programs written using @racket[future]. #:prefab]{ Represents a future event as logged by the run-time system. See @refsecref["future-logging"] for more information.} - -@defstruct[gc-info ([major? boolean?] - [pre-used integer?] - [pre-admin integer?] - [code-page-total integer?] - [post-used integer?] - [post-admin integer?] - [start-time integer?] - [end-time integer?] - [start-real-time real?] - [end-real-time real?]) - #:prefab]{ - Represents a garbage collection. The only fields used by the visualizer - are @racket[start-real-time] and @racket[end-real-time], which are inexact - numbers representing time in the same way as @racket[current-inexact-milliseconds]. -} diff --git a/collects/games/cards/classes.rkt b/collects/games/cards/classes.rkt index 0c36a37b8d..018cdc15d4 100644 --- a/collects/games/cards/classes.rkt +++ b/collects/games/cards/classes.rkt @@ -123,8 +123,8 @@ (public* [only-front-selected (lambda () - (let loop ([s (find-next-selected-snip #f)][ok (find-first-snip)]) - (when s + (let loop ([s (find-next-selected-snip #f)][ok (find-first-snip)]) + (when s (if (eq? s ok) (loop (find-next-selected-snip s) (send ok next)) diff --git a/collects/games/gobblet/model.rkt b/collects/games/gobblet/model.rkt index f6e7d8f4d5..32ff79717f 100644 --- a/collects/games/gobblet/model.rkt +++ b/collects/games/gobblet/model.rkt @@ -445,7 +445,7 @@ (let ([v (if who (compact-board board who) board)]) - ;; Find canonical mapping. + ;; Find canonical mapping. (hash-table-get memory v (lambda () diff --git a/collects/games/gobblet/test-model.rkt b/collects/games/gobblet/test-model.rkt index 03df53c5b8..f14fa6b109 100644 --- a/collects/games/gobblet/test-model.rkt +++ b/collects/games/gobblet/test-model.rkt @@ -193,7 +193,7 @@ (define-values/invoke-unit/sig model^ model-unit #f config^) (let ([c (let ([canonicalize (make-canonicalize)]) - (lambda (b who) + (lambda (b who) (canon-test 4 canonicalize b who fold-board board-ref move empty-board yellow-pieces red-pieces piece-color piece-size other diff --git a/collects/games/jewel/shapes.scm b/collects/games/jewel/shapes.scm index 13631dc00b..a8c4a57fc0 100644 --- a/collects/games/jewel/shapes.scm +++ b/collects/games/jewel/shapes.scm @@ -247,7 +247,7 @@ (glVertex3f sizex (- bsizey) sizez); (glVertex3f (- sizex) (- bsizey) sizez); -; setmaterial(blue); +; setmaterial(blue); (glNormal3f 0.0 sizey sizez); (glVertex3f (- sizex) bsizey sizez); @@ -323,7 +323,7 @@ (glEnd); -; setmaterial(red); +; setmaterial(red); (glBegin GL_TRIANGLES); (glNormal3f sizex sizey sizez); diff --git a/collects/games/paint-by-numbers/solve.rkt b/collects/games/paint-by-numbers/solve.rkt index 16c8298b96..9395b71652 100644 --- a/collects/games/paint-by-numbers/solve.rkt +++ b/collects/games/paint-by-numbers/solve.rkt @@ -1,5 +1,3 @@ - - (module solve mzscheme (require mzlib/list @@ -14,63 +12,63 @@ void)]) (define (solve row-info col-info set-entry setup-progress) - (local ( - (define (pause) '(sleep 1/16)) - - ; all test cases are commented out. - - ; to work on large lists, we must make filter tail-recursive. - ; this one reverses. + (local [ + (define (pause) '(sleep 1/16)) + + ; all test cases are commented out. + + ; to work on large lists, we must make filter tail-recursive. + ; this one reverses. ; filter-rev : returns a list of all elements in a-list which ; satisfy the predicate. If a precedes b in a-list, and both ; occur in the result, then b will precede a in the result. ; ((A -> boolean) (list-of A) -> (list-of A)) - (define (filter-rev fun a-list) - (foldl (lambda (elt built-list) - (if (fun elt) - (cons elt built-list) - built-list)) - null - a-list)) - - ;(equal? (filter-rev (lambda (x) (> x 13)) '(2 98 27 1 23 2 09)) - ; '(23 27 98)) - - - ; transpose : transposes a matrix represented as a list of lists - ; ((list-of (list-of T)) -> (list-of (list-of T))) - - (define (transpose list-list) - (apply map list list-list)) - - ;(equal? (transpose '((a b c d e) - ; (f g h i j) - ; (k l m n o))) - ; '((a f k) + (define (filter-rev fun a-list) + (foldl (lambda (elt built-list) + (if (fun elt) + (cons elt built-list) + built-list)) + null + a-list)) + + ;(equal? (filter-rev (lambda (x) (> x 13)) '(2 98 27 1 23 2 09)) + ; '(23 27 98)) + + + ; transpose : transposes a matrix represented as a list of lists + ; ((list-of (list-of T)) -> (list-of (list-of T))) + + (define (transpose list-list) + (apply map list list-list)) + + ;(equal? (transpose '((a b c d e) + ; (f g h i j) + ; (k l m n o))) + ; '((a f k) ; (b g l) - ; (c h m) - ; (d i n) - ; (e j o))) - + ; (c h m) + ; (d i n) + ; (e j o))) + ; TYPE-DECLARATIONS: ; there are three kinds of cell-list: the board-row-list, the tally-list, and the try-list. - ; + ; ; (type: board-row (list-of (union 'off 'on 'unknown))) ; (type: tally-row (list-of (union 'off 'on 'unknown 'maybe-off 'maybe-on 'mixed))) ; (type: try-row (list-of (union 'maybe-off 'maybe-on 'unknown))) (define try-row? (listof (symbols 'maybe-off 'maybe-on 'unknown))) (define try-batch? (listof (or/c number? (listof try-row?)))) - ; + ; ; (type: board (list-of board-row)) - ; board-ref : returns the board element in (col,row); + ; board-ref : returns the board element in (col,row); ; (board num num -> (union 'on 'off 'unknown)) - (define (board-ref board row col) + (define (board-ref board row col) (list-ref (list-ref board row) col)) ; board-width : returns the width of the board @@ -84,30 +82,30 @@ (define (board-height board) (length board)) - - ; extract-rows : returns the board as a list of rows + + ; extract-rows : returns the board as a list of rows ; (board -> board) - (define (extract-rows board) - board) - - ; extract-cols : returns the board as a list of columns + (define (extract-rows board) + board) + + ; extract-cols : returns the board as a list of columns ; (board -> board) - (define (extract-cols board) - (transpose board)) - + (define (extract-cols board) + (transpose board)) + ; reassemble-rows : turns a list of rows into a board ; (board -> board) - (define (reassemble-rows board-line-list) - board-line-list) - + (define (reassemble-rows board-line-list) + board-line-list) + ; reassemble-cols : turns a list of columns into a board ; (board -> board) - (define (reassemble-cols board-line-list) - (transpose board-line-list)) + (define (reassemble-cols board-line-list) + (transpose board-line-list)) ; entirely-unknown : does this row consist entirely of 'unknown? @@ -118,10 +116,10 @@ (define (finished? board) (not (ormap (lambda (row) (ormap (lambda (cell) (eq? cell 'unknown)) row)) board))) - + ; threshold info : the threshold is the limit at which - ; memoize-tries will simply give up. + ; memoize-tries will simply give up. (define initial-threshold 2000) @@ -153,48 +151,48 @@ ;(equal? (condensed->long-form '(((? !) u) (* () X O))) ; '(((maybe-on maybe-off) unknown) (mixed () off on))) - - ; check-changed : check whether a tally-row reveals new information to be added + + ; check-changed : check whether a tally-row reveals new information to be added ; to the grid ; (tally-row -> boolean) - (define (check-changed tally-list) - (ormap (lambda (cell) - (case cell - ((off on unknown mixed) #f) - ((maybe-off maybe-on) #t) - (else (error "unknown element found in check-changed: ~a" cell)))) - tally-list)) - + (define (check-changed tally-list) + (ormap (lambda (cell) + (case cell + ((off on unknown mixed) #f) + ((maybe-off maybe-on) #t) + (else (error "unknown element found in check-changed: ~a" cell)))) + tally-list)) + ;(and (equal? (check-changed '(off off on unknown mixed)) #f) - ; (equal? (check-changed '(off on maybe-off on mixed)) #t) + ; (equal? (check-changed '(off on maybe-off on mixed)) #t) ; (equal? (check-changed '(off maybe-on on on unknown)) #t)) - - ; rectify : transform a tally-row into a board row, by changing maybe-off + + ; rectify : transform a tally-row into a board row, by changing maybe-off ; to off and maybe-on to on. - ; (tally-row -> board-row) + ; (tally-row -> board-row) - (define (rectify tally-list) - (map (lambda (cell) - (case cell - ((off on unknown) cell) - ((maybe-off) 'off) - ((maybe-on) 'on) - ((mixed) 'unknown) - (else (error "unknown element in rectified row")))) - tally-list)) - - ;(equal? (rectify '(off on maybe-on mixed unknown maybe-off)) - ; '(off on on unknown unknown off)) - - ; make-row-formulator: - ; given a set of block lengths, create a function which accepts a - ; set of pads and formulates a try-row: - ; (num-list -> (num-list num -> (list-of (union 'maybe-off 'maybe-on 'unknown)))) - - (define (make-row-formulator blocks) - (lambda (pads) - (apply append + (define (rectify tally-list) + (map (lambda (cell) + (case cell + ((off on unknown) cell) + ((maybe-off) 'off) + ((maybe-on) 'on) + ((mixed) 'unknown) + (else (error "unknown element in rectified row")))) + tally-list)) + + ;(equal? (rectify '(off on maybe-on mixed unknown maybe-off)) + ; '(off on on unknown unknown off)) + + ; make-row-formulator: + ; given a set of block lengths, create a function which accepts a + ; set of pads and formulates a try-row: + ; (num-list -> (num-list num -> (list-of (union 'maybe-off 'maybe-on 'unknown)))) + + (define (make-row-formulator blocks) + (lambda (pads) + (apply append (let loop ([pads pads] [blocks blocks]) (cond [(null? (cdr pads)) @@ -205,12 +203,12 @@ (cons (build-list (car pads) (lambda (x) 'maybe-off)) (cons (build-list (car blocks) (lambda (x) 'maybe-on)) (loop (cdr pads) (cdr blocks))))]))))) - + #| - (equal? ((make-row-formulator '(3 1 1 5)) '(1 2 1 3 3)) - '(maybe-off maybe-on maybe-on maybe-on maybe-off maybe-off maybe-on maybe-off maybe-on - maybe-off maybe-off maybe-off maybe-on maybe-on maybe-on maybe-on maybe-on - maybe-off maybe-off maybe-off)) + (equal? ((make-row-formulator '(3 1 1 5)) '(1 2 1 3 3)) + '(maybe-off maybe-on maybe-on maybe-on maybe-off maybe-off maybe-on maybe-off maybe-on + maybe-off maybe-off maybe-off maybe-on maybe-on maybe-on maybe-on maybe-on + maybe-off maybe-off maybe-off)) (equal? ((make-row-formulator '(3 1 1 5)) '(2 4 4)) '(maybe-off maybe-off @@ -218,38 +216,38 @@ maybe-off maybe-off maybe-off maybe-off maybe-on unknown unknown unknown unknown unknown unknown unknown unknown unknown unknown)) - |# - - #| check-try : - see whether a try fits with the existing row information (curried) - (tally-row -> (try-row -> boolean)) - |# - - (define (check-try tally-list) - (lambda (try-list) - (andmap (lambda (tally try) + |# + + #| check-try : + see whether a try fits with the existing row information (curried) + (tally-row -> (try-row -> boolean)) + |# + + (define (check-try tally-list) + (lambda (try-list) + (andmap (lambda (tally try) (or (eq? try 'unknown) (case tally ((off) (eq? try 'maybe-off)) ((on) (eq? try 'maybe-on)) (else #t)))) - tally-list - try-list))) - - #| - (equal? ((check-try '(unknown off on unknown unknown unknown)) - '(maybe-on maybe-on maybe-on maybe-off maybe-off maybe-off)) - #f) - - (equal? ((check-try '(unknown off on unknown unknown unknown)) - '(maybe-off maybe-off maybe-on maybe-on maybe-on maybe-off)) - #t) + tally-list + try-list))) + + #| + (equal? ((check-try '(unknown off on unknown unknown unknown)) + '(maybe-on maybe-on maybe-on maybe-off maybe-off maybe-off)) + #f) + + (equal? ((check-try '(unknown off on unknown unknown unknown)) + '(maybe-off maybe-off maybe-on maybe-on maybe-on maybe-off)) + #t) (equal? ((check-try '(unknown off on unknown unknown unknown)) '(unknown unknown unknown unknown unknown unknown)) #t) - |# - + |# + #| choose : like math. as in, "9 choose 3" (num num -> num) |# @@ -295,17 +293,17 @@ (choose 29 4)) |# - #| build-possibles: - builds a list of the possible rows. given a number of spaces, and a number - of bins to put the spaces in, and a row-formulator, and a line-checker predicate, - build-possibles makes a list of every possible row which passes the predicate. + #| build-possibles: + builds a list of the possible rows. given a number of spaces, and a number + of bins to put the spaces in, and a row-formulator, and a line-checker predicate, + build-possibles makes a list of every possible row which passes the predicate. If the number of possibilities grows larger than the threshold, the search is aborted. - - (num num ((list-of num) -> try-row) (try-row -> bool) num -> (union (list-of try-row) #f)) - |# - - (define (build-possibles things total-bins row-formulator line-checker threshold) + + (num num ((list-of num) -> try-row) (try-row -> bool) num -> (union (list-of try-row) #f)) + |# + + (define (build-possibles things total-bins row-formulator line-checker threshold) (let/ec escape (let* ([built-list null] [list-length 0] @@ -335,9 +333,9 @@ (try-loop (+ in-this-bin 1)))))))) built-list))) - - #| - ;build-possibles test case + + #| + ;build-possibles test case (let* ([row-formulator-one (make-row-formulator '(2))] [line-checker (check-try '(unknown unknown unknown on unknown unknown))] [test-one (build-possibles 4 2 row-formulator-one line-checker 10000)] @@ -351,101 +349,101 @@ '((maybe-off maybe-off maybe-off maybe-on maybe-off maybe-on) (maybe-off maybe-on maybe-off maybe-on maybe-off maybe-off) (maybe-on maybe-off maybe-off maybe-on maybe-off maybe-off))))) - |# - - #| spare-spaces: - calculates the number of spare spaces in a line. In other words, - line-length - sum-of-all-blocks - - ((list-of num) num -> num) - |# - - (define (spare-spaces block-list line-length) - (let* ([black-spaces (apply + block-list)] - [spare-spaces (- line-length black-spaces)]) - spare-spaces)) - - ; first-pass: - ; generates the information about row contents which can be inferred directly - ; from the block info and nothing else (i.e., uses no information from an existing - ; board. - ; ((list-of (list-of num)) num -> (list-of (list-of (union 'on 'unknown)))) - - (define (first-pass info-list line-length) - (let ((row-pass - (lambda (block-list) - (let* ([spares (- (spare-spaces block-list line-length) (max 0 (- (length block-list) 1)))] - [shortened-blocks - (map (lambda (block-length) (- block-length spares)) - block-list)] - [all-but-start - (foldr append null - (let build-row-loop ([blocks-left shortened-blocks]) - (if (null? blocks-left) - null - (let ([extra-pad (if (null? (cdr blocks-left)) 0 1)]) - (if (> (car blocks-left) 0) - (cons (build-list (car blocks-left) (lambda (x) 'on)) - (cons (build-list (+ spares extra-pad) (lambda (x) 'unknown)) - (build-row-loop (cdr blocks-left)))) - (cons (build-list (+ spares extra-pad (car blocks-left)) - (lambda (x) 'unknown)) - (build-row-loop (cdr blocks-left))))))))] - [whole-row (append (build-list spares (lambda (x) 'unknown)) - all-but-start)]) - whole-row)))) - (map row-pass info-list))) - - #| - (let ([test-result (first-pass '((4 3) (5 1)) 10)]) - (equal? test-result '((unknown unknown on on unknown unknown unknown on unknown unknown) - (unknown unknown unknown on on unknown unknown unknown unknown unknown)))) - |# - - #| unify-passes: - unify the result of running first-pass on both the rows and the columns - (let ([BOARD (list-of (list-of (union 'unknown 'on)))]) - (BOARD BOARD -> BOARD)) - |# - - (define (unify-passes board-a board-b) - (let ([unify-rows - (lambda (row-a row-b) - (map (lambda (cell-a cell-b) - (case cell-a - ((on) 'on) - (else cell-b))) - row-a row-b))]) - (map unify-rows board-a board-b))) - - #| - (let* ([board-a '((unknown unknown on) (on unknown unknown))] - [board-b '((unknown on unknown) (on on unknown))] - [test-result (unify-passes board-a board-b)]) - (equal? test-result '((unknown on on) (on on unknown)))) - |# - - #| whole-first-pass: - take a set of row descriptions and the board dimensions and generate the - merged first-pass info - ((list-of (list-of num)) (list-of (list-of num)) num num -> - (list-of board-row)) - |# - - (define (whole-first-pass row-info col-info width height) - (unify-passes (first-pass row-info width) - (transpose (first-pass col-info height)))) - - #| memoize-tries: - given the black block widths and the line length and some initial board - and a progress-bar updater, calculate all possibilities for each row. + |# + + #| spare-spaces: + calculates the number of spare spaces in a line. In other words, + line-length - sum-of-all-blocks + + ((list-of num) num -> num) + |# + + (define (spare-spaces block-list line-length) + (let* ([black-spaces (apply + block-list)] + [spare-spaces (- line-length black-spaces)]) + spare-spaces)) + + ; first-pass: + ; generates the information about row contents which can be inferred directly + ; from the block info and nothing else (i.e., uses no information from an existing + ; board. + ; ((list-of (list-of num)) num -> (list-of (list-of (union 'on 'unknown)))) + + (define (first-pass info-list line-length) + (let ((row-pass + (lambda (block-list) + (let* ([spares (- (spare-spaces block-list line-length) (max 0 (- (length block-list) 1)))] + [shortened-blocks + (map (lambda (block-length) (- block-length spares)) + block-list)] + [all-but-start + (foldr append null + (let build-row-loop ([blocks-left shortened-blocks]) + (if (null? blocks-left) + null + (let ([extra-pad (if (null? (cdr blocks-left)) 0 1)]) + (if (> (car blocks-left) 0) + (cons (build-list (car blocks-left) (lambda (x) 'on)) + (cons (build-list (+ spares extra-pad) (lambda (x) 'unknown)) + (build-row-loop (cdr blocks-left)))) + (cons (build-list (+ spares extra-pad (car blocks-left)) + (lambda (x) 'unknown)) + (build-row-loop (cdr blocks-left))))))))] + [whole-row (append (build-list spares (lambda (x) 'unknown)) + all-but-start)]) + whole-row)))) + (map row-pass info-list))) + + #| + (let ([test-result (first-pass '((4 3) (5 1)) 10)]) + (equal? test-result '((unknown unknown on on unknown unknown unknown on unknown unknown) + (unknown unknown unknown on on unknown unknown unknown unknown unknown)))) + |# + + #| unify-passes: + unify the result of running first-pass on both the rows and the columns + (let ([BOARD (list-of (list-of (union 'unknown 'on)))]) + (BOARD BOARD -> BOARD)) + |# + + (define (unify-passes board-a board-b) + (let ([unify-rows + (lambda (row-a row-b) + (map (lambda (cell-a cell-b) + (case cell-a + ((on) 'on) + (else cell-b))) + row-a row-b))]) + (map unify-rows board-a board-b))) + + #| + (let* ([board-a '((unknown unknown on) (on unknown unknown))] + [board-b '((unknown on unknown) (on on unknown))] + [test-result (unify-passes board-a board-b)]) + (equal? test-result '((unknown on on) (on on unknown)))) + |# + + #| whole-first-pass: + take a set of row descriptions and the board dimensions and generate the + merged first-pass info + ((list-of (list-of num)) (list-of (list-of num)) num num -> + (list-of board-row)) + |# + + (define (whole-first-pass row-info col-info width height) + (unify-passes (first-pass row-info width) + (transpose (first-pass col-info height)))) + + #| memoize-tries: + given the black block widths and the line length and some initial board + and a progress-bar updater, calculate all possibilities for each row. If skip-unknowns is #t, rows whose content is entirely unknown will be skipped, and #f returned for that row. - effect: updates the progress bar - ((list-of (list-of num)) num (list-of board-row) (-> void) boolean -> (union (list-of try-row) #f)) - |# - - (define (memoize-tries info-list line-length board-rows old-tries threshold) + effect: updates the progress bar + ((list-of (list-of num)) num (list-of board-row) (-> void) boolean -> (union (list-of try-row) #f)) + |# + + (define (memoize-tries info-list line-length board-rows old-tries threshold) (let* ([unmemoized (filter number? old-tries)]) (if (null? unmemoized) old-tries @@ -464,133 +462,133 @@ old-tries info-list board-rows))))) - - #| - (equal? (memoize-tries '((4) (1 3)) - 6 - '((unknown on unknown unknown unknown unknown) - (unknown off unknown unknown unknown unknown)) - void) - '(((maybe-on maybe-on maybe-on maybe-on maybe-off maybe-off) - (maybe-off maybe-on maybe-on maybe-on maybe-on maybe-off)) - ((maybe-on maybe-off maybe-on maybe-on maybe-on maybe-off) - (maybe-on maybe-off maybe-off maybe-on maybe-on maybe-on)))) - |# - - #| batch-try: - take a board-line list and a list of possibles, and trim it down by - checking each try-list against the appropriate board-line - - ((list-of board-row) (list-of (union (list-of try-row) #f)) -> (list-of (union (list-of try-row) #f))) - |# - - (define (batch-try board-line-list try-list-list-list) - (map (lambda (line try-list-list) + + #| + (equal? (memoize-tries '((4) (1 3)) + 6 + '((unknown on unknown unknown unknown unknown) + (unknown off unknown unknown unknown unknown)) + void) + '(((maybe-on maybe-on maybe-on maybe-on maybe-off maybe-off) + (maybe-off maybe-on maybe-on maybe-on maybe-on maybe-off)) + ((maybe-on maybe-off maybe-on maybe-on maybe-on maybe-off) + (maybe-on maybe-off maybe-off maybe-on maybe-on maybe-on)))) + |# + + #| batch-try: + take a board-line list and a list of possibles, and trim it down by + checking each try-list against the appropriate board-line + + ((list-of board-row) (list-of (union (list-of try-row) #f)) -> (list-of (union (list-of try-row) #f))) + |# + + (define (batch-try board-line-list try-list-list-list) + (map (lambda (line try-list-list) (if (not (number? try-list-list)) (filter ; filter-rev (let ([f (check-try line)]) (lambda (try-list) (f try-list))) try-list-list) try-list-list)) - board-line-list - try-list-list-list)) - - #| - (equal? (batch-try '((unknown unknown unknown off) - (unknown on unknown unknown)) - '(((maybe-on maybe-on maybe-on maybe-off) - (maybe-off maybe-on maybe-on maybe-on)) - ((maybe-on maybe-on maybe-off maybe-off) - (maybe-off maybe-on maybe-on maybe-off) - (maybe-off maybe-off maybe-on maybe-on)))) - '(((maybe-on maybe-on maybe-on maybe-off)) - ((maybe-off maybe-on maybe-on maybe-off) - (maybe-on maybe-on maybe-off maybe-off)))) - |# - - ; tabulate-try : take one possibility, and merge it with the row possibles - ; (tally-list try-list) -> tally-list - - (define (tabulate-try tally-list try-list) - (map (lambda (tally try) - (case tally - ((off on mixed) tally) - ((unknown) try) - ((maybe-off maybe-on) (if (eq? try tally) - try - 'mixed)) - (else (error "unknown cell type during tabulate-try: ~a" tally)))) - tally-list - try-list)) - - - #| - (equal? (tabulate-try '(on off maybe-off maybe-off maybe-on maybe-on maybe-on) - '(on off mixed maybe-on maybe-on mixed maybe-off)) - '(on off mixed mixed maybe-on mixed mixed)) - |# - - ; batch-tabulate : take a board-line-list and a list of sets of tries which check with the board - ; and tabulate them all to produce a new board line list (before rectification) - ; (board-line-list try-list-list-opt-list) -> tally-list - (define (batch-tabulate board-line-list try-list-list-opt-list) - (map (lambda (board-line try-list-list-opt) + board-line-list + try-list-list-list)) + + #| + (equal? (batch-try '((unknown unknown unknown off) + (unknown on unknown unknown)) + '(((maybe-on maybe-on maybe-on maybe-off) + (maybe-off maybe-on maybe-on maybe-on)) + ((maybe-on maybe-on maybe-off maybe-off) + (maybe-off maybe-on maybe-on maybe-off) + (maybe-off maybe-off maybe-on maybe-on)))) + '(((maybe-on maybe-on maybe-on maybe-off)) + ((maybe-off maybe-on maybe-on maybe-off) + (maybe-on maybe-on maybe-off maybe-off)))) + |# + + ; tabulate-try : take one possibility, and merge it with the row possibles + ; (tally-list try-list) -> tally-list + + (define (tabulate-try tally-list try-list) + (map (lambda (tally try) + (case tally + ((off on mixed) tally) + ((unknown) try) + ((maybe-off maybe-on) (if (eq? try tally) + try + 'mixed)) + (else (error "unknown cell type during tabulate-try: ~a" tally)))) + tally-list + try-list)) + + + #| + (equal? (tabulate-try '(on off maybe-off maybe-off maybe-on maybe-on maybe-on) + '(on off mixed maybe-on maybe-on mixed maybe-off)) + '(on off mixed mixed maybe-on mixed mixed)) + |# + + ; batch-tabulate : take a board-line-list and a list of sets of tries which check with the board + ; and tabulate them all to produce a new board line list (before rectification) + ; (board-line-list try-list-list-opt-list) -> tally-list + (define (batch-tabulate board-line-list try-list-list-opt-list) + (map (lambda (board-line try-list-list-opt) (if (not (number? try-list-list-opt)) (foldl (lambda (x y) (tabulate-try y x)) board-line try-list-list-opt) board-line)) - board-line-list - try-list-list-opt-list)) - - - ; (equal? (batch-tabulate '((unknown unknown unknown off) - ; (unknown unknown on unknown)) - ; '(((maybe-on maybe-on maybe-off maybe-off) - ; (maybe-off maybe-on maybe-on maybe-off)) - ; ((maybe-off maybe-on maybe-on maybe-off) - ; (maybe-off maybe-off maybe-on maybe-on)))) - ; '((mixed maybe-on mixed off) - ; (maybe-off mixed on mixed))) - - (define (print-board board) - (for-each (lambda (row) - (for-each (lambda (cell) - (printf (case cell - ((off) " ") - ((unknown) ".") - ((on) "#")))) - row) - (printf "\n")) - (extract-rows board))) - - ; animate-changes takes a board and draws it on the main screen - (define (animate-changes board draw-thunk outer-size inner-size) - (let outer-loop ([outer-index 0]) - (if (= outer-index outer-size) - null - (let inner-loop ([inner-index 0]) - (if (= inner-index inner-size) - (begin - (pause) - (outer-loop (+ outer-index 1))) - (begin - (draw-thunk board outer-index inner-index) - (inner-loop (+ inner-index 1)))))))) - - (define (draw-rows-thunk board row col) - (set-entry col row (board-ref board row col))) - - (define (draw-cols-thunk board col row) - (set-entry col row (board-ref board row col))) - - ; (print-board '((on on unknown off) - ; (on on unknown unknown) - ; (unknown unknown on on) - ; (off unknown on on))) - - ; do-lines takes a board-line-list and a try-list-list-list and returns two things: a tally-list-list - ; and a new try-list-list-list - ; (board-line-list try-list-list-opt-list) -> (tally-list-list try-list-list-opt-list) - (define do-lines + board-line-list + try-list-list-opt-list)) + + + ; (equal? (batch-tabulate '((unknown unknown unknown off) + ; (unknown unknown on unknown)) + ; '(((maybe-on maybe-on maybe-off maybe-off) + ; (maybe-off maybe-on maybe-on maybe-off)) + ; ((maybe-off maybe-on maybe-on maybe-off) + ; (maybe-off maybe-off maybe-on maybe-on)))) + ; '((mixed maybe-on mixed off) + ; (maybe-off mixed on mixed))) + + (define (print-board board) + (for-each (lambda (row) + (for-each (lambda (cell) + (printf (case cell + ((off) " ") + ((unknown) ".") + ((on) "#")))) + row) + (printf "\n")) + (extract-rows board))) + + ; animate-changes takes a board and draws it on the main screen + (define (animate-changes board draw-thunk outer-size inner-size) + (let outer-loop ([outer-index 0]) + (if (= outer-index outer-size) + null + (let inner-loop ([inner-index 0]) + (if (= inner-index inner-size) + (begin + (pause) + (outer-loop (+ outer-index 1))) + (begin + (draw-thunk board outer-index inner-index) + (inner-loop (+ inner-index 1)))))))) + + (define (draw-rows-thunk board row col) + (set-entry col row (board-ref board row col))) + + (define (draw-cols-thunk board col row) + (set-entry col row (board-ref board row col))) + + ; (print-board '((on on unknown off) + ; (on on unknown unknown) + ; (unknown unknown on on) + ; (off unknown on on))) + + ; do-lines takes a board-line-list and a try-list-list-list and returns two things: a tally-list-list + ; and a new try-list-list-list + ; (board-line-list try-list-list-opt-list) -> (tally-list-list try-list-list-opt-list) + (define do-lines (contract (->* (any/c try-batch?) ((listof (listof any/c)) try-batch?)) @@ -600,10 +598,10 @@ new-tries))) 'do-lines 'caller)) - - ; full-set takes a board and a pair of try-list-list-lists and returns a new board, a new pair - ; of try-list-list-lists, and a boolean (whether it's changed) - (define full-set + + ; full-set takes a board and a pair of try-list-list-lists and returns a new board, a new pair + ; of try-list-list-lists, and a boolean (whether it's changed) + (define full-set (contract (->* (any/c try-batch? try-batch?) (any/c try-batch? try-batch? boolean?)) @@ -633,15 +631,15 @@ (values final-board new-row-tries new-col-tries (or row-changed col-changed)))) 'full-set 'caller)) - + ; on 2002-10-17, I wrapped another layer of looping around the inner loop. ; the purpose of this outer loop is to allow the solver to ignore rows (or ; columns) about which the solver knows nothing for as long as possible. - (define (local-solve row-info col-info) - (let* ([rows (length row-info)] - [cols (length col-info)] - [initial-board (whole-first-pass row-info col-info cols rows)] + (define (local-solve row-info col-info) + (let* ([rows (length row-info)] + [cols (length col-info)] + [initial-board (whole-first-pass row-info col-info cols rows)] [_ (animate-changes initial-board draw-cols-thunk (board-width initial-board) (board-height initial-board))]) @@ -668,7 +666,7 @@ (outer-loop board (next-threshold skip-threshold) row-tries col-tries) (outer-loop board skip-threshold row-tries col-tries))))))))) - ) + ] (local-solve row-info col-info) ))) diff --git a/collects/graphics/graphics-posn-less-unit.rkt b/collects/graphics/graphics-posn-less-unit.rkt index 7a04ac8a97..5ce087837d 100644 --- a/collects/graphics/graphics-posn-less-unit.rkt +++ b/collects/graphics/graphics-posn-less-unit.rkt @@ -206,8 +206,8 @@ (lambda () (set! the-world (with-handlers ([exn:break? break-handler] - [exn? exn-handler]) - (on-tick-proc the-world))))) + [exn? exn-handler]) + (on-tick-proc the-world))))) ;; World -> World (define on-tick-proc void) (define exn-handler diff --git a/collects/graphics/turtle-test.rkt b/collects/graphics/turtle-test.rkt index fd92389b34..d509bfd9c8 100644 --- a/collects/graphics/turtle-test.rkt +++ b/collects/graphics/turtle-test.rkt @@ -40,6 +40,6 @@ stretchable-width #t)) options) - (make-object grow-box-spacer-pane% frame) + (make-object grow-box-spacer-pane% frame) (send frame show #t)) diff --git a/collects/gui-debugger/TODO.txt b/collects/gui-debugger/TODO.txt index c2a6e9d15c..cab4f1f3a7 100644 --- a/collects/gui-debugger/TODO.txt +++ b/collects/gui-debugger/TODO.txt @@ -1,7 +1,7 @@ - Stack navigation from REPL - Automated tests -- Trace by function name - +- Trace by function name + CHANGES TO MAKE----------------------------------------------------------------------------- Ability to add named anchors into code using Special menu in DRS -- use those anchors as tracepoints. @@ -10,8 +10,8 @@ Demo monitoring DrRacket for Robby? Bind Stop button to kill-all. On the whole, I like the tool, although it'd be nice to have either - (a) an interactive pointy-clicky interface rather than figuring - out line/column co-ordinates, or + (a) an interactive pointy-clicky interface rather than figuring + out line/column co-ordinates, or Re-direct, or at least prefix, program output from the client so that it can be distinguished from the script diff --git a/collects/gui-debugger/debug-tool.rkt b/collects/gui-debugger/debug-tool.rkt index 9bef7cbbb5..bfa60c5f6b 100644 --- a/collects/gui-debugger/debug-tool.rkt +++ b/collects/gui-debugger/debug-tool.rkt @@ -1,14 +1,14 @@ -#lang racket +#lang racket/base ;; DrRacket's debugging tool -(require mzlib/etc - mzlib/list - mzlib/class - mzlib/unit - mzlib/contract - mred - mzlib/match +(require racket/function + racket/list + racket/class + racket/unit + racket/contract + racket/match + racket/gui drscheme/tool "marks.rkt" mrlib/switchable-button @@ -20,7 +20,8 @@ string-constants lang/debugger-language-interface images/compile-time - (for-syntax racket/class + (for-syntax racket/base + racket/class racket/draw images/icons/arrow images/icons/control @@ -60,8 +61,8 @@ debugger-language<%> (lambda (superclass) (class* superclass (debugger-language<%>) - (public debugger:supported?) - (define (debugger:supported?) #t) + (public debugger:supported?) + (define (debugger:supported?) #t) (super-instantiate ()))))) (define phase2 void) @@ -112,7 +113,7 @@ ;; (
) => () ;; ( ... ) => ( ...) (define trim-expr-str - (opt-lambda (str [len 10]) + (lambda (str [len 10]) (let* ([strlen (string-length str)] [starts-with-paren (and (> strlen 0) (char=? (string-ref str 0) #\())] @@ -157,7 +158,7 @@ [else v])) (define filename->defs - (opt-lambda (source [default #f]) + (lambda (source [default #f]) (let/ec k (cond [(is-a? source editor<%>) source] @@ -985,7 +986,7 @@ (rest frames)))))) (define/public suspend-gui - (opt-lambda (frames status [switch-tabs? #f] [already-stopped? #f]) + (lambda (frames status [switch-tabs? #f] [already-stopped? #f]) (let ([top-of-stack? (zero? (get-frame-num))] [status-message (send (get-frame) get-status-message)]) (set! want-suspend-on-break? #f) @@ -1052,7 +1053,7 @@ (define/public suspend ;; ==called from user thread== - (opt-lambda (break-handler frames [status #f]) + (lambda (break-handler frames [status #f]) ;; suspend-sema ensures that we allow only one suspended thread ;; at a time (cond @@ -1391,8 +1392,8 @@ (bitmap debug-bitmap) (alternate-bitmap small-debug-bitmap) (parent (new vertical-pane% - [parent (get-button-panel)] - [alignment '(center center)])) + [parent (get-button-panel)] + [alignment '(center center)])) (callback (λ (button) (debug-callback))))) (inherit register-toolbar-button) (register-toolbar-button debug-button #:number 60) diff --git a/collects/honu/core/api.rkt b/collects/honu/core/api.rkt index c1fb359dba..891e9f46b1 100644 --- a/collects/honu/core/api.rkt +++ b/collects/honu/core/api.rkt @@ -5,10 +5,12 @@ (require "private/syntax.rkt" "private/literals.rkt" (for-syntax "private/compile.rkt" + "private/syntax.rkt" "private/parse2.rkt")) (provide define-honu-syntax define-literal (for-syntax racket-syntax honu-expression + honu-syntax honu-body parse-all)) diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt index ddc1b05567..f7aa0405e3 100644 --- a/collects/honu/core/main.rkt +++ b/collects/honu/core/main.rkt @@ -9,6 +9,7 @@ "private/macro2.rkt" "private/class.rkt" "private/operator.rkt" + "private/syntax.rkt" (prefix-in literal: "private/literals.rkt") (prefix-in syntax-parse: syntax/parse) (prefix-in racket: racket/base) @@ -35,6 +36,7 @@ [honu-while while] [honu-macro macro] [honu-phase phase] + [honu-racket racket] [honu-primitive-macro primitive_macro] [honu-pattern pattern] [racket:read-line readLine] diff --git a/collects/honu/core/private/macro2.rkt b/collects/honu/core/private/macro2.rkt index 3ac8799a69..20d476ef80 100644 --- a/collects/honu/core/private/macro2.rkt +++ b/collects/honu/core/private/macro2.rkt @@ -7,11 +7,11 @@ racket/syntax "template.rkt" "literals.rkt" + "syntax.rkt" (prefix-in phase1: "parse2.rkt") "debug.rkt" (prefix-in phase1: "compile.rkt") "util.rkt" - (prefix-in syntax: syntax/parse/private/residual-ct) racket/base) (for-meta 2 syntax/parse racket/base @@ -28,6 +28,9 @@ "literals.rkt" "syntax.rkt" "debug.rkt" + + (for-meta 0 "template.rkt" syntax/stx) + (for-meta -1 "literals.rkt" "compile.rkt" "parse2.rkt" "parse-helper.rkt") #; (for-syntax "honu-typed-scheme.rkt") @@ -37,14 +40,30 @@ (require syntax/parse "literals.rkt" "debug.rkt" + "util.rkt" + (prefix-in syntax: syntax/parse/private/residual-ct) racket/syntax racket/set + racket/match + (for-syntax syntax/parse + racket/base + racket/syntax) (for-template racket/base syntax/parse)) (provide (all-defined-out)) (struct pattern-variable [name original depth class] #:transparent) + ;; given the name of an object and some fields this macro defines + ;; name.field for each of the fields + (define-syntax (define-struct-fields stx) + (syntax-parse stx + [(_ name type (field ...)) + (with-syntax ([(field* ...) + (for/list ([field (syntax->list #'(field ...))]) + (format-id field "~a.~a" (syntax-e #'name) (syntax-e field)))]) + #'(match-define (struct type (field* ...)) name))])) + ;; makes a syntax object with the right number of nested ellipses patterns (define (pattern-variable->syntax variable) (debug 2 "Convert pattern variable to syntax ~a location ~a\n" variable (pattern-variable-original variable)) @@ -126,6 +145,83 @@ (define variables (find (reverse-syntax original-pattern))) (debug 2 "Found variables ~a\n" variables) (for/list ([x variables]) x)) + + ;; variable is the original pattern variable, like 'foo' + ;; and new-name is the new generated name, 'temp1' + ;; we want to bind all the attributes from temp1 to foo, so if temp1 has + ;; temp1_a + ;; temp1_b ... + ;; + ;; we want to bind + ;; foo_a temp_a + ;; (foo_b ...) (temp_b ...) + (define (bind-attributes variable new-name) + (debug "Syntax class of ~a is ~a at ~a\n" + (pattern-variable-class variable) + (syntax-local-value (pattern-variable-class variable) (lambda () #f)) + (syntax-local-phase-level)) + (define attributes + (let ([syntax-class (syntax-local-value (pattern-variable-class variable))]) + (for/list ([attribute (syntax:stxclass-attrs syntax-class)]) + (pattern-variable (syntax:attr-name attribute) + (pattern-variable-original variable) + (+ (pattern-variable-depth variable) + (syntax:attr-depth attribute)) + #f)))) + + (define (mirror-attribute attribute) + (debug "Mirror attribute ~a\n" attribute) + (define-struct-fields attribute pattern-variable + (name original depth class)) + ;; create a new pattern variable with a syntax object that uses + ;; the given lexical context and whose name is prefix_suffix + (define (create lexical prefix suffix) + (pattern-variable->syntax + (pattern-variable (format-id lexical "~a_~a" prefix suffix) + attribute.original attribute.depth attribute.class))) + (define-struct-fields variable pattern-variable + (name original depth class)) + (debug "Bind attributes ~a ~a\n" variable.name attribute.name) + (with-syntax ([bind-attribute + #; + (create name (syntax-e name) name) + (pattern-variable->syntax + (pattern-variable (format-id variable.name "~a_~a" + (syntax-e variable.name) + attribute.name) + attribute.original + attribute.depth + attribute.class))] + [new-attribute + #; + (create new-name new-name name) + (pattern-variable->syntax + (pattern-variable + (format-id new-name "~a_~a" + new-name + attribute.name) + attribute.original attribute.depth #f))]) + (debug "Bind ~a to ~a\n" #'bind-attribute #'new-attribute) + #'(#:with bind-attribute #'new-attribute))) + + (for/set ([attribute attributes]) + (mirror-attribute attribute))) + + ;; returns a set of #:with clauses for syntax-parse that + ;; bind all the old variables and their attributes to some new names + ;; taking care of ellipses depth + (define (pattern-variables+attributes variables use) + (for/union ([old variables] + [new use]) + (define-struct-fields old pattern-variable (name original depth class)) + (with-syntax ([old-syntax (pattern-variable->syntax old)] + [new.result (pattern-variable->syntax + (pattern-variable (format-id new "~a_result" new) + old.original + old.depth + old.class))]) + (set-union (set #'(#:with old-syntax #'new.result)) + (bind-attributes old new))))) ) (require (for-meta 2 (submod "." analysis))) @@ -238,34 +334,6 @@ (syntax #'stuff*))]))) |# -(provide honu-syntax) -;; Do any honu-specific expansion here -(define-honu-syntax honu-syntax - (lambda (code) - (syntax-parse code #:literal-sets (cruft) - #; - [(_ (#%parens single) . rest) - (define context #'single) - (define compressed (compress-dollars #'single)) - (values - (with-syntax ([stuff* (datum->syntax context compressed context context)]) - (phase1:racket-syntax #'stuff*)) - #'rest - #f)] - [(_ (#%parens stuff ...) . rest) - (define context (stx-car #'(stuff ...))) - (define compressed (compress-dollars #'(stuff ...))) - (values - (with-syntax ([stuff* (datum->syntax context - (syntax->list compressed) - context context)]) - ;; (debug "Stuff is ~a\n" (syntax->datum #'stuff*)) - ;; (debug "Stuff syntaxed is ~a\n" (syntax->datum #'#'stuff*)) - (with-syntax ([(out ...) #'stuff*]) - (phase1:racket-syntax #'stuff*))) - #; #'(%racket-expression (parse-stuff stuff ...)) - #'rest - #f)]))) ;; combine syntax objects ;; #'(a b) + #'(c d) = #'(a b c d) @@ -301,128 +369,64 @@ (begin-for-syntax (define-syntax (generate-pattern stx) - - ;; given the name of an object and some fields this macro defines - ;; name.field for each of the fields - (define-syntax (define-struct-fields stx) - (syntax-parse stx - [(_ name type (field ...)) - (with-syntax ([(field* ...) - (for/list ([field (syntax->list #'(field ...))]) - (format-id field "~a.~a" (syntax-e #'name) (syntax-e field)))]) - #'(match-define (struct type (field* ...)) name))])) - (syntax-parse stx - [(_ name literals original-pattern maybe-out) - (define variables (find-pattern-variables #'original-pattern)) - (define use (generate-temporaries variables)) - (define mapping (make-hash)) - (for ([old variables] - [new use]) - (debug "Update mapping ~a to ~a\n" (syntax-e (pattern-variable-name old)) new) - (hash-set! mapping - (syntax-e (pattern-variable-name old)) - (pattern-variable new - (pattern-variable-original old) - (pattern-variable-depth old) - (pattern-variable-class old)))) + [(_ name literals (pattern-stx out-stx) ...) - ;; variable is the original pattern variable, like 'foo' - ;; and new-name is the new generated name, 'temp1' - ;; we want to bind all the attributes from temp1 to foo, so if temp1 has - ;; temp1_a - ;; temp1_b ... - ;; - ;; we want to bind - ;; foo_a temp_a - ;; (foo_b ...) (temp_b ...) - (define (bind-attributes variable new-name) - (debug "Syntax class of ~a is ~a at ~a\n" - (pattern-variable-class variable) - (syntax-local-value (pattern-variable-class variable) (lambda () #f)) - (syntax-local-phase-level)) - (define attributes - (let ([syntax-class (syntax-local-value (pattern-variable-class variable))]) - (for/list ([attribute (syntax:stxclass-attrs syntax-class)]) - (pattern-variable (syntax:attr-name attribute) - (pattern-variable-original variable) - (+ (pattern-variable-depth variable) - (syntax:attr-depth attribute)) - #f)))) + (define (make-syntax-class-pattern honu-pattern maybe-out) + (define variables (find-pattern-variables honu-pattern)) + (define use (generate-temporaries variables)) + (define mapping (make-hash)) + (for ([old variables] + [new use]) + (debug "Update mapping ~a to ~a\n" (syntax-e (pattern-variable-name old)) new) + (hash-set! mapping + (syntax-e (pattern-variable-name old)) + (pattern-variable new + (pattern-variable-original old) + (pattern-variable-depth old) + (pattern-variable-class old)))) - (define (mirror-attribute attribute) - (debug "Mirror attribute ~a\n" attribute) - ;; create a new pattern variable with a syntax object that uses - ;; the given lexical context and whose name is prefix_suffix - (define-struct-fields attribute pattern-variable - (name original depth class)) - (define (create lexical prefix suffix) - (pattern-variable->syntax - (pattern-variable (format-id lexical "~a_~a" prefix suffix) - attribute.original attribute.depth attribute.class))) - (define-struct-fields variable pattern-variable - (name original depth class)) - (debug "Bind attributes ~a ~a\n" variable.name attribute.name) - (with-syntax ([bind-attribute - #; - (create name (syntax-e name) name) - (pattern-variable->syntax - (pattern-variable (format-id variable.name "~a_~a" - (syntax-e variable.name) - attribute.name) - attribute.original - attribute.depth - attribute.class))] - [new-attribute - #; - (create new-name new-name name) - (pattern-variable->syntax - (pattern-variable - (format-id new-name "~a_~a" - new-name - attribute.name) - attribute.original attribute.depth #f))]) - (debug "Bind ~a to ~a\n" #'bind-attribute #'new-attribute) - #'(#:with bind-attribute #'new-attribute))) + (define withs (pattern-variables+attributes variables use)) - (for/set ([attribute attributes]) - (mirror-attribute attribute))) + (with-syntax ([(new-pattern ...) (convert-pattern honu-pattern mapping)] + [((withs ...) ...) (set->list withs)] + [(result-with ...) (if (syntax-e maybe-out) + (with-syntax ([(out ...) maybe-out]) + #'(#:with result (parse-stuff honu-syntax (#%parens out ...)))) + #'(#:with result #'()))]) + (syntax/loc honu-pattern + [pattern (~seq new-pattern ...) + withs ... ... + result-with ... + ]))) - (define withs - (for/union ([old variables] - [new use]) - (define-struct-fields old pattern-variable (name original depth class)) - (with-syntax ([old-syntax (pattern-variable->syntax old)] - [new.result (pattern-variable->syntax - (pattern-variable (format-id new "~a_result" new) - old.original - old.depth - old.class))]) - (set-union (set #'(#:with old-syntax #'new.result)) - (bind-attributes old new))))) + (define pattern-stuff + (for/list ([pattern (syntax->list #'(pattern-stx ...))] + [out (syntax->list #'(out-stx ...))]) + (make-syntax-class-pattern pattern out))) + #; (debug "With bindings ~a\n" withs) (with-syntax ([(literal ...) #'literals] - [(new-pattern ...) (convert-pattern #'original-pattern mapping)] - [((withs ...) ...) (set->list withs)] - [(result-with ...) (if (syntax-e #'maybe-out) - (with-syntax ([(out ...) #'maybe-out]) - #'(#:with result (out ...))) - #'(#:with result #'()))]) + [(new-pattern ...) pattern-stuff]) + #; (debug "Result with ~a\n" (syntax->datum #'(quote-syntax (result-with ...)))) (define output #'(quote-syntax (begin - ;; define at phase1 so we can use it + ;; define at phase1 so we can use it in a macro (begin-for-syntax (define-literal-set local-literals (literal ...)) (define-splicing-syntax-class name - #:literal-sets ([cruft #:at name] - [local-literals #:at name]) - [pattern (~seq new-pattern ...) - withs ... ... - result-with ... - ]))))) + #:literal-sets ([cruft #:at name] + [local-literals #:at name]) + new-pattern ... + + #; + [pattern (~seq new-pattern ...) + withs ... ... + result-with ... + ]))))) (debug "Output is ~a\n" (pretty-syntax output)) output)]))) @@ -432,21 +436,23 @@ (lambda (code) (syntax-parse code #:literal-sets (cruft) [(_ name (#%parens literal ...) - (#%braces pattern ...) - (~optional (#%braces out ...)) + (~seq (#%braces original-pattern ...) + (~optional (~seq honu-comma maybe-out) + #:defaults ([maybe-out #'#f]))) + ... . rest) - (values (with-syntax ([out* (attribute out)]) - (phase1:racket-syntax - (splicing-let-syntax - ([make (lambda (stx) - (syntax-parse stx - [(_ new-name) - (syntax-local-introduce - (generate-pattern name - (literal ...) - (pattern ...) - out*))]))]) - (make name)))) + (values + (phase1:racket-syntax + (splicing-let-syntax + ([make (lambda (stx) + (syntax-parse stx + [(_ new-name) + (syntax-local-introduce + (generate-pattern name + (literal ...) + ((original-pattern ...) maybe-out) + ...))]))]) + (make name))) #'rest #f)]))) @@ -459,3 +465,30 @@ (define out (phase1:racket-syntax (begin-for-syntax (parse-stuff body ...)))) (values out #'rest #t)]))) + +;; not sure this is useful but it lets you write racket syntax expressions +;; from inside honu. the main issue is all the bindings available +;; are honu bindings so things like (+ 1 x) wont work. +(provide honu-racket) +(define-honu-syntax honu-racket + (lambda (code) + (define (remove-cruft stx) + (syntax-parse stx #:literal-sets (cruft) + [(#%parens inside ...) + (remove-cruft #'(inside ...))] + [(#%braces inside ...) + (remove-cruft #'(inside ...))] + [(#%brackets inside ...) + (remove-cruft #'(inside ...))] + [(head rest ...) + (with-syntax ([head* (remove-cruft #'head)] + [(rest* ...) (remove-cruft #'(rest ...))]) + #'(head* rest* ...))] + [x #'x])) + + (syntax-parse code #:literal-sets (cruft) + [(_ (#%parens stx ...) . rest) + (define out + (with-syntax ([(stx* ...) (remove-cruft #'(stx ...))]) + (phase1:racket-syntax (phase0:racket-syntax (stx* ...))))) + (values out #'rest #t)]))) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index 68480fb544..57762927c5 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -316,7 +316,10 @@ (do-parse #'(parsed ... rest ...) precedence left current) ;; (debug "Remove repeats from ~a\n" #'parsed) - (define re-parse (remove-repeats #'parsed) + (define re-parse + #'parsed + #; + (remove-repeats #'parsed) #; (with-syntax ([(x ...) #'parsed]) (debug "Properties on parsed ~a\n" (syntax-property-symbol-keys #'parsed)) diff --git a/collects/honu/core/private/syntax.rkt b/collects/honu/core/private/syntax.rkt index aa617c2923..a296f73464 100644 --- a/collects/honu/core/private/syntax.rkt +++ b/collects/honu/core/private/syntax.rkt @@ -1,8 +1,9 @@ -#lang racket +#lang racket/base (provide (all-defined-out)) -(require (for-syntax syntax/define +(require (for-syntax racket/base + syntax/define "transformer.rkt")) #| @@ -22,3 +23,47 @@ [rhs rhs]) (syntax/loc stx (define-syntax id (make-honu-transformer rhs)))))) + +;; Do any honu-specific expansion here +(require (for-syntax + "template.rkt" ;; for compress-dollars at phase 1 + "compile.rkt" + "literals.rkt" + syntax/stx + syntax/parse) + "template.rkt") ;; for remove-repeats at phase 0 +(define-honu-syntax honu-syntax + (lambda (code) + (syntax-parse code #:literal-sets (cruft) + #; + [(_ (#%parens single) . rest) + (define context #'single) + (define compressed (compress-dollars #'single)) + (values + (with-syntax ([stuff* (datum->syntax context compressed context context)]) + (phase1:racket-syntax #'stuff*)) + #'rest + #f)] + [(_ (#%parens stuff ...) . rest) + (define context (stx-car #'(stuff ...))) + (define compressed (compress-dollars #'(stuff ...))) + (values + (with-syntax ([stuff* (datum->syntax context + (syntax->list compressed) + context context)]) + ;; (debug "Stuff is ~a\n" (syntax->datum #'stuff*)) + ;; (debug "Stuff syntaxed is ~a\n" (syntax->datum #'#'stuff*)) + + ;; stuff* will be expanded when this syntax is returned because + ;; the whole thing will be + ;; (remove-repeats #'((repeat$ 1) (repeat$ 2))) + ;; so remove-repeats will be executed later + (racket-syntax + (remove-repeats #'stuff*)) + + #; + (with-syntax ([(out ...) #'stuff*]) + (phase1:racket-syntax #'stuff*))) + #; #'(%racket-expression (parse-stuff stuff ...)) + #'rest + #f)]))) diff --git a/collects/honu/syntax.rkt b/collects/honu/syntax.rkt new file mode 100644 index 0000000000..d73638cda8 --- /dev/null +++ b/collects/honu/syntax.rkt @@ -0,0 +1,10 @@ +#lang honu + +/* Standard syntax-rules but as a macro-defining form */ + +provide macro_rules; +macro macro_rules(){ + name:identifier (literal ...){ pattern ... }{ template ... } +} { + syntax(macro name (literal ...){ pattern ... }{ syntax(template ...) }) +} diff --git a/collects/htdp/convert.rkt b/collects/htdp/convert.rkt index 1d3515a463..660f884866 100644 --- a/collects/htdp/convert.rkt +++ b/collects/htdp/convert.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang racket/base (require racket/gui) diff --git a/collects/htdp/dir.rkt b/collects/htdp/dir.rkt index 155cfa23d4..9f248c1151 100644 --- a/collects/htdp/dir.rkt +++ b/collects/htdp/dir.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang racket/base (provide ;; map the directory tree at the given path into a data representation according to model 3 of diff --git a/collects/htdp/hangman.rkt b/collects/htdp/hangman.rkt index ed5501c46b..c12d5684c9 100644 --- a/collects/htdp/hangman.rkt +++ b/collects/htdp/hangman.rkt @@ -104,7 +104,7 @@ xylaphon yellow zombie)) - WORDS)) + WORDS)) ;; ------------------------------------------------------------------------ ;; The GUI @@ -122,11 +122,11 @@ ------------------------------------------------ | | - | a ... z "Check" "Status" word | + | a ... z "Check" "Status" word | | choice% button% message% message% | - | | + | | | Welcome/Winner/Loser | - | message% | + | message% | ------------------------------------------------ |# diff --git a/collects/htdp/matrix.txt b/collects/htdp/matrix.txt index 1306be5607..b891322958 100644 --- a/collects/htdp/matrix.txt +++ b/collects/htdp/matrix.txt @@ -3,33 +3,33 @@ rectangle: a list of lists of equal length -files: - mrlib/matrix-snip.ss : the image snips for matrix +files: + mrlib/matrix-snip.ss : the image snips for matrix - works with matrices that implement matrix<%> - i.e., support a ->rectangle method + works with matrices that implement matrix<%> + i.e., support a ->rectangle method - it writes out a matrix as a rectangle and - reconstructs it as a rectangle + it writes out a matrix as a rectangle and + reconstructs it as a rectangle - the function visible-matrix may therefore yield a - rectangle or a matrix representation proper + the function visible-matrix may therefore yield a + rectangle or a matrix representation proper - drscheme/private/eval.ss : requires matrix-snip to share at module level + drscheme/private/eval.ss : requires matrix-snip to share at module level htdp/matrix.ss : uses snips to present matrices, requires matrix-snip htdp/matrix-invisible.ss : make matrices invisible - * they are created from two mutually recursive units: - * matrix-unit and a 'rendering' unit + * they are created from two mutually recursive units: + * matrix-unit and a 'rendering' unit - htdp/matrix-sig.ss : the functions that matrix-unit.ss provides - and that matrix-render.ss needs + htdp/matrix-sig.ss : the functions that matrix-unit.ss provides + and that matrix-render.ss needs - htdp/matrix-render-sig.ss: the functions that matrix-unit expects from the - rendering unit + htdp/matrix-render-sig.ss: the functions that matrix-unit expects from the + rendering unit - htdp/matrix-unit.ss : the matrix functionality + htdp/matrix-unit.ss : the matrix functionality - htdp/tests/matrix-test.ss: a textual test - htdp/tests/matrix-client.ss a test with embedded images + htdp/tests/matrix-test.ss: a textual test + htdp/tests/matrix-client.ss a test with embedded images diff --git a/collects/htdp/world.rkt b/collects/htdp/world.rkt index 8c8235bb4c..1333f9eeec 100644 --- a/collects/htdp/world.rkt +++ b/collects/htdp/world.rkt @@ -108,7 +108,7 @@ Matthew ;; world manipulation functions: ;; ============================= (provide ;; forall(World): - big-bang ;; Number Number Number World [Boolean] -> true + big-bang ;; Number Number Number World [Boolean] -> true ) (provide-higher-order-primitive @@ -849,7 +849,7 @@ Matthew (define y (- (send e get-y) INSET)) (define m (mouse-event->symbol e)) (when (and (<= 0 x WIDTH) (<= 0 y HEIGHT)) - (with-handlers ([exn:break? break-handler][exn? exn-handler]) + (with-handlers ([exn:break? break-handler][exn? exn-handler]) (let ([new-world (f the-world x y m)]) (unless (equal? new-world the-world) (set! the-world new-world) diff --git a/collects/images/icons/style.rkt b/collects/images/icons/style.rkt index 302558df58..2133e6fa3d 100644 --- a/collects/images/icons/style.rkt +++ b/collects/images/icons/style.rkt @@ -1,10 +1,10 @@ -#lang racket +#lang racket/base -(require racket/draw unstable/parameter-group +(require racket/class racket/draw unstable/parameter-group racket/contract unstable/latent-contract unstable/latent-contract/defthing "../private/flomap.rkt" "../private/deep-flomap.rkt" - (for-syntax syntax/parse)) + (for-syntax racket/base syntax/parse)) (provide light-metal-icon-color metal-icon-color diff --git a/collects/images/scribblings/icons.scrbl b/collects/images/scribblings/icons.scrbl index b5f3f02808..b402a1ad3c 100644 --- a/collects/images/scribblings/icons.scrbl +++ b/collects/images/scribblings/icons.scrbl @@ -475,3 +475,6 @@ Icons for the Debugger. The @racket[small-debugger-icon] is used when the toolba @doc-apply[small-macro-stepper-hash-color]{ Constants used within @racketmodname[images/icons/tool]. } + + +@close-eval[icons-eval] diff --git a/collects/images/scribblings/logos.scrbl b/collects/images/scribblings/logos.scrbl index 1b3633b063..32b9df2379 100644 --- a/collects/images/scribblings/logos.scrbl +++ b/collects/images/scribblings/logos.scrbl @@ -38,3 +38,6 @@ Returns the algebraic stepper logo. Returns the macro stepper logo. @examples[#:eval logos-eval (macro-stepper-logo)] } + + +@close-eval[logos-eval] diff --git a/collects/lang/htdp-beginner-abbr.rkt b/collects/lang/htdp-beginner-abbr.rkt index a6bb01796a..bb494b704b 100644 --- a/collects/lang/htdp-beginner-abbr.rkt +++ b/collects/lang/htdp-beginner-abbr.rkt @@ -46,11 +46,11 @@ #%top-interaction empty - ; signature : -> mixed one-of predicate combined - ; Number Real Rational Integer Natural Boolean True False String Symbol Char Empty-list Any - ; cons-of - ; Property - ; check-property for-all ==> expect expect-within expect-member-of expect-range + ; signature : -> mixed one-of predicate combined + ; Number Real Rational Integer Natural Boolean True False String Symbol Char Empty-list Any + ; cons-of + ; Property + ; check-property for-all ==> expect expect-within expect-member-of expect-range ) ;; procedures: diff --git a/collects/lang/htdp-beginner.rkt b/collects/lang/htdp-beginner.rkt index 38d36f063a..071b18d647 100644 --- a/collects/lang/htdp-beginner.rkt +++ b/collects/lang/htdp-beginner.rkt @@ -51,11 +51,11 @@ #%top-interaction empty - ; signature : -> mixed one-of predicate combined - ; Number Real Rational Integer Natural Boolean True False String Symbol Char Empty-list Any - ; cons-of - ; Property - ; check-property for-all ==> expect expect-within expect-member-of expect-range + ; signature : -> mixed one-of predicate combined + ; Number Real Rational Integer Natural Boolean True False String Symbol Char Empty-list Any + ; cons-of + ; Property + ; check-property for-all ==> expect expect-within expect-member-of expect-range ) ;; procedures: diff --git a/collects/lang/htdp-intermediate-lambda.rkt b/collects/lang/htdp-intermediate-lambda.rkt index 26963134e4..55298bca69 100644 --- a/collects/lang/htdp-intermediate-lambda.rkt +++ b/collects/lang/htdp-intermediate-lambda.rkt @@ -51,11 +51,11 @@ #%top-interaction empty - ; signature : -> mixed one-of predicate combined - ; Number Real Rational Integer Natural Boolean True False String Symbol Char Empty-list Any - ; cons-of - ; Property - ; check-property for-all ==> expect expect-within expect-member-of expect-range + ; signature : -> mixed one-of predicate combined + ; Number Real Rational Integer Natural Boolean True False String Symbol Char Empty-list Any + ; cons-of + ; Property + ; check-property for-all ==> expect expect-within expect-member-of expect-range ) ;; procedures: diff --git a/collects/lang/htdp-intermediate.rkt b/collects/lang/htdp-intermediate.rkt index 11edaae542..b488cbfb39 100644 --- a/collects/lang/htdp-intermediate.rkt +++ b/collects/lang/htdp-intermediate.rkt @@ -52,11 +52,11 @@ #%top-interaction empty - ; signature : -> mixed one-of predicate combined - ; Number Real Rational Integer Natural Boolean True False String Symbol Char Empty-list Any - ; cons-of - ; Property - ; check-property for-all ==> expect expect-within expect-member-of expect-range + ; signature : -> mixed one-of predicate combined + ; Number Real Rational Integer Natural Boolean True False String Symbol Char Empty-list Any + ; cons-of + ; Property + ; check-property for-all ==> expect expect-within expect-member-of expect-range ) diff --git a/collects/lang/private/advanced-funs.rkt b/collects/lang/private/advanced-funs.rkt index 656483110d..dbf562e07c 100644 --- a/collects/lang/private/advanced-funs.rkt +++ b/collects/lang/private/advanced-funs.rkt @@ -69,43 +69,43 @@ } @defproc[(with-input-from-string [s string] [p (-> any)]) any]{ Turns @racket[s] into input for @racket[read] operations in @racket[p]. - @interaction[#:eval (asl) - (with-input-from-string "hello" read) - (string-length (symbol->string (with-input-from-string "hello" read)))] + @interaction[#:eval (asl) + (with-input-from-string "hello" read) + (string-length (symbol->string (with-input-from-string "hello" read)))] } @defproc[(with-output-to-string [p (-> any)]) any]{ Produces a string from all write/display/print operations in @racket[p]. @interaction[#:eval (asl) - (with-output-to-string (lambda () (display 10)))] + (with-output-to-string (lambda () (display 10)))] } @defproc[(print [x any]) void]{ Prints the argument as a value. @interaction[#:eval (asl) - (print 10) - (print "hello") - (print 'hello)] + (print 10) + (print "hello") + (print 'hello)] } @defproc[(display [x any]) void]{ Prints the argument to stdout (without quotes on symbols and strings, etc.). @interaction[#:eval (asl) - (display 10) - (display "hello") - (display 'hello)] + (display 10) + (display "hello") + (display 'hello)] } @defproc[(write [x any]) void]{ Prints the argument to stdout (in a traditional style that is somewhere between @racket[print] and @racket[display]). @interaction[#:eval (asl) - (write 10) - (write "hello") - (write 'hello)] + (write 10) + (write "hello") + (write 'hello)] } @defproc[((pp pretty-print) [x any]) void]{ Pretty prints S-expressions (like @racket[write]). @interaction[#:eval (asl) - (pretty-print '((1 2 3) ((a) ("hello world" true) (((false "good bye")))))) - (pretty-print (build-list 10 (lambda (i) (build-list 10 (lambda (j) (= i j)))))) - ] + (pretty-print '((1 2 3) ((a) ("hello world" true) (((false "good bye")))))) + (pretty-print (build-list 10 (lambda (i) (build-list 10 (lambda (j) (= i j)))))) + ] } @defproc[(printf [f string] [x any] ...) void]{ @@ -189,7 +189,7 @@ @defproc[(build-vector [n nat] [f (nat -> X)]) (vectorof X)]{ Constructs a vector by applying @racket[f] to the numbers @racket[0] through @racket[(- n 1)]. @interaction[#:eval (asl) (build-vector 5 add1)] - } + } @defproc[(vector-ref [v (vector X)] [n nat]) X]{ Extracts the @racket[n]th element from @racket[v]. @interaction[#:eval (asl) v (vector-ref v 3)] @@ -197,7 +197,7 @@ @defproc[(vector-length [v (vector X)]) nat]{ Determines the length of @racket[v]. @interaction[#:eval (asl) v (vector-length v)] - } + } @defproc[(vector-set! [v (vectorof X)][n nat][x X]) void]{ Updates @racket[v] at position @racket[n] to be @racket[x]. @interaction[#:eval (asl) v (vector-set! v 3 77) v] @@ -238,49 +238,49 @@ Constructs a mutable hash table from an optional list of mappings that uses equal? for comparisions. @interaction[#:eval (asl) - (make-hash) - (make-hash '((b 69) (e 61) (i 999))) - ] + (make-hash) + (make-hash '((b 69) (e 61) (i 999))) + ] } @defproc[((advanced-make-hasheq make-hasheq)) (hash X Y)]{ Constructs a mutable hash table from an optional list of mappings that uses eq? for comparisions. @interaction[#:eval (asl) - (make-hasheq) - (make-hasheq '((b 69) (e 61) (i 999))) - ] + (make-hasheq) + (make-hasheq '((b 69) (e 61) (i 999))) + ] } @defproc[((advanced-make-hasheqv make-hasheqv)) (hash X Y)]{ Constructs a mutable hash table from an optional list of mappings that uses eqv? for comparisions. @interaction[#:eval (asl) - (make-hasheqv) - (make-hasheqv '((b 69) (e 61) (i 999))) - ] + (make-hasheqv) + (make-hasheqv '((b 69) (e 61) (i 999))) + ] } @defproc[((advanced-make-immutable-hash make-immutable-hash)) (hash X Y)]{ Constructs an immutable hash table from an optional list of mappings that uses equal? for comparisions. @interaction[#:eval (asl) - (make-immutable-hash) - (make-immutable-hash '((b 69) (e 61) (i 999))) - ] + (make-immutable-hash) + (make-immutable-hash '((b 69) (e 61) (i 999))) + ] } @defproc[((advanced-make-immutable-hasheq make-immutable-hasheq)) (hash X Y)]{ Constructs an immutable hash table from an optional list of mappings that uses eq? for comparisions. @interaction[#:eval (asl) - (make-immutable-hasheq) - (make-immutable-hasheq '((b 69) (e 61) (i 999))) - ] + (make-immutable-hasheq) + (make-immutable-hasheq '((b 69) (e 61) (i 999))) + ] } @defproc[((advanced-make-immutable-hasheqv make-immutable-hasheqv)) (hash X Y)]{ Constructs an immutable hash table from an optional list of mappings that uses eqv? for comparisions. @interaction[#:eval (asl) - (make-immutable-hasheqv) - (make-immutable-hasheqv '((b 69) (e 61) (i 999))) - ] + (make-immutable-hasheqv) + (make-immutable-hasheqv '((b 69) (e 61) (i 999))) + ] } @defproc[(hash-set! [h (hash X Y)] [k X] [v Y]) void?]{ Updates a mutable hash table with a new mapping. @@ -318,44 +318,44 @@ @defproc[(hash-has-key? [h (hash X Y)] [x X]) boolean]{ Determines if a key is associated with a value in a hash table. @interaction[#:eval (asl) - ish - (hash-has-key? ish 'b) - hsh - (hash-has-key? hsh 'd)] + ish + (hash-has-key? ish 'b) + hsh + (hash-has-key? hsh 'd)] } @defproc[(hash-remove! [h (hash X Y)] [x X]) void]{ Removes an mapping from a mutable hash table. @interaction[#:eval (asl) - hsh - (hash-remove! hsh 'r) - hsh] + hsh + (hash-remove! hsh 'r) + hsh] } @defproc[(hash-remove [h (hash X Y)] [k X]) (hash X Y)]{ Constructs an immutable hash table with one less mapping than an existing immutable hash table. @interaction[#:eval (asl) - ish - (hash-remove ish 'b)] + ish + (hash-remove ish 'b)] } @defproc[(hash-map [h (hash X Y)] [f (X Y -> Z)]) (listof Z)]{ Constructs a new list by applying a function to each mapping of a hash table. @interaction[#:eval (asl) - ish - (hash-map ish list)] + ish + (hash-map ish list)] } @defproc[(hash-for-each [h (hash X Y)] [f (X Y -> any)]) void?]{ Applies a function to each mapping of a hash table for effect only. @interaction[#:eval (asl) - hsh - (hash-for-each hsh (lambda (ky vl) (hash-set! hsh ky (+ vl 1)))) - hsh] + hsh + (hash-for-each hsh (lambda (ky vl) (hash-set! hsh ky (+ vl 1)))) + hsh] } @defproc[(hash-count [h hash]) integer]{ Determines the number of keys mapped by a hash table. @interaction[#:eval (asl) - ish - (hash-count ish)] + ish + (hash-count ish)] } @defproc[(hash-copy [h hash]) hash]{ Copies a hash table. @@ -363,36 +363,36 @@ @defproc[(hash? [x any]) boolean]{ Determines if a value is a hash table. @interaction[#:eval (asl) - ish - (hash? ish) - (hash? 42)] + ish + (hash? ish) + (hash? 42)] } @defproc[(hash-equal? [h hash?]) boolean]{ Determines if a hash table uses equal? for comparisons. @interaction[#:eval (asl) - ish - (hash-equal? ish) - ieq - (hash-equal? ieq) - ] + ish + (hash-equal? ish) + ieq + (hash-equal? ieq) + ] } @defproc[(hash-eq? [h hash]) boolean]{ Determines if a hash table uses eq? for comparisons. @interaction[#:eval (asl) - hsh - (hash-eq? hsh) - heq - (hash-eq? heq) - ] + hsh + (hash-eq? hsh) + heq + (hash-eq? heq) + ] } @defproc[(hash-eqv? [h hash]) boolean]{ Determines if a hash table uses eqv? for comparisons. @interaction[#:eval (asl) - heq - (hash-eqv? heq) - heqv - (hash-eqv? heqv) - ] + heq + (hash-eqv? heq) + heqv + (hash-eqv? heqv) + ] })) #| diff --git a/collects/lang/private/continuation-mark-key.rkt b/collects/lang/private/continuation-mark-key.rkt index 4646862d79..ff3ec8a942 100644 --- a/collects/lang/private/continuation-mark-key.rkt +++ b/collects/lang/private/continuation-mark-key.rkt @@ -5,5 +5,5 @@ ; The test code also needs access to this. ;; cm-key : symbol -;; the key used to put information on the continuation +;; the key used to put information on the continuation (define teaching-languages-continuation-mark-key (gensym 'teaching-languages-continuation-mark-key)) diff --git a/collects/lang/private/intermediate-funs.rkt b/collects/lang/private/intermediate-funs.rkt index adbacf6d86..7a7f3e06a4 100644 --- a/collects/lang/private/intermediate-funs.rkt +++ b/collects/lang/private/intermediate-funs.rkt @@ -173,7 +173,7 @@ (apply max a-list) ] } - @defproc[(compose [f (X -> Y)] [g (Y -> Z)]) (X -> Z)]{ + @defproc[(compose [f (Y -> Z)] [g (X -> Y)]) (X -> Z)]{ Composes a sequence of procedures into a single procedure: @codeblock{(compose f g) = (lambda (x) (f (g x)))} @interaction[#:eval (isl) diff --git a/collects/lang/private/sl-eval.rkt b/collects/lang/private/sl-eval.rkt index 106a37d158..84f7509797 100644 --- a/collects/lang/private/sl-eval.rkt +++ b/collects/lang/private/sl-eval.rkt @@ -1,6 +1,7 @@ -#lang racket +#lang racket/base (require teachpack/2htdp/scribblings/img-eval + racket/pretty racket/sandbox mzlib/pconvert file/convertible diff --git a/collects/lang/private/teach.rkt b/collects/lang/private/teach.rkt index 0d51932a11..f434efff45 100644 --- a/collects/lang/private/teach.rkt +++ b/collects/lang/private/teach.rkt @@ -948,7 +948,7 @@ raw-predicate sigs #'name_))) - (let ((arbs (map signature-arbitrary sigs))) + (let ((arbs (map signature-arbitrary sigs))) (when (andmap values arbs) (set-signature-arbitrary! sig @@ -1914,7 +1914,7 @@ (let ([bindings (syntax->list (syntax (binding ...)))]) (for-each (lambda (binding) (syntax-case binding () - [(something . exprs) + [(something . exprs) (not (identifier/non-kw? (syntax something))) (teach-syntax-error who @@ -2445,7 +2445,7 @@ who stx #'q - "expected a question and an answer, but found only one part")] + "expected a question and an answer, but found only one part")] [(_ q a) (with-syntax ([who who] [target target-stx]) diff --git a/collects/lazy/lazy-tool.rkt b/collects/lazy/lazy-tool.rkt index e65c260853..8dadeb65c0 100644 --- a/collects/lazy/lazy-tool.rkt +++ b/collects/lazy/lazy-tool.rkt @@ -1,17 +1,18 @@ -#lang racket +#lang racket/base -(require string-constants +(require racket/unit + racket/class + string-constants drracket/tool lang/stepper-language-interface) (provide tool@) (define tool@ - (unit + (unit (import drracket:tool^) (export drracket:tool-exports^) - (define (stepper-settings-language %) (if (implementation? % stepper-language<%>) (class* % (stepper-language<%>) @@ -50,13 +51,12 @@ ; (equal? (drracket:language:simple-settings->vector s) ; (drracket:language:simple-settings->vector (default-settings)))) (super-new))) - - + (define (phase1) (void)) - + ;; phase2 : -> void (define (phase2) - + (define lazy-language% (stepper-settings-language ((drracket:language:get-default-mixin) @@ -64,7 +64,7 @@ (module-based-language-extension (drracket:language:simple-module-based-language->module-based-language-mixin drracket:language:simple-module-based-language%)))))) - + (drracket:language-configuration:add-language (instantiate lazy-language% () (one-line-summary "Lazy Racket") diff --git a/collects/macro-debugger/macro-debugger.scrbl b/collects/macro-debugger/macro-debugger.scrbl index e0a24f4377..03a9827764 100644 --- a/collects/macro-debugger/macro-debugger.scrbl +++ b/collects/macro-debugger/macro-debugger.scrbl @@ -567,3 +567,6 @@ module path and the module paths of its immediate dependents. (get-dependencies 'openssl #:exclude (list 'racket)) ] } + + +@close-eval[the-eval] diff --git a/collects/macro-debugger/model/reductions.rkt b/collects/macro-debugger/model/reductions.rkt index fdc88b0c97..3b1c43d8fe 100644 --- a/collects/macro-debugger/model/reductions.rkt +++ b/collects/macro-debugger/model/reductions.rkt @@ -222,12 +222,7 @@ [#:learn (list #'?var)])] [(Wrap p:provide (e1 e2 rs ?1 inners ?2)) - (let ([wrapped-inners - (for/list ([inner (in-list inners)]) - (match inner - [(Wrap deriv (e1 e2)) - (make local-expansion e1 e2 - #f e1 inner #f e2 #f)]))]) + (let ([wrapped-inners (map expr->local-action inners)]) (R [! ?1] [#:pattern ?form] [#:pass1] @@ -668,7 +663,9 @@ [#:do (DEBUG (printf "** module begin pass 2\n"))] [ModulePass ?forms pass2] ;; ignore pass3 for now: only provides - )])) + [#:new-local-context + [#:pattern ?form] + [LocalActions ?form (map expr->local-action (or pass3 null))]])])) ;; ModulePass : (list-of MBRule) -> RST (define (ModulePass mbrules) @@ -724,12 +721,14 @@ [#:set-syntax (append stxs old-forms)] [ModulePass ?forms rest]])] [(cons (Wrap mod:lift-end (stxs)) rest) - (R [#:pattern ?forms] - [#:when (pair? stxs) - [#:left-foot null] - [#:set-syntax (append stxs #'?forms)] - [#:step 'splice-module-lifts stxs]] - [ModulePass ?forms rest])] + ;; In pass2, stxs contains a mixture of terms and kind-tagged terms (pairs) + (let ([stxs (map (lambda (e) (if (pair? e) (car e) e)) stxs)]) + (R [#:pattern ?forms] + [#:when (pair? stxs) + [#:left-foot null] + [#:set-syntax (append stxs #'?forms)] + [#:step 'splice-module-lifts stxs]] + [ModulePass ?forms rest]))] [(cons (Wrap mod:skip ()) rest) (R [#:pattern (?firstS . ?rest)] [ModulePass ?rest rest])] @@ -796,6 +795,12 @@ (when #f (apply error sym args))) +(define (expr->local-action d) + (match d + [(Wrap deriv (e1 e2)) + (make local-expansion e1 e2 + #f e1 d #f e2 #f)])) + ;; opaque-table ;; Weakly remembers assoc between opaque values and ;; actual syntax, so that actual can be substituted in diff --git a/collects/macro-debugger/tool.rkt b/collects/macro-debugger/tool.rkt index 5c48147b03..f5716694d1 100644 --- a/collects/macro-debugger/tool.rkt +++ b/collects/macro-debugger/tool.rkt @@ -269,8 +269,12 @@ (set! user-custodian (current-custodian))) (define (uncaught-exception-raised) ;; =user= - ;; formerly shut down user custodian - (void)) + (set! normal-termination? #t) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () + (cleanup) + (custodian-shutdown-all user-custodian))))) (define (show-error-report/tab) ;; =drs= (send the-tab turn-on-error-report) (send (send the-tab get-error-report-text) scroll-to-position 0) @@ -294,7 +298,6 @@ (parameterize ([current-eventspace drs-eventspace]) (queue-callback (λ () - (send the-tab syncheck:clear-highlighting) (cleanup) (custodian-shutdown-all user-custodian)))))) diff --git a/collects/meta/drdr/job-queue.rkt b/collects/meta/drdr/job-queue.rkt new file mode 100644 index 0000000000..c48dbbd568 --- /dev/null +++ b/collects/meta/drdr/job-queue.rkt @@ -0,0 +1,100 @@ +#lang racket/base +(require racket/list + racket/match + racket/local + racket/contract + racket/async-channel) + +(define current-worker (make-parameter #f)) + +(define-struct job-queue (async-channel)) +(define-struct job (paramz thunk)) +(define-struct done ()) + +(define (make-queue how-many) + (define jobs-ch (make-async-channel)) + (define work-ch (make-async-channel)) + (define done-ch (make-async-channel)) + (define (working-manager spaces accept-new? jobs continues) + (if (and (not accept-new?) + (empty? jobs) + (empty? continues)) + (killing-manager how-many) + (apply + sync + (if (and accept-new? + (not (zero? spaces))) + (handle-evt + jobs-ch + (match-lambda + [(? job? the-job) + (working-manager (sub1 spaces) accept-new? (list* the-job jobs) continues)] + [(? done?) + (working-manager spaces #f jobs continues)])) + never-evt) + (handle-evt + done-ch + (lambda (reply-ch) + (working-manager spaces accept-new? jobs (list* reply-ch continues)))) + (if (empty? jobs) + never-evt + (handle-evt + (async-channel-put-evt work-ch (first jobs)) + (lambda (_) + (working-manager spaces accept-new? (rest jobs) continues)))) + (map + (lambda (reply-ch) + (handle-evt + (async-channel-put-evt reply-ch 'continue) + (lambda (_) + (working-manager (add1 spaces) accept-new? jobs (remq reply-ch continues))))) + continues)))) + (define (killing-manager left) + (unless (zero? left) + (sync + (handle-evt + done-ch + (lambda (reply-ch) + (async-channel-put reply-ch 'stop) + (killing-manager (sub1 left))))))) + (define (worker i) + (match (async-channel-get work-ch) + [(struct job (paramz thunk)) + (call-with-parameterization + paramz + (lambda () + (parameterize ([current-worker i]) + (thunk)))) + (local [(define reply-ch (make-async-channel))] + (async-channel-put done-ch reply-ch) + (local [(define reply-v (async-channel-get reply-ch))] + (case reply-v + [(continue) (worker i)] + [(stop) (void)] + [else + (error 'worker "Unknown reply command")])))])) + (define the-workers + (for/list ([i (in-range 0 how-many)]) + (thread (lambda () + (worker i))))) + (define the-manager + (thread (lambda () (working-manager how-many #t empty empty)))) + (make-job-queue jobs-ch)) + +(define (submit-job! jobq thunk) + (async-channel-put + (job-queue-async-channel jobq) + (make-job (current-parameterization) + thunk))) + +(define (stop-job-queue! jobq) + (async-channel-put + (job-queue-async-channel jobq) + (make-done))) + +(provide/contract + [current-worker (parameter/c (or/c false/c exact-nonnegative-integer?))] + [job-queue? (any/c . -> . boolean?)] + [rename make-queue make-job-queue (exact-nonnegative-integer? . -> . job-queue?)] + [submit-job! (job-queue? (-> any) . -> . void)] + [stop-job-queue! (job-queue? . -> . void)]) diff --git a/collects/meta/drdr/plt-build.rkt b/collects/meta/drdr/plt-build.rkt index d1d3d10feb..4e2c6be73d 100644 --- a/collects/meta/drdr/plt-build.rkt +++ b/collects/meta/drdr/plt-build.rkt @@ -1,7 +1,7 @@ #lang racket (require racket/file racket/runtime-path - (planet jaymccarthy/job-queue) + "job-queue.rkt" "metadata.rkt" "run-collect.rkt" "cache.rkt" @@ -165,8 +165,8 @@ thunk (λ () ;; Close the output ports - #;(close-input-port stdout) - #;(close-input-port stderr) + ;;(close-input-port stdout) + ;;(close-input-port stderr) ;; Kill the guard (kill-thread waiter) @@ -200,8 +200,7 @@ (path->string (build-path trunk-dir "bin" "gracket"))) (define collects-pth (build-path trunk-dir "collects")) - ;; XXX Use a single GUI thread so that other non-GUI apps can run in parallel - (define gui-lock (make-semaphore 1)) + (define gui-workers (make-job-queue 1)) (define test-workers (make-job-queue (number-of-cpus))) (define (test-directory dir-pth upper-sema) (define dir-log (build-path (trunk->log dir-pth) ".index.test")) @@ -224,6 +223,7 @@ (define directory? (directory-exists? pth)) (cond [directory? + ;; XXX do this in parallel? (test-directory pth dir-sema)] [else (define log-pth (trunk->log pth)) @@ -236,40 +236,46 @@ (current-subprocess-timeout-seconds))) (define pth-cmd/general (path-command-line pth)) - (define pth-cmd + (define-values + (pth-cmd the-queue) (match pth-cmd/general [#f - #f] + (values #f #f)] [(list-rest (or 'mzscheme 'racket) rst) - (lambda (k) - (k (list* racket-path rst)))] + (values + (lambda (k) + (k (list* racket-path rst))) + test-workers)] [(list-rest 'mzc rst) - (lambda (k) (k (list* mzc-path rst)))] + (values + (lambda (k) (k (list* mzc-path rst))) + test-workers)] [(list-rest 'raco rst) - (lambda (k) (k (list* raco-path rst)))] + (values + (lambda (k) (k (list* raco-path rst))) + test-workers)] [(list-rest (or 'mred 'mred-text 'gracket 'gracket-text) rst) - (if (on-unix?) - (lambda (k) - (call-with-semaphore - gui-lock - (λ () - (k - (list* gracket-path - "-display" - (format - ":~a" - (cpu->child - (current-worker))) - rst))))) - #f)] + (values + (if (on-unix?) + (lambda (k) + (k + (list* gracket-path + "-display" + (format + ":~a" + (cpu->child + (current-worker))) + rst))) + #f) + gui-workers)] [_ - #f])) + (values #f #f)])) (cond [pth-cmd (submit-job! - test-workers + the-queue (lambda () (dynamic-wind void @@ -331,7 +337,8 @@ (notify! "All testing scheduled... waiting for completion") (semaphore-wait top-sema)) (notify! "Stopping testing") - (stop-job-queue! test-workers)) + (stop-job-queue! test-workers) + (stop-job-queue! gui-workers)) (define (recur-many i r f) (if (zero? i) @@ -409,10 +416,6 @@ (list "-d" (format ":~a" i) "--sm-disable" "--no-composite") - #;empty - #;(list "-display" - (format ":~a" i) - "-rc" "/home/pltdrdr/.fluxbox/init") inner))))) (start-x-server diff --git a/collects/meta/drdr/xorg.conf b/collects/meta/drdr/xorg.conf new file mode 100644 index 0000000000..001b35cc98 --- /dev/null +++ b/collects/meta/drdr/xorg.conf @@ -0,0 +1,89 @@ +Section "ServerFlags" + option "AllowMouseOpenFail" +EndSection + +Section "ServerLayout" + Identifier "X.org Configured" + Screen 0 "Screen0" 0 0 + InputDevice "Mouse0" "CorePointer" + InputDevice "Keyboard0" "CoreKeyboard" +EndSection + +Section "Files" + ModulePath "/usr/lib/xorg/modules" + FontPath "/usr/share/fonts/X11/misc" + FontPath "/usr/share/fonts/X11/cyrillic" + FontPath "/usr/share/fonts/X11/100dpi/:unscaled" + FontPath "/usr/share/fonts/X11/75dpi/:unscaled" + FontPath "/usr/share/fonts/X11/Type1" + FontPath "/usr/share/fonts/X11/100dpi" + FontPath "/usr/share/fonts/X11/75dpi" + FontPath "/var/lib/defoma/x-ttcidfont-conf.d/dirs/TrueType" + FontPath "built-ins" +EndSection + +Section "Module" + Load "dbe" + Load "dri" + Load "glx" + Load "record" + Load "extmod" + Load "dri2" +EndSection + +Section "InputDevice" + Identifier "Keyboard0" + Driver "void" +EndSection + +Section "InputDevice" + Identifier "Mouse0" + Driver "void" +EndSection + +Section "Monitor" + Identifier "Monitor0" + VendorName "AVO" + ModelName "Smart Cable" + HorizSync 24.0 - 61.0 + VertRefresh 56.0 - 75.0 +EndSection + +Section "Device" + Identifier "Card0" + Driver "mga" + VendorName "Matrox Graphics, Inc." + BoardName "MGA G200e [Pilot] ServerEngines (SEP1)" + BusID "PCI:30:0:0" +EndSection + +Section "Screen" + Identifier "Screen0" + Device "Card0" + Monitor "Monitor0" + SubSection "Display" + Viewport 0 0 + Depth 1 + EndSubSection + SubSection "Display" + Viewport 0 0 + Depth 4 + EndSubSection + SubSection "Display" + Viewport 0 0 + Depth 8 + EndSubSection + SubSection "Display" + Viewport 0 0 + Depth 15 + EndSubSection + SubSection "Display" + Viewport 0 0 + Depth 16 + EndSubSection + SubSection "Display" + Viewport 0 0 + Depth 24 + EndSubSection +EndSection + diff --git a/collects/meta/planet2-index/basic/main.rkt b/collects/meta/planet2-index/basic/main.rkt new file mode 100644 index 0000000000..f864ae269d --- /dev/null +++ b/collects/meta/planet2-index/basic/main.rkt @@ -0,0 +1,44 @@ +#lang racket/base +(require racket/list + racket/contract + web-server/http + web-server/dispatch) + +(define (response/sexpr v) + (response 200 #"Okay" (current-seconds) + #"text/s-expr" empty + (λ (op) (write v op)))) + +(define (planet2-index/basic get-pkgs pkg-name->info) + (define (write-info req pkg-name) + (response/sexpr (pkg-name->info pkg-name))) + (define (display-info req pkg-name) + (define info (pkg-name->info pkg-name)) + (response/xexpr + `(html + (body + (h1 ,pkg-name) + (p (a ([href ,(hash-ref info 'source)]) ,(hash-ref info 'source))) + (p ,(hash-ref info 'checksum)))))) + (define (list-pkgs req) + (response/xexpr + `(html + (body + (table + (tr (th "Package")) + ,@(for/list ([n (in-list (sort (get-pkgs) string<=?))]) + `(tr + (td (a ([href ,(get-url display-info n)]) ,n))))))))) + (define-values (dispatch get-url) + (dispatch-rules + [() list-pkgs] + [("") list-pkgs] + [("pkg" (string-arg) "display") display-info] + [("pkg" (string-arg)) write-info])) + dispatch) + +(provide/contract + [planet2-index/basic + (-> (-> (listof string?)) + (-> string? (hash/c symbol? any/c)) + (-> request? response?))]) diff --git a/collects/meta/planet2-index/official/.gitignore b/collects/meta/planet2-index/official/.gitignore new file mode 100644 index 0000000000..cd3d01855c --- /dev/null +++ b/collects/meta/planet2-index/official/.gitignore @@ -0,0 +1 @@ +/root diff --git a/collects/meta/planet2-index/official/gravatar.rkt b/collects/meta/planet2-index/official/gravatar.rkt new file mode 100644 index 0000000000..067243cfb7 --- /dev/null +++ b/collects/meta/planet2-index/official/gravatar.rkt @@ -0,0 +1,52 @@ +#lang racket/base +(require racket/string + racket/contract + xml + xml/path + racket/port + net/url + file/md5 + planet2/util) + +(define (gravatar-hash email) + (bytes->string/utf-8 + (md5 + (string-downcase + (string-trim email))))) + +(module+ test + (require rackunit) + (check-equal? (gravatar-hash "MyEmailAddress@example.com ") + "0bc83cb571cd1c50ba6f3e8a78ef1346") + (check-equal? (gravatar-hash "MyEmailAddress@example.com ") + (gravatar-hash " MyEmailAddress@example.com "))) + +(define (gravatar-image-url email) + (format "https://secure.gravatar.com/avatar/~a.jpg?d=retro" + (gravatar-hash email))) + +(define (gravatar-profile email) + (parameterize ([collapse-whitespace #t] + [xexpr-drop-empty-attributes #t]) + (call/input-url+200 + (string->url + (format "http://www.gravatar.com/~a.xml" + (gravatar-hash email))) + (compose string->xexpr port->string)))) + +(define (gravatar-display-name email) + (define profile (gravatar-profile email)) + (and profile + (se-path* '(response entry displayName) + profile))) + +(module+ test + (check-equal? (gravatar-display-name "jay.mccarthy@gmail.com") + "Jay McCarthy") + (check-equal? (gravatar-display-name "jay@racket-lang.org") + #f)) + +(provide/contract + [gravatar-display-name (-> string? (or/c string? false/c))] + [gravatar-profile (-> string? xexpr?)] + [gravatar-image-url (-> string? string?)]) diff --git a/collects/meta/planet2-index/official/main.rkt b/collects/meta/planet2-index/official/main.rkt new file mode 100644 index 0000000000..daea39eff8 --- /dev/null +++ b/collects/meta/planet2-index/official/main.rkt @@ -0,0 +1,652 @@ +#lang racket/base +(require web-server/http + web-server/servlet-env + racket/file + racket/function + racket/runtime-path + web-server/dispatch + planet2/util + racket/match + racket/package + racket/system + racket/date + racket/string + web-server/servlet + web-server/formlets + racket/bool + racket/list + net/sendmail + meta/planet2-index/basic/main + web-server/http/id-cookie + file/sha1) + +(define-syntax-rule (while cond e ...) + (let loop () + (when cond + e ... + (loop)))) + +(define (snoc l x) + (append l (list x))) + +(define (salty str) + (sha1 (open-input-string str))) + +(define-runtime-path src ".") + +(define-runtime-path root "root") +(make-directory* root) +(define secret-key + (make-secret-salt/file + (build-path root "secret.key"))) +(define users-path (build-path root "users")) +(make-directory* users-path) + +(module+ main + (define users-old-path (build-path root "users.old")) + (when (directory-exists? users-old-path) + (for ([u (in-list (directory-list users-old-path))]) + (define uop (build-path users-old-path u)) + (display-to-file (salty (file->string uop)) + (build-path users-path u)) + (delete-file uop)) + (delete-directory users-old-path))) + +(define pkgs-path (build-path root "pkgs")) +(make-directory* pkgs-path) + +(define id-cookie-name "id") + +;; XXX Add a caching system +(define (package-list) + (sort (map path->string (directory-list pkgs-path)) + string-ci<=?)) +(define (package-exists? pkg-name) + (file-exists? (build-path pkgs-path pkg-name))) +(define (package-remove! pkg-name) + (delete-file (build-path pkgs-path pkg-name))) +(define (package-info pkg-name) + (file->value (build-path pkgs-path pkg-name))) +(define (package-info-set! pkg-name i) + (write-to-file i (build-path pkgs-path pkg-name) + #:exists 'replace)) + +(define (package-ref pkg-info key) + (hash-ref pkg-info key + (λ () + (match key + [(or 'author 'checksum 'source) + (error 'planet2 "Package ~e is missing a required field: ~e" + (hash-ref pkg-info 'name) key)] + ['tags + empty] + [(or 'last-checked 'last-edit 'last-updated) + -inf.0])))) + +(define-values (main-dispatch main-url) + (dispatch-rules + [() page/main] + [("") page/main] + [("info" (string-arg)) page/info] + [("search" (string-arg) ...) page/search] + [("query" "search" (string-arg) ...) page/search/query] + [("account" "login") page/login] + [("account" "logout") page/logout] + [("manage") page/manage] + [("manage" "update") page/manage/update] + [("manage" "edit" (string-arg)) page/manage/edit] + [("manage" "upload") page/manage/upload] + [else basic-start])) + +(define (page/main req) + (redirect-to (main-url page/search empty))) + +(define (format-time s) + (if s + (parameterize ([date-display-format 'rfc2822]) + (date->string (seconds->date s #f) #t)) + "")) + +(define (package-url->useful-url pkg-url-str) + (define pkg-url + (string->url pkg-url-str)) + (match (url-scheme pkg-url) + ["github" + (match-define (list* user repo branch path) + (url-path pkg-url)) + (url->string + (struct-copy url pkg-url + [scheme "http"] + [path (list* user repo (path/param "tree" empty) branch path)]))] + [_ + pkg-url-str])) + +(define (page/info req pkg-name) + (page/info-like + (list (cons "Packages" (main-url page/main)) + pkg-name) + #f + (λ (embed/url t) + (main-url page/search (list t))) + req pkg-name)) + +(define (search-term-eval pkg-name info term) + (match term + [(regexp #rx"^author:(.*?)$" (list _ author)) + (equal? author (package-ref info 'author))] + [_ + (define term-rx (regexp-quote term)) + (for/or ([tag (list* pkg-name (package-ref info 'tags))]) + (regexp-match? term-rx tag))])) + +(define breadcrumb->string + (match-lambda + [(? string? label) + label] + [(cons (? string? label) + (? string? url)) + label])) +(define breadcrumb->xexpr + (match-lambda + [(? string? label) + `(span ,label)] + [(cons (? string? label) + (? string? url)) + `(span (a ([href ,url]) ,label))])) + +(define (template req #:breadcrumb bc . xexpr-forest) + (send/back + (response/xexpr + `(html + (head + (script ([src "/sorttable.js"]) " ") + (link ([rel "stylesheet"] + [type "text/css"] + [href "/style.css"])) + (title ,@(add-between (map breadcrumb->string bc) " > "))) + (body + (div ([class "breadcrumb"]) + ,@(add-between (map breadcrumb->xexpr bc) " > ") + ,(cond + [(current-user req #f) + => (λ (user) + `(span ([id "logout"]) + ,user + " | " + (a ([href ,(main-url page/logout)]) "logout")))] + [else + ""])) + ,@xexpr-forest + (div ([id "footer"]) + "Powered by " + (a ([href "http://racket-lang.org/"]) "Racket") ". " + "Written by " + (a ([href "http://faculty.cs.byu.edu/~jay"]) "Jay McCarthy") + ".")))))) + +(define (page/logout req) + (redirect-to + (main-url page/main) + #:headers + (list (cookie->header (logout-id-cookie id-cookie-name))))) + +(define (package-list/search ts) + (filter + (λ (p) + (define i (package-info p)) + (for/and ([t (in-list ts)]) + (search-term-eval p i t))) + (package-list))) + +(define search-formlet + (formlet + ,{(to-string (required (text-input))) + . => . new-terms} + (string-split new-terms))) + +(define (page/search/query req old-terms) + (define terms (formlet-process search-formlet req)) + (redirect-to (main-url page/search (append old-terms terms)))) + +(define (page/search req terms) + (define pkgs (package-list/search terms)) + (template + req + #:breadcrumb + (list* (cons "Packages" (main-url page/main)) + "Search" + (for/list ([t (in-list terms)]) + (cons t (main-url page/search (remove* (list t) terms))))) + `(div ([id "menu"]) + (form ([action ,(main-url page/search/query terms)]) + (span ([class "menu_option"]) + ,@(formlet-display search-formlet) + (input ([type "submit"] [value "Search"]))) + (span ([class "menu_option"]) + (a ([href ,(main-url page/manage)]) + ,(if (current-user req #f) + "Manage Your Packages" + "Contribute a Package"))))) + (package-table page/info pkgs #:terms terms))) + +(define (page/login req) + (login req) + (redirect-to (main-url page/main))) + +(define (login req [last-error #f]) + (define login-formlet + (formlet + (table + (tr (td "Email Address:") + (td ,{(to-string (required (text-input))) . => . email})) + (tr (td "Password:") + (td ,{(to-string (required (password-input))) . => . passwd}))) + (values email passwd))) + (define log-req + (send/suspend + (λ (k-url) + (template + req + #:breadcrumb + (list "Login") + `(div ([id "login"]) + (form ([action ,k-url] [method "post"]) + ,@(formlet-display login-formlet) + (input ([type "submit"] [value "Log in"]))) + (p "If you enter an unclaimed email address, then an account will be created.") + (p "Passwords are stored in the delicious SHA1 format, but transfered as plain-text over the HTTPS connection.") + ,@(if last-error + `((h1 ([class "error"]) ,last-error)) + '())))))) + (define-values + (email passwd) + (formlet-process login-formlet log-req)) + + (define (authenticated!) + (redirect/get + #:headers + (list + (cookie->header + (make-id-cookie id-cookie-name secret-key email))))) + + (when (regexp-match (regexp-quote "/") email) + (send/back + (template + log-req + #:breadcrumb + (list "Login" "Account Registration Error") + `(p "Email addresses may not contain / on Planet2:" + (tt ,email))))) + + (define password-path (build-path users-path email)) + + (cond + [(not (file-exists? password-path)) + (send/suspend + (λ (k-url) + (send-mail-message + "planet2@racket-lang.org" + "Account confirmation for Planet2" + (list email) + empty empty + (list "Someone tried to register your email address for an account on Planet2. If you want to authorize this registration and log in, please click the following link:" + "" + (format "https://plt-etc.byu.edu:9004~a" k-url) + "" + "This link will expire, so if it is not available, you'll have to try to register again.")) + (template + log-req + #:breadcrumb + (list "Login" "Account Registration") + `(p "An email has been sent to " + (tt ,email) + ", please click the link it contains to register and log in.")))) + (display-to-file (salty passwd) password-path) + (authenticated!)] + [(not (bytes=? (string->bytes/utf-8 (salty passwd)) + (file->bytes password-path))) + (login req (format "The given password is incorrect for email address ~e" + email))] + [else + (authenticated!)])) + +(define (current-user req required?) + (define id + (request-id-cookie id-cookie-name secret-key req)) + (cond + [id + id] + [required? + (current-user (login req) required?)] + [else + #f])) + +(define (package-list/mine req) + (define u (current-user req #t)) + (package-list/search (list (format "author:~a" u)))) + +(define (package-table page/package pkgs + #:terms [terms empty]) + `(table + ([class "packages sortable"]) + (thead + (tr (th "Package") (th "Author") (th "Description") (th "Tags"))) + (tbody + ,@(for/list ([p (in-list pkgs)]) + (define i (package-info p)) + (define author (package-ref i 'author)) + `(tr + ([class ,(if (< (- (current-seconds) (* 2 24 60 60)) + (package-ref i 'last-updated)) + "recent" + "")]) + (td (a ([href ,(main-url page/package p)]) + ,p)) + (td (a ([href ,(main-url page/search + (snoc terms + (format "author:~a" author)))]) + ,author)) + (td ,(package-ref i 'description)) + (td ,@(for/list ([t (in-list (package-ref i 'tags))]) + `(span (a ([href ,(main-url page/search (snoc terms t))]) + ,t) + " ")))))))) + +(define (page/manage req) + (define pkgs (package-list/mine req)) + (template + req + #:breadcrumb + (list (cons "Packages" (main-url page/main)) + (current-user req #t) + "Manage") + `(div ([id "menu"]) + (span ([class "menu_option"]) + (a ([href ,(main-url page/manage/upload)]) + "Upload a new package")) + (span ([class "menu_option"]) + (a ([href ,(main-url page/manage/update)]) + "Update checksums"))) + (package-table page/manage/edit pkgs))) + +(define (page/manage/upload req) + (page/manage/edit req #f)) + +(define (request-binding/string req id [fail? #t]) + (define res + (bindings-assq (string->bytes/utf-8 id) + (request-bindings/raw req))) + (cond + [res + (bytes->string/utf-8 + (binding:form-value + res))] + [fail? + (error 'planet2 "Missing field ~e" id)] + [else + #f])) + +(define (page/manage/edit req pkg) + (define (edit-details pkg-req) + (define new-pkg (request-binding/string pkg-req "name")) + (when (string=? new-pkg "") + (error 'planet2 "Name must not be empty: ~e" new-pkg)) + (define new-source (request-binding/string pkg-req "source")) + (when (string=? new-source "") + (error 'planet2 "Source must not be empty: ~e" new-source)) + (define new-desc (request-binding/string pkg-req "description")) + + (when (regexp-match #rx"[^a-zA-Z0-9_\\-]" new-pkg) + (error 'planet2 + "Illegal character in name; only alphanumerics, plus '-' and '_' allowed: ~e" + new-pkg)) + + (when (and (not (equal? pkg new-pkg)) + (or (regexp-match #rx"^[Pp][Ll][Tt]" new-pkg) + (regexp-match #rx"^[Pp][Ll][Aa][Nn][Ee][Tt]" new-pkg) + (regexp-match #rx"^[Rr][Aa][Cc][Kk][Ee][Tt]" new-pkg))) + (error 'planet2 + "Packages that start with plt, planet, and racket are not allowed without special permission. Please create your package with a different name, then email curation to request a rename: ~e" + new-pkg)) + + (when (and (package-exists? new-pkg) + (not (equal? (package-ref (package-info new-pkg) 'author) + (current-user pkg-req #t)))) + (error 'planet2 + "Packages may only be modified by their authors: ~e" + new-pkg)) + + (package-begin + (define* i + (if pkg + (package-info pkg) + (hasheq))) + + (define* i + (hash-set i 'name new-pkg)) + (define* i + (hash-set i 'source new-source)) + (define* i + (hash-set i 'author (current-user pkg-req #t))) + (define* i + (hash-set i 'description new-desc)) + (define* i + (hash-set i 'last-edit (current-seconds))) + (define* i + (if pkg + i + (hash-set i 'checksum ""))) + + (package-info-set! new-pkg i)) + + (unless (or (not pkg) (equal? new-pkg pkg)) + (package-remove! pkg)) + + (update-checksum new-pkg) + + (define new-tag + (request-binding/string pkg-req "tag" #f)) + (add-tag! new-pkg new-tag) + + (redirect-to + (main-url page/manage/edit new-pkg))) + + (page/info-like + (list* (cons "Packages" (main-url page/main)) + (current-user req #t) + (cons "Manage" (main-url page/manage)) + (if pkg + (list pkg + "Edit") + (list "Upload"))) + edit-details + (λ (embed/url t) + (embed/url (remove-tag-handler pkg t))) + req pkg)) + + +(define (tags-normalize ts) + (remove-duplicates (sort ts string-ciuseful-url (package-ref i 'source))]) + ,(package-ref i 'source))))) + (tr + (td "Checksum") + (td ,(package-ref* i 'checksum ""))) + (tr + (td "Last Update") + (td ,(format-time (package-ref* i 'last-updated #f)))) + (tr + (td "Last Checked") + (td ,(format-time (package-ref* i 'last-checked #f)))) + (tr + (td "Description") + (td ,(if edit-details + `(textarea ([name "description"]) + ,(package-ref* i 'description "")) + (package-ref i 'description)))) + (tr + (td "Last Edit") + (td ,(format-time (package-ref* i 'last-edit #f)))) + (tr + (td "Tags") + (td + (ul + ,@(for/list ([t (in-list (package-ref* i 'tags empty))]) + `(li (a ([href ,(tag-url embed/url t)]) + ,t))) + ,(if pkg-name + `(li (input ([name "tag"] [type "text"]))) + "")))) + `(tr (td ([class "submit"] [colspan "2"]) + (input ([type "submit"] [value "Submit"])))))) + (template + req + #:breadcrumb + bc + `(div + ([class "package"]) + (form ([action ,(embed/url form-handler)] [method "post"]) + ,the-table)))))) + +(define (page/manage/update req) + (update-checksums + (package-list/mine req)) + (redirect-to (main-url page/manage))) + +(define (update-checksums pkgs) + (for-each update-checksum pkgs)) + +(define (update-checksum pkg-name) + (define i (package-info pkg-name)) + (define old-checksum + (package-ref i 'checksum)) + (define now (current-seconds)) + (define new-checksum + (package-url->checksum (package-ref i 'source))) + (package-begin + (define* i + (hash-set i 'checksum + (or new-checksum + old-checksum))) + (define* i + (hash-set i 'last-checked now)) + (define* i + (if (and new-checksum (equal? new-checksum old-checksum)) + i + (hash-set i 'last-updated now))) + (package-info-set! pkg-name i))) + +(define basic-start + (planet2-index/basic package-list package-info)) + +(define (go port) + (printf "launching on port ~a\n" port) + (thread + (λ () + (while true + (printf "updating checksums\n") + (update-checksums (package-list)) + ;; update once per day based on whenever the server started + (sleep (* 24 60 60))))) + (serve/servlet + main-dispatch + #:command-line? #t + #:listen-ip #f + #:ssl? #t + #:ssl-cert (build-path root "server-cert.pem") + #:ssl-key (build-path root "private-key.pem") + #:extra-files-paths + (list (build-path src "static") + (build-path root "static")) + #:servlet-regexp #rx"" + #:port port)) + +(module+ main + (go 9004)) diff --git a/collects/meta/planet2-index/official/static/sorttable.js b/collects/meta/planet2-index/official/static/sorttable.js new file mode 100644 index 0000000000..4f74f1e2ea --- /dev/null +++ b/collects/meta/planet2-index/official/static/sorttable.js @@ -0,0 +1,515 @@ +function TocviewToggle(glyphid, id) { + var glyph = document.getElementById(glyphid); + var s = document.getElementById(id).style; + var expand = s.display == "none"; + s.display = expand ? "block" : "none"; + glyph.innerHTML = expand ? "▼" : "►"; +} + +function ToggleOn(id) { + var s = document.getElementById(id).style; + var li = document.getElementById("li" + id); + s.display = "block"; + li.setAttribute("class", "tab-selected"); +} +function ToggleOff(id) { + var s = document.getElementById(id).style; + var li = document.getElementById("li" + id); + s.display = "none"; + li.setAttribute("class", ""); +} + +/* + SortTable + version 2 + 7th April 2007 + Stuart Langridge, http://www.kryogenix.org/code/browser/sorttable/ + + Instructions: + Download this file + Add to your HTML + Add class="sortable" to any table you'd like to make sortable + Click on the headers to sort + + Thanks to many, many people for contributions and suggestions. + Licenced as X11: http://www.kryogenix.org/code/browser/licence.html + This basically means: do what you want with it. +*/ + + +var stIsIE = /*@cc_on!@*/false; + +sorttable = { + init: function() { + // quit if this function has already been called + if (arguments.callee.done) return; + // flag this function so we don't do the same thing twice + arguments.callee.done = true; + // kill the timer + if (_timer) clearInterval(_timer); + + if (!document.createElement || !document.getElementsByTagName) return; + + sorttable.DATE_RE = /^(\d\d?)[\/\.-](\d\d?)[\/\.-]((\d\d)?\d\d)$/; + + forEach(document.getElementsByTagName('table'), function(table) { + if (table.className.search(/\bsortable\b/) != -1) { + sorttable.makeSortable(table); + } + }); + + }, + + makeSortable: function(table) { + if (table.getElementsByTagName('thead').length == 0) { + // table doesn't have a tHead. Since it should have, create one and + // put the first table row in it. + the = document.createElement('thead'); + the.appendChild(table.rows[0]); + table.insertBefore(the,table.firstChild); + } + // Safari doesn't support table.tHead, sigh + if (table.tHead == null) table.tHead = table.getElementsByTagName('thead')[0]; + + if (table.tHead.rows.length != 1) return; // can't cope with two header rows + + // Sorttable v1 put rows with a class of "sortbottom" at the bottom (as + // "total" rows, for example). This is B&R, since what you're supposed + // to do is put them in a tfoot. So, if there are sortbottom rows, + // for backwards compatibility, move them to tfoot (creating it if needed). + sortbottomrows = []; + for (var i=0; i5' : ' ▴'; + this.appendChild(sortrevind); + return; + } + if (this.className.search(/\bsorttable_sorted_reverse\b/) != -1) { + // if we're already sorted by this column in reverse, just + // re-reverse the table, which is quicker + sorttable.reverse(this.sorttable_tbody); + this.className = this.className.replace('sorttable_sorted_reverse', + 'sorttable_sorted'); + this.removeChild(document.getElementById('sorttable_sortrevind')); + sortfwdind = document.createElement('span'); + sortfwdind.id = "sorttable_sortfwdind"; + sortfwdind.innerHTML = stIsIE ? ' 6' : ' ▾'; + this.appendChild(sortfwdind); + return; + } + + // remove sorttable_sorted classes + theadrow = this.parentNode; + forEach(theadrow.childNodes, function(cell) { + if (cell.nodeType == 1) { // an element + cell.className = cell.className.replace('sorttable_sorted_reverse',''); + cell.className = cell.className.replace('sorttable_sorted',''); + } + }); + sortfwdind = document.getElementById('sorttable_sortfwdind'); + if (sortfwdind) { sortfwdind.parentNode.removeChild(sortfwdind); } + sortrevind = document.getElementById('sorttable_sortrevind'); + if (sortrevind) { sortrevind.parentNode.removeChild(sortrevind); } + + this.className += ' sorttable_sorted'; + sortfwdind = document.createElement('span'); + sortfwdind.id = "sorttable_sortfwdind"; + sortfwdind.innerHTML = stIsIE ? ' 6' : ' ▾'; + this.appendChild(sortfwdind); + + // build an array to sort. This is a Schwartzian transform thing, + // i.e., we "decorate" each row with the actual sort key, + // sort based on the sort keys, and then put the rows back in order + // which is a lot faster because you only do getInnerText once per row + row_array = []; + col = this.sorttable_columnindex; + rows = this.sorttable_tbody.rows; + for (var j=0; j 12) { + // definitely dd/mm + return sorttable.sort_ddmm; + } else if (second > 12) { + return sorttable.sort_mmdd; + } else { + // looks like a date, but we can't tell which, so assume + // that it's dd/mm (English imperialism!) and keep looking + sortfn = sorttable.sort_ddmm; + } + } + } + } + return sortfn; + }, + + getInnerText: function(node) { + // gets the text we want to use for sorting for a cell. + // strips leading and trailing whitespace. + // this is *not* a generic getInnerText function; it's special to sorttable. + // for example, you can override the cell text with a customkey attribute. + // it also gets .value for fields. + + hasInputs = (typeof node.getElementsByTagName == 'function') && + node.getElementsByTagName('input').length; + + if (node.getAttribute("sorttable_customkey") != null) { + return node.getAttribute("sorttable_customkey"); + } + else if (typeof node.textContent != 'undefined' && !hasInputs) { + return node.textContent.replace(/^\s+|\s+$/g, ''); + } + else if (typeof node.innerText != 'undefined' && !hasInputs) { + return node.innerText.replace(/^\s+|\s+$/g, ''); + } + else if (typeof node.text != 'undefined' && !hasInputs) { + return node.text.replace(/^\s+|\s+$/g, ''); + } + else { + switch (node.nodeType) { + case 3: + if (node.nodeName.toLowerCase() == 'input') { + return node.value.replace(/^\s+|\s+$/g, ''); + } + case 4: + return node.nodeValue.replace(/^\s+|\s+$/g, ''); + break; + case 1: + case 11: + var innerText = ''; + for (var i = 0; i < node.childNodes.length; i++) { + innerText += sorttable.getInnerText(node.childNodes[i]); + } + return innerText.replace(/^\s+|\s+$/g, ''); + break; + default: + return ''; + } + } + }, + + reverse: function(tbody) { + // reverse the rows in a tbody + newrows = []; + for (var i=0; i=0; i--) { + tbody.appendChild(newrows[i]); + } + delete newrows; + }, + + /* sort functions + each sort function takes two parameters, a and b + you are comparing a[0] and b[0] */ + sort_numeric: function(a,b) { + aa = parseFloat(a[0].replace(/[^0-9.-]/g,'')); + if (isNaN(aa)) aa = 0; + bb = parseFloat(b[0].replace(/[^0-9.-]/g,'')); + if (isNaN(bb)) bb = 0; + return aa-bb; + }, + sort_alpha: function(a,b) { + if (a[0]==b[0]) return 0; + if (a[0] 0 ) { + var q = list[i]; list[i] = list[i+1]; list[i+1] = q; + swap = true; + } + } // for + t--; + + if (!swap) break; + + for(var i = t; i > b; --i) { + if ( comp_func(list[i], list[i-1]) < 0 ) { + var q = list[i]; list[i] = list[i-1]; list[i-1] = q; + swap = true; + } + } // for + b++; + + } // while(swap) + } +} + +/* ****************************************************************** + Supporting functions: bundled here to avoid depending on a library + ****************************************************************** */ + +// Dean Edwards/Matthias Miller/John Resig + +/* for Mozilla/Opera9 */ +if (document.addEventListener) { + document.addEventListener("DOMContentLoaded", sorttable.init, false); +} + +/* for Internet Explorer */ +/*@cc_on @*/ +/*@if (@_win32) + document.write("