diff --git a/.github/CONTRIBUTING.md b/.github/CONTRIBUTING.md new file mode 100644 index 000000000..dcf5e5e3f --- /dev/null +++ b/.github/CONTRIBUTING.md @@ -0,0 +1 @@ +Please see [the guidelines on racket/racket, the main repo](https://github.com/racket/racket/blob/master/.github/CONTRIBUTING.md) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 000000000..e5d004bce --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,37 @@ +name: Build and Test + +on: [push, pull_request] + +jobs: + build-test: + name: Build & Test (Racket ${{ matrix.variant }}) + runs-on: ubuntu-22.04 + container: racket/racket-ci:latest + + strategy: + fail-fast: false + matrix: + variant: ['CS'] + + steps: + - uses: actions/checkout@v4 + - uses: Bogdanp/setup-racket@v1.11 + with: + architecture: 'x64' + distribution: 'minimal' + variant: ${{ matrix.variant }} + version: 'current' + snapshot_site: 'utah' + - name: Install and setup + run: | + raco pkg install --auto compiler-lib + racket -l- pkg/dirs-catalog --link --check-metadata pkgs-catalog . + echo file://`pwd`/pkgs-catalog/ > catalog-config.txt + raco pkg config catalogs >> catalog-config.txt + raco pkg config --set catalogs `cat catalog-config.txt` + raco pkg install -i --auto --no-setup gui-lib/ gui-doc/ gui/ tex-table/ gui-test/ + raco setup --pkgs gui gui-lib gui-test tex-table + - name: Run tests + run: | + xvfb-run -a racket -l tests/gracket/wxme + xvfb-run -a raco test -e -l tests/gracket/test diff --git a/.github/workflows/resyntax-analyze.yml b/.github/workflows/resyntax-analyze.yml new file mode 100644 index 000000000..c90200411 --- /dev/null +++ b/.github/workflows/resyntax-analyze.yml @@ -0,0 +1,51 @@ +name: Resyntax Analysis + +# The Resyntax integration is split into two phases: a workflow that analyzes the code and uploads +# the analysis as an artifact, and a workflow that downloads the analysis artifact and creates a +# review of the pull request. This split is for permissions reasons; the analysis workflow checks out +# the pull request branch and compiles it, executing arbitrary code as it does so. For that reason, +# the first workflow has read-only permissions in the github repository. The second workflow only +# downloads the pull request review artifact and submits it, and it executes with read-write permissions +# without executing any code in the repository. This division of responsibilities allows Resyntax to +# safely analyze pull requests from forks. This strategy is outlined in the following article: +# https://securitylab.github.com/research/github-actions-preventing-pwn-requests/ + +on: + pull_request: + types: + - opened + - reopened + - synchronize + - ready_for_review + +jobs: + analyze: + runs-on: ubuntu-latest + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + + steps: + - name: Checkout code + uses: actions/checkout@v3.3.0 + # See https://github.com/actions/checkout/issues/118. + with: + fetch-depth: 0 + - name: Install Racket + uses: Bogdanp/setup-racket@v1.9.1 + with: + version: current + distribution: minimal + local_catalogs: $GITHUB_WORKSPACE + dest: '"${HOME}/racketdist-current-CS"' + sudo: never + - name: Install local packages + run: raco pkg install --auto gui gui-lib gui-doc tex-table gui-test + - name: Install Resyntax + run: raco pkg install --auto resyntax + - name: Analyze changed files + run: xvfb-run racket -l- resyntax/cli analyze --local-git-repository . "origin/${GITHUB_BASE_REF}" --output-as-github-review --output-to-file ./resyntax-review.json + - name: Upload analysis artifact + uses: actions/upload-artifact@v3.1.2 + with: + name: resyntax-review + path: resyntax-review.json diff --git a/.github/workflows/resyntax-autofixer.yml b/.github/workflows/resyntax-autofixer.yml new file mode 100644 index 000000000..1af175a54 --- /dev/null +++ b/.github/workflows/resyntax-autofixer.yml @@ -0,0 +1,33 @@ +name: Resyntax Autofixer + +on: + workflow_dispatch: + schedule: + - cron: "0 0 * * 2" + +jobs: + autofix: + runs-on: ubuntu-latest + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + permissions: + pull-requests: write + contents: write + steps: + - name: Checkout code + uses: actions/checkout@v3.6.0 + - uses: Bogdanp/setup-racket@v1.11 + with: + version: current + local_catalogs: $GITHUB_WORKSPACE + dest: '"${HOME}/racketdist-current-CS"' + sudo: never + - name: Install and setup + run: | + raco pkg install -i --auto --no-setup --skip-installed gui-test + raco pkg update --auto --no-setup gui-doc gui-lib gui tex-table + raco setup gui-doc gui-lib gui-test gui tex-table + - name: Create a Resyntax pull request + uses: jackfirth/create-resyntax-pull-request@v0.5.1 + with: + private-key: ${{ secrets.RESYNTAX_APP_PRIVATE_KEY }} diff --git a/.github/workflows/resyntax-submit-review.yml b/.github/workflows/resyntax-submit-review.yml new file mode 100644 index 000000000..5cb99944b --- /dev/null +++ b/.github/workflows/resyntax-submit-review.yml @@ -0,0 +1,56 @@ +name: Resyntax Review Submission + +# The Resyntax integration is split into two workflows. See ./resyntax-analyze.yml for details about +# why it works this way. + +on: + workflow_run: + workflows: ["Resyntax Analysis"] + types: + - completed + +jobs: + review: + runs-on: ubuntu-latest + if: > + ${{ github.event.workflow_run.event == 'pull_request' && + github.event.workflow_run.conclusion == 'success' }} + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + permissions: + pull-requests: write + + steps: + - name: Checkout code + uses: actions/checkout@v3.3.0 + - name: Download Resyntax analysis + # This uses a github script instead of the download-artifact action because + # that action doesn't work for artifacts uploaded by other workflows. See + # https://github.com/actions/download-artifact/issues/130 for more info. + uses: actions/github-script@v6.4.0 + with: + script: | + var artifacts = await github.rest.actions.listWorkflowRunArtifacts({ + owner: context.repo.owner, + repo: context.repo.repo, + run_id: ${{github.event.workflow_run.id}}, + }); + var matchArtifact = artifacts.data.artifacts.filter((artifact) => { + return artifact.name == "resyntax-review" + })[0]; + var download = await github.rest.actions.downloadArtifact({ + owner: context.repo.owner, + repo: context.repo.repo, + artifact_id: matchArtifact.id, + archive_format: 'zip', + }); + var fs = require('fs'); + fs.writeFileSync('${{github.workspace}}/resyntax-review.zip', Buffer.from(download.data)); + - run: unzip resyntax-review.zip + - name: Create pull request review + uses: actions/github-script@v6.4.0 + with: + github-token: ${{ secrets.GITHUB_TOKEN }} + script: | + var create_review_request = require('./resyntax-review.json'); + await github.rest.pulls.createReview(create_review_request); diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index f1574c43a..000000000 --- a/.travis.yml +++ /dev/null @@ -1,30 +0,0 @@ -sudo: false - -language: c - -env: -- PATH=~/racket/bin:$PATH - -services: -- xvfb - -before_install: -#- curl -L -o installer.sh http://plt.eecs.northwestern.edu/snapshots/current/installers/racket-test-current-x86_64-linux-precise.sh -- curl -L -o installer.sh http://www.cs.utah.edu/plt/snapshots/current/installers/racket-current-x86_64-linux-precise.sh -- sh installer.sh --in-place --dest ~/racket/ - -install: -- raco pkg install --auto -i --no-setup --skip-installed gui-test -- racket -l- pkg/dirs-catalog --link --check-metadata pkgs-catalog . -- echo file://`pwd`/pkgs-catalog/ > catalog-config.txt -- raco pkg config catalogs >> catalog-config.txt -- raco pkg config --set catalogs `cat catalog-config.txt` -- raco pkg update -i --auto --no-setup gui-lib/ gui-doc/ gui/ tex-table/ gui-test/ -- raco setup --pkgs gui gui-lib gui-test tex-table -- ls $HOME/.racket/download-cache - -script: -- racket -l tests/gracket/wxme -- raco test -e -l tests/gracket/test - -after_script: diff --git a/README.md b/README.md index 26ba36fd7..286b709ca 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,9 @@ This the source for the Racket packages: "gui", "gui-doc", "gui-lib", "gui-test" Contribute to Racket by submitting a [pull request], reporting an [issue], joining the [development mailing list], or visiting the -IRC or Slack channels. +IRC or Slack channels. See our [contributing guidelines] for a +build guide and other important information you need to know to +contribute. ### License @@ -22,3 +24,4 @@ is licensed under the [Apache 2.0] license and the [MIT] license. [issue]: https://github.com/racket/gui/issues [development mailing list]: https://lists.racket-lang.org [LICENSE]: LICENSE +[contributing guidelines]: https://github.com/racket/racket/blob/master/.github/CONTRIBUTING.md diff --git a/gui-doc/info.rkt b/gui-doc/info.rkt index 586ce7cac..390d8b14b 100644 --- a/gui-doc/info.rkt +++ b/gui-doc/info.rkt @@ -7,19 +7,22 @@ "at-exp-lib" "draw-doc" "draw-lib" - "scribble-lib" - "snip-lib" + ["scribble-lib" #:version "1.42"] + ["snip-lib" #:version "1.5"] "string-constants-lib" - "syntax-color-lib" + ["syntax-color-lib" #:version "1.3"] "wxme-lib" "gui-lib" "pict-lib" "racket-doc" "string-constants-doc" - "xrepl-doc")) + "simple-tree-text-markup-doc")) (define deps '("base")) (define update-implies '("gui-lib")) (define pkg-desc "documentation part of \"gui\"") (define pkg-authors '(mflatt robby)) + +(define license + '(Apache-2.0 OR MIT)) diff --git a/gui-doc/mrlib/scribblings/interactive-value-port.scrbl b/gui-doc/mrlib/scribblings/interactive-value-port.scrbl index fb5cd8e72..e55fa3df4 100644 --- a/gui-doc/mrlib/scribblings/interactive-value-port.scrbl +++ b/gui-doc/mrlib/scribblings/interactive-value-port.scrbl @@ -1,5 +1,5 @@ #lang scribble/doc -@(require "common.rkt" (for-label mrlib/interactive-value-port scheme/pretty)) +@(require "common.rkt" (for-label mrlib/interactive-value-port racket/pretty)) @title{Interactive Value Port} diff --git a/gui-doc/mrlib/scribblings/name-message.scrbl b/gui-doc/mrlib/scribblings/name-message.scrbl index f68c5de49..296ecca4f 100644 --- a/gui-doc/mrlib/scribblings/name-message.scrbl +++ b/gui-doc/mrlib/scribblings/name-message.scrbl @@ -100,6 +100,14 @@ current label. By default, the name-message does not allow shrinking. } +@defmethod[(wob?) boolean?]{ + Determines if the name message drawn in dark mode (when it returns @racket[#true]) or + light mode (when it returns @racket[#false]). Returns @racket[(white-on-black-panel-scheme?)] + by default. + + @history[#:added "1.79"] + } + } @; ---------------------------------------------------------------------- diff --git a/gui-doc/mrlib/scribblings/panel-wob.scrbl b/gui-doc/mrlib/scribblings/panel-wob.scrbl index 81028c0cd..3da45e417 100644 --- a/gui-doc/mrlib/scribblings/panel-wob.scrbl +++ b/gui-doc/mrlib/scribblings/panel-wob.scrbl @@ -6,11 +6,14 @@ @defmodule[mrlib/panel-wob] @defproc[(white-on-black-panel-scheme?) boolean?]{ - Determines if the foreground color of the panel background - is lighter than the background color. If they appear to - be the same, @racket[white-on-black-panel-scheme?] returns - @racket[#f]. - This predicate is intended to determine if the underlying - operating system is in a ``dark'' mode. + operating system is in a dark mode. + + Under relatively recent versions of Mac OS, it queries dark + mode directly. See also @racket[application-dark-mode-handler]. + + On other platforms, it determines if the foreground color + of the panel background is lighter than the background + color. If they appear to be the same, + @racket[white-on-black-panel-scheme?] returns @racket[#f]. } diff --git a/gui-doc/mrlib/scribblings/switchable-button.scrbl b/gui-doc/mrlib/scribblings/switchable-button.scrbl index 4cdc815a5..6411d65c8 100644 --- a/gui-doc/mrlib/scribblings/switchable-button.scrbl +++ b/gui-doc/mrlib/scribblings/switchable-button.scrbl @@ -24,7 +24,8 @@ [callback (-> (is-a?/c switchable-button%) any/c)] [alternate-bitmap (is-a?/c bitmap%) bitmap] [vertical-tight? boolean? #f] - [min-width-includes-label? boolean? #f])]{ + [min-width-includes-label? boolean? #f] + [right-click-menu (or/c #f (list/c string? (-> any)))])]{ The @racket[callback] is called when the button is pressed. The @racket[label] and @racket[bitmap] are used as discussed above. @@ -39,7 +40,14 @@ If the @racket[min-width-includes-label?] is @racket[#t], then the minimum width includes both the bitmap and the label. Otherwise, it includes only the bitmap. - } + + If @racket[right-click-menu] is not @racket[#f], then right + click (or control click on some platforms) opens a context + sensitive menu under the button with one menu item whose + label is the string and whose callback is the thunk. + + @history[#:changed "1.76" @list{Added the @racket[right-click-menu] argument}] +} @defmethod[(set-label-visible [visible? boolean?]) void?]{ Sets the visibility of the string part of the label. diff --git a/gui-doc/mrlib/scribblings/syntax-browser.scrbl b/gui-doc/mrlib/scribblings/syntax-browser.scrbl index 9c40f3794..665eb99c0 100644 --- a/gui-doc/mrlib/scribblings/syntax-browser.scrbl +++ b/gui-doc/mrlib/scribblings/syntax-browser.scrbl @@ -5,14 +5,27 @@ @defmodule[mrlib/syntax-browser] -@defproc[(render-syntax/snip [stx syntax?]) (is-a?/c snip%)]{ +@defproc[(render-syntax/snip [stx syntax?] + [#:summary-width summary-width (or/c #f 0 (integer-in 3 #f) +inf.0) 32]) + (is-a?/c snip%)]{ Constructs a @racket[snip%] object that displays information about @racket[stx]. + + The @racket[summary-width] parameter controls the width (in + characters) of the syntax object that is shown before the + triangle is turned down. If it is @racket[#f], the value of + the @racket[print-syntax-width] parameter is used. + + @history[#:changed "1.59" @list{Added @racket[summary-width] argument and changed default width to 32.}] } -@defproc[(render-syntax/window [stx syntax?]) void?]{ Uses - @racket[render-syntax/snip]'s result, together with a frame +@defproc[(render-syntax/window [stx syntax?] + [#:summary-width summary-width (or/c #f 0 (integer-in 3 #f) +inf.0) 32]) + void?]{ + Uses @racket[render-syntax/snip]'s result, together with a frame and editor-canvas to show @racket[stx]. + + @history[#:changed "1.59" @list{Added @racket[summary-width] argument and changed default width to 32.}] } @defthing[snip-class (is-a?/c snip-class%)]{ diff --git a/gui-doc/scribblings/framework/color.scrbl b/gui-doc/scribblings/framework/color.scrbl index 05fc9c327..011651c71 100644 --- a/gui-doc/scribblings/framework/color.scrbl +++ b/gui-doc/scribblings/framework/color.scrbl @@ -1,16 +1,18 @@ #lang scribble/doc @(require scribble/manual scribble/extract) -@(require (for-label framework scheme/gui syntax-color/lexer-contract syntax-color/racket-lexer)) +@(require (for-label framework scheme/gui syntax-color/lexer-contract syntax-color/racket-lexer + syntax-color/color-textoid)) @title{Color} -@definterface[color:text<%> (text:basic<%>)]{ +@definterface[color:text<%> (text:basic<%> [#:no-inherit color-textoid<%>])]{ This interface describes how coloring is stopped and started for text that knows how to color itself. It also describes how to query the lexical and s-expression structure of the text. @defmethod[(start-colorer (token-sym->style (-> symbol? string?)) (get-token (or/c (-> input-port? (values any/c - symbol? + (or/c symbol? + (hash/c symbol? any/c #:immutable #t)) (or/c symbol? #f) (or/c exact-positive-integer? #f) (or/c exact-positive-integer? #f))) @@ -18,7 +20,8 @@ exact-nonnegative-integer? (not/c dont-stop?) (values any/c - symbol? + (or/c symbol? + (hash/c symbol? any/c #:immutable #t)) (or/c symbol? #f) (or/c exact-positive-integer? #f) (or/c exact-positive-integer? #f) @@ -28,76 +31,145 @@ void?]{ Starts tokenizing the buffer for coloring and parenthesis matching. - The @racket[token-sym->style] argument will be passed the first return - symbol from @racket[get-token], and it should return the style-name that - the token should be colored. - - The @racket[get-token] argument's contract above is just - the basic checks it should satisfy; it is also expected to - satisfy the @racket[lexer/c] contract, which attempts to - also check the invariants described here. - - The arguments to @racket[get-token] are an input port and - optionally an offset and mode value. When it accepts just an - input port, @racket[get-token] should return the next token - as 5 values: - - @itemize[ - @item{This value is intended to represent the textual - component of the token. If the second value returned by - @racket[get-token] is @racket['symbol] and this value is a string - then the value is used to differentiate between symbols and keywords - for the purpose of coloring and formatting, configurable from DrRacket's - preference's editing menu.} - @item{A symbol describing the type of the token. This symbol is - transformed into a style-name via the @racket[token-sym->style] argument. - The symbols @racket['white-space] and @racket['comment] have special - meaning and should always be returned for white space and comment tokens - respectively. The symbol @racket['no-color] can be used to indicate that - although the token is not white space, it should not be colored. The - symbol @racket['eof] must be used to indicate when all the tokens have - been consumed.} - @item{A symbol indicating how the token should be treated by the paren - matcher or @racket[#f]. This symbol should be in the pairs argument.} - @item{The starting position of the token (or @racket[#f] if eof); this - number is relative to the third result of @racket[port-next-location] - when applied to the input port that gets passed to @racket[get-token].} - @item{The ending position of the token (or @racket[#f] if eof); this - is also relative to the port's location, just like the previous value.}] - - When @racket[get-token] accepts an offset and mode value in addition to an - input port, it must also return two extra results. - The offset given to @racket[get-token] can be added - to the position of the input port to obtain absolute coordinates within a - text stream. The extra two results are - @itemize[@item{a backup distance; - The backup distance returned by @racket[get-token] indicates the - maximum number of characters to back up (counting from the start of the - token) and for re-parsing after a change to the editor within the token's - region.} - @item{a new mode; - The mode argument allows @racket[get-token] to communicate - information from earlier parsing to later. When @racket[get-token] is - called for the beginning on a stream, the mode argument is @racket[#f]; - thereafter, the mode returned for the previous token is provided to - @racket[get-token] for the next token. - - If the mode result is a @racket[dont-stop] struct, then the value inside - the struct is considered the new mode, and the colorer is guaranteed - not to be interrupted until at least the next call to this tokenizing - function that does not return a @racket[dont-stop] struct (unless, of course, - it returns an eof token, in which case the new mode result is ignored). - This is useful, for example, when a lexer has to read ahead in the buffer - to decide on the tokens at this point; then that read-ahead will be - inconsistent if an edit happens; returning a @racket[dont-stop] - struct ensures that no changes to the buffer happen. + The main argument is @racket[get-token]. It accepts either three + arguments or only the first of these three: + + @itemlist[ + + @item{@racket[_input-port] --- An input port to parse from. The + port is not necessarily the same for every call to + @racket[get-token].} + + @item{@racket[_offset] --- An integer that can be added to the + position of @racket[_input-port] to obtain an absolute coordinate + within a text stream.} + + @item{@racket[_mode] --- An arbitrary value that is @racket[#f] + when @racket[_input-port] represents the start of the input + stream, and otherwise is the last result of @racket[get-token] + as returned for the just-preceding token. + + The @racket[_mode] value is intended to record the state of + parsing in a way that allows it to be restarted mid-stream. The + @racket[_mode] value should not be a mutable value; if part of + the input stream is re-tokenized, the @racket[_mode] saved from + the immediately preceding token is given again to the + @racket[get-token] function.} + + ] + + The @racket[get-token] function produces either 7 results or the + first 5 of these results, depending on how many arguments + @racket[get-token] accepts: + + @itemlist[ + + @item{@racket[_token] --- A value intended to represent the + textual component of the token. This value is ignored by + @method[color:text<%> start-colorer].} + + @item{@racket[_attribs] --- Either a symbol or a hash table with + symbol keys. Except for @racket['eof], a symbol by itself + is treated the same as a hash table that maps + @racket['type] to the symbol. A @racket[get-token] that + accepts only a single argument must always produce just a + symbol for @racket[_attribs]. + + The symbol @racket['eof] (not a hash table) must be + returned as @racket[_attribs] to indicate when all the + tokens have been consumed. + + The value of @racket['color] in @racket[_attribs] is + passed to @racket[token-sym->style], which returns a style + name that that is used to ``color'' the token. If + @racket['color] is not mapped by @racket[_attribs], then + the value of @racket['type] is used, instead. In addition, + if @racket['comment?] is mapped to a true value, then the + token's color is adjusted to de-emphasize it relative to + surrounding text. + + Certain values for @racket['type] in @racket[_attribs] are + treated specially. The symbols @racket['white-space] and + @racket['comment] should always be used for whitespace and + comment tokens, respectively. The symbol + @racket['no-color] can be used to indicate that although + the token is not whitespace, it should not be colored. + + These and other keys in @racket[_attribs] can be used by + tools that call @method[color:text<%> + classify-position*].} + + @item{@racket[_paren] --- A symbol indicating how the token + should be treated by the parenthesis matcher, or + @racket[#f] if the token does not correspond to an open or + close parentheses. A @racket[_parens] symbol should be one + of the symbols in the @racket[pairs] argument. + + Parenthesis matching uses this symbol in combination with + @racket[_parens] to determine matching pairs and to enable + navigation options that take matches into account. + + For example, suppose pairs is @racket['((|(| |)|) (|[| + |]|) (begin end))]. This means that there are three kinds + of parentheses. Any token that has @racket['begin] as its + @racket[_paren] value will act as an open for matching + tokens that have @racket['end] as @racket[_paren]. + Similarly, any token with @racket['|]|] will act as a + closing match for tokens with @racket['|[|]. When trying + to correct a mismatched closing parenthesis, each closing + symbol in pairs will be converted to a string and tried as + a closing parenthesis.} + + @item{@racket[_start] --- The starting position of the token (or + @racket[#f] for an end-of-file). This number is relative + to the third result of @racket[(port-next-location + _input-port)].} + + @item{@racket[__end] --- The ending position of the token (or + @racket[#f] for an end-of-file). This is number is also + relative to the port's location, like @racket[_start].} + + @item{@racket[_backup] --- A backup distance, which indicates + the maximum number of characters to back up (counting from + the start of the token) and for re-parsing after a change + to the editor within the token's region. A + @racket[_backup] is typically @racket[0].} + + @item{@racket[_mode] (the new one) --- A value that is passed to + a later call to @racket[get-token] to continue parsing the + input program. - The mode should not be a mutable - value; if part of the stream is re-tokenized, the mode saved from the - immediately preceding token is given again to the @racket[get-token] - function.}] - - The @racket[get-token] function must obey the following invariants: + If @racket[_mode] is a @racket[dont-stop] structure, then + the value inside the structure is considered the new + @racket[_mode], and the colorer is guaranteed not to be + interrupted until at least the next call to + @racket[get-token] that does not return a + @racket[dont-stop] structure (unless, of course, it + returns an @racket['eof] value for @racket[_attribs], in + which case the new @racket[_mode] result is ignored). A + @racket[dont-stop] result is useful, for example, when a + lexer has to read ahead in @racket[_input-port] to decide + on the tokens at this point; that read-ahead will be + inconsistent if an edit happens, so a @racket[dont-stop] + structure ensures that no changes to the buffer happen + between calls. + + As mentioned above, the @racket[_mode] result should not + be a mutable value. Also, it should be comparable with + @racket[equal?] to short-circuit reparsing when + @racket[get-token] returns the same results for an input + position.} + + ] + + The @racket[token-sym->style] and @racket[parens] arguments are + used as described above with the @racket[_attribs] and + @racket[_paren] results, respectively. + + The @racket[get-token] argument's contract above reflects just + the basic constraints it should satisfy. It is also expected to + satisfy the @racket[lexer*/c] contract, which attempts to + check the following additional invariants: @itemize[ @item{Every position in the buffer must be accounted for in exactly one token, and every token must have a non-zero width. Accordingly, @@ -125,17 +197,6 @@ would result in a single string token modifying previous tokens. To handle these situations, @racket[get-token] can treat the first line as a single token, or it can precisely track backup distances.}] - - The @racket[pairs] argument is a list of different kinds of matching - parens. The second value returned by @racket[get-token] is compared to - this list to see how the paren matcher should treat the token. An example: - Suppose pairs is @racket['((|(| |)|) (|[| |]|) (begin end))]. This means - that there are three kinds of parens. Any token which has @racket['begin] - as its second return value will act as an open for matching tokens with - @racket['end]. Similarly any token with @racket['|]|] will act as a - closing match for tokens with @racket['|[|]. When trying to correct a - mismatched closing parenthesis, each closing symbol in pairs will be - converted to a string and tried as a closing parenthesis. The @racket[get-token] function is usually be implemented with a lexer using the @racket[parser-tools/lex] library, but can be implemented directly. @@ -156,6 +217,8 @@ 0 (not mode))]))] + + @history[#:changed "1.63" @elem{Added support for hash-table @racket[_attribs] results.}] } @defmethod[(stop-colorer [clear-colors? boolean? #t]) void?]{ Stops coloring and paren matching the buffer. @@ -363,12 +426,27 @@ @defmethod[(classify-position [position exact-nonnegative-integer?]) (or/c symbol? #f)]{ - Return a symbol for the lexer-determined token type for the token that - contains the item after @racket[position]. + Return a symbol for the lexer-determined token type for the token + that contains the item after @racket[position]. Using + @method[color:text<%> classify-position] is the same as using + @method[color:text<%> classify-position*] and checking for a + @racket['type] value in the resulting hash. Must only be called while the tokenizer is started. } + @defmethod[(classify-position* [position exact-nonnegative-integer?]) + (or/c (and/c (hash/c symbol? any/c) immutable?) #f)]{ + + Return a hash table for the lexer-determined token attributes for + the token that contains the item after @racket[position]. The + result is @racket[#f] if no attributes are available for the + position. + + Must only be called while the tokenizer is started. + + @history[#:added "1.63"]} + @defmethod[(get-token-range [position exact-nonnegative-integer?]) (values (or/c #f exact-nonnegative-integer?) (or/c #f exact-nonnegative-integer?))]{ @@ -379,6 +457,13 @@ This method must be called only when the tokenizer is started. } + @defmethod[(get-backward-navigation-limit (start exact-integer?)) + exact-integer?]{ + Returns a limit for backward-matching parenthesis starting at position + @racket[start]. + + @history[#:added "1.65"]} + @defmethod[#:mode pubment (on-lexer-valid [valid? boolean?]) any]{ This method is an observer for when the lexer is working. It is called when the lexer's state changes from valid to invalid (and back). The @@ -413,8 +498,16 @@ Sets the @racket[get-token] function used to color the contents of the editor. - See @method[color:text<%> start-colorer]'s @racket[get-token] argument - for the contract on this method's @racket[get-token] argument. + See @method[color:text<%> start-colorer]'s @racket[_get-token] argument + for the contract on this method's @racket[_get-token] argument. + } + @defmethod[(set-matches [matches (listof (list/c symbol? symbol?))]) void?]{ + Sets the matching parentheses pairs for this editor. + + See @method[color:text<%> start-colorer]'s @racket[_pairs] argument + for more information about this argument. + + @history[#:added "1.60"] } } diff --git a/gui-doc/scribblings/framework/editor-snip.scrbl b/gui-doc/scribblings/framework/editor-snip.scrbl index ca17c3a85..e27576ff2 100644 --- a/gui-doc/scribblings/framework/editor-snip.scrbl +++ b/gui-doc/scribblings/framework/editor-snip.scrbl @@ -33,7 +33,7 @@ } @defmethod[(get-color) (or/c string? (is-a?/c color%))]{ Returns @racketblock[ - (if (preferences:get 'framework:white-on-black?) + (if (color-prefs:white-on-black-color-scheme?) "white" "black")] } diff --git a/gui-doc/scribblings/framework/editor.scrbl b/gui-doc/scribblings/framework/editor.scrbl index ade97b344..cde79686a 100644 --- a/gui-doc/scribblings/framework/editor.scrbl +++ b/gui-doc/scribblings/framework/editor.scrbl @@ -40,14 +40,14 @@ @method[editor:basic<%> run-after-edit-sequence]'s argument will be called. } - @defmethod*[(((get-top-level-window) (or/c #f (is-a?/c top-level-window<%>))))]{ + @defmethod[(get-top-level-window) (or/c #f (is-a?/c top-level-window<%>))]{ Returns the @racket[top-level-window<%>] currently associated with this buffer. - This does not work for embedded editors. - - + Note that the result of this method may not currently be displaying this + editor (e.g., the editor may be for a tab that's not currently active in + DrRacket). } @defmethod*[(((save-file-out-of-date?) boolean?))]{ Returns @racket[#t] if the file on disk has been modified, by some other program. @@ -160,7 +160,9 @@ If the second result is a @racket[text%] object, then the first result will be a position in the editor and - otherwise the first result will be @racket[#f]. + otherwise the first result will be @racket[#f]. The position + is found by calling @method[text% find-position], using + @racket[#f] as the @racket[_at-eol?] argument. The @racket[editor<%>] object will always be the nearest enclosing editor containing the point (@racket[x], @racket[y]). @@ -180,14 +182,18 @@ This installs the global keymap @racket[keymap:get-global] to handle keyboard and mouse mappings not handled by @racket[keymap]. The global keymap is created when the framework is invoked. - @defmethod*[#:mode augment (((can-save-file? (filename string?) (format symbol?)) boolean?))]{ + + @defmethod[#:mode augment (can-save-file? (filename string?) (format symbol?)) boolean?]{ Checks to see if the file on the disk has been modified out side of this editor, using @method[editor:basic<%> save-file-out-of-date?]. If it has, this method prompts the user to be sure they want to save. - } + See also @racket[editor:doing-autosave?] and + @racket[editor:silent-cancel-on-save-file-out-of-date?]. + } + @defmethod*[#:mode augment (((after-save-file (success? boolean?)) void?))]{ If the current filename is not a temporary filename, this method calls @@ -474,29 +480,59 @@ @defmixin[editor:autoload-mixin (editor:basic<%>) (editor:autoload<%>)]{ The result of this mixin uses @racket[filesystem-change-evt] to track - changes to the file that this editor uses to save into, offering to + changes to the file that this editor saves to, offering to revert the buffer to match the file when the file changes. + It strives to make sure that there is never a moment when + the file is unmonitored so there should be no races with + other processes. That said a call to + @method[editor:autoload-mixin set-filename] will disrupt the + connection. + + The result of this mixin calls @method[editor<%> enable-sha1] during + initialization of the object. + + The mixin uses @racket[editor:doing-autosave?] to avoid tracking + changes to autosave files (as autosaving also uses @method[editor<%> save-file] + and @method[editor<%> load-file]). + @defmethod[#:mode override (set-filename [filename (or/c path-string? #f)] [temporary? any/c #f]) void?]{ - Tracks changes to the @racket[filename]. + Disables the monitoring, unless the call is in the dynamic extent of + a call to @method[editor<%> load-file] + or @method[editor<%> save-file]. } @defmethod[#:mode augment (on-close) void?]{ - Uses @racket[filesystem-change-evt-cancel] to stop tracking changes. + Uses @racket[filesystem-change-evt-cancel] to stop tracking changes + to the file. } @defmethod[#:mode augment (on-save-file [filename path?] [format (or/c 'guess 'standard 'text 'text-force-cr 'same 'copy)]) void?]{ - Temporarily disables tracking of the file so that saving doesn't trigger - the offer to revert the buffer. + Establishes the monitoring of @racket[filename] and ties it to this @racket[editor<%>]. } @defmethod[#:mode augment (after-save-file [success? any/c]) void?]{ - Re-enables tracking of the file after the disabled - change in @method[editor:autoload-mixin on-save-file]. + Uses the updated sha1 from @method[editor<%> get-file-sha1], now that the editor's content + and the file on the disk have been synchronized. +} + + @defmethod[#:mode augment (on-load-file [filename path?] + [format (or/c 'guess 'standard 'text 'text-force-cr 'same 'copy)]) + void?]{ + Establishes the monitoring of @racket[filename] and ties it to this @racket[editor<%>]. + } + @defmethod[#:mode augment (after-load-file [success? any/c]) void?]{ + Uses the updated sha1 from @method[editor<%> get-file-sha1], now that the editor's content + and the file on the disk have been synchronized. } + + @defmethod[#:mode override (update-sha1? [path path-string?]) any/c]{ + Returns @racket[#f] when @racket[(editor:doing-autosave?)] is @racket[#t]; + otherwise returns the result of the super method. + } } diff --git a/gui-doc/scribblings/framework/frame.scrbl b/gui-doc/scribblings/framework/frame.scrbl index 3aab7ba45..3abe28f28 100644 --- a/gui-doc/scribblings/framework/frame.scrbl +++ b/gui-doc/scribblings/framework/frame.scrbl @@ -77,6 +77,13 @@ Returns @racket[#f]. } + @defmethod[(get-all-open-files) (listof path?)]{ + Indicates the files that are currently open in this frame. + + Returns @racket['()]. + + @history[#:added "1.74"] + } @defmethod*[(((get-filename (temp (or/c #f (box boolean?)) #f)) (or/c #f path?)))]{ This returns the filename that the frame is currently being saved as, or @racket[#f] if there is no appropriate filename. @@ -86,11 +93,21 @@ If @racket[temp] is a box, it is filled with @racket[#t] or @racket[#f], depending if the filename is a temporary filename. } - @defmethod*[(((make-visible (filename string?)) void?))]{ + @defmethod[(make-visible [filename (or/c path-string? symbol?)] + [#:start-pos start-pos #f (or/c #f exact-nonnegative-integer?)] + [#:end-pos end-pos start-pos (or/c #f exact-nonnegative-integer?)]) + void?]{ Makes the file named by @racket[filename] visible (intended for - use with tabbed editing). + use with tabbed editing), using @method[text:basic<%> port-name-matches?] + to find the editor if @racket[filename] is a @racket[symbol?]. - } + If both @racket[start-pos] and @racket[end-pos] + are numbers, sets the insertion point to the range from + @racket[start-pos] and @racket[end-pos]. + +@history[#:changed "1.75" @list{generalized the @racket[filename] argument to allow + symbols and added the @racket[start-pos] and @racket[end-pos] arguments.}] + } } @defmixin[frame:basic-mixin (frame%) (frame:basic<%>)]{ This mixin provides the basic functionality that the framework expects. It @@ -232,11 +249,11 @@ height. The preferences key is the one passed to the initialization argument of the class. } - @defmethod[#:mode override (on-move (width position-integer?) - (height position-integer?)) + @defmethod[#:mode override (on-move (x position-integer?) + (y position-integer?)) void?]{ - Updates the preferences according to the width and - height, if @racket[position-preferences-key] is not @racket[#f], using + Updates the preferences according to the x,y position, + if @racket[position-preferences-key] is not @racket[#f], using it as the preferences key. } } @@ -557,6 +574,11 @@ @defmethod*[(((get-editor) (is-a?/c editor<%>)))]{ Returns the editor in this frame. } + + @defmethod*[(((find-editor (predicate ((is-a?/c editor<%>) . -> . boolean?))) + (or/c (is-a?/c editor<%>) #f)))]{ + Finds an editor matching the predicate, or returns @racket[#f] if there isn't any. + } } @defmixin[frame:editor-mixin (frame:standard-menus<%>) (frame:editor<%>)]{ This mixin adds functionality to support an @@ -602,10 +624,16 @@ @method[frame:editor<%> get-editor]. } - @defmethod*[#:mode override (((editing-this-file? (filename path?)) boolean?))]{ + @defmethod[#:mode override (editing-this-file? [filename path?]) boolean?]{ Returns @racket[#t] if the filename is the file that this frame is editing. } + @defmethod[#:mode override (get-all-open-files) (listof path?)]{ + Returns a list of all the paths for files that are open in this frame. + + @history[#:added "1.74"] + } + @defmethod*[#:mode augment (((on-close) void?))]{ Calls the @racket[editor:basic<%>]'s method @method[editor:basic<%> on-close]. diff --git a/gui-doc/scribblings/framework/framework.scrbl b/gui-doc/scribblings/framework/framework.scrbl index 48dc7ffa4..ff2fd6b47 100644 --- a/gui-doc/scribblings/framework/framework.scrbl +++ b/gui-doc/scribblings/framework/framework.scrbl @@ -112,6 +112,7 @@ the @secref["editor-snip"] section. @include-section["preferences.scrbl"] @include-section["preferences-text.scrbl"] @include-section["racket.scrbl"] +@include-section["srcloc-snip.scrbl"] @include-section["text.scrbl"] @include-section["splash.scrbl"] @include-section["test.scrbl"] diff --git a/gui-doc/scribblings/framework/group.scrbl b/gui-doc/scribblings/framework/group.scrbl index dc558578a..70f48ffac 100644 --- a/gui-doc/scribblings/framework/group.scrbl +++ b/gui-doc/scribblings/framework/group.scrbl @@ -84,8 +84,15 @@ Calls the @method[top-level-window<%> can-close?] method of each frame in the group. } - @defmethod*[(((locate-file [name path?]) (or/c false/c (is-a?/c frame:basic<%>))))]{ + @defmethod*[(((locate-file [name (or/c path? symbol?)]) (or/c false/c (is-a?/c frame:basic<%>))))]{ Returns the frame that is editing or viewing the file @racket[name]. + + If @racket[name] is a @racket[symbol?], uses the + @method[text:basic<%> port-name-matches?] method to + find a window that's editing this file. + + @history[#:changed "1.75" @list{generalized the @racket[filename] argument to allow + symbols and added the @racket[start-pos] and @racket[end-pos] arguments.}] } } diff --git a/gui-doc/scribblings/framework/racket.scrbl b/gui-doc/scribblings/framework/racket.scrbl index ef367a3b9..dd2b60cf6 100644 --- a/gui-doc/scribblings/framework/racket.scrbl +++ b/gui-doc/scribblings/framework/racket.scrbl @@ -49,6 +49,11 @@ @racket[start]. } + @defmethod*[#:mode override + (((get-backward-navigation-limit (start exact-integer?)) exact-integer?))]{ + Calls @method[racket:text<%> get-limit]. + } + @defmethod*[(((balance-parens (key-event (is-a?/c key-event%))) void?))]{ This function is called when the user types a close parenthesis in the @racket[text%]. If the close parenthesis that the user inserted does not @@ -79,6 +84,17 @@ through @racket[end]. } + @defmethod*[(((tabify-selection/reverse-choices (start exact-integer? (send this get-start-position)) + (end exact-integer? (send this get-end-position))) + void?))]{ + Sets the tabbing for the lines containing positions @racket[start] + through @racket[end], but if there are multiple valid tabbings to cycle through, + this method should cycle through the choices in reverse order. The default + implementation calls @method[racket:text<%> tabify-selection]. + + @history[#:added "1.77"] + } + @defmethod*[(((tabify-all) void?))]{ Tabs all lines. @@ -131,33 +147,115 @@ Deletes any trailing whitespace from the old line. } - @defmethod*[(((box-comment-out-selection - (start-pos (or/c (symbols 'start) exact-integer?)) - (end-pos (or/c (symbols 'end) exact-integer?))) - void?))]{ - This method comments out a selection in the text by putting it into a - comment box. - - Removes the region from @racket[start-pos] to @racket[end-pos] from the - editor and inserts a comment box with that region of text inserted into the - box. - - If @racket[start-pos] is @racket['start], the starting point of the - selection is used. If @racket[end-pos] is @racket['end], the ending point - of the selection is used. - } - - @defmethod*[(((comment-out-selection (start exact-integer?) - (end exact-integer?)) - void?))]{ - Comments the lines containing positions @racket[start] through @racket[end] - by inserting a semi-colon at the front of each line. - } - - @defmethod*[(((uncomment-selection (start exact-integer?) (end exact-integer?)) void?))]{ - Uncomments the lines containing positions @racket[start] through - @racket[end]. - } + @defmethod[(box-comment-out-selection + [start-pos (or/c 'start exact-integer?) 'start] + [end-pos (or/c 'end exact-integer?) 'end]) + #t]{ + This method comments out a selection in the text by putting it into a + comment box. + + Removes the region from @racket[start-pos] to @racket[end-pos] from the + editor and inserts a comment box with that region of text inserted into the + box. + + If @racket[start-pos] is @racket['start], the starting point of the + selection is used. If @racket[end-pos] is @racket['end], the ending point + of the selection is used. + } + + @defmethod[(comment-out-selection [start-pos exact-nonnegative-integer? (get-start-position)] + [end-pos exact-nonnegative-integer? (get-end-position)] + [#:start start (and/c string? (not/c #rx"[\r\n]")) ";"] + [#:padding padding (and/c string? (not/c #rx"[\r\n]")) ""]) + #t]{ + Comments the lines containing positions @racket[start-pos] through @racket[end-pos] + by inserting a @racket[start] followed by @racket[padding] at the + start of each paragraph. + } + + @defmethod[(region-comment-out-selection + [start-pos exact-nonnegative-integer? (get-start-position)] + [end-pos exact-nonnegative-integer? (get-end-position)] + [#:start start (and/c string? (not/c #rx"[\r\n]")) "#|"] + [#:end end (and/c string? (not/c #rx"[\r\n]")) "|#"] + [#:continue continue (and/c string? (not/c #rx"[\r\n]")) ""] + [#:padding padding (and/c string? (not/c #rx"[\r\n]")) " "]) + #t]{ + Comments the region between @racket[start-pos] and @racket[end-pos] + by inserting a @racket[start] at @racket[start-pos], @racket[end] at @racket[end-pos], + and @racket[continue] followed by @racket[padding] at the start of each paragraph + between @racket[start-pos] and @racket[end-pos]. + } + + @defmethod[(uncomment-box/selection + [#:start start (and/c string? (not/c #rx"[\r\n]")) ";"] + [#:padding padding (and/c string? (not/c #rx"[\r\n]")) ""]) #t]{ + If the result of @method[editor<%> get-focus-snip] is a comment snip, + then removes the comment snip. Otherwise, calls @racket[uncomment-selection] + with @racket[start] and @racket[padding]. + } + + @defmethod[(uncomment-selection [start-pos exact-nonnegative-integer? (get-start-position)] + [end-pos exact-nonnegative-integer? (get-end-position)] + [#:start start string ";"]) void?]{ + Uncomments the paragraphs containing positions + @racket[start-pos] through @racket[end-pos] if it has line-based comments or + a box comment. + + Specifically, checks for a box comment and, if present removes it. + If a box comment is not present, then removes line-based comments (if any) + on the paragraphs between @racket[start-pos] and @racket[end-pos]. + } + + @defmethod[(uncomment-selection/box [start-pos exact-nonnegative-integer? (get-start-position)] + [end-pos exact-nonnegative-integer? (get-end-position)]) + boolean?]{ + Checks for a box comment and, if present removes it. Returns @racket[#t] if + it found (and removed) a box comment, and @racket[#f] if it did not find + a box comment. + } + + @defmethod[(uncomment-selection/line [start-pos exact-nonnegative-integer? (get-start-position)] + [end-pos exact-nonnegative-integer? (get-end-position)] + [#:start start (and/c string? (not/c #rx"[\r\n]")) ";"] + [#:padding padding (and/c string? (not/c #rx"[\r\n]")) ""]) + #t]{ + Removes each occurrence of + @racket[start] that appears (potentially following + whitespace) at the start of each paragraph that enclose the + range between @racket[start-pos] and @racket[end-pos]. + } + + @defmethod[(uncomment-selection/region [start-pos exact-nonnegative-integer? (get-start-position)] + [end-pos exact-nonnegative-integer? (get-end-position)] + [#:start start (and/c string? (not/c #rx"[\r\n]")) "#|"] + [#:end end (and/c string? (not/c #rx"[\r\n]")) "|#"] + [#:continue continue (and/c string? (not/c #rx"[\r\n]")) ""] + [#:padding padding (and/c string? (not/c #rx"[\r\n]")) " "]) + #t]{ + Removes the region comment on the paragraphs between @racket[start-pos] and @racket[end-pos]. + } + + @defmethod[(commented-out/line? [start-pos exact-nonnegative-integer? (get-start-position)] + [end-pos exact-nonnegative-integer? (get-end-position)] + [#:start start (and/c string? (not/c #rx"[\r\n]")) ";"] + [#:padding padding (and/c string? (not/c #rx"[\r\n]")) ""]) + boolean?]{ + Considers each paragraph between @racket[start-pos] and @racket[end-pos], returning + @racket[#t] if any of them have the line comment @racket[start] commenting any + portion of them out. + } + + @defmethod[(commented-out/region? [start-pos exact-nonnegative-integer? (get-start-position)] + [end-pos exact-nonnegative-integer? (get-end-position)] + [#:start start (and/c string? (not/c #rx"[\r\n]")) "#|"] + [#:end end (and/c string? (not/c #rx"[\r\n]")) "|#"] + [#:continue continue (and/c string? (not/c #rx"[\r\n]")) ""]) + boolean?]{ + Returns @racket[#t] if the paragraphs at @racket[start-pos] and @racket[end-pos] + have @racket[start] and @racket[end] in them and the paragraphs in between + start with @racket[continue]. + } @defmethod*[(((get-forward-sexp (start exact-integer?)) (or/c #f exact-integer?)))]{ @@ -303,13 +401,22 @@ The resulting mode assumes that it is only set to an editor that is the result of @racket[racket:text-mixin]. - @defmethod*[#:mode override (((on-disable-surrogate) void?))]{ - Removes the scheme keymap (see also @racket[racket:get-keymap]) and + @defconstructor[([include-paren-keymap? boolean? #t])]{ + If @racket[include-paren-keymap?] is @racket[#f] only the + result of @racket[racket:get-non-paren-keymap] is used + by @method[racket:text-mode-mixin on-enable-surrogate]; + otherwise the result of @racket[racket:get-keymap] is used. + + @history[#:added "1.64"] + } + + @defmethod[#:mode override (on-disable-surrogate) void?]{ + Removes the racket keymap (see also @racket[racket:get-keymap]) and disables any parenthesis highlighting in the host editor. } - @defmethod*[#:mode override (((on-enable-surrogate) void?))]{ - Adds the scheme keymap (see also @racket[racket:get-keymap]) and enables a + @defmethod[#:mode override (on-enable-surrogate) void?]{ + Adds the racket keymap (see also @racket[racket:get-keymap]) and enables a parenthesis highlighting in the host editor. } } diff --git a/gui-doc/scribblings/framework/srcloc-snip.scrbl b/gui-doc/scribblings/framework/srcloc-snip.scrbl new file mode 100644 index 000000000..b12f51d00 --- /dev/null +++ b/gui-doc/scribblings/framework/srcloc-snip.scrbl @@ -0,0 +1,26 @@ +#lang scribble/doc +@(require scribble/manual scribble/extract) +@(require (for-label framework)) +@(require (for-label scheme/gui)) +@title{Srcloc Snips} + +@defclass[srcloc-snip:snip% editor-snip% ()]{ +This snip implements clickable links to @racket[srcloc] locations. + +The snip is initialized with an appropriate editor, into which a +representation for the link can be inserted. When the reprenstation +has been inserted, the @racket[activate-link] method needs to be +called to activate the link. + +@defconstructor[([srcloc srcloc?])]{ + The @racket[srcloc] field specifies where the link points. +} + +@defmethod[#:mode public (activate-link) void?]{ + This makes the content of the snip's editor clickable, such that + clicking highlights the position of the srcloc. +} +} + +@(include-previously-extracted "main-extracts.rkt" #rx"^srcloc-snip:") + diff --git a/gui-doc/scribblings/framework/text.scrbl b/gui-doc/scribblings/framework/text.scrbl index 9a43060ee..e3dbd9eca 100644 --- a/gui-doc/scribblings/framework/text.scrbl +++ b/gui-doc/scribblings/framework/text.scrbl @@ -8,7 +8,9 @@ functionality needed by the framework. @defmethod[(highlight-range [start exact-nonnegative-integer?] [end exact-nonnegative-integer?] - [color (or/c string? (is-a?/c color%))] + [color (or/c string? + (is-a?/c color%) + color-prefs:color-scheme-color-name?)] [caret-space boolean? #f] [priority (or/c 'high 'low) 'low] [style (or/c 'rectangle 'ellipse 'hollow-ellipse 'dot) 'rectangle] @@ -20,12 +22,23 @@ This function highlights a region of text in the buffer. The range between @racket[start] and @racket[end] will be highlighted with - the given @racket[color], if the style is @racket['rectangle] (the default). If - the style is @racket['ellipse], then an ellipse is drawn around the range + the given @racket[color]. If the @racket[color] is a + @racket[color-prefs:color-scheme-color-name?] then the color is looked up + each time the rectangle is drawn, so that changes to the color scheme are + reflected in the highlighted range. + + If the style is @racket['rectangle] (the default), then the highlighted region + is drawn as a rectangle, highlighting all of the text between the start and end. + If the style is @racket['ellipse], then an ellipse is drawn around the range in the editor, using the color. If the style is @racket['hollow-ellipse], then the outline of an ellipse is drawn around the range in the editor, using the color. - + If the style is @racket['single-rectangle] then a rectangle whose upper-left + corner is the starting position of the range and whose lower-right corner is + the ending position of the range; this may not highlight some of the text in the + range, as the first and last position may be in different paragraphs and + the intermediate paragraphs may be wider than the distance from the start to + the end. If the style is @racket['dot], then @racket[start] and @racket[end] must be the same, and a dot is drawn at the bottom of that position in the editor. @@ -67,12 +80,17 @@ @method[text:basic<%> unhighlight-ranges/key], or @method[text:basic<%> unhighlight-ranges] must be called directly to remove the highlighting. + + @history[#:changed "1.68" @list{Allow the @racket[color] argument to be + @racket[color-prefs:color-scheme-color-name?]}] } @defmethod[(unhighlight-range (start exact-nonnegative-integer?) (end exact-nonnegative-integer?) - (color (or/c string? (is-a?/c color%))) + (color (or/c string? + (is-a?/c color%) + color-prefs:color-scheme-color-name?)) (caret-space boolean? #f) (style (or/c 'rectangle 'ellipse 'hollow-ellipse) 'rectangle)) void?]{ @@ -85,6 +103,9 @@ If you expect to call this method many times (when there are many ranges set) consider instead calling @method[text:basic<%> unhighlight-ranges]. + + @history[#:changed "1.68" @list{Allow the @racket[color] argument to be + @racket[color-prefs:color-scheme-color-name?]}] } @defmethod[(unhighlight-ranges/key [key any/c]) void?]{ @@ -270,6 +291,26 @@ } } +@definterface[text:indent-guides<%> (text%)]{ + Classes implementing this interface provide indent guides + as thin vertical lines, showing which columns where earlier + lines started. + + @history[#:added "1.69"] + + @defmethod[#:mode public-final (show-indent-guides! [on? any/c]) void?]{ + Enables or disables indent guides in this editor. Defaults to enabled. + } + + @defmethod[#:mode public-final (show-indent-guides?) boolean?]{ + Returns a boolean indicating if indent guides are shown in the current editor. + } +} + +@defmixin[text:indent-guides-mixin (text%) (text:indent-guides<%>)]{ + +} + @definterface[text:inline-overview<%> (text%)]{ Classes implementing this interface provide an overview along the right-hand side of the @racket[text%]'s view, showing @@ -290,9 +331,9 @@ } } -@defmixin[text:inline-overview-mixin (text%) (text:inline-overview<%>)]{ +@defmixin[text:inline-overview-mixin (text%) (text:inline-overview<%>)]{} -} +@defmixin[text:inline-overview-mpw-mixin (text% text:max-width-paragraph<%>) (text:inline-overview<%>)]{} @definterface[text:line-spacing<%> (text:basic<%>)]{ Objects implementing this interface adjust their @@ -311,6 +352,48 @@ preference changes. } +@definterface[text:max-width-paragraph<%> ()]{ + + Text objects implementing this interface track the width of + the widest line. + + @defmethod[#:mode public-final (get-max-width-paragraph) natural?]{ + Returns the index of the widest paragraph, i.e. the value of + @racket[para] that maximizes the expression + @racketblock[(- (#,(method text% paragraph-end-position) para) + (#,(method text% paragraph-start-position) para))] + + This method will, in some cases, loop over every line of + the editor to get its answer but it will cache the result + and track when edits happen that do not invalidate its + previous response. In those cases, it will just return its + cached result. + + } + + @defmethod[#:mode augment (after-max-width-paragraph-change) any]{ + + This method is called whenever the result of + @method[text:max-paragraph-width<%> get-max-width-paragraph] + would change. + + If the current cache for the result of + @method[text:max-paragraph-width<%> get-max-width-paragraph] + is invalid, then this method will be called, even if the actual + maximum width may not have changed. In other words, this method + is guaranteed to be called at least as often as the result of + @method[text:max-paragraph-width<%> get-max-width-paragraph] + changes, but it may be called more often than that. + + } + + @history[#:added "1.78"] +} + +@defmixin[text:max-width-paragraph-mixin (text%) (text:max-paragraph-width<%>)]{ + @history[#:added "1.78"] +} + @definterface[text:ascii-art-enlarge-boxes<%> ()]{ @defmethod[(set-ascii-art-enlarge [e? any/c]) void?]{ Enables or disables the ascii art box enlarging mode based on @racket[e?]'s true value. @@ -615,7 +698,7 @@ @racket['framework:anchored-search] preference is on. } - @defmethod[(get-search-hit-count) (values number? number?)]{ + @defmethod[(get-search-hit-count) (values natural? natural?)]{ Returns the number of hits for the search in the buffer before the insertion point and the total number of hits. Both are based on the count found last time that a search completed. @@ -628,7 +711,7 @@ } - @defmethod[(get-replace-search-hit) (or/c number? #f)]{ + @defmethod[(get-replace-search-hit) (or/c (list*of (is-a?/c text%) natural?) #f)]{ Returns the position of the nearest search hit that comes after the insertion point. @@ -639,7 +722,7 @@ @method[text:searching<%> finish-pending-search-work]. } - @defmethod[(set-replace-start [pos (or/c number? #f)]) void?]{ + @defmethod[(set-replace-start [pos (or/c natural? #f)]) void?]{ This method is ignored. (The next replacement start is now tracked via the @method[text% after-set-position] method.) } @@ -675,7 +758,7 @@ } @defmixin[text:searching-mixin (editor:keymap<%> text:basic<%>) (text:searching<%>)]{ - This @racket[text%] can be searched. + This @racket[text%] can be searched. See also @racket[text:searching-embedded-mixin] The result of this mixin uses the same initialization arguments as the mixin's argument. @@ -701,6 +784,44 @@ } } +@definterface[text:searching-embedded<%> ()]{ + Classes that implement this interface are produced by + @racket[text:searching-exmbedded-mixin] and have overridden + observer methods that forward information about changes to the editor + that can affect the searching results state. + +@history[#:added "1.80"] + +} + +@defmixin[text:searching-embedded-mixin (text%) (text:searching-embedded<%>)]{ + This mixin is expected to be used with editors that appear inside @racket[editor-snip%]s + and that can have search results. I cooperates with the enclosing @racket[text:searching<%>] + object to inform it when a change to the editor has occurred that can affect + the current search results and how they are displayed. + +@history[#:added "1.80"] + + @defmethod[#:mode augment (after-insert [start exact-nonnegative-integer?] + [len exact-nonnegative-integer?]) void?]{ + Tells the outermost enclosing editor that the contents + of the editor has changed, which can affect the way + search results are displayed. + } + + @defmethod[#:mode augment (after-delete [start exact-nonnegative-integer?] + [len exact-nonnegative-integer?]) void?]{ + Tells the outermost enclosing editor that the contents + of the editor has changed, which can affect the way + search results are displayed. + } + + @defmethod[#:mode augment (after-set-position) void?]{ + Tells the outermost enclosing editor that the position + of the editor has changed, which can affect the way + search results are displayed. + } +} @definterface[text:return<%> (text%)]{ Objects supporting this interface were created by @racket[text:return-mixin]. } @@ -1346,6 +1467,11 @@ @defmixin[text:ports-mixin (text:wide-snip<%>) (text:ports<%>)]{ + The ports from this mixin accepts as special values (see + @racket[port-writes-special?]) markup from the + @racketmodname[simple-tree-text-markup/data] module, and renders + them with graphical boxes and clickable srcloc links. + @defmethod*[#:mode augment (((can-insert? (start exact-integer?) (len exact-integer?)) boolean?))]{ Returns the results of the @racket[inner] call, unless @method[text:ports<%> get-allow-edits] returns @racket[#f]. diff --git a/gui-doc/scribblings/gui/add-color-intf.scrbl b/gui-doc/scribblings/gui/add-color-intf.scrbl index 00bc50f68..aca108346 100644 --- a/gui-doc/scribblings/gui/add-color-intf.scrbl +++ b/gui-doc/scribblings/gui/add-color-intf.scrbl @@ -12,14 +12,24 @@ get-background-add]. @defmethod[(get [r (box/c (integer-in -1000 1000))] [g (box/c (integer-in -1000 1000))] - [b (box/c (integer-in -1000 1000))]) + [b (box/c (integer-in -1000 1000))] + [a (or/c (box/c real?) #f) #f]) void?]{ Gets all of the additive values. @boxisfill[@racket[r] @elem{the additive value for the red component of the color}] @boxisfill[@racket[g] @elem{the additive value for the green component of the color}] @boxisfill[@racket[b] @elem{the additive value for the blue component of the color}] -} + @boxisfillnull[@racket[a] @elem{the additive value for the alpha component of the color}] + +@history[#:changed "1.63" @elem{Added the @racket[a] optional argument.}]} + +@defmethod[(get-a) + real?]{ + + Gets the additive value for the alpha component of the color. + +@history[#:added "1.63"]} @defmethod[(get-b) (integer-in -1000 1000)]{ @@ -40,10 +50,19 @@ Gets the additive value for the green component of the color. @defmethod[(set [r (integer-in -1000 1000)] [g (integer-in -1000 1000)] - [b (integer-in -1000 1000)]) + [b (integer-in -1000 1000)] + [a real? 0.0]) void?]{ Sets all of the additive values. -} + + +@history[#:changed "1.63" @elem{Added the @racket[a] optional argument.}]} + +@defmethod[(set-a [v real?]) + void?]{ + Sets the additive value for the alpha component of the color. + +@history[#:added "1.63"]} @defmethod[(set-b [v (integer-in -1000 1000)]) void?]{ diff --git a/gui-doc/scribblings/gui/canvas-intf.scrbl b/gui-doc/scribblings/gui/canvas-intf.scrbl index e48213cec..9f1406d99 100644 --- a/gui-doc/scribblings/gui/canvas-intf.scrbl +++ b/gui-doc/scribblings/gui/canvas-intf.scrbl @@ -47,7 +47,7 @@ To draw onto a canvas, get its device context via @method[canvas<%> canvas's parent window shows through.} @item{Drawing can also occur at any time outside an @method[canvas<%> - on-paint] call form the windowing system, including from + on-paint] call from the windowing system, including from threads other than the @tech{handler thread} of the canvas's eventspace. Drawing outside an @method[canvas<%> on-paint] callback from the system is transient in the sense that diff --git a/gui-doc/scribblings/gui/column-control-event-class.scrbl b/gui-doc/scribblings/gui/column-control-event-class.scrbl index fd6a53676..4282259d4 100644 --- a/gui-doc/scribblings/gui/column-control-event-class.scrbl +++ b/gui-doc/scribblings/gui/column-control-event-class.scrbl @@ -4,7 +4,9 @@ @defclass/title[column-control-event% control-event% ()]{ A @racket[column-control-event%] object contains information about a - event on an @racket[list-box%] column header. + event on an @racket[list-box%] column header. Except on Windows, + the @racket['clickable-headers] style must be specified when + creating a @racket[list-box%] for column events to be generated. @defconstructor[([column exact-nonnegative-integer?] [event-type (or/c 'list-box-column)] diff --git a/gui-doc/scribblings/gui/dialog-class.scrbl b/gui-doc/scribblings/gui/dialog-class.scrbl index a4cd32aa1..8433f651e 100644 --- a/gui-doc/scribblings/gui/dialog-class.scrbl +++ b/gui-doc/scribblings/gui/dialog-class.scrbl @@ -32,7 +32,7 @@ title bar. If the dialog's label is changed (see @method[window<%> set-label]), the title bar is updated. The @racket[parent] argument can be @racket[#f] or an existing - frame. On Windows, if @racket[parent] is an existing frame, the + frame or dialog. On Windows, if @racket[parent] is not @racket[#f], the new dialog is always on top of its parent. On Windows and Unix, a dialog is iconized when its parent is iconized. diff --git a/gui-doc/scribblings/gui/dialog-funcs.scrbl b/gui-doc/scribblings/gui/dialog-funcs.scrbl index a74060b01..79623f0ec 100644 --- a/gui-doc/scribblings/gui/dialog-funcs.scrbl +++ b/gui-doc/scribblings/gui/dialog-funcs.scrbl @@ -167,7 +167,7 @@ See also @racket[path-dialog%] for a richer interface. [directory (or/c path-string? #f) #f] [style (listof (or/c 'enter-packages 'common)) null] [#:dialog-mixin dialog-mixin (make-mixin-contract path-dialog%) (λ (x) x)]) - (or/c path #f)]{ + (or/c path? #f)]{ Obtains a directory pathname from the user via the platform-specific standard (modal) dialog, using @racket[parent] as the parent window if @@ -265,9 +265,11 @@ before the dialog is created. 'default=1 'default=2 'default=3)) '(no-default)] [close-result any/c #f] + [#:return-the-dialog? return-the-dialog? any/c #f] [#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values]) - (or/c 1 2 3 close-result)]{ - + (if/c return-the-dialog? + (is-a?/c dialog%) + (or/c 1 2 3 close-result))]{ Displays a message to the user in a (modal) dialog, using @racket[parent] as the parent window if it is specified. The dialog's title is @racket[title]. The @racket[message] string can be arbitrarily @@ -325,12 +327,22 @@ The @racket[style] list must contain exactly one of @racket['default=1], In addition, @racket[style] can contain @racket['caution], @racket['stop], or @racket['no-icon] to adjust the icon that appears - n the dialog, the same for @racket[message-box]. - -The class that implements the dialog provides a @racket[get-message] - method that takes no arguments and returns the text of the message as - a string. (The dialog is accessible through the -@racket[get-top-level-windows] function.) + in the dialog, the same for @racket[message-box]. + +If @racket[return-the-dialog?] is a true value, then the dialog + is not shown and is instead returned from @racket[message-box/custom]. +The dialog responds to these three additional messages (via @racket[send]): +@itemlist[ + @item{@racket[_get-message] This method takes no arguments + and returns the text of the message as + a string.} + @item{@racket[_set-message] This method accepts one string argument + and changes the message of the dialog to the given argument.} + @item{@racket[_show-and-return-results] This method accepts no arguments + and shows the dialog. It returns after the dialog closes, with the result that the + @racket[message-box/custom] would have returned if @racket[return-the-dialog?] + had been @racket[#false].}] +The dialog is also accessible through the @racket[get-top-level-windows] function. The @racket[message-box/custom] function can be called in a thread other than the handler thread of the relevant eventspace (i.e., the eventspace of @@ -338,7 +350,10 @@ The @racket[message-box/custom] function can be called in a thread current thread blocks while the dialog runs on the handler thread. The @racket[dialog-mixin] argument is applied to the class that implements the dialog -before the dialog is created. +before the dialog is created. + +@history[#:changed "1.53" @list{Added the @racket[return-the-dialog?] argument + and the ability to change the dialog box's message.}] } @defproc[(message+check-box [title label-string?] @@ -348,8 +363,11 @@ before the dialog is created. [style (listof (or/c 'ok 'ok-cancel 'yes-no 'caution 'stop 'no-icon 'checked)) '(ok)] + [#:return-the-dialog? return-the-dialog? any/c #f] [#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values]) - (values (or/c 'ok 'cancel 'yes 'no) boolean?)]{ + (if/c return-the-dialog? + (is-a?/c dialog%) + (values (or/c 'ok 'cancel 'yes 'no) boolean?))]{ See also @racket[message+check-box/custom]. @@ -361,7 +379,15 @@ Like @racket[message-box], except that boolean indicating whether the box was checked; and} @item{@racket[style] can contain @racket['checked] to indicate that the check box should be initially checked.} -]} + @item{If @racket[return-the-dialog?] is a true value, the resulting object + also has a public @racket[_set-check-label] method. That method + accepts a single, @racket[label-string?] argument and sets the + checkbox's label to that string.} +] + +@history[#:changed "1.53" @list{Added the @racket[return-the-dialog?] argument and + the ability to change the dialog box's message and check label.}] +} @defproc[(message+check-box/custom [title label-string?] [message string?] diff --git a/gui-doc/scribblings/gui/dynamic.scrbl b/gui-doc/scribblings/gui/dynamic.scrbl index 95697dc94..111cde3d8 100644 --- a/gui-doc/scribblings/gui/dynamic.scrbl +++ b/gui-doc/scribblings/gui/dynamic.scrbl @@ -13,11 +13,36 @@ library provides functions for dynamically accessing the Returns @racket[#t] if dynamic access to the GUI bindings is available. The bindings are available if @racketmodname[racket/gui/base] has been loaded, instantiated, and -attached to the namespace in which @racket[racket/gui/dynamic] was +attached to the namespace in which @racketmodname[racket/gui/dynamic] was instantiated.} @defproc[(gui-dynamic-require [sym symbol?]) any]{ Like @racket[dynamic-require], but specifically to access exports of -@racketmodname[racket/gui/base].} +@racketmodname[racket/gui/base], and only when @racket[(gui-available?)] +returns true. + +The @racket[gui-dynamic-require] function is intended primarily for +use under a @racket[(gui-available?)] conditional. It can also be used +as a shorthand for @racket[dynamic-require] with +@racket['racket/gui/base], but only after ensuring that the bindings +are available. One way to make @racketmodname[racket/gui/base] +bindings available, so that @racket[(gui-available?)] returns true, is +through @racket[dynamic-require]: + +@racketblock[ +(dynamic-require 'racket/gui/base #f) +] + +Unlike @racket[require], using @racket[dynamic-require] delays the +instantiation of @racketmodname[racket/gui/base] until the run-time +call of @racket[dynamic-require]. With @racketmodname[racket/gui/base] +so declared, @racket[gui-dynamic-require] can be used to access +bindings: + +@racketblock[ +(define window (new (gui-dynamic-require 'frame%) + [label "Frame"])) +(send window show #t) +]} diff --git a/gui-doc/scribblings/gui/editor-admin-class.scrbl b/gui-doc/scribblings/gui/editor-admin-class.scrbl index 2b671f115..fa352f94c 100644 --- a/gui-doc/scribblings/gui/editor-admin-class.scrbl +++ b/gui-doc/scribblings/gui/editor-admin-class.scrbl @@ -189,8 +189,9 @@ Does nothing. @popupmenuinfo[@elem{administrator's @techlink{display}} @elem{top-level editor in this administrator's @techlink{display}} - @elem{The result is @racket[#t] if the popup succeeds, - @racket[#f] otherwise (independent of whether the + @elem{The result is @racket[#f] if this admin is not connected to + a canvas or the canvas it is connected to does not have an editor, + @racket[#t] otherwise (independent of whether the user selects an item in the popup menu).}] The menu is displayed at @racket[x] and @racket[y] in editor coordinates. diff --git a/gui-doc/scribblings/gui/editor-funcs.scrbl b/gui-doc/scribblings/gui/editor-funcs.scrbl index deb21a70c..a7ee135f0 100644 --- a/gui-doc/scribblings/gui/editor-funcs.scrbl +++ b/gui-doc/scribblings/gui/editor-funcs.scrbl @@ -126,9 +126,7 @@ of the list should be the @racket[text%] object where the mouse was clicked for the popup menu and the position where the click happened. In that case, the @onscreen{Copy} and @onscreen{Cut} menus are enabled when the click lands on a snip that is not a @racket[string-snip%], and the corresponding -callbacks will copy and cut that one snip. - -} +callbacks will copy and cut that one snip.} @defparam[current-text-keymap-initializer proc ((is-a?/c keymap%) . -> . any/c)]{ @@ -141,10 +139,11 @@ The initializer takes a keymap object and returns nothing. The default initializer chains the given keymap to an internal keymap that implements standard text editor keyboard and mouse bindings for cut, copy, paste, undo, and select-all. The right mouse button is mapped - to popup an edit menu when the button is released. On Unix, - start-of-line (Ctl-A) and end-of-line (Ctl-E) are also mapped. + to popup an edit menu when the button is released. -} +@history[#:changed "1.51" @elem{Changed Unix keybindings in the default initializer + to match Windows, dropping + start-of-line and end-of-line bindings.}]} @defproc[(editor-set-x-selection-mode [on any/c]) void?]{ diff --git a/gui-doc/scribblings/gui/editor-intf.scrbl b/gui-doc/scribblings/gui/editor-intf.scrbl index a9eb0ce26..d717c1b92 100644 --- a/gui-doc/scribblings/gui/editor-intf.scrbl +++ b/gui-doc/scribblings/gui/editor-intf.scrbl @@ -554,6 +554,22 @@ See also @method[editor<%> dc-location-to-editor-location]. } +@defmethod[(enable-sha1) void?]{ + + Once this method has been called, any future calls to + @method[editor<%> load-file] or @method[editor<%> save-file] + will compute the sha1 (see + @secref["sha" #:doc '(lib "scribblings/reference/reference.scrbl")]) + of the file that is loaded or saved. + + Once the sha1 computation has been enabled, it cannot be disabled. + + See also @method[editor<%> is-sha1-enabled?], @method[editor<%> get-file-sha1], + and @method[editor<%> update-sha1?]. + + @history[#:added "1.50"] +} + @defmethod[(end-edit-sequence) void?]{ @@ -636,6 +652,7 @@ Returns a list of canvases displaying the editor. An editor may be @racket[null] is returned. } + @defmethod[(get-file-creator-and-type) (values (or/c #f (and/c bytes? #rx#"^....$")) (or/c #f (and/c bytes? #rx#"^....$")))]{ @@ -708,6 +725,24 @@ If the editor is displayed in a single canvas, then the canvas's }} +@defmethod[(get-file-sha1) (or/c bytes? #f)]{ + Returns the sha1 (see @secref["sha" #:doc '(lib "scribblings/reference/reference.scrbl")]) + of the most recently loaded or saved file + in this editor (but see @method[editor<%> update-sha1?]), + unless @method[editor<%> enable-sha1] was + never called or no file has been loaded or saved since it was + called, in which case this method returns @racket[#f]. + + This method's result will change only after + @method[editor<%> save-file] or @method[editor<%> load-file] + are called, and can be monitored via + @method[editor<%> after-save-file] and @method[editor<%> after-load-file]. + + See also @method[editor<%> is-sha1-enabled?]. + + @history[#:added "1.50"] + } + @defmethod[(get-filename [temp (or/c (box/c any/c) #f) #f]) (or/c path-string? #f)]{ @@ -768,7 +803,6 @@ Returns the main keymap currently used by the editor. } - @defmethod[(get-load-overwrites-styles) boolean?]{ @@ -1115,6 +1149,19 @@ Returns @racket[#t] if the editor has been modified since the last Returns @racket[#t] if the editor is currently being printed through the @method[editor<%> print] method, @racket[#f] otherwise.} +@defmethod[(is-sha1-enabled?) boolean]{ + Returns @racket[#t] when this editor will track the sha1 + (see @secref["sha" #:doc '(lib "scribblings/reference/reference.scrbl")]) + of the contents of the file on disk and @racket[#f] otherwise. + + If @method[editor<%> enable-sha1] has not been called, this method returns + @racket[#f] or, in other words, the computation of the sha1 is disabled + by default. + + See also @method[editor<%> get-file-sha1] and @method[editor<%> update-sha1?]. + + @history[#:added "1.50"] + } @defmethod[(kill [time exact-integer? 0]) void?]{ @@ -1619,12 +1666,19 @@ Provides a way to add arbitrary graphics to an editor's @techlink{display}. Thi method is called just before and just after every painting of the editor. +The @racket[dx] and @racket[dy] arguments specify the drawing + coordinates in @racket[dc] for the editor's top-left corner. That is, + to draw at a particular position in editor coordinates, add + @racket[dx] and @racket[dy] to get @racket[dc] drawing coordinates. + The @racket[before?] argument is @racket[#t] when the method is called just before painting the contents of the editor or @racket[#f] when it is called after painting. The @racket[left], @racket[top], @racket[right], and @racket[bottom] arguments specify which region of the editor is being - repainted, in editor coordinates. To get the coordinates for - @racket[dc], offset editor coordinates by adding (@racket[dx], @racket[dy]). + repainted, in editor coordinates, in case it is useful to optimize for drawing + into only that subregion. (Since @racket[left], @racket[top], @racket[right], and + @racket[bottom] are in editor coordinates, add @racket[dx] or @racket[dy] + to get the corresponding @racket[dc] region.) See @|drawcaretdiscuss| for information about @racket[draw-caret]. The @method[editor<%> on-paint] method, together with the snips' @@ -1907,8 +1961,7 @@ See @method[editor<%> read-header-from-file]. boolean?]{ Reads new contents for the editor from a stream. The return value is - @racket[#t] if there are no errors, @racket[#f] otherwise. See also - @|filediscuss|. + @racket[#t] if there are no errors, @racket[#f] otherwise. The stream provides either new mappings for names in the editor's style list, or it indicates that the editor should share a @@ -1928,6 +1981,29 @@ The stream provides either new mappings for names in the editor's the previously-read list.} ] + +Leveraging @method[editor<%> read-from-file] to read from the editor stream + requires some ceremony which may not be obvious at first; calls to + @racket[read-editor-global-header] and @racket[read-editor-global-footer] + must bracket any call to @method[editor<%> read-from-file], and only one + stream at a time can be read from using these methods or written to using + @racket[write-editor-global-header] and @racket[write-editor-global-footer]. + See also @|filediscuss|. + +As a complete example consider the following: +@racketblock[ + (define (deserialize-text byte-stream) + (define editor (new text% [auto-wrap #t])) + (define editor-stream-in-bytes-base + (make-object editor-stream-in-bytes-base% byte-stream)) + (define editor-stream-in + (make-object editor-stream-in% editor-stream-in-bytes-base)) + (read-editor-global-header editor-stream-in) + (send editor read-from-file editor-stream-in) + (read-editor-global-footer editor-stream-in) + editor) +] + } @@ -2529,6 +2605,18 @@ See @method[editor<%> set-undo-preserves-all-history] for more information. @history[#:added "1.1"]} +@defmethod[(update-sha1? [path path-string?]) any/c]{ + + Called when updating the file's sha1 (so only if + @method[editor<%> enable-sha1] has been called); if this + method returns @racket[#f], then the sha1 is not updated + and the result of @method[editor<%> get-file-sha1] does not + change. + + See also @method[editor<%> is-sha1-enabled?]. + + @history[#:added "1.50"] +} @defmethod*[([(use-file-text-mode) boolean?] [(use-file-text-mode [on? any/c]) void?])]{ @@ -2585,11 +2673,32 @@ Does nothing. boolean?]{ Writes the current editor contents to the given stream. The return - value is @racket[#t] if there are no errors, @racket[#f] otherwise. See - also @|filediscuss|. + value is @racket[#t] if there are no errors, @racket[#f] otherwise. If the editor's style list has already been written to the stream, it is not re-written. Instead, the editor content indicates that the editor shares a previously-written style list. This sharing will be recreated when the stream is later read. + +Leveraging @method[editor<%> write-to-file] to write to the editor stream + requires some ceremony which may not be obvious at first; calls to + @racket[write-editor-global-header] and @racket[write-editor-global-footer] + must bracket any call to @method[editor<%> write-to-file], and only one + stream at a time can be written to using these methods or read from using + @racket[read-editor-global-header] and @racket[read-editor-global-footer]. + See also @|filediscuss|. + +As a complete example consider the following: +@racketblock[ + (define (serialize-text text) + (define editor-stream-out-bytes-base + (new editor-stream-out-bytes-base%)) + (define editor-stream-out + (make-object editor-stream-out% editor-stream-out-bytes-base)) + (write-editor-global-header editor-stream-out) + (send text write-to-file editor-stream-out) + (write-editor-global-footer editor-stream-out) + (send editor-stream-out-bytes-base get-bytes)) +] + }} diff --git a/gui-doc/scribblings/gui/editor-overview.scrbl b/gui-doc/scribblings/gui/editor-overview.scrbl index 4a9b4e083..dc4df8ba5 100644 --- a/gui-doc/scribblings/gui/editor-overview.scrbl +++ b/gui-doc/scribblings/gui/editor-overview.scrbl @@ -225,6 +225,34 @@ When an editor is drawn into a display, each snip and position has a editor. Locations in an editor are only meaningful when the editor is displayed. +@subsection[#:tag "graphemes"]{Characters and Graphemes} + +An @tech{item} corresponds to a Racket + character in an editor with text. Some things that a user would + perceive as a character are composed of multiple Racket characters, + however, such as a pirate-flag emoji (which uses a four-character + encoding) or ``e'' plus an accent modifier (which also has a single + character representation, but might be represented through those two + characters). A @deftech{grapheme} is an approximation to a + user-perceived character as defined by the Unicode grapheme-cluster + specification. Racket provides support for graphemes though functions like + @racket[string-grapheme-count] and @racket[char-grapheme-step]. + +Working with graphemes in a text editor requires extra care. Methods + like @xmethod[text% grapheme-position] and @xmethod[text% + position-grapheme] convert between item and grapheme indices, but + most operations are based in item positions, and they are generally + not constrained to preserve grapheme-cluster sequences. A grapheme + cluster that is within a single snip will render as a single + grapheme, but a grapheme cluster that spans a snip boundary will be + rendered as two partial graphemes. The @xmethod[text% insert] method + takes optional arguments to trigger the detection of grapheme + sequences that would span the existing and inserted content and + ensure that the sequences are kept together. + +A small number of @racket[text%] methods are grapheme-sensitive by + default: @method[text% delete], @method[text% insert] of a character, + and @method[text% move-position]. @subsection[#:tag "editoradministrators"]{Administrators} @@ -777,7 +805,7 @@ Thus, disabling an @racket[editor-canvas%] object (using A second supported pattern is reading an editor in a background thread while the editor may be manipulated in other threads. Since no - @techlink{location}-independent reads introduce locks, the such reads in + @techlink{location}-independent reads introduce locks, such reads in the background thread will not impair other threads. However, other threads may interfere with the background thread, causing it to receive erroneous or out-of-date content information. This one-sided diff --git a/gui-doc/scribblings/gui/editor-stream-in-class.scrbl b/gui-doc/scribblings/gui/editor-stream-in-class.scrbl index d81676183..d9d60f1d4 100644 --- a/gui-doc/scribblings/gui/editor-stream-in-class.scrbl +++ b/gui-doc/scribblings/gui/editor-stream-in-class.scrbl @@ -45,9 +45,12 @@ Like @method[editor-stream-in% get-unterminated-bytes], but the last } @defmethod[(get-exact) - exact-integer?]{ + (or/c exact-integer? (and/c real? inexact?))]{ -Returns the next integer value in the stream. + Returns the next number value in the stream. Despite the + name, this method may return an inexact number, but only if + the next element in the stream was actually written as an + inexact number. } diff --git a/gui-doc/scribblings/gui/event-class.scrbl b/gui-doc/scribblings/gui/event-class.scrbl index f741f0808..d0592791a 100644 --- a/gui-doc/scribblings/gui/event-class.scrbl +++ b/gui-doc/scribblings/gui/event-class.scrbl @@ -3,9 +3,6 @@ @title[#:style 'hidden]{@racket[event%]} -The bindings documented in this section are also provided by the -@racketmodname[racket/gui/base] library. - @declare-exporting[racket/gui/event racket/gui/base racket/gui @@ -13,6 +10,13 @@ The bindings documented in this section are also provided by the @defmodule*/no-declare[(racket/gui/event)] +The bindings documented in this section are also provided by the +@racketmodname[racket/gui/base] library. + +@history[#:changed "7.3.0.1" @elem{Added @racketmodname[racket/gui/event] + that exports @racket[event%] and + subclasses.}] + @defclass[event% object% ()]{ An @racket[event%] object contains information about a control, @@ -22,33 +26,31 @@ keyboard, mouse, or scroll event. See also @racket[mouse-event%], and @racket[scroll-event%]. - @defconstructor[([time-stamp exact-integer? 0])]{ See @method[event% get-time-stamp] for information about - @racket[time-stamp]. + @racket[time-stamp].} -} @defmethod[(get-time-stamp) exact-integer?]{ -Returns the time, in milliseconds, when the event occurred. This time - is compatible with times reported by Racket's - @racket[current-milliseconds] procedure. +Returns a time, in milliseconds, when the event occurred. + +This time is @emph{not} necessarily compatible with times reported by + Racket's @racket[current-milliseconds] procedure. It may be based on + milliseconds since the system was rebooted. It may also ``wrap + around'' (instead of always increasing) due to the system's + representation of time.} -} @defmethod[(set-time-stamp [time exact-integer?]) void?]{ -Set the time, in milliseconds, when the event occurred. See also - Racket's @racket[current-milliseconds]. +Set a time, in milliseconds, when the event occurred. See also + @method[event% get-time-stamp]. If the supplied value is outside the platform-specific range of time values, @|MismatchExn|. -} - - @history[#:changed "7.3.0.1" @elem{Added @racketmodname[racket/gui/event] - that also exports @racket[event%] and subclasses.}]} +}} diff --git a/gui-doc/scribblings/gui/frame-class.scrbl b/gui-doc/scribblings/gui/frame-class.scrbl index 582eb36b3..45d0896a5 100644 --- a/gui-doc/scribblings/gui/frame-class.scrbl +++ b/gui-doc/scribblings/gui/frame-class.scrbl @@ -8,7 +8,7 @@ A frame is a top-level container window. It has a title bar (which status line. @defconstructor[([label label-string?] - [parent (or/c (is-a?/c frame%) #f) #f] + [parent (or/c (is-a?/c frame%) (is-a?/c dialog) #f) #f] [width (or/c dimension-integer? #f) #f] [height (or/c dimension-integer? #f) #f] [x (or/c position-integer? #f) #f] @@ -34,7 +34,7 @@ bar. If the frame's label is changed (see @method[window<%> set-label]), the title bar is updated. The @racket[parent] argument can be @racket[#f] or an existing -frame. On Windows, if @racket[parent] is an existing frame, +frame or dialog. On Windows, if @racket[parent] is not @racket[#f], the new frame is always on top of its parent. On Windows and Unix (for many window managers), a frame is iconized when its parent is iconized. @@ -102,9 +102,11 @@ Even if the frame is not shown, a few notification events may be @WindowKWs[@racket[enabled]] @AreaContKWs[] @AreaKWs[] -@history[#:changed "6.0.0.6" @elem{Added @racket['fullscreen-button] - and @racket['fullscreen-aux] options - for @racket[style].}] +@history[#:changed "1.1" @elem{Added @racket['fullscreen-button] + and @racket['fullscreen-aux] options + for @racket[style].} + #:changed "1.66" @elem{Allow a @racket[dialog%] instance + as @racket[parent].}] } diff --git a/gui-doc/scribblings/gui/init.scrbl b/gui-doc/scribblings/gui/init.scrbl index ba91a51fc..a244431d9 100644 --- a/gui-doc/scribblings/gui/init.scrbl +++ b/gui-doc/scribblings/gui/init.scrbl @@ -25,6 +25,6 @@ library for GRacket. It re-exports the @racketmodname[racket/init] and the users home directory if it exists, rather than their @racket[(find-system-path 'init-file)]. Unlike @racketmodname[racket/interactive], this library does not - start @racketmodname[xrepl]. + start @racketmodname[xrepl #:indirect]. @history[#:added "1.27"]} diff --git a/gui-doc/scribblings/gui/list-box-class.scrbl b/gui-doc/scribblings/gui/list-box-class.scrbl index b027194cd..564374206 100644 --- a/gui-doc/scribblings/gui/list-box-class.scrbl +++ b/gui-doc/scribblings/gui/list-box-class.scrbl @@ -81,7 +81,9 @@ The @racket[columns] list determines the number of columns in the list also includes @racket['clickable-headers], then a click on a header triggers a call to @racket[callback] with a @racket[column-control-event%] argument whose event type is - @indexed-racket['list-box-column]. + @indexed-racket['list-box-column]; for historical reasons, + @racket['clickable-headers] has no effect on Windows and + header clicks are always reported. The @racket[style] specification must include exactly one of the following: diff --git a/gui-doc/scribblings/gui/message-class.scrbl b/gui-doc/scribblings/gui/message-class.scrbl index b28cacf96..2474b285f 100644 --- a/gui-doc/scribblings/gui/message-class.scrbl +++ b/gui-doc/scribblings/gui/message-class.scrbl @@ -10,12 +10,13 @@ A message control is a static line of text or a static bitmap. The @method[message% set-label]). -@defconstructor[([label (or/c label-string? (is-a?/c bitmap%) +@defconstructor[([label (or/c label-string? (is-a?/c bitmap%) (or/c 'app 'caution 'stop))] - [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) + [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) (is-a?/c panel%) (is-a?/c pane%))] [style (listof (or/c 'deleted)) null] [font (is-a?/c font%) normal-control-font] + [color (or/c #f string? (is-a?/c color%)) #f] [enabled any/c #t] [vert-margin spacing-integer? 2] [horiz-margin spacing-integer? 2] @@ -39,11 +40,20 @@ Creates a string or bitmap message initially showing @racket[label]. @FontKWs[@racket[font]] @WindowKWs[@racket[enabled]] @SubareaKWs[] @AreaKWs[] +The @racket[color] argument determines the color of the text label. It +has no effect on symbol and bitmap labels. If it is @racket[#f], the +system default text color is used. If it is a string, then the color +is looked up in @racket[the-color-database]. + If @racket[auto-resize] is not @racket[#f], then automatic resizing is initially enabled (see @method[message% auto-resize]), and the @racket[message%] object's @tech{graphical minimum size} is as small as possible. +@history[ + #:changed "1.58" @elem{Added the @racket[color] argument.} +] + } @defmethod*[([(auto-resize) boolean?] @@ -65,5 +75,25 @@ The same as @xmethod[window<%> set-label] when @racket[label] is a Otherwise, sets the bitmap label for a bitmap message. @bitmaplabeluseisbm[label] @|bitmapiforiglabel| -}} +} + +@defmethod*[([(set-color [color (or/c #f (is-a?/c color%))]) void?] + [(set-color [color-name string?]) void?])]{ + Sets the label's text color. When @racket[color] is @racket[#f], sets + the label's text color to the platform default. This method has no + effect if the label is a symbol or a bitmap. + + @history[ + #:added "1.58" + #:changed "1.71" @elem{Added support for setting the color to the system default.} + ] +} + +@defmethod[(get-color) (or/c #f (is-a?/c color%))]{ + Returns the current user-specified label color or @racket[#f] if the + system default is used. + @history[#:added "1.58"] +} + +} diff --git a/gui-doc/scribblings/gui/miscwin-funcs.scrbl b/gui-doc/scribblings/gui/miscwin-funcs.scrbl index faaf41c10..d7070c9ae 100644 --- a/gui-doc/scribblings/gui/miscwin-funcs.scrbl +++ b/gui-doc/scribblings/gui/miscwin-funcs.scrbl @@ -355,7 +355,7 @@ On Mac OS, Quicktime is used to play sounds; most sound with OS 7.5 and up) is required. On Unix, the function invokes an external sound-playing program---looking - by default for a few known programs (@exec{aplay}, @exec{play}, + by default for a few known programs (@exec{paplay}, @exec{aplay}, @exec{play}, @exec{esdplay}, @exec{sndfile-play}, @exec{audioplay}). A play command can be defined through the @ResourceFirst{playcmd} preference (see @|mrprefsdiscuss|). The preference can hold a diff --git a/gui-doc/scribblings/gui/mouse-event-class.scrbl b/gui-doc/scribblings/gui/mouse-event-class.scrbl index c76458013..fe472877e 100644 --- a/gui-doc/scribblings/gui/mouse-event-class.scrbl +++ b/gui-doc/scribblings/gui/mouse-event-class.scrbl @@ -59,20 +59,24 @@ See the corresponding @racketidfont{get-} and @racketidfont{set-} @defmethod[(button-changed? [button (or/c 'left 'middle 'right 'any) 'any]) boolean?]{ -Returns @racket[#t] if this was a mouse button press or release event, +Returns @racket[#t] if this was a mouse button press or release event + (i.e., type @racket['left-down], @racket['left-up], + @racket['middle-down], @racket['middle-up], + @racket['right-down], or @racket['right-up]), @racket[#f] otherwise. See also @method[mouse-event% button-up?] and @method[mouse-event% button-down?]. If @racket[button] is not @racket['any], then @racket[#t] is only returned - if it is a release event for a specific button. + if it is a press or release event for a specific button. } @defmethod[(button-down? [button (or/c 'left 'middle 'right 'any) 'any]) boolean?]{ -Returns @racket[#t] if the event is for a button press, @racket[#f] +Returns @racket[#t] if the event is for a button press (i.e., type @racket['left-down], + @racket['middle-down], or @racket['right-down]), @racket[#f] otherwise. If @racket[button] is not @racket['any], then @racket[#t] is only returned @@ -83,7 +87,8 @@ If @racket[button] is not @racket['any], then @racket[#t] is only returned @defmethod[(button-up? [button (or/c 'left 'middle 'right 'any) 'any]) boolean?]{ -Returns @racket[#t] if the event is for a button release, @racket[#f] +Returns @racket[#t] if the event is for a button release (i.e., type @racket['left-up], + @racket['middle-up], or @racket['right-up]), @racket[#f] otherwise. (As noted in @|mousekeydiscuss|, button release events are sometimes dropped.) @@ -95,15 +100,18 @@ If @racket[button] is not @racket['any], then @racket[#t] is only returned @defmethod[(dragging?) boolean?]{ -Returns @racket[#t] if this was a dragging event (motion while a button - is pressed), @racket[#f] otherwise. +Returns @racket[#t] if this was a dragging event: type @racket['motion] while a button + is pressed (as reported by @method[mouse-event get-left-down], + @method[mouse-event get-middle-down], or + or @method[mouse-event get-right-down]), @racket[#f] otherwise. } @defmethod[(entering?) boolean?]{ -Returns @racket[#t] if this event is for the mouse entering a window, +Returns @racket[#t] if this event is for the mouse entering a window + (i.e., type @racket['enter]), @racket[#f] otherwise. When the mouse button is up, an enter/leave event notifies a window @@ -235,7 +243,8 @@ Returns the y-position of the mouse at the time of the event in the @defmethod[(leaving?) boolean?]{ -Returns @racket[#t] if this event is for the mouse leaving a window, +Returns @racket[#t] if this event is for the mouse leaving a window + (i.e., type @racket['leave]), @racket[#f] otherwise. See @method[mouse-event% entering?] for information about enter and @@ -246,8 +255,8 @@ leave events while the mouse button is clicked. @defmethod[(moving?) boolean?]{ -Returns @racket[#t] if this was a moving event (whether a button is - pressed is not), @racket[#f] otherwise. +Returns @racket[#t] if this was a moving event (i.e., type @racket['motion]), + @racket[#f] otherwise. } diff --git a/gui-doc/scribblings/gui/mult-color-intf.scrbl b/gui-doc/scribblings/gui/mult-color-intf.scrbl index 869258454..60216dd28 100644 --- a/gui-doc/scribblings/gui/mult-color-intf.scrbl +++ b/gui-doc/scribblings/gui/mult-color-intf.scrbl @@ -14,7 +14,8 @@ See also @method[style-delta% get-foreground-mult] and @defmethod[(get [r (box/c real?)] [g (box/c real?)] - [b (box/c real?)]) + [b (box/c real?)] + [a (or/c (box/c real?) #f) #f]) void?]{ Gets all of the scaling values. @@ -22,8 +23,17 @@ Gets all of the scaling values. @boxisfill[@racket[r] @elem{the scaling value for the red component of the color}] @boxisfill[@racket[g] @elem{the scaling value for the green component of the color}] @boxisfill[@racket[b] @elem{the scaling value for the blue component of the color}] +@boxisfillnull[@racket[a] @elem{the scaling value for the alpha component of the color}] + +@history[#:changed "1.63" @elem{Added the @racket[a] optional argument.}]} + +@defmethod[(get-a) + real?]{ + +Gets the multiplicative scaling value for the alpha component of the color. + +@history[#:added "1.63"]} -} @defmethod[(get-b) real?]{ @@ -48,12 +58,20 @@ Gets the multiplicative scaling value for the red component of the color. @defmethod[(set [r real?] [g real?] - [b real?]) + [b real?] + [a real? 1.0]) void?]{ Sets all of the scaling values. -} +@history[#:changed "1.63" @elem{Added the @racket[a] optional argument.}]} + +@defmethod[(set-a [v real?]) + void?]{ + +Sets the multiplicative scaling value for the alpha component of the color. + +@history[#:added "1.63"]} @defmethod[(set-b [v real?]) void?]{ diff --git a/gui-doc/scribblings/gui/pasteboard-class.scrbl b/gui-doc/scribblings/gui/pasteboard-class.scrbl index 788cc79c8..ee4c15e23 100644 --- a/gui-doc/scribblings/gui/pasteboard-class.scrbl +++ b/gui-doc/scribblings/gui/pasteboard-class.scrbl @@ -682,7 +682,7 @@ Inserts @racket[snip] at @techlink{location} @math{(@racket[x], @racket[before]. (@|seesniporderdiscuss|) If @racket[before] is not provided or is @racket[#f], then @racket[snip] is inserted behind all other snips. If @racket[x] and @racket[y] are not provided, the snip - is added at @math{(0, 0)}. + is added at the center of the pasteboard. } diff --git a/gui-doc/scribblings/gui/slider-class.scrbl b/gui-doc/scribblings/gui/slider-class.scrbl index a851d8123..9e06bd4d4 100644 --- a/gui-doc/scribblings/gui/slider-class.scrbl +++ b/gui-doc/scribblings/gui/slider-class.scrbl @@ -23,7 +23,7 @@ Whenever the user changes the value of a slider, its callback (is-a?/c panel%) (is-a?/c pane%))] [callback ((is-a?/c slider%) (is-a?/c control-event%) . -> . any) (lambda (b e) (void))] [init-value position-integer? min-value] - [style (listof (or/c 'horizontal 'vertical 'plain + [style (listof (or/c 'horizontal 'vertical 'upward 'plain 'vertical-label 'horizontal-label 'deleted)) '(horizontal)] @@ -44,21 +44,25 @@ If @racket[label] is a string, it is used as the label for the slider. The @racket[min-value] and @racket[max-value] arguments specify the range of the slider, inclusive. The @racket[init-value] argument - optionally specifies the slider's initial value. If the sequence - [@racket[min-value], @racket[initial-value], @racket[maximum-value]] - is not increasing, @|MismatchExn|. + optionally specifies the slider's initial value. The sequence + [@racket[min-value], @racket[init-value], @racket[max-value]] + must be non-decreasing. Otherwise, @|MismatchExn|. The @racket[callback] procedure is called (with the event type @indexed-racket['slider]) when the user changes the slider's value. -The @racket[style] argument must include either @racket['vertical] for - a vertical slider, or @racket['horizontal] for a horizontal - slider. If @racket[style] includes @racket['plain], the slider does +The @racket[style] argument must include either @racket['horizontal] for a horizontal + slider going left-to-right, @racket['upward] for + a vertical slider going up, or @racket['vertical] for + a vertical slider going down (but beware that @racket['vertical] might render + with misleading colors on Mac OS, where the system toolkit supports only upward sliders). + If @racket[style] includes @racket['plain], the slider does not display numbers for its range and current value to the user. @HVLabelNote[@racket[style]]{slider} @DeletedStyleNote[@racket[style] @racket[parent]]{slider} @FontKWs[@racket[font]] @WindowKWs[@racket[enabled]] @SubareaKWs[] @AreaKWs[] +@history[#:changed "1.73" @elem{Added @racket['upward] as a possible @racket[style] element.}] } diff --git a/gui-doc/scribblings/gui/snip-class.scrbl b/gui-doc/scribblings/gui/snip-class.scrbl index f0dadaf09..c91bf4495 100644 --- a/gui-doc/scribblings/gui/snip-class.scrbl +++ b/gui-doc/scribblings/gui/snip-class.scrbl @@ -206,13 +206,36 @@ Returns the administrator for this snip. (The administrator can be } @defmethod[(get-count) - (integer-in 0 100000)]{ + exact-nonnegative-integer?]{ Returns the snip's @techlink{count} (i.e., number of @techlink{item}s within the snip). } +@defmethod[(get-grapheme-count) + exact-nonnegative-integer?]{ + +Returns the number of @techlink{graphemes} in the snip, which is +usually the same result as @method[snip<%> get-count], but can be +smaller with multiple consecutive @tech{items} form a grapheme. + +@history[#:added "1.4"]} + + +@defmethod[(grapheme-position [n exact-nonnegative-integer?]) + exact-nonnegative-integer?]{ + +Returns the number of @tech{items} in the snip that form the first +@racket[n] @tech{graphemes}; or, equivalently, converts from an +@tech{grapheme}-based position to a @tech{item}-based position. + +When @method[snip<%> get-count] is the same as @method[snip<%> +get-grapheme-count], this method returns @racket[n]. + +@history[#:added "1.4"]} + + @defmethod[(get-extent [dc (is-a?/c dc<%>)] [x real?] [y real?] @@ -619,6 +642,19 @@ Does nothing. }} +@defmethod[(position-grapheme [n exact-nonnegative-integer?]) + exact-nonnegative-integer?]{ + +Returns the number of @tech{graphemes} within the snip formed by the +first @racket[n] @tech{items}; or, equivalently, converts from an +@tech{item}-based position to a @tech{grapheme}-based position. + +When @method[snip<%> get-count] is the same as @method[snip<%> +get-grapheme-count], this method returns @racket[n]. + +@history[#:added "1.4"]} + + @defmethod[(partial-offset [dc (is-a?/c dc<%>)] [x real?] [y real?] @@ -720,10 +756,12 @@ The snip's (new) editor is usually internally locked for reading when @methspec{ Sets the snip's @techlink{count} (i.e., the number of @techlink{item}s - within the snip). + within the snip) to @racket[(max 1 c)]. The snip's @tech{grapheme} count is + set to be equal to its character count. -The snip's @techlink{count} may be changed by the system (in extreme cases to - maintain consistency) without calling this method. +The snip's @techlink{count} may be changed by the system (in extreme + cases to maintain consistency) without calling this method or + @method[snip% set-char-and-grapheme-count]. } @methimpl{ @@ -733,6 +771,26 @@ Sets the snip's @techlink{count} and notifies the snip's administrator }} +@defmethod[(set-char-and-grapheme-count [char-c exact-nonnegative-integer?] + [grapheme-c exact-nonnegative-integer?]) + void?]{ +@methspec{ + +Sets the snip's @techlink{count} to @racket[(max 1 char-c)] and its + @tech{grapheme} count to @racket[(max 1 grapheme-c)]. + + The snip's @techlink{count} may be changed by the system (in extreme cases to + maintain consistency) without calling this method or @method[snip% set-count]. + +} +@methimpl{ + Sets the snip's @techlink{count} and notifies the snip's administrator + that the snip's size has changed. + +} + +@history[#:added "1.4"]} + @defmethod[(set-flags [flags (listof symbol?)]) void?]{ diff --git a/gui-doc/scribblings/gui/startup.scrbl b/gui-doc/scribblings/gui/startup.scrbl index 1e3138dcb..6db6fcd26 100644 --- a/gui-doc/scribblings/gui/startup.scrbl +++ b/gui-doc/scribblings/gui/startup.scrbl @@ -1,7 +1,7 @@ #lang scribble/doc @(require "common.rkt" (for-label racket/gui/dynamic)) -@title{Startup Actions} +@title[#:tag "Startup_Actions"]{Startup Actions} The @racketmodname[racket/gui/base] module can be instantiated only once per operating-system process, because it sets hooks in the Racket @@ -11,7 +11,7 @@ exception. Furthermore, on Mac OS, the sole instantiation of @racketmodname[racket/gui/base] must be in the process's original @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{place}. -Loading @racketmodname[racket/gui/base] sets two parameters: +Instantiating @racketmodname[racket/gui/base] sets two parameters: @itemlist[ @@ -36,3 +36,6 @@ Loading @racketmodname[racket/gui/base] sets two parameters: ] +The thread where @racketmodname[racket/gui/base] is instantiated also +becomes the @tech{handler thread} for the initial eventspace. See also +@secref["espacethreads"]. diff --git a/gui-doc/scribblings/gui/style-delta-class.scrbl b/gui-doc/scribblings/gui/style-delta-class.scrbl index c408aba77..77f8dae38 100644 --- a/gui-doc/scribblings/gui/style-delta-class.scrbl +++ b/gui-doc/scribblings/gui/style-delta-class.scrbl @@ -147,7 +147,7 @@ The family and face settings in a style delta are interdependent: ([change-command (or/c 'change-size 'change-bigger 'change-smaller)] - [v byte?]) + [v exact-integer?]) ([change-command (or/c 'change-underline 'change-size-in-pixels)] [v any/c]))]{ diff --git a/gui-doc/scribblings/gui/style-list-class.scrbl b/gui-doc/scribblings/gui/style-list-class.scrbl index fc7724447..d8050fdb3 100644 --- a/gui-doc/scribblings/gui/style-list-class.scrbl +++ b/gui-doc/scribblings/gui/style-list-class.scrbl @@ -148,6 +148,28 @@ The callback @racket[f] replaces any callback for which it is retained as long as the opaque key produced by @method[style-list% notify-on-change] is reachable.} + @defmethod[(begin-style-change-sequence) void?]{ + + Bracket changes to styles contained in a + @racket[style-list%] with + @method[style-list% begin-style-change-sequence] and + @method[style-list% end-style-change-sequence] to avoid extra work + during the style changes. + + Call to @method[style-list% begin-style-change-sequence] and + @method[style-list% end-style-change-sequence] can be nested + arbitrarily; changes to styles are not propagated to the + @racket[editor<%>]s that use this @racket[style-list%] until + the last call to @method[style-list% end-style-change-sequence] and + redundant calls are skipped at that point. + + @history[#:added "1.5"] + } + @defmethod[(end-style-change-sequence) void?]{ + Call to match calls to @method[style-list% begin-style-change-sequence]. + + @history[#:added "1.5"] + } @defmethod[(number) exact-nonnegative-integer?]{ diff --git a/gui-doc/scribblings/gui/system-menu-funcs.scrbl b/gui-doc/scribblings/gui/system-menu-funcs.scrbl index b1f069f4b..941a327ed 100644 --- a/gui-doc/scribblings/gui/system-menu-funcs.scrbl +++ b/gui-doc/scribblings/gui/system-menu-funcs.scrbl @@ -1,5 +1,6 @@ #lang scribble/doc -@(require "common.rkt") +@(require "common.rkt" + (for-label mrlib/panel-wob)) @title{System Menus} @@ -152,3 +153,22 @@ If the current eventspace is not the initial eventspace, this procedure returns @racket[void] (when called with zero arguments) or has no effect (when called with a handler). } + +@defproc*[([(application-dark-mode-handler) + (-> any)] + [(application-dark-mode-handler [handler-thunk (-> any)]) + void?])]{ + + When the current @tech{eventspace} is the initial + eventspace this procedure retrieves or installs a thunk that + is called under Mac OS when the OS switches to or from dark mode. + See also @racket[white-on-black-panel-scheme?]. + + The default handler does nothing. + + If the current eventspace is not the initial eventspace, + this procedure returns @racket[void] (when called with zero + arguments) or has no effect (when called with a handler). + + @history[#:added "1.68"] +} diff --git a/gui-doc/scribblings/gui/tab-panel-class.scrbl b/gui-doc/scribblings/gui/tab-panel-class.scrbl index 1ef1ce3be..79a661198 100644 --- a/gui-doc/scribblings/gui/tab-panel-class.scrbl +++ b/gui-doc/scribblings/gui/tab-panel-class.scrbl @@ -23,7 +23,10 @@ The @racket[tab-panel%] class does not implement the virtual [callback ((is-a?/c tab-panel%) (is-a?/c control-event%) . -> . any) (lambda (b e) (void))] - [style (listof (or/c 'no-border 'deleted)) null] + [style (listof (or/c 'no-border + 'can-reorder 'can-close 'new-button + 'flat-portable 'deleted)) + null] [font (is-a?/c font%) normal-control-font] [enabled any/c #t] [vert-margin spacing-integer? 0] @@ -49,13 +52,37 @@ The @racket[callback] procedure is called (with the event type @indexed-racket['tab-panel]) when the user changes the tab selection. If the @racket[style] list includes @racket['no-border], no border is - drawn around the panel content. @DeletedStyleNote[@racket[style] @racket[parent]]{tab panel} + drawn around the panel content. + If the @racket[style] list includes @racket['can-reorder], then the + user may be able to drag tabs to reorder them, in which case + @method[tab-panel% on-reorder] is called; reordering is always + enabled if @racket['no-border] is also included in @racket[style]. + If the @racket[style] list includes @racket['can-close], then the + user may be able to click a close icon for a tab, in which case + @method[tab-panel% on-close-request] is called; closing is always + enabled if @racket['no-border] is also included in @racket[style]. + If the @racket[style] list includes @racket['flat-portable] or if + the @indexed-envvar{PLT_FLAT_PORTABLE_TAB_PANEL} environment variable + is defined when @racketmodname[racket/gui] is loaded, and if the + style list also includes @racket['no-border], then a + platform-independent implementation is used for the tab control; + the @racket['flat-portable] flag is + effectively always included in @racket[style] on Windows if either + @racket['can-reorder] or @racket['can-close] is included. + If the @racket[style] list includes @racket['new-button] and the + platform-independent implementation is used for the tab control, + then a new tab button is added to the right of the last tab to allow + inserting new tabs. If the new tab button is clicked, + @method[tab-panel% on-new-request] is called. + @DeletedStyleNote[@racket[style] @racket[parent]]{tab panel} @FontKWs[@racket[font]] @WindowKWs[@racket[enabled]] @SubareaKWs[] @AreaKWs[] - - -} +@history[#:changed "1.55" @elem{Added the @racket['can-reorder] and + @racket['can-close] styles.} + #:changed "1.56" @elem{Added the @racket['flat-portable] style + with reordering and closing support on Windows.} + #:changed "1.62" @elem{Added the @racket['new-button] style.}]} @defmethod[(append [choice label-string?]) void?]{ @@ -100,6 +127,39 @@ Returns the index (counting from 0) of the currently selected tab. If } +@defmethod[#:mode pubment + (on-reorder [former-indices (listof exact-nonnegative-integer?)]) + void?]{ + +Called when the user reorders tabs by dragging, which is enabled where +available by including the @racket['can-reorder] style (possibly with +@racket['no-border]) when creating the panel. The +@racket[former-indices] list reports, for each new tab position, the +position where the tab was located before reordering. + +@history[#:added "1.55"]} + + +@defmethod[(on-close-request [index exact-nonnegative-integer?]) + void?]{ + +Called when the user clicks the close box in a tab, which is enabled +where available by including the @racket['can-close] style (possibly +with @racket['no-border]) when creating the panel. The @racket[index] +argument identifies the tab to potentially close. + +@history[#:added "1.55"]} + + +@defmethod[(on-new-request) + void?]{ + +Called when the user clicks the new tab button in a tab panel, which +is enabled where available by including the @racket['new-button] style. + +@history[#:added "1.62"]} + + @defmethod[(set [choices (listof label-string?)]) void?]{ diff --git a/gui-doc/scribblings/gui/text-class.scrbl b/gui-doc/scribblings/gui/text-class.scrbl index 5beac75de..bb074dcb8 100644 --- a/gui-doc/scribblings/gui/text-class.scrbl +++ b/gui-doc/scribblings/gui/text-class.scrbl @@ -415,7 +415,7 @@ See @|timediscuss| for a discussion of the @racket[time] argument. If Deletes the specified range or the currently selected text (when no range is provided) in the editor. If @racket[start] is @racket['start], then the starting selection @techlink{position} is - used; if @racket[end] is @racket['back], then only the character + used; if @racket[end] is @racket['back], then only the @tech{grapheme} preceding @racket[start] is deleted. If @racket[scroll-ok?] is not @racket[#f] and @racket[start] is the same as the current caret @techlink{position}, then the editor's @techlink{display} may be @@ -426,7 +426,9 @@ Deletes the specified range or the currently selected text (when no system in response to other method calls} @elem{@method[text% on-delete]} @elem{content deletion}] -} +@history[#:changed "1.67" @elem{Changed @racket['back] to delete a + grapheme instead of a character.}]} + @defmethod[(do-copy [start exact-nonnegative-integer?] [end exact-nonnegative-integer?] @@ -675,7 +677,8 @@ If @racket[case-sensitive?] is @racket[#f], then an uppercase and lowercase [start (or/c exact-nonnegative-integer? 'start) 'start] [end (or/c exact-nonnegative-integer? 'eof) 'eof] [get-start? any/c #t] - [case-sensitive? any/c #t]) + [case-sensitive? any/c #t] + [#:recur-inside? recur-inside? (-> (is-a?/c editor-snip%) any/c) (λ (x) #t)]) (or/c exact-nonnegative-integer? #f (cons/c @@ -690,6 +693,13 @@ If @racket[case-sensitive?] is @racket[#f], then an uppercase and lowercase are the editors on the path to the editor where the search string occurred and whose final @racket[cdr] position is the search result position. + + Each time an embedded editor is encountered, @racket[recur-inside?] is called + with the @racket[editor-snip%] object; if @racket[recur-inside?] returns + @racket[#false], results from that embedded editor (and editors embedded into it) + are skipped. + + @history[#:changed "1.80" @list{Added the @racket[recur-inside?] argument}] } @defmethod[(find-string-all [str non-empty-string?] @@ -711,7 +721,8 @@ Finds all occurrences of a string using @method[text% find-string]. If [start (or/c exact-nonnegative-integer? 'start) 'start] [end (or/c exact-nonnegative-integer? 'eof) 'eof] [get-start? any/c #t] - [case-sensitive any/c #t]) + [case-sensitive any/c #t] + [#:recur-inside? recur-inside? (-> (is-a?/c editor-snip%) any/c) (λ (x) #t)]) (listof (or/c exact-nonnegative-integer? (cons/c (is-a?/c editor<%>) @@ -720,9 +731,11 @@ Finds all occurrences of a string using @method[text% find-string]. If (or/c (cons/c (is-a?/c editor<%>) nested-editor-search-result) (listof exact-nonnegative-integer?))))))]{ -Like @method[text% find-string-embedded], but also searches in embedded -editors, returning search results a list of the editors that contain -the matches. +Like @method[text% find-string-all], but also searches in embedded +editors like @method[text% find-string-embedded], returning the search results +as a list of the editors that contain the matches. + +@history[#:changed "1.80" @list{Added the @racket[recur-inside?] argument}] } @defmethod[(find-wordbreak [start (or/c (box/c exact-nonnegative-integer?) #f)] @@ -1115,6 +1128,16 @@ Returns the wordbreaking map that is used by the standard wordbreaking } +@defmethod[(grapheme-position [n exact-nonnegative-integer?]) + exact-nonnegative-integer?]{ + +Returns the number of @tech{items} in the editor that form the first +@racket[n] @tech{graphemes}; or, equivalently, converts from an +@tech{grapheme}-based position to a @tech{item}-based position. + +@history[#:added "1.67"]} + + @defmethod[(hide-caret [hide? any/c]) void?]{ @@ -1134,20 +1157,23 @@ See also @method[text% caret-hidden?] and @method[editor<%> lock]. ([(insert [str string?] [start exact-nonnegative-integer?] [end (or/c exact-nonnegative-integer? 'same) 'same] - [scroll-ok? any/c #t]) + [scroll-ok? any/c #t] + [join-graphemes? any/c #f]) void?] [(insert [n (and/c exact-nonnegative-integer? (<=/c (string-length str)))] [str string?] [start exact-nonnegative-integer?] [end (or/c exact-nonnegative-integer? 'same) 'same] - [scroll-ok? any/c #t]) + [scroll-ok? any/c #t] + [join-graphemes? any/c #f]) void?] [(insert [str string?]) void?] [(insert [n (and/c exact-nonnegative-integer? (<=/c (string-length str)))] - [str string?]) + [str string?] + [join-graphemes? any/c #f]) void?] [(insert [snip (is-a?/c snip%)] [start exact-nonnegative-integer?] @@ -1194,6 +1220,18 @@ If @racket[scroll-ok?] is not @racket[#f] and @racket[start] is the editor's @techlink{display} is scrolled to show the new selection @techlink{position}. +If @racket[join-graphemes?] is provided and not @racket[#f] or if a + character is provided to insert, then if characters before or after + the inserted content would form a @tech{grapheme} that spans the + start or end of the inserted content, those characters are + effectively added to the start and end of the inserted content, and + the insertion range is adjusted to cover the absorbed characters. As + a result, the grapheme-forming characters will be reliably placed in + the same @tech{snip} so that the grapheme renders properly. That + adjustment may effectively change the @tech{style} of the inserted + content or of existing content that is involved with newly formed + grapheme clusters + See also @method[text% get-styles-sticky]. } @@ -1376,7 +1414,7 @@ If @racket[extend?] is not @racket[#f], the selection range is The possible values for @racket[kind] are: @itemize[ -@item{@racket['simple] --- move one item or line} +@item{@racket['simple] --- move one @tech{grapheme} or line} @item{@racket['word] --- works with @racket['right] or @racket['left]} @item{@racket['page] --- works with @racket['up] or @racket['down]} @item{@racket['line] --- works with @racket['right] or @racket['left]; moves to the start or end of the line} @@ -1384,7 +1422,8 @@ The possible values for @racket[kind] are: See also @method[text% set-position]. -} +@history[#:changed "1.67" @elem{Changed @racket['simple] mode to move + left or right by a grapheme instead of an item.}]} @defmethod[#:mode pubment @@ -1430,14 +1469,15 @@ Handles the following: @item{Any other character in the range @racket[(integer->char 32)] to @racket[(integer->char 255)] --- inserts the character into the - editor.} + editor (in @tech{grapheme}-joining mode; see @method[text% insert]).} ] Note that an editor's @racket[editor-canvas%] normally handles mouse wheel events (see also @method[editor-canvas% on-char] ). -} +@history[#:changed "1.67" @elem{Changed character inserting to use + grapheme-joining mode.}]} @defmethod[#:mode override @@ -1713,6 +1753,17 @@ See @|timediscuss| for a discussion of the @racket[time] argument. If } + +@defmethod[(position-grapheme [n exact-nonnegative-integer?]) + exact-nonnegative-integer?]{ + +Returns the number of @tech{graphemes} within the editor formed by the +first @racket[n] @tech{items}; or, equivalently, converts from an +@tech{item}-based position to a @tech{grapheme}-based position. + +@history[#:added "1.67"]} + + @defmethod[(position-line [start exact-nonnegative-integer?] [at-eol? any/c #f]) exact-nonnegative-integer?]{ diff --git a/gui-doc/scribblings/gui/win-overview.scrbl b/gui-doc/scribblings/gui/win-overview.scrbl index 886883232..c09be7c8e 100644 --- a/gui-doc/scribblings/gui/win-overview.scrbl +++ b/gui-doc/scribblings/gui/win-overview.scrbl @@ -818,7 +818,7 @@ An @deftech{eventspace} is a context for processing GUI all windows when a modal dialog is shown.) -@subsection{Event Types and Priorities} +@subsection[#:tag "Event_Types_and_Priorities"]{Event Types and Priorities} @section-index["events" "timer"] @section-index["events" "explicitly queued"] @@ -875,7 +875,12 @@ Although a programmer has no direct control over the order in which @subsection[#:tag "espacethreads"]{Eventspaces and Threads} When a new eventspace is created, a corresponding @tech{handler - thread} is created for the eventspace. When the system dispatches an + thread} is created for the eventspace. The initial eventspace does + not create a new handler thread, but instead uses the thread where + @racketmodname[racket/gui/base] is instantiated as the initial + eventspace's handler thread; see also @secref["Startup_Actions"]. + +When the system dispatches an event for an eventspace, it always does so in the eventspace's handler thread. A handler procedure can create new threads that run indefinitely, but as long as the handler thread is running a handler @@ -891,6 +896,30 @@ When a handler thread shows a dialog, the dialog's @method[dialog% semaphore from a non-handler thread is equivalent to calling @racket[semaphore-wait]. +Windowing functions and methods from @racketmodname[racket/gui/base] + can be called in any thread, but beware of creating race conditions + among the threads or with the handler thread: + +@itemlist[ + + @item{Although graphical objects are thread-safe, callbacks or other + event handlers might see changing object states if graphical + elements are manipulated in multiple threads.} + + @item{Editor classes have specific threading constraints. See + @secref["editorthreads"].} + +] + +Because it's easy to create confusing race conditions by manipulating +GUI elements in a non-handler thread (while callbacks might run in the +handler thread), it's best to instead perform all GUI setup and +manipulations in the handler thread. The @racket[queue-callback] +function can be helpful to schedule work in the handler thread from +any other thread. When already running in the handler thread, use +@racket[yield] to wait on non-GUI events while allowing GUI events to +proceed. + @subsection[#:tag "currenteventspace"]{Creating and Setting the Eventspace} @@ -916,7 +945,7 @@ When an eventspace is created, it is placed under the management of can-close?] or @xmethod[top-level-window<%> on-close]), all timers in the eventspace are stopped, and all enqueued callbacks are removed. Attempting to create a new window, timer, or explicitly - queued event in a shut-down eventspace raises the @racket[exn:misc] + queued event in a shut-down eventspace raises the @racket[exn:fail] exception. An eventspace is a @techlink[#:doc reference-doc]{synchronizable @@ -924,8 +953,12 @@ An eventspace is a @techlink[#:doc reference-doc]{synchronizable @racket[sync]. As a synchronizable event, an eventspace is in a blocking state when a frame is visible, a timer is active, a callback is queued, or a @racket[menu-bar%] is created with a @racket['root] - parent. (Note that the blocking state of an eventspace is unrelated - to whether an event is ready for dispatching.) + parent. Note that the blocking state of an eventspace is unrelated to + whether an event is ready for dispatching. Note also that an + eventspace is not necessarily in a blocking state while an event is + being handled, timer is firing, or callback is being run, and an + eventspace may be left in a block state if its @tech{handler thread} + has terminated. @subsection[#:tag "evtcontjump"]{Continuations and Event Dispatch} diff --git a/gui-doc/scribblings/gui/window-intf.scrbl b/gui-doc/scribblings/gui/window-intf.scrbl index fe1a2ce75..0a8819458 100644 --- a/gui-doc/scribblings/gui/window-intf.scrbl +++ b/gui-doc/scribblings/gui/window-intf.scrbl @@ -468,6 +468,19 @@ Does nothing. }} + @defmethod[(on-superwindow-activate [active? any/c]) + void?]{ + @methspec{ + Called via the event queue whenever the containing @racket[top-level-window<%>] + is either activated or deactivated (see @method[top-level-window<%> on-activate]). + } + + @methimpl{ + Does nothing. + } + @history[#:added "1.54"] + } + @defmethod[(on-superwindow-enable [enabled? any/c]) void?]{ @@ -539,7 +552,9 @@ The @racket[menu] is popped up within the window at position @defmethod[(refresh) void?]{ -Enqueues an event to repaint the window. +Enqueues a window-refresh event to repaint the window; see +@secref["Event_Types_and_Priorities"] for more information +on the event's priority. } diff --git a/gui-doc/scribblings/gui/wxme.scrbl b/gui-doc/scribblings/gui/wxme.scrbl index ca4a3a7d5..76d92f11f 100644 --- a/gui-doc/scribblings/gui/wxme.scrbl +++ b/gui-doc/scribblings/gui/wxme.scrbl @@ -217,10 +217,11 @@ obtain the ``special'' result from the @tech{WXME}-decoding port.} Represents a @tech{WXME} input stream for use by @racket[snip-reader<%>] instances. -@defmethod[(read-integer [what any/c]) exact-integer?]{ +@defmethod[(read-integer [what any/c]) (or/c (integer-in (- (expt 2 31)) (expt 2 31)) + (and/c real? inexact?))]{ -Reads an exact integer, analogous to @method[editor-stream-in% -get-exact]. +Like @method[editor-stream-in% get-exact], returns either an +exact integer or an inexact real. The @racket[what] field describes what is being read, for error-message purposes, in case the stream does not continue with an diff --git a/gui-lib/framework/collapsed-snipclass-wxme.rkt b/gui-lib/framework/collapsed-snipclass-wxme.rkt index 24ed58799..2973c4830 100644 --- a/gui-lib/framework/collapsed-snipclass-wxme.rkt +++ b/gui-lib/framework/collapsed-snipclass-wxme.rkt @@ -1,11 +1,35 @@ #lang racket/base (require racket/class + racket/port wxme) (provide reader) (define what "collapsed-sexp") +(define collapsed-readable% + (class* object% (readable<%>) + (init-field snips/bytes) + (define/public (read-special source line column position) + (define-values (in out) (make-pipe-with-specials)) + (set-port-next-location! out line column position) + (thread + (λ () + (for ([snip/byte (in-list snips/bytes)]) + (cond + [(bytes? snip/byte) (write-bytes snip/byte out)] + [else + (define-values (line column position) (port-next-location out)) + (write-special (snip/byte source line column position) out)])) + (close-output-port out))) + ;; this datum->syntax and read is to match the one in + ;; the framework%'s sexp-snip%'s read-special method + (datum->syntax + #f + (read in) + (list source line column position 1))) + (super-new))) + (define reader (new (class* object% (snip-reader<%>) (define/public (read-header version stream) (void)) @@ -13,11 +37,24 @@ (define left (send stream read-bytes what)) (define right (send stream read-bytes what)) (define count (send stream read-integer what)) - (define snips - (for/list ([x (in-range 0 count)]) + (define all-bytes? #t) + (define snips/bytes + (for/list ([_ (in-range 0 count)]) (define snip-class-name (bytes->string/utf-8 (send stream read-bytes what))) - (read-snip-from-port snip-class-name - 'collapsed-snipclass-wxme.rkt - stream))) - (apply bytes-append snips)) + (define got + (read-snip-from-port snip-class-name + 'collapsed-snipclass-wxme.rkt + stream)) + (cond + [(bytes? got) got] + [text-only? + ;; here we just make an attempt to turn the special into + ;; something someone might recognize + (string->bytes/utf-8 (format "~s" got))] + [else + (set! all-bytes? #f) + got]))) + (cond + [all-bytes? (apply bytes-append snips/bytes)] + [else (new collapsed-readable% [snips/bytes snips/bytes])])) (super-new)))) diff --git a/gui-lib/framework/framework-unit.rkt b/gui-lib/framework/framework-unit.rkt index e88199c3f..9b58eef6a 100644 --- a/gui-lib/framework/framework-unit.rkt +++ b/gui-lib/framework/framework-unit.rkt @@ -7,6 +7,7 @@ "private/text-sig.rkt" "private/number-snip.rkt" "private/comment-box.rkt" + "private/srcloc-snip.rkt" "private/application.rkt" "private/version.rkt" "private/color-model.rkt" @@ -55,6 +56,7 @@ framework:color^ framework:color-prefs^ framework:comment-box^ + framework:srcloc-snip^ framework:finder^ framework:group^ framework:canvas^ @@ -67,7 +69,7 @@ preferences@ early-init@ application@ version@ color-model@ mode@ exit@ menu@ number-snip@ autosave@ path-utils@ icon@ keymap@ - editor@ pasteboard@ text@ color@ color-prefs@ comment-box@ + editor@ pasteboard@ text@ color@ color-prefs@ comment-box@ srcloc-snip@ finder@ group@ canvas@ panel@ frame@ handler@ racket@ main@)) (define-unit/new-import-export framework@ (import mred^) (export framework^) @@ -89,6 +91,7 @@ (prefix color: framework:color^) (prefix color-prefs: framework:color-prefs^) (prefix comment-box: framework:comment-box^) + (prefix srcloc-snip: framework:srcloc-snip^) (prefix finder: framework:finder^) (prefix group: framework:group^) (prefix canvas: framework:canvas^) diff --git a/gui-lib/framework/main.rkt b/gui-lib/framework/main.rkt index e52262cec..d5fe9ca2f 100644 --- a/gui-lib/framework/main.rkt +++ b/gui-lib/framework/main.rkt @@ -30,7 +30,8 @@ framework/private/decorated-editor-snip)) (require (for-doc racket/base scribble/manual framework/private/mapdesc - setup/getinfo racket/pretty string-constants)) + setup/getinfo racket/pretty string-constants + (for-label racket/file string-constants racket/pretty))) (provide-signature-elements (prefix application: framework:application-class^) @@ -51,6 +52,7 @@ (prefix color: framework:color-class^) (prefix color-prefs: framework:color-prefs-class^) (prefix comment-box: framework:comment-box-class^) + (prefix srcloc-snip: framework:srcloc-snip-class^) (prefix finder: framework:finder-class^) (prefix group: framework:group-class^) (prefix canvas: framework:canvas-class^) @@ -191,6 +193,49 @@ handling a few special cases for performance and backwards compatibility reasons.}) + (proc-doc/names + number-snip:number->string/snip + (->* (number?) + (#:exact-prefix (or/c 'always 'never 'when-necessary) + #:inexact-prefix (or/c 'always 'never 'when-necessary) + #:fraction-view (or/c #f 'mixed 'improper 'decimal)) + (or/c number-snip:is-number-snip? string?)) + ((num) ([exact-prefix 'never] [inexact-prefix 'never] [fraction-view #f])) + + @{For a number @racket[num], returns a @tech{number snip} or a + string according to the specified format arguments. + + The @racket[exact-prefix] argument specifies whether the representation + should carry a @litchar{#e} prefix: Always, never, or when necessary to + identify a representation that would otherwise be considered inexact. + + Similarly for @racket[inexact-prefix]. Note however that @racket['when-necessary] + is usually equivalent to @racket['never], as inexact numbers are always + printed with a decimal dot, which is sufficient to identify a number + representation as inexact. + + The @racket[fraction-view] field specifies how exact non-integer reals + - fractions - should be rendered: As a mixed fraction, an improper fraction, + or a decimal, possibly identifying periodic digits. For @racket['decimal], + if it's not possible to render the number as a decimal exactly, a fraction + representation might be generated. This is currently the case for complex + numbers. + + If @racket[fraction-view] is @racket[#f], this option comes from + the @racket['framework:fraction-snip-style] preference.}) + + (proc-doc/names + number-snip:make-pretty-print-size + (->* () + (#:exact-prefix (or/c 'always 'never 'when-necessary) + #:inexact-prefix (or/c 'always 'never 'when-necessary) + #:fraction-view (or/c #f 'mixed 'improper 'decimal)) + (number? boolean? output-port? . -> . exact-nonnegative-integer?)) + (() ([exact-prefix 'never] [inexact-prefix 'never] [fraction-view #f])) + @{This returns a procedure usable in a @racket[pretty-print-size-hook] implementation, + to go with @racket[number-snip:number->string/snip]. The arguments are as with + @racket[number-snip:number->string/snip].}) + (proc-doc/names number-snip:make-repeating-decimal-snip (-> real? boolean? number-snip:is-number-snip?) @@ -225,12 +270,32 @@ (-> number-snip:is-number-snip? real?) (ns) @{Returns the number that this @tech{number snip} displays.}) + + (proc-doc/names + number-snip:remove-decimal-looking-number-snips-on-insertion-mixin + (-> (subclass?/c text%) (subclass?/c text%)) + (text%) + @{Overrides the @method[text% on-insert] and + @method[text% after-insert] to replace @racket[number-snip%] + objects that look like ASCII with their corresponding ASCII + text.}) (thing-doc comment-box:snipclass (is-a?/c snip-class%) @{The @racket[snip-class%] object used by @racket[comment-box:snip%].}) + (thing-doc + srcloc-snip:snipclass + (is-a?/c snip-class%) + @{The @racket[snip-class%] object used by @racket[srcloc-snip:snip%].}) + + (proc-doc/names + srcloc-snip:select-srcloc + (srcloc? . -> . void?) + (srcloc) + @{Finds the editor containing the specified srcloc and selects it.}) + (proc-doc/names version:add-spec (any/c any/c . -> . void?) @@ -385,12 +450,39 @@ () @{Adds a font selection preferences panel to the preferences dialog.}) + (proc-doc/names + preferences:add-boolean-option-with-ask-me + (-> (or/c (is-a?/c area-container<%>) #f) + string? + string? + string? + symbol? + void?) + (parent label option1 option2 pref-key) + + @{Adds a checkbox to @racket[parent] with three options; the first two are given by @racket[option1] and @racket[option2], and +the third is "Ask me". The preference named by@racket[pref-key] is updated based on the selection in the checkbox. +}) + (proc-doc/names preferences:show-dialog (-> void?) () @{Shows the preferences dialog.}) + (proc-doc/names + preferences:show-tab-panel + (-> (listof string?) void) + (labels) + @{Shows the preferences dialog, making a particular panel visible. + The strings in the @racket[labels] argument control which one is visible. + + The strings in the @racket[labels] argument correspond to the strings passed to + @racket[preferences:add-panel]. + + @history[#:added "1.76"] + }) + (proc-doc/names preferences:hide-dialog (-> void?) @@ -467,13 +559,19 @@ (proc-doc/names autosave:restore-autosave-files/gui - (-> void?) - () + (->* () ((or/c #f (listof (list/c (or/c #f absolute-path?) absolute-path?)))) void?) + (() ((table #f))) @{Opens a GUI to ask the user about recovering any autosave files left around - from crashes and things. + from crashes or other catastrophic failures. + +If @racket[table] is not supplied, then the file in +@racket[autosave:current-toc-path] is consulted to find the files to restore. +If it is supplied, then it is used to find the files to recover. Each inner +list names the original file and the autosave file. If the original file +was never saved, then the first element of the list is @racket[#f]. This function doesn't return until the user has finished restoring the - autosave files. (It uses yield to handle events however.)}) + autosave files. It uses @racket[yield] to handle events, however.)}) (proc-doc/names exit:exiting? @@ -919,31 +1017,41 @@ (proc-doc/names handler:edit-file - (->* ((or/c path? false/c)) - ((-> (is-a?/c frame:editor<%>))) + (->* ((or/c path? symbol? #f)) + ((-> (is-a?/c frame:editor<%>)) + #:start-pos (or/c exact-nonnegative-integer? #f) + #:end-pos (or/c exact-nonnegative-integer? #f)) (or/c false/c (is-a?/c frame:editor<%>))) ((filename) ((make-default - (λ () ((handler:current-create-new-window) filename))))) + (λ () ((handler:current-create-new-window) (and (path? filename) filename)))) + (start-pos #f) + (end-pos start-pos))) @{This function invokes the appropriate format handler to open the file (see @racket[handler:insert-format-handler]). @itemize[ - @item{If @racket[filename] is a string, this function checks the result - of @racket[group:get-the-frame-group] to see if the + @item{If @racket[filename] is a string or a symbol, this function checks the result + of @racket[group:get-the-frame-group]'s @method[group:% locate-file] method to see if the @racket[filename] is already open by a frame in the group. @itemize[ @item{If so, it returns the frame.} - @item{If not, this function calls + @item{If not and if @racket[filename] is a string, this function calls @racket[handler:find-format-handler] with @racket[filename]. @itemize[ @item{If a handler is found, it is applied to @racket[filename] and its result is the final result.} - @item{If not, @racket[make-default] is used.}]}]} + @item{If not, @racket[make-default] is used.}]} + @item{If the file is not already open by a frame in the group + and if @racket[filename] is a symbol, + @racket[make-default] is used.}]} @item{If @racket[filename] is @racket[#f], @racket[make-default] is - used.}]}) + used.}] + +@history[#:changed "1.75" @list{generalized the @racket[filename] argument to allow + symbols and added the @racket[start-pos] and @racket[end-pos] arguments.}]}) (parameter-doc handler:current-create-new-window @@ -1009,6 +1117,20 @@ @{Sizes the @racket['framework:recently-opened-files/pos] preference list length to @racket[num].}) + (proc-doc/names + handler:update-currently-open-files + (-> void?) + () + + @{ +This is called when new files are opened or when files +are closed or when the frontmost window changes. As long as the app +is not currently exiting, it updates the +preference with the key @racket['framework:last-opened-files] to +hold a list of list of paths, to record the lists of files that +are currently open in tabs. +}) + (proc-doc/names icon:get-paren-highlight-bitmap (-> (is-a?/c bitmap%)) @@ -1512,6 +1634,13 @@ @racket[open-input-text-editor] and then uses @racket[read] to parse the range of the buffer.}) + (thing-doc + racket:default-paren-matches + (listof (list/c symbol? symbol?)) + @{The default parentheses that are matched when using @racket[racket:text-mode-mixin]. + + @history[#:added "1.60"]}) + (proc-doc/names racket:add-preferences-panel (-> void?) @@ -1522,7 +1651,70 @@ racket:get-keymap (-> (is-a?/c keymap%)) () - @{Returns a keymap with binding suitable for Racket.}) + @{Returns a keymap with binding suitable for Racket; the keymap + is created with @racket[racket:setup-keymap] where the @racket[_paren-keymap] + is not @racket[#f] but a keymap, and that keymap is added to the result of + this function via @method[keymap% chain-to-keymap]. The @racket[_paren-keymap] + argument is also the result of @racket[racket:get-paren-keymap].}) + + (proc-doc/names + racket:get-paren-keymap + (-> (is-a?/c keymap%)) + () + @{Returns a keymap with binding suitable for the parentheses keystrokes in Racket; the keymap + is created and passed to @racket[racket:setup-keymap] as the @racket[_paren-keymap] + argument. See also @racket[racket:get-keymap] + + @history[#:added "1.64"]}) + + (proc-doc/names + racket:get-non-paren-keymap + (-> (is-a?/c keymap%)) + () + @{Returns a keymap with all of the bindings in the keymap returned by + @racket[racket:get-keymap] except those in the keymap returned by + @racket[racket:get-paren-keymap] + + @history[#:added "1.64"]}) + + (proc-doc/names + racket:add-pairs-keybinding-functions + (-> (is-a?/c keymap%) void?) + (keymap) + @{Adds keybindings that are intended to be bound to parenthesis characters + to @racket[keymap]. See @racket[racket:setup-keymap] for more information. + + @history[#:added "1.64"]}) + + (proc-doc/names + racket:map-pairs-keybinding-functions + (->* ((is-a?/c keymap%) char? char?) + (#:alt-as-meta-keymap (or/c #f (is-a?/c keymap%))) + void?) + ((keymap open close) ([alt-as-meta-keymap #f])) + @{Binds a number of parenthesis-related keystrokes: + + @itemlist[ + @item{binds the keystroke of the character @racket[open] to + a function named @racket[(format "maybe-insert-~a~a-pair" open close)], unless @racket[open] is + @racket[#\[], in which case it is mapped to @racket["maybe-insert-[]-pair-maybe-fixup-[]"],} + @item{binds @racket[close] to @racket["balance-parens"] + unless @racket[open] and @racket[close] are the same character,} + @item{binds @racket[open] with the meta key modifier to @racket[(format "insert-~a~a-pair" open close)],} + @item{binds @racket[close] with the meta key modifier to + to @racket["balance-parens-forward"] unless the opening and closing characters are the same,} + @item{binds @racket[close], but with the prefix + @racket["~g:c:"] (e.g., @racket["~g:c:)"]) to the keystroke with the name + @racket[(format "non-clever-~a" close)], and} + @item{if @racket[open] is @racket[#\[], binds @racket["~g:c:["] to + @racket["non-clever-open-square-bracket"].}] + + If any of these functions are no present in @racket[keymap], they are also added to it. + + The @racket[alt-as-meta-keymap] argument is treated as + @racket[keymap:setup-global] treats it. + + @history[#:added "1.64"]}) (proc-doc/names racket:add-coloring-preferences-panel @@ -1586,14 +1778,31 @@ (proc-doc/names racket:setup-keymap (((is-a?/c keymap%)) - (#:alt-as-meta-keymap (or/c #f (is-a?/c keymap%))) + (#:alt-as-meta-keymap (or/c #f (is-a?/c keymap%)) + #:paren-keymap (or/c #f (is-a?/c keymap%)) + #:paren-alt-as-meta-keymap (or/c #f (is-a?/c keymap%))) . ->* . void?) - ((keymap) ([alt-as-meta-keymap #f])) - @{Initializes @racket[keymap] with Racket-mode keybindings. The - @racket[alt-as-meta-keymap] argument is treated the same as - for @racket[keymap:setup-global]. - - @history[#:changed "1.40" @elem{Added the @racket[#:alt-as-meta-keymap] argument.}]}) + ((keymap) ([alt-as-meta-keymap #f] [paren-keymap #f] [paren-alt-as-meta-keymap #f])) + @{Initializes @racket[keymap] with Racket-mode keybindings. + + The @racket[alt-as-meta-keymap] argument is treated the same as + for @racket[keymap:setup-global]. The + @racket[paren-alt-as-meta-keymap] argument is similar, but matched + up with @racket[paren-keymap] and used only when @racket[paren-keymap] + is not @racket[#f]. + + The @racket[paren-keymap] is + filled with the keybindings that are bound to parentheses in + the default racket keymap, which is done by calling + @racket[racket:map-pairs-keybinding-functions] with the keymap + and the characters @racket[#\[] and @racket[#\]], + @racket[#\(] and @racket[#\)], + @racket[#\{] and @racket[#\}], + @racket[#\|] and @racket[#\|], and + @racket[#\"] and @racket[#\"]. + + @history[#:changed "1.40" @elem{Added the @racket[#:alt-as-meta-keymap] argument.} + #:changed "1.64" @elem{Added the @racket[#:paren-keymap] and @racket[paren-alt-as-meta-keymap] arguments.}]}) (parameter-doc editor:doing-autosave? @@ -1602,6 +1811,24 @@ @{A parameter that indicates whether or not we are currently saving the editor because of an autosave. See also @method[editor:backup-autosave<%> do-autosave].}) + (parameter-doc + editor:silent-cancel-on-save-file-out-of-date? + (parameter/c boolean?) + autosaving? + @{A parameter that indicates how to handle the situation + where a save happens but the file saved on the disk is newer + than the last time this editor was saved. + + If @racket[editor:silent-cancel-on-save-file-out-of-date?]'s value is + @racket[#true], then a save that might overwrite some other + change is silently ignored and no save actually happens + (via @method[editor:basic-mixin can-save-file?]). If it is + @racket[#false] (and @racket[editor:doing-autosave?] is also + @racket[#false]) then a dialog is opened to ask the user + what to do. + + @history[#:added "1.53"]}) + (proc-doc/names editor:set-current-preferred-font-size (-> exact-nonnegative-integer? void?) @@ -1842,7 +2069,9 @@ void?) (pref-sym black-on-white-color white-on-black-color) @{Registers a preference whose value will be updated when the user clicks on - one of the color scheme default settings in the preferences dialog. + one of the @tech{color scheme} default settings in the preferences dialog, but + does not give it a name that can be configured by a color scheme; consider using + @racket[color-prefs:add-color-scheme-entry] instead. Also calls @racket[preferences:set-default] and @racket[preferences:set-un/marshall] with appropriate arguments to register @@ -1857,9 +2086,11 @@ ((pref-name style-name color/sd) ((white-on-black-color #f) (background #f))) - @{This function registers a color preference and initializes the style list - returned from @racket[editor:get-standard-style-list]. In particular, it - calls @racket[preferences:set-default] and + @{This function registers a color preference but does not give it + a name that can be configured by a @tech{color scheme}; consider using + @racket[color-prefs:add-color-scheme-entry] instead. + + This function calls @racket[preferences:set-default] and @racket[preferences:set-un/marshall] to install the pref for @racket[pref-name], using @racket[color/sd] as the default color. The preference is bound to a @racket[style-delta%], and initially the @@ -1892,10 +2123,20 @@ (proc-doc/names color-prefs:add-to-preferences-panel - (string? ((is-a?/c vertical-panel%) . -> . void?) . -> . void?) - (name func) + (->* (string? + (-> (is-a?/c vertical-panel%) void?)) + (#:style (listof (or/c 'border + 'hscroll 'auto-hscroll 'hide-hscroll + 'vscroll 'auto-vscroll 'hide-vscroll))) + void?) + ((name func) ((style '()))) @{Calls @racket[func] with the subpanel of the preferences coloring panel - that corresponds to @racket[name].}) + that corresponds to @racket[name]. + + The panel is created as a @racket[vertical-panel%], passing @racket[style] as the + @racket[style] argument to its constructor. + + @history[#:changed "1.61" @list{Added the @racket[#:style] argument.}]}) (proc-doc/names color-prefs:build-color-selection-panel @@ -1914,6 +2155,18 @@ @racket[editor:get-standard-style-list] and @racket[example-text] is shown in the panel so users can see the results of their configuration.}) + (proc-doc/names + color-prefs:normalize-color-selection-button-widths + (-> (is-a?/c area-container<%>) + void?) + (parent) + @{Given a panel that was passed to @racket[color-prefs:build-color-selection-panel] +(perhaps multiple times), @racket[color-prefs:normalize-color-selection-button-widths] +will ensure that the panel contents line up with each other, by making sure that +the color selection buttons all have the same size. + +@history[#:added "1.72"]}) + (proc-doc/names color-prefs:marshall-style-delta (-> (is-a?/c style-delta%) printable/c) @@ -1922,11 +2175,31 @@ (proc-doc/names color-prefs:unmarshall-style-delta - (-> printable/c (or/c false/c (is-a?/c style-delta%))) + (-> printable/c (or/c #f (is-a?/c style-delta%))) (marshalled-style-delta) @{Builds a style delta from its printed representation. Returns @racket[#f] if the printed form cannot be parsed.}) + (proc-doc/names + color-prefs:white-on-black-color-scheme? + (-> boolean?) + () + @{ + +Returns @racket[#true] if the current @tech{color scheme} is in dark mode +(i.e. has a light foreground with a dark background) and +@racket[#false] if it is in light mode (i.e. a dark foreground with +a light background). + +This function uses the @racket['framework:white-on-black-mode?] preference; +returning its value if it is a boolean and using @racket[white-on-black-panel-scheme?] if +it is set to @racket['platform]. This function is intended +to be used in place of @racket[white-on-black-panel-scheme?] +for code that supports @tech{color scheme}s. + +@history[#:added "1.79"] +}) + (proc-doc/names color-prefs:white-on-black (-> any) @@ -1958,12 +2231,17 @@ #f)]) [result void?]) (#f #f #f #f #f) - @{Registers a new color or style named @racket[name] for use in the color schemes. - If @racket[style] is provided, a new style is registered; if not a color is + @{Registers a new color or style named @racket[name] for use in the @tech{color schemes}. + If @racket[style] is not @racket[#f], a new style is registered; if not a color is registered. - The default values of all of the keyword arguments are @racket[#f], except - @racket[bold], which defaults to @racket['base] (if @racket[style] is not @racket[#f]).}) + If a style is registered, the style is stored in the style list + returned from @racket[editor:get-standard-style-list]. + + Use @racket[color-prefs:lookup-in-color-scheme] to get the current value + of the entry. + + }) (proc-doc/names color-prefs:add-color-scheme-preferences-panel @@ -1971,7 +2249,7 @@ (() ((extras void))) @{Adds a panel for choosing a color-scheme to the preferences dialog. - The @racket[extras] argument is called after the color schemes have been added + The @racket[extras] argument is called after the @tech{color schemes} have been added to the preferences panel. It is passed the panel containing the color schemes and can add items to it.}) @@ -1983,10 +2261,11 @@ @index{framework:color-schemes} @racket['framework:color-schemes]. Each definition must bind a list of hash tables, each of which introduces a new - color scheme. Each hash table should have keys that specify + @deftech{color scheme}. Each hash table should have keys that specify details of the color scheme, as follows: @itemlist[@item{@racket['name]: must be either a string or a symbol; - if it is a symbol and @racket[string-constant?], + it names the entire color scheme. + If it is a symbol and @racket[string-constant?], it is passed to @racket[dynamic-string-constant] to get the name; otherwise it is used as the name directly. If absent, the name of the directory containing the @filepath{info.rkt} @@ -1994,12 +2273,18 @@ @item{@racket['white-on-black-base?]: must be a boolean indicating if this color-scheme is based on an inverted color scheme. If absent, it is @racket[#f].} + @item{@racket['inverted-base-name]: must be a + symbol or @racket[#f]. This field is no longer used; in the past + it linked two color schemes and was used when switching between light + and dark modes. Now, two separate preferences are kept; the user's + choice for dark mode and their choice for light mode.} @item{@racket['example]: must be a string and is used in the preferences dialog to show an example of the color scheme. If absent, the string used in the ``Classic'' color scheme is used.} @item{@racket['colors]: must be a non-empty list whose first position - is a symbol, naming a color or style. The rest of the elements describe - the style or color. In either case, an element may be a vector describing + is a symbol, naming a color or style entry in the color scheme. + The rest of the elements describe the style or color. + In either case, an element may be a vector describing a color, see below. If the name corresponds to a style, then the list may also contain @@ -2043,37 +2328,59 @@ is called, it logs the active set of color names and style names to the @tt{color-scheme} logger at the info level. So, for example, starting up DrRacket like this: @tt{racket -W info@"@"color-scheme -l drracket} will print out the styles used in your - version of DrRacket.}) + version of DrRacket. + +@history[#:changed "1.68" @list{Added @racket['inverted-base-name].} + #:changed "1.79" @list{Ignore @racket['inverted-base-name].}] +}) (proc-doc/names color-prefs:set-current-color-scheme (-> symbol? void?) (name) - @{Sets - the current color scheme to the scheme named @racket[name], - if @racket[name] is @racket[color-prefs:known-color-scheme-name?]. - Otherwise, does nothing.}) + @{ +Set's the user's preferred @tech{color scheme} to +the one whose name is @racket[name]. +Also, updates the colors in DrRacket's GUI to the colors in +that color scheme if the named color scheme matches the +dark/light mode that the GUI is in. +}) - (proc-doc + (proc-doc/names color-prefs:get-current-color-scheme-name - (-> color-prefs:color-scheme-style-name?) - @{Returns the current color scheme's name.}) + (->* () (#:wob? boolean?) symbol?) + (() ((wob? (white-on-black-color-scheme?)))) + @{Returns the name of either the user's preferred dark mode or light mode @tech{color scheme}, +based on the @racket[wob?] boolean. If the boolean is @racket[#true], returns the dark mode's name, +otherwise the light mode's.}) (proc-doc/names color-prefs:known-color-scheme-name? (-> any/c boolean?) (name) @{Returns @racket[#t] if the input is a @racket[symbol?] that names - a color or style that is part of the current color scheme. - - In order to return @racket[#t], @racket[name] must have been - passed as the first argument to @racket[color-prefs:add-color-scheme-entry].}) + a color or style that is an entry in the current @tech{color scheme}. + + In order to return @racket[#t], @racket[name] must have been + passed as the first argument to @racket[color-prefs:add-color-scheme-entry].}) + + (proc-doc/names + color-prefs:get-inverted-base-color-scheme + (-> symbol? (or/c #f symbol?)) + (name) + @{ +Returns the inverted-base @tech{color scheme} name +of color scheme named @racket[name], if it has one. + +@history[#:added "1.68" + #:changed "1.79" @list{This function is no longer used.}] +}) (proc-doc/names color-prefs:color-scheme-style-name? (-> any/c boolean?) (name) - @{Returns @racket[#t] if @racket[name] is a known color scheme name, + @{Returns @racket[#t] if @racket[name] is a known @tech{color scheme} name, and is connected to a style. In order to return @racket[#t], @racket[name] must have been @@ -2084,21 +2391,22 @@ color-prefs:color-scheme-color-name? (-> any/c boolean?) (name) - @{Returns @racket[#t] if @racket[name] is a known color scheme name, + @{Returns @racket[#t] if @racket[name] is a known @tech{color scheme} name, and is connected to a color. In order to return @racket[#t], @racket[name] must have been passed as the first argument to @racket[color-prefs:add-color-scheme-entry] and the @racket[#:style] argument must have also been omitted or be @racket[#f].}) - (proc-doc + (proc-doc color-prefs:lookup-in-color-scheme (->i ([name color-prefs:known-color-scheme-name?]) - () + (#:wob? [wob boolean?]) [result (name) (if (color-prefs:color-scheme-style-name? name) (is-a?/c style-delta%) (is-a?/c color%))]) + ((white-on-black-color-scheme?)) @{Returns the current style delta or color associated with @racket[name].}) (proc-doc @@ -2111,32 +2419,44 @@ () [result void?]) @{Updates the current color or style delta associated with - @racket[name] in the current color scheme.}) + @racket[name] in the current @tech{color scheme}.}) (proc-doc color-prefs:register-color-scheme-entry-change-callback (->i ([name color-prefs:known-color-scheme-name?] - [fn (name) - (-> (if (color-prefs:color-scheme-style-name? name) - (is-a?/c style-delta%) - (is-a?/c color%)) - any)]) - ([weak? boolean?]) + [fn (name weak?) + (if weak? + (procedure-arity-includes/c 1) + (-> (if (color-prefs:color-scheme-style-name? name) + (is-a?/c style-delta%) + (is-a?/c color%)) + any))]) + ([weak? boolean?] + #:style-list [style-list (or/c #f (is-a?/c style-list%))]) [result void?]) - (#f) + (#f #f) @{Registers a callback that is invoked whenever the color mapped by @racket[name] changes. Changes may happen due to calls to @racket[color-prefs:set-in-color-scheme] or due to calls to @racket[color-prefs:set-current-color-scheme]. If @racket[weak?] is @racket[#t], the @racket[fn] argument is held - onto weakly; otherwise it is held onto strongly.}) + onto weakly; otherwise it is held onto strongly. + + If @racket[style-list] is not @racket[#f] then calls to all of the + registered callbacks (including @racket[fn]) are bracketed + by calls to @method[style-list% begin-style-change-sequence] + and @method[style-list% end-style-change-sequence] for the given + @racket[style-list%]. + + @history[#:changed "1.68" @list{added the @racket[style-list] argument}] +}) (proc-doc color-prefs:get-color-scheme-names (-> (values set? set?)) - @{Returns two sets; the first is the known color scheme names that are just colors - and the second is the known color scheme names that are styles. + @{Returns two sets; the first is the known @tech{color scheme} names that are just colors + and the second is the known @tech{color scheme} names that are styles. These are all of the names that have been passed to @racket[color-prefs:add-color-scheme-entry].}) ) diff --git a/gui-lib/framework/preferences.rkt b/gui-lib/framework/preferences.rkt index 5c7836a0e..4d8ab16ed 100644 --- a/gui-lib/framework/preferences.rkt +++ b/gui-lib/framework/preferences.rkt @@ -365,6 +365,23 @@ the state transitions / contracts are: copy value))) +;; same-pref-value? : sym any any -> boolean +;; compares two preference values; if they are +;; eq? then they are the same. Otherwise, they +;; are the same if they marshall to equal? values +(define (same-pref-value? p val1 val2) + (cond + [(eq? val1 val2) #t] + [else + (define pref-state (find-layer p)) + (define marshall-unmarshall (preferences:layer-marshall-unmarshall pref-state)) + (define un/marshaller (hash-ref marshall-unmarshall p #f)) + (cond + [un/marshaller + (define marsh (un/marshall-marshall un/marshaller)) + (equal? (marsh val1) (marsh val2))] + [else #f])])) + (define (preferences:restore-defaults) (let loop ([prefs-state (preferences:current-layer)]) (when prefs-state @@ -387,8 +404,14 @@ the state transitions / contracts are: [else sofar])))) (define (preferences:restore-prefs-snapshot snapshot) - (multi-set (map car (preferences:snapshot-x snapshot)) - (map cdr (preferences:snapshot-x snapshot))) + (define items + (for/list ([key+val (in-list (preferences:snapshot-x snapshot))] + #:unless + (same-pref-value? (car key+val) + (cdr key+val) + (preferences:get (car key+val)))) + key+val)) + (multi-set (map car items) (map cdr items)) (void)) (begin-for-doc diff --git a/gui-lib/framework/private/aspell.rkt b/gui-lib/framework/private/aspell.rkt index 2632f1f80..034dfd6f5 100644 --- a/gui-lib/framework/private/aspell.rkt +++ b/gui-lib/framework/private/aspell.rkt @@ -21,14 +21,15 @@ '("/usr/bin" "/bin" "/usr/local/bin" - "/opt/local/bin/")) + "/opt/local/bin/" + "/opt/homebrew/bin/")) (define (find-aspell-binary-path) (define aspell (if (eq? (system-type) 'windows) "aspell.exe" "aspell")) (define ispell (if (eq? (system-type) 'windows) "ispell.exe" "ispell")) (or (find-executable-path aspell) (find-executable-path ispell) - (for/or ([cp aspell-candidate-paths]) + (for/or ([cp (in-list aspell-candidate-paths)]) (define c1 (build-path cp aspell)) (define c2 (build-path cp ispell)) (or (and (file-exists? c1) diff --git a/gui-lib/framework/private/autosave.rkt b/gui-lib/framework/private/autosave.rkt index 09cd6525c..10678a11d 100644 --- a/gui-lib/framework/private/autosave.rkt +++ b/gui-lib/framework/private/autosave.rkt @@ -1,15 +1,19 @@ -#lang scheme/unit +#lang racket/base - (require racket/class - racket/file - "sig.rkt" - "text-sig.rkt" - "../gui-utils.rkt" - "../preferences.rkt" - "srcloc-panel.rkt" - mred/mred-sig - string-constants) - +(require racket/class + racket/unit + racket/file + racket/match + "sig.rkt" + "text-sig.rkt" + "../gui-utils.rkt" + "../preferences.rkt" + "srcloc-panel.rkt" + mred/mred-sig + string-constants) +(provide autosave@) + +(define-unit autosave@ (import mred^ [prefix exit: framework:exit^] [prefix frame: framework:frame^] @@ -43,6 +47,7 @@ (case (system-type) [(unix) ".plt-autosave-toc-save.rktd"] [else "PLT-autosave-toc-save.rktd"])) + (make-directory* base) (build-path base save-filename-path)) (define autosave-timer% @@ -66,8 +71,11 @@ (write new-name-mapping port)) #:exists 'truncate #:mode 'text)))) - (let ([seconds (preferences:get 'framework:autosave-delay)]) - (start (* 1000 seconds) #t))) + (cond + [(null? objects) (set! timer #f)] + [else + (let ([seconds (preferences:get 'framework:autosave-delay)]) + (start (* 1000 seconds) #t))])) (super-new) (let ([seconds (preferences:get 'framework:autosave-delay)]) (start (* 1000 seconds) #t)))) @@ -125,204 +133,228 @@ (cons weak-box (loop (cdr objects))) (loop (cdr objects))))])))) - ;; restore-autosave-files/gui : -> (union #f (is-a?/c top-level-window<%>)) + ;; restore-autosave-files/gui : -> void? ;; opens a frame that lists the autosave files that have changed. - (define (restore-autosave-files/gui) - + (define (restore-autosave-files/gui [table #f]) + (cond + [table (restore-autosave-files/gui/table table)] + [else + (define toc-path (current-toc-path)) + (when (file-exists? toc-path) + ;; Load table from file, and check that the file was not corrupted + (define raw-read-table + (with-handlers ([exn:fail? (λ (x) null)]) + (call-with-input-file toc-path read))) + (define table + (if (and (list? raw-read-table) + (andmap (λ (i) + (and (list? i) + (= 2 (length i)) + (or (not (car i)) + (bytes? (car i))) + (bytes? (cadr i)))) + raw-read-table)) + (map (λ (ent) (list (if (bytes? (list-ref ent 0)) + (bytes->path (list-ref ent 0)) + #f) + (bytes->path (list-ref ent 1)))) + raw-read-table) + null)) + (restore-autosave-files/gui/table table))])) + + (define (restore-autosave-files/gui/table table) + ;; main : -> void ;; start everything going (define (main) - (define toc-path (current-toc-path)) - (when (file-exists? toc-path) - ;; Load table from file, and check that the file was not corrupted - (let* ([table (let ([v (with-handlers ([exn:fail? (λ (x) null)]) - (call-with-input-file toc-path read))]) - (if (and (list? v) - (andmap (λ (i) - (and (list? i) - (= 2 (length i)) - (or (not (car i)) - (bytes? (car i))) - (bytes? (cadr i)))) - v)) - (map (λ (ent) (list (if (bytes? (list-ref ent 0)) - (bytes->path (list-ref ent 0)) - #f) - (bytes->path (list-ref ent 1)))) - v) - null))] - ;; assume that the autosave file was deleted due to the file being saved - [filtered-table - (filter (λ (x) (file-exists? (cadr x))) table)]) - (unless (null? filtered-table) - (let* ([dlg (new (frame:focus-table-mixin dialog%) - (label (string-constant recover-autosave-files-frame-title)))] - [t (new (text:foreground-color-mixin - (editor:standard-style-list-mixin text:basic%)) - [auto-wrap #t])] - [ec (new canvas:color% - (parent dlg) - (editor t) - (line-count 2) - (stretchable-height #f) - (style '(no-hscroll)))] - [hp (new-horizontal-panel% - [parent dlg] - [stretchable-height #f])] - [vp (new-vertical-panel% - [parent hp] - [stretchable-height #f])] - [details-parent (new-horizontal-panel% [parent dlg])]) - (send vp set-alignment 'right 'center) - (make-object grow-box-spacer-pane% hp) - (send t insert (string-constant autosave-explanation)) - (send t hide-caret #t) - (send t set-position 0 0) - (send t lock #t) - - (for-each (add-table-line vp dlg details-parent) filtered-table) - (make-object button% - (string-constant autosave-done) - vp - (λ (x y) - (when (send dlg can-close?) - (send dlg on-close) - (send dlg show #f)))) - (send dlg show #t) - (void)))))) - + ;; assume that the autosave file was deleted due to the file being saved + (define filtered-table (filter (λ (x) (file-exists? (cadr x))) table)) + (unless (null? filtered-table) + (define dlg + (new (frame:focus-table-mixin dialog%) + (label (string-constant recover-autosave-files-frame-title)) + [width 600])) + (define t + (new (text:foreground-color-mixin + (editor:standard-style-list-mixin text:basic%)) + [auto-wrap #t])) + (define ec (new canvas:color% + (parent dlg) + (editor t) + (line-count 2) + (stretchable-height #f) + (style '(no-hscroll)))) + (define hp (new-horizontal-panel% + [parent dlg] + [stretchable-height #f])) + (define vp (new-vertical-panel% + [parent hp] + [stretchable-height #f])) + (define details-parent (new-horizontal-panel% [parent dlg])) + (send vp set-alignment 'right 'center) + (make-object grow-box-spacer-pane% hp) + (send t insert (string-constant autosave-explanation)) + (send t hide-caret #t) + (send t set-position 0 0) + (send t lock #t) + + (define only-one? (= 1 (length filtered-table))) + (for ([table-entry (in-list filtered-table)]) + (add-table-line vp dlg details-parent table-entry only-one?)) + (new button% + [label (string-constant autosave-done)] + [parent vp] + [callback + (λ (x y) + (when (send dlg can-close?) + (send dlg on-close) + (send dlg show #f)))]) + (send dlg show #t) + (void))) + ;; add-table-line : (is-a? area-container<%>) ;; (or/c #f (is-a?/c top-level-window<%>)) ;; (is-a? area-container<%>) ;; -> (list/c (or/c #f path?) path?) ;; -> void? ;; adds in a line to the overview table showing this pair of files. - (define (add-table-line area-container dlg show-details-parent) - (λ (table-entry) - (letrec ([orig-file (car table-entry)] - [backup-file (cadr table-entry)] - [hp (new-horizontal-panel% - (parent area-container) - (style '(border)) - (stretchable-height #f))] - [vp (new-vertical-panel% - (parent hp))] - [msg1-panel (new-horizontal-panel% - (parent vp))] - [msg1-label (new message% - (parent msg1-panel) - (label (string-constant autosave-original-label:)))] - [msg1 (new message% - (label (if orig-file (path->string orig-file) (string-constant autosave-unknown-filename))) - (stretchable-width #t) - (parent msg1-panel))] - [msg2-panel (new-horizontal-panel% - (parent vp))] - [msg2-label (new message% - (parent msg2-panel) - (label (string-constant autosave-autosave-label:)))] - [msg2 (new message% - (label (path->string backup-file)) - (stretchable-width #t) - (parent msg2-panel))] - [details - (make-object button% (string-constant autosave-details) hp - (λ (x y) - (show-files table-entry show-details-parent dlg)))] - [delete - (make-object button% - (string-constant autosave-delete-button) - hp - (λ (delete y) - (when (delete-autosave table-entry) - (disable-line) - (send msg2 set-label (string-constant autosave-deleted)))))] - [recover - (make-object button% - (string-constant autosave-recover) - hp - (λ (recover y) - (let ([filename-result (recover-file dlg table-entry)]) - (when filename-result - (disable-line) - (send msg2 set-label (string-constant autosave-recovered!)) - (send msg1 set-label (gui-utils:quote-literal-label - (path->string filename-result) - #:quote-amp? #f))))))] - [disable-line - (λ () - (send recover enable #f) - (send details enable #f) - (send delete enable #f))]) - (let ([w (max (send msg1-label get-width) (send msg2-label get-width))]) - (send msg1-label min-width w) - (send msg2-label min-width w)) - (void)))) + (define (add-table-line area-container dlg show-details-parent table-entry show-details-initially/no-details-button?) + (match-define (list orig-file backup-file) table-entry) + (define hp (new-horizontal-panel% + (parent area-container) + (style '(border)) + (stretchable-height #f))) + (define vp (new-vertical-panel% + (parent hp))) + (define msg1-panel (new-horizontal-panel% + (parent vp))) + (define msg1-label + (new message% + (parent msg1-panel) + (label (string-constant autosave-original-label:)))) + (define msg1 + (new message% + (label (if orig-file (path->string orig-file) (string-constant autosave-unknown-filename))) + (stretchable-width #t) + (parent msg1-panel))) + (define msg2-panel (new-horizontal-panel% (parent vp))) + (define msg2-label (new message% + (parent msg2-panel) + (label (string-constant autosave-autosave-label:)))) + (define msg2 (new message% + (label (path->string backup-file)) + (stretchable-width #t) + (parent msg2-panel))) + (define (details-callback) + (show-files table-entry show-details-parent dlg)) + (define details + (and (not show-details-initially/no-details-button?) + (new button% + [label (string-constant autosave-details)] + [parent hp] + [callback + (λ (x y) (details-callback))]))) + (define delete + (new button% + [label (string-constant autosave-delete-button)] + [parent hp] + [callback + (λ (delete y) + (when (delete-autosave table-entry) + (disable-line) + (send msg2 set-label (string-constant autosave-deleted))))])) + (define recover + (new button% + [label (string-constant autosave-recover)] + [parent hp] + [callback + (λ (recover y) + (let ([filename-result (recover-file dlg table-entry)]) + (when filename-result + (disable-line) + (send msg2 set-label (string-constant autosave-recovered!)) + (send msg1 set-label (gui-utils:quote-literal-label + (path->string filename-result) + #:quote-amp? #f)))))])) + (define (disable-line) + (send recover enable #f) + (when details (send details enable #f)) + (send delete enable #f)) + (define w (max (send msg1-label get-width) (send msg2-label get-width))) + (send msg1-label min-width w) + (send msg2-label min-width w) + (when show-details-initially/no-details-button? + (details-callback)) + (void)) ;; delete-autosave : (list (union #f string[filename]) string[filename]) -> boolean ;; result indicates if delete occurred (define (delete-autosave table-entry) - (let ([autosave-file (cadr table-entry)]) - (and (gui-utils:get-choice - (format (string-constant are-you-sure-delete?) - autosave-file) - (string-constant autosave-delete-title) - (string-constant cancel) - (string-constant warning) - #f - #:dialog-mixin frame:focus-table-mixin) - (with-handlers ([exn:fail? - (λ (exn) - (message-box - (string-constant warning) - (format (string-constant autosave-error-deleting) - autosave-file - (if (exn? exn) - (format "~a" (exn-message exn)) - (format "~s" exn)))) - #f)]) - (delete-file autosave-file) - #t)))) - + (define autosave-file (cadr table-entry)) + (and (gui-utils:get-choice + (format (string-constant are-you-sure-delete?) + autosave-file) + (string-constant autosave-delete-title) + (string-constant cancel) + (string-constant warning) + #f + #:dialog-mixin frame:focus-table-mixin) + (with-handlers ([exn:fail? + (λ (exn) + (message-box + (string-constant warning) + (format (string-constant autosave-error-deleting) + autosave-file + (if (exn? exn) + (format "~a" (exn-message exn)) + (format "~s" exn))) + #:dialog-mixin frame:focus-table-mixin) + #f)]) + (delete-file autosave-file) + #t))) + ;; show-files : (list (or/c #f path?) path?) (is-a?/c area-container<%>) (is-a?/c dialog%) -> void (define (show-files table-entry show-details-parent dlg) - (let ([file1 (list-ref table-entry 0)] - [file2 (list-ref table-entry 1)]) - (send dlg begin-container-sequence) - (define had-children? #f) - (send show-details-parent change-children (λ (x) - (set! had-children? (not (null? x))) - '())) - (when file1 - (add-file-viewer file1 show-details-parent (string-constant autosave-original-label))) - (add-file-viewer file2 show-details-parent (string-constant autosave-autosave-label)) - (send dlg end-container-sequence) - (unless had-children? - (send dlg center)))) - + (match-define (list file1 file2) table-entry) + (send dlg begin-container-sequence) + (define had-children? #f) + (send show-details-parent change-children (λ (x) + (set! had-children? (not (null? x))) + '())) + (when file1 + (add-file-viewer file1 show-details-parent (string-constant autosave-original-label))) + (add-file-viewer file2 show-details-parent (string-constant autosave-autosave-label)) + (send dlg end-container-sequence) + (unless had-children? + (send dlg center))) + ;; add-file-viewer : path? -> void (define (add-file-viewer filename parent label) (define vp (make-object vertical-panel% parent)) (define t (make-object show-files-text%)) (define msg1 (make-object message% label vp)) - (define msg2 (new message% + (define msg2 (new message% [label (gui-utils:quote-literal-label (path->string filename) #:quote-amp? #f)] [parent vp])) (define ec (make-object canvas:color% vp t)) (send ec min-height 400) - (send t load-file filename) + (with-handlers ([exn:fail? (λ (exn) + (send t insert "Error loading original file:\n\n") + (define p (send t last-position)) + (send t insert (exn-message exn)) + (send t set-position 0))]) + (send t load-file filename)) (send t hide-caret #t) (send t lock #t)) - - (define show-files-frame% frame:basic%) + (define show-files-text% (text:foreground-color-mixin text:keymap%)) - + (main)) - - ;; recover-file : (union #f (is-a?/c toplevel-window<%>)) + + ;; recover-file : (union #f (is-a?/c toplevel-window<%>)) ;; (list (union #f string[filename]) string) ;; -> (union #f string) (define (recover-file parent table-entry) @@ -335,9 +367,31 @@ (let ([tmp-name (and (file-exists? orig-name) (make-temporary-file "autosave-repair~a" orig-name))]) (when (file-exists? orig-name) - (delete-file orig-name)) + (let loop ([i 0]) + (cond + [(= i 100) + ;; here we either have a LOT of renamed files or something + ;; is going wrong; just give up on the original file + (delete-file orig-name)] + [else + (define-values (base name dir) (split-path orig-name)) + (define split-name-m (regexp-match #rx#"^(.*)([.][^.]*)$" (path->bytes name))) + (define new-suffix (string->bytes/utf-8 (format "~a~a" "-autorec" (if (= i 0) "" i)))) + (define renamed-candidate + (if split-name-m + (bytes-append (list-ref split-name-m 0) + new-suffix + #"." + (list-ref split-name-m 1)) + (bytes-append (path->bytes name) new-suffix))) + (define full-candidate (build-path base (bytes->path renamed-candidate))) + (cond + [(file-exists? full-candidate) + (loop (+ i 1))] + [else + (rename-file-or-directory orig-name full-candidate)])]))) (copy-file autosave-name orig-name) (delete-file autosave-name) (when tmp-name (delete-file tmp-name)) - orig-name))))) + orig-name)))))) diff --git a/gui-lib/framework/private/bday.rkt b/gui-lib/framework/private/bday.rkt deleted file mode 100644 index 2c49adbea..000000000 --- a/gui-lib/framework/private/bday.rkt +++ /dev/null @@ -1,28 +0,0 @@ -#lang s-exp framework/private/decode - - bZFPT8MwDMXv/RR - POzmHSC sgAQeGE - Os NAVp3Q xzaxR0 - VJEVJ NolvT5 - Kl3fi T04t/z - 45jF/ Rph32v - GNp2sl XN1y3 - 0KNx7F twehCg - KUtz1hkE UI9BQ - QhQAfbAH vajGB - +R4Mxjl5CJ dA/1x - stUFF 2jLns 0es+e - H9XJ V3dXra lVX9 - 0+Py3 omXsXv1JD - cd4i Zf0mizt - vebOX C7HTL - Njn/K ZKsm52 - 1bLzM zYpw8 - oPUGA W6AcX2 - pR6Mf 0OUAl - oc4/H 3h6iK - ucfJj MMKhd - KIcIn zeTCM - fBpv5u UcZ9en -fFpE5i VQnvBp -K2P9C+ Aq8G8= diff --git a/gui-lib/framework/private/color-local-member-name.rkt b/gui-lib/framework/private/color-local-member-name.rkt index e7c5b2b44..56b10bab3 100644 --- a/gui-lib/framework/private/color-local-member-name.rkt +++ b/gui-lib/framework/private/color-local-member-name.rkt @@ -1,4 +1,4 @@ #lang racket/base (require racket/class) -(define-local-member-name tokenizing-give-up-early) -(provide tokenizing-give-up-early) +(define-local-member-name tokenizing-give-up-early match-parens) +(provide tokenizing-give-up-early match-parens) diff --git a/gui-lib/framework/private/color-prefs.rkt b/gui-lib/framework/private/color-prefs.rkt index 6cb1ee74e..50dfac85e 100644 --- a/gui-lib/framework/private/color-prefs.rkt +++ b/gui-lib/framework/private/color-prefs.rkt @@ -1,4 +1,20 @@ #lang racket/unit + +#| + +The color scheme library should probalby move into mrlib +so that other mrlib libraries can depend on it without +pulling in the framework. + +I'm not sure how to do that wrt to the editor style list, +tho, as the sharing of that is pretty key to how this works. + +Notably the syntax snips don't quite work currently; when you +open them and then switch from dark to light mode, the label +on top's background stays in the wrong mode. + +|# + (require racket/class racket/gui/base string-constants @@ -9,16 +25,19 @@ setup/collects string-constants racket/pretty + mrlib/panel-wob "../preferences.rkt" "sig.rkt" - "srcloc-panel.rkt") + "srcloc-panel.rkt" + (prefix-in wob-cs: "wob-color-scheme.rkt") + ) (import [prefix preferences: framework:preferences^] [prefix editor: framework:editor^] [prefix canvas: framework:canvas^] [prefix racket: framework:racket^] [prefix color: framework:color^]) - (export framework:color-prefs^) + (export framework:color-prefs/int^) (init-depend framework:editor^) (define standard-style-list-text% (editor:standard-style-list-mixin text%)) @@ -159,22 +178,12 @@ (λ (color-button evt) (define pref (get-from-pref-sym)) (define orig-add (send pref get-foreground-add)) - (define orig-mult (send pref get-foreground-mult)) - (define (avg x y z) (/ (+ x y z) 3)) - (define (pin-between lo x hi) (min (max lo x) hi)) - (define orig-α - (- 1 (pin-between 0 - (avg (send orig-mult get-r) - (send orig-mult get-g) - (send orig-mult get-b)) - 1))) - (define (to-byte v) (pin-between 0 (inexact->exact (round v)) 255)) (define color (make-object color% - (to-byte (- 255 (/ (- 255 (send orig-add get-r)) orig-α))) - (to-byte (- 255 (/ (- 255 (send orig-add get-g)) orig-α))) - (to-byte (- 255 (/ (- 255 (send orig-add get-b)) orig-α))) - orig-α)) + (send orig-add get-r) + (send orig-add get-g) + (send orig-add get-b) + (send orig-add get-a))) (define users-choice (get-color-from-user (format (string-constant syntax-coloring-choose-color) example-text) @@ -184,15 +193,7 @@ (when users-choice (update-style-delta (λ (delta) - (define new-α (send users-choice alpha)) - (define α*users-choice - (make-object color% - (to-byte (- 255 (* (- 255 (send users-choice red)) new-α))) - (to-byte (- 255 (* (- 255 (send users-choice green)) new-α))) - (to-byte (- 255 (* (- 255 (send users-choice blue)) new-α))))) - (send delta set-delta-foreground α*users-choice) - (define new-mult (send delta get-foreground-mult)) - (send new-mult set (- 1 new-α) (- 1 new-α) (- 1 new-α))))))]))) + (send delta set-delta-foreground users-choice)))))]))) (define background-color-button (and (>= (get-display-depth) 8) @@ -208,7 +209,8 @@ [color (make-object color% (send add get-r) (send add get-g) - (send add get-b))] + (send add get-b) + (send add get-a))] [users-choice (get-color-from-user (format (string-constant syntax-coloring-choose-color) example-text) @@ -248,19 +250,90 @@ (send underline-check set-value (send sd get-underlined-on)) (send smoothing-menu set-selection (smoothing->index (send sd get-smoothing-on))))) (void)) + +(define (normalize-color-selection-button-widths parent) + (send parent reflow-container) + (define button-labels + (list (string-constant cs-background-color) + (string-constant cs-foreground-color) + (string-constant cs-change-color))) + (define buttons '()) + + (let loop ([obj parent]) + (cond + [(is-a? obj area-container<%>) + (for ([child (in-list (send obj get-children))]) + (loop child))] + [(is-a? obj button%) + (when (member (send obj get-label) + button-labels) + (set! buttons (cons obj buttons)))])) + + (define max-width + (for/fold ([biggest 0]) + ([button (in-list buttons)]) + (max biggest (send button get-width)))) + (for ([button (in-list buttons)]) + (send button min-width max-width))) + + (define (add/mult-get c) + (list (send c get-r) + (send c get-g) + (send c get-b) + (send c get-a))) + + (define (add/mult-set c v) + (send c set (car v) (cadr v) (caddr v) (cadddr v))) + + (define (avg x y z) (/ (+ x y z) 3)) + (define (pin-between lo x hi) (min (max lo x) hi)) + (define (to-byte v) (pin-between 0 (inexact->exact (round v)) 255)) - (define (add/mult-set m v) - (send m set (car v) (cadr v) (caddr v))) + (define (encoded-add-get a) + ;; for historical reasons, the alpha component is + ;; encoded in a combination of `add` and `mult`; + ;; we just get the add part of the encoding here + (let ([r (send a get-r)] + [g (send a get-g)] + [b (send a get-b)] + [α (send a get-a)]) + (list + (to-byte (- 255 (* (- 255 r) α))) + (to-byte (- 255 (* (- 255 g) α))) + (to-byte (- 255 (* (- 255 b) α)))))) - (define (add/mult-get m) - (let ([b1 (box 0)] - [b2 (box 0)] - [b3 (box 0)]) - (send m get b1 b2 b3) - (map unbox (list b1 b2 b3)))) + (define (encoded-add-set m v) + ;; still in encoded form, to be fixed up by `mult-set` + (send m set (car v) (cadr v) (caddr v))) + + (define (encoded-mult-get m a) + ;; encodes part of `a`; we can only represent + ;; style deltas that fit into the encoding, which corresponds + ;; to a `set-delta-foreground` or `set-delta-background` + (let ([α (send a get-a)]) + (list (- 1 α) (- 1 α) (- 1 α)))) + + (define (encoded-mult-set m a v) + ;; updates both `m` and `a`, assuming that first part of + ;; encoding has been installed in `a`: + (let ([α (- 1 (pin-between 0 + (avg (car v) (cadr v) (caddr v)) + 1))] + [r (send a get-r)] + [g (send a get-g)] + [b (send a get-b)]) + (send m set 0.0 0.0 0.0 0.0) + (if (zero? α) + (send a set 0 0 0 0.0) + (send a set + (to-byte (- 255 (/ (- 255 r) α))) + (to-byte (- 255 (/ (- 255 g) α))) + (to-byte (- 255 (/ (- 255 b) α))) + α)))) (define style-delta-get/set - (let ([lo3n (λ (x) (and (list? x) (= (length x) 3) (andmap number? x)))]) + (let ([lo3n (λ (x) (and (list? x) (= (length x) 3) (andmap number? x)))] + [lo4n (λ (x) (and (list? x) (= (length x) 4) (andmap number? x)))]) (list (list (λ (x) (send x get-alignment-off)) (λ (x v) (send x set-alignment-off v)) (λ (x) (memq x '(base top center bottom)))) @@ -269,12 +342,15 @@ (λ (x v) (send x set-alignment-on v)) (λ (x) (memq x '(base top center bottom)))) - (list (λ (x) (add/mult-get (send x get-background-add))) - (λ (x v) (add/mult-set (send x get-background-add) v)) + ;; encoded form is replaced later by direct form, if present: + (list (λ (x) (encoded-add-get (send x get-background-add))) + (λ (x v) (encoded-add-set (send x get-background-add) v)) lo3n) - - (list (λ (x) (add/mult-get (send x get-background-mult))) - (λ (x v) (add/mult-set (send x get-background-mult) v)) + + ;; encoded form is replaced later by direct form, if present: + (list (λ (x) (encoded-mult-get (send x get-background-mult) (send x get-background-add))) + ;; setter relies on `add-set` running first: + (λ (x v) (encoded-mult-set (send x get-background-mult) (send x get-background-add) v)) lo3n) (list (λ (x) (send x get-face)) @@ -285,12 +361,15 @@ (λ (x v) (send x set-family v)) (λ (x) (memq x '(base default decorative roman script swiss modern symbol system)))) - (list (λ (x) (add/mult-get (send x get-foreground-add))) - (λ (x v) (add/mult-set (send x get-foreground-add) v)) + ;; encoded form is replaced later by direct form, if present: + (list (λ (x) (encoded-add-get (send x get-foreground-add))) + (λ (x v) (encoded-add-set (send x get-foreground-add) v)) lo3n) - - (list (λ (x) (add/mult-get (send x get-foreground-mult))) - (λ (x v) (add/mult-set (send x get-foreground-mult) v)) + + ;; encoded form is replaced later by direct form, if present: + (list (λ (x) (encoded-mult-get (send x get-foreground-mult) (send x get-foreground-add))) + ;; setter relies on `add-set` running first: + (λ (x v) (encoded-mult-set (send x get-foreground-mult) (send x get-foreground-add) v)) lo3n) (list (λ (x) (send x get-size-add)) @@ -323,7 +402,23 @@ (list (λ (x) (send x get-weight-on)) (λ (x v) (send x set-weight-on v)) - (λ (x) (memq x '(base normal bold light))))))) + (λ (x) (memq x '(base normal bold light)))) + + ;; replaces whatever is read through the encoded form: + (list (λ (x) (add/mult-get (send x get-background-add))) + (λ (x v) (add/mult-set (send x get-background-add) v)) + lo4n) + (list (λ (x) (add/mult-get (send x get-background-mult))) + (λ (x v) (add/mult-set (send x get-background-mult) v)) + lo4n) + + ;; replaces whatever is read through the encoded form: + (list (λ (x) (add/mult-get (send x get-foreground-add))) + (λ (x v) (add/mult-set (send x get-foreground-add) v)) + lo4n) + (list (λ (x) (add/mult-get (send x get-foreground-mult))) + (λ (x v) (add/mult-set (send x get-foreground-mult) v)) + lo4n)))) (define (marshall-style-delta style) (map (λ (fs) ((car fs) style)) style-delta-get/set)) @@ -345,6 +440,12 @@ (cdr info)))]))) style)) + + (define (unmarshall-style-delta-with-background info) + (define style (unmarshall-style-delta info)) + (send style set-transparent-text-backing-on #f) + (send style set-transparent-text-backing-off #t) + style) (define (make-style-delta color bold underline? italic? #:background [background #f]) (define sd (make-object style-delta%)) @@ -498,15 +599,14 @@ panel) ;; add-to-preferences-panel : string (vertical-panel -> void) -> void - (define (add-to-preferences-panel panel-name func) + (define (add-to-preferences-panel panel-name func #:style [style '()]) (preferences:add-panel (list (string-constant preferences-colors) panel-name) (λ (parent) - (let ([panel (new-vertical-panel% (parent parent))]) + (let ([panel (new-vertical-panel% (parent parent) [style style])]) (func panel) panel)))) - ;; see docs (define (register-color-preference pref-name style-name color/sd [white-on-black-color #f] [use-old-marshalling? #t] @@ -527,9 +627,11 @@ (set! color-scheme-colors (cons (list pref-name color/sd - (to-color white-on-black-color)) + (to-color white-on-black-color 'register-color-preference)) color-scheme-colors))) - (preferences:set-un/marshall pref-name marshall-style-delta unmarshall-style-delta) + (preferences:set-un/marshall pref-name marshall-style-delta (if background + unmarshall-style-delta-with-background + unmarshall-style-delta)) (preferences:add-callback pref-name (λ (sym v) (editor:set-standard-style-list-delta style-name v))) @@ -538,12 +640,10 @@ (define color-scheme-colors '()) (define (set-default/color-scheme pref-sym black-on-white white-on-black) - (let ([bw-c (to-color black-on-white)] - [wb-c (to-color white-on-black)]) + (let ([bw-c (to-color black-on-white 'set-default/color-scheme)] + [wb-c (to-color white-on-black 'set-default/color-scheme)]) (set! color-scheme-colors - (cons (list pref-sym - (to-color black-on-white) - (to-color white-on-black)) + (cons (list pref-sym bw-c wb-c) color-scheme-colors)) (preferences:set-default pref-sym bw-c (λ (x) (is-a? x color%))) @@ -563,7 +663,7 @@ (make-object color% red green blue α)] [else #f])) - (define (to-color c) + (define (to-color c who) (cond [(is-a? c color%) c] [(is-a? c style-delta%) @@ -580,8 +680,8 @@ (send add get-b))))] [(string? c) (or (send the-color-database find-color c) - (error 'register-color-scheme - "did not find color ~s in the-color-database" + (error who + "color not found in the-color-database\n color: ~e" c))])) (define (black-on-white) (do-colorization cadr)) @@ -622,22 +722,24 @@ (string-append "#lang racket ; draw a graph of\n" "(require plot) ; cos and log\n" - "(plot #:label \"y = cos(x) & y = log(x)\"\n" + "(plot #:title \"y = cos(x) & y = log(x)\"\n" " (list (function cos -5 5) (function log -5 5)))\n" "\"an unclosed string is an error")) -(struct color-scheme (name button-label white-on-black-base? mapping example) #:transparent) +(struct color-scheme (name button-label white-on-black-base? mapping example inverted-base-name) #:transparent) (define black-on-white-color-scheme-name 'classic) (define white-on-black-color-scheme-name 'white-on-black) (define known-color-schemes - ;; note:first item in this list must be the black-on-white color scheme - ;; and the second must the white-on-black color scheme + ;; note: first item in this list must be the default black-on-white color scheme + ;; and the second must the default white-on-black color scheme (list (color-scheme black-on-white-color-scheme-name (string-constant classic-color-scheme) - #f (make-hash) default-example) + #f (make-hash) default-example + white-on-black-color-scheme-name) (color-scheme white-on-black-color-scheme-name (string-constant white-on-black-color-scheme) - #t (make-hash) default-example))) + #t (make-hash) default-example + black-on-white-color-scheme-name))) (define color-change-callbacks (make-hash)) @@ -648,12 +750,16 @@ (define-logger color-scheme) +(define white-on-black-color-scheme? wob-cs:white-on-black-color-scheme?) + (define (register-info-based-color-schemes) (log-color-scheme-info "color-names: ~a\nstyle-names:\n~a\n" (sort (set->list known-color-names) symbollist known-style-names) symbolstring name)) - name) + (define (tidy-name name) + (if (symbol? name) + (if (string-constant? name) + (dynamic-string-constant name) + (symbol->string name)) + name)) + (register-color-scheme (tidy-name name) white-on-black-base? mapping - example))] + example + #:inverted-base-name + (and inverted-base-name + (tidy-name inverted-base-name))))] [else (when cs-info (log-color-scheme-warning @@ -697,17 +809,19 @@ (pretty-format (contract-name info-file-result-check?)) dir (pretty-format cs-info)))]))) + (check/fix-inverted-base-names) ;; the color-scheme saved in the user's preferences may not be known ;; until after the code above executes, which would mean that the ;; color scheme in effect up to that point may be wrong. So fix that here: - (set-current-color-scheme preferred-color-scheme #t)) + (set-current-color-scheme preferred-color-scheme)) ;; register-color-scheme : string boolean? (listof (cons/c symbol? (listof props)) -> void ;; props = (or/c 'bold 'italic 'underline ;; ;; called based on the contents of info.rkt files -(define (register-color-scheme scheme-name white-on-black-base? mapping example) +(define (register-color-scheme scheme-name white-on-black-base? mapping example + #:inverted-base-name [inverted-base-name #f]) (define (good-line? line) (or (set-member? known-color-names (car line)) (set-member? known-style-names (car line)))) @@ -735,7 +849,58 @@ (props->color (cdr line))] [(set-member? known-style-names name) (props->style-delta (cdr line))])))) - example))))) + example + (cond + [(symbol? inverted-base-name) + inverted-base-name] + [(not inverted-base-name) #f] + [else + (string->symbol inverted-base-name)])))))) + +(define (check/fix-inverted-base-names) + (define name->scheme + (for/hash ([a-color-scheme (in-list known-color-schemes)]) + (values (color-scheme-name a-color-scheme) + a-color-scheme))) + (set! known-color-schemes + (for/list ([a-color-scheme (in-list known-color-schemes)]) + (match-define (color-scheme name button-label white-on-black-base? + mapping example inverted-base-name) + a-color-scheme) + (let/ec escape + (define (fail why-fmt . args) + (log-error (apply format why-fmt args)) + (escape (color-scheme name button-label white-on-black-base? + mapping example #f))) + (when inverted-base-name + (define inverted (hash-ref name->scheme inverted-base-name #f)) + (unless inverted (fail "color scheme named ~s has an inverted-base-name ~s but that color scheme does not exist" + name inverted-base-name)) + (unless (equal? (not (color-scheme-white-on-black-base? inverted)) + white-on-black-base?) + (fail "color scheme named ~s has ~s and so does its inverted-base-name color scheme, ~s" + name + (if white-on-black-base? + "a white on black base" + "a black on white base") + inverted-base-name))) + a-color-scheme)))) + +(define (get-inverted-base-color-scheme cs-name) + (define cs (lookup-color-scheme cs-name)) + (cond + [cs + (define inverted-base-name (color-scheme-inverted-base-name cs)) + (cond + [inverted-base-name + (define inverted-base (lookup-color-scheme inverted-base-name)) + (cond + [(equal? (white-on-black-color-scheme?) + (color-scheme-white-on-black-base? inverted-base)) + inverted-base-name] + [else #f])] + [else #f])] + [else #f])) (define color-vector/c (or/c (vector/c byte? byte? byte? #:flat? #t) @@ -795,11 +960,17 @@ 1.0))) ;; returns the user's preferred color, wrt to the current color scheme -(define (lookup-in-color-scheme color-name) +(define (lookup-in-color-scheme color-name #:wob? [wob? (white-on-black-color-scheme?)]) + (lookup-in-color-scheme/given-mapping + color-name + (preferences:get (color-scheme-entry-name->pref-name color-name)) + (get-current-color-scheme #:wob? wob?))) + +(define (lookup-in-given-color-scheme color-name color-scheme) (lookup-in-color-scheme/given-mapping color-name (preferences:get (color-scheme-entry-name->pref-name color-name)) - (get-current-color-scheme))) + color-scheme)) (define (lookup-in-color-scheme/given-mapping color-name table a-color-scheme) (cond @@ -825,7 +996,7 @@ ;; set-color : symbol (or/c string? (is-a?/c color%) (is-a?/c style-delta%)) -> void (define (set-in-color-scheme color-name clr/sd) (define table (preferences:get (color-scheme-entry-name->pref-name color-name))) - (define current-color-scheme (get-current-color-scheme)) + (define current-color-scheme (get-current-color-scheme #:wob? (white-on-black-color-scheme?))) (define scheme-name (color-scheme-name current-color-scheme)) (define new-table (cond @@ -856,19 +1027,22 @@ (= (send c1 blue) (send c2 blue)) (= (send c1 alpha) (send c2 alpha)))) -(define (get-current-color-scheme) - ;; if pref not recognized, return white-on-black color scheme - ;; so that if some color scheme goes away, we have - ;; some reasonable backup plan (and, if it comes back +(define (get-current-color-scheme #:wob? wob?) + ;; if pref is not recognized as an existing color scheme name, + ;; return one of the two original color schemes so that + ;; if some color scheme goes away, we have some + ;; reasonable backup plan (and, if it comes back ;; we don't lose the prefs) - (define pref-val (preferences:get 'framework:color-scheme)) + (define pref-name (if wob? 'framework:color-scheme-dark 'framework:color-scheme-light)) + (define pref-val (preferences:get pref-name)) (define found-color-scheme (lookup-color-scheme pref-val)) (cond [found-color-scheme found-color-scheme] - [else (car known-color-schemes)])) + [wob? (built-in-wob-color-scheme)] + [else (built-in-color-scheme)])) -(define (get-current-color-scheme-name) - (color-scheme-name (get-current-color-scheme))) +(define (get-current-color-scheme-name #:wob? [wob? (white-on-black-color-scheme?)]) + (color-scheme-name (get-current-color-scheme #:wob? wob?))) ;; string -> (or/c #f color-scheme?) (define (lookup-color-scheme name) @@ -876,35 +1050,58 @@ (and (equal? name (color-scheme-name known-color-scheme)) known-color-scheme))) -(define (set-current-color-scheme name [avoid-shortcircuit? #f]) +(define (built-in-wob-color-scheme) (list-ref known-color-schemes 1)) +(define (built-in-color-scheme) (list-ref known-color-schemes 0)) + +(define (set-current-color-scheme name) (define color-scheme (or (for/or ([known-color-scheme (in-list known-color-schemes)]) (and (equal? name (color-scheme-name known-color-scheme)) known-color-scheme)) (car known-color-schemes))) - (when (or avoid-shortcircuit? - (not (equal? (color-scheme-name color-scheme) - (color-scheme-name (get-current-color-scheme))))) - (preferences:set 'framework:color-scheme name) - (define old-wob (preferences:get 'framework:white-on-black?)) - (define new-wob (color-scheme-white-on-black-base? color-scheme)) - (unless (equal? old-wob new-wob) - (preferences:set 'framework:white-on-black? new-wob) - (if new-wob - (white-on-black) - (black-on-white))) - (for ([(color-name fns) (in-hash color-change-callbacks)]) - (for ([fn/b (in-list fns)]) - (define fn (if (weak-box? fn/b) (weak-box-value fn/b) fn/b)) - (when fn - (fn (lookup-in-color-scheme color-name))))))) + (preferences:set (if (color-scheme-white-on-black-base? color-scheme) + 'framework:color-scheme-dark + 'framework:color-scheme-light) + (color-scheme-name color-scheme)) + (when (equal? (color-scheme-white-on-black-base? color-scheme) + (white-on-black-color-scheme?)) + (change-colors-to-match-color-scheme color-scheme))) + +(define (change-colors-to-match-color-scheme color-scheme) + (if (color-scheme-white-on-black-base? color-scheme) + (white-on-black) + (black-on-white)) + (define style-lists-begun '()) + (dynamic-wind + (λ () + (set! style-lists-begun + (for*/list ([(color-name fns+sls) (in-hash color-change-callbacks)] + [fn+sl (in-list fns+sls)]) + (define sl/b (cdr fn+sl)) + (define sl (if (weak-box? sl/b) + (weak-box-value sl/b) + sl/b)) + (and sl (send sl begin-style-change-sequence) sl)))) + (λ () + (for ([(color-name fns+sls) (in-hash color-change-callbacks)]) + (for ([fn/b (in-list (map car fns+sls))]) + (define fn (if (weak-box? fn/b) (weak-box-value fn/b) fn/b)) + (when fn + (fn (lookup-in-given-color-scheme color-name color-scheme)))))) + (λ () + (for ([style-list (in-list style-lists-begun)]) + (when style-list + (send style-list end-style-change-sequence)))))) (define (get-available-color-schemes) (for/list ([(name a-color-scheme) (in-hash known-color-schemes)]) name)) -(define (register-color-scheme-entry-change-callback color fn [weak? #f]) - (define wb/f (if weak? (make-weak-box fn) fn)) +(define (register-color-scheme-entry-change-callback color fn [weak? #f] + #:style-list [style-list #f]) + (define wb/f (if weak? + (cons (make-weak-box fn) (make-weak-box style-list)) + (cons fn style-list))) ;; so we know which callbacks to call when a color scheme change happens (hash-set! color-change-callbacks color @@ -917,23 +1114,26 @@ (λ (pref ht) (define fn (cond - [(weak-box? wb/f) - (define fn (weak-box-value wb/f)) + [(weak-box? (car wb/f)) + (define fn (weak-box-value (car wb/f))) (unless fn (remover)) fn] - [else wb/f])) + [else (car wb/f)])) (when fn - (fn (lookup-in-color-scheme/given-mapping + (fn (lookup-in-color-scheme/given-mapping color ht - (get-current-color-scheme))))))) + (get-current-color-scheme + #:wob? (white-on-black-color-scheme?)))))))) (void)) +;; we remove elements of the list when the function isn't reachable anymore +;; if the style-list isn't reachable we'll keep the function in there. (define (remove-gones lst) - (for/list ([x (in-list lst)] - #:when (or (not (weak-box? x)) - (weak-box-value x))) - x)) + (for/list ([fn+sl (in-list lst)] + #:when (or (not (weak-box? (car fn+sl))) + (weak-box-value (car fn+sl)))) + fn+sl)) (define (known-color-scheme-name? n) (or (set-member? known-color-names n) @@ -996,7 +1196,9 @@ (hash (if (preferences:get 'framework:white-on-black?) white-on-black-color-scheme-name black-on-white-color-scheme-name) - (unmarshall-style-delta val))] + (if background + (unmarshall-style-delta-with-background val) + (unmarshall-style-delta val)))] [(unmarshall-color val) => (λ (clr) @@ -1006,13 +1208,15 @@ black-on-white-color-scheme-name) clr))] [(hash? val) - ;; this may return a bogus hash, but the preferesnces system will check + ;; this may return a bogus hash, but the preferences system will check ;; and revert this to the default pref in that case (for/hash ([(k v) (in-hash val)]) (values k (if style-name - (unmarshall-style-delta v) + (if background + (unmarshall-style-delta-with-background v) + (unmarshall-style-delta v)) (and (vector? v) (= (vector-length v) 4) (make-object color% @@ -1024,10 +1228,37 @@ (register-color-scheme-entry-change-callback name (λ (sd) - (editor:set-standard-style-list-delta style-name sd))) + (editor:set-standard-style-list-delta style-name sd)) + #:style-list (editor:get-standard-style-list)) (define init-value (lookup-in-color-scheme name)) (editor:set-standard-style-list-delta style-name init-value))) +(define color-scheme-examples-parents '()) +(define (update-dark-light-preferences-panel-ordering dark-should-be-first?) + (for ([color-scheme-examples-parent (in-list color-scheme-examples-parents)]) + (define dark-is-first? + (let loop ([area (car (send color-scheme-examples-parent get-children))]) + (cond + [(is-a? area message%) + (equal? (send area get-label) (string-constant dark-color-scheme))] + [(is-a? area area-container<%>) + (for/or ([area (in-list (send area get-children))]) + (loop area))] + [else #f]))) + (unless (equal? dark-should-be-first? dark-is-first?) + (send color-scheme-examples-parent + change-children + reverse)))) + +(preferences:add-callback + 'framework:white-on-black-mode? + (λ (p v) + (update-dark-light-preferences-panel-ordering + (match v + ['platform (white-on-black-panel-scheme?)] + [#t #t] + [#f #f])))) + (define (add-color-scheme-preferences-panel #:extras [extras void]) (preferences:add-panel (list (string-constant preferences-colors) @@ -1037,61 +1268,156 @@ (new-vertical-panel% [parent parent] [style '(auto-vscroll)])) - (extras vp) - (define buttons - (for/list ([color-scheme (in-list known-color-schemes)]) - (define hp (new-horizontal-panel% - [parent vp] - [alignment '(left top)] - [stretchable-height #t])) + (define top-hp (new-horizontal-panel% + [parent vp] + [stretchable-height #f] + [alignment '(center center)])) + (define top-hp2 (new-horizontal-panel% + [parent vp] + [stretchable-height #f] + [alignment '(center center)])) + (define white-on-black-mode-choice + (case (system-type) + [(windows) + (new choice% + [parent top-hp] + [label (string-constant color-mode)] + [choices (list (string-constant light-mode) + (string-constant dark-mode))] + [selection (if (preferences:get 'framework:white-on-black-mode?) 1 0)] + [callback + (λ (_1 _2) + (preferences:set 'framework:white-on-black-mode? + (match (send white-on-black-mode-choice get-selection) + [0 #f] + [1 #t])))])] + [else + (new choice% + [parent top-hp] + [label (string-constant color-mode)] + [choices (list (string-constant use-os-dark-mode-selection) + (string-constant always-light-mode) + (string-constant always-dark-mode))] + [callback + (λ (_1 _2) + (preferences:set 'framework:white-on-black-mode? + (match (send white-on-black-mode-choice get-selection) + [0 'platform] + [1 #f] + [2 #t])))])])) + (case (system-type) + [(windows) + (preferences:add-callback + 'framework:white-on-black-mode? + (λ (_1 val) + (send white-on-black-mode-choice + set-selection + (if val 1 0))))] + [else + (preferences:add-callback + 'framework:white-on-black-mode? + (λ (_1 val) + (send white-on-black-mode-choice + set-selection + (match val + ['platform 0] + [#t 2] + [#f 1]))))]) + + (define color-scheme-examples-vp + (new-vertical-panel% + [spacing 10] + [border 10] + [parent vp])) + (set! color-scheme-examples-parents + (cons + color-scheme-examples-vp + color-scheme-examples-parents)) + (define (mk-color-scheme-radio-buttons white-on-black? radio-panel pref-sym) + (for ([color-scheme (in-list known-color-schemes)] + #:when (equal? white-on-black? (color-scheme-white-on-black-base? color-scheme))) + (define vp (new-vertical-panel% + [parent radio-panel] + [alignment '(left top)] + [stretchable-height #f])) + (define label (new radio-box% + [parent vp] + [label #f] + [selection + (if (equal? (preferences:get pref-sym) + (color-scheme-name color-scheme)) + 0 + #f)] + [callback + (λ (_1 _2) + (preferences:set + pref-sym + (color-scheme-name color-scheme)))] + [choices (list (color-scheme-button-label color-scheme))])) + (preferences:add-callback + pref-sym + (λ (p v) + (send label set-selection + (if (equal? v (color-scheme-name color-scheme)) + 0 + #f)))) (define t (new racket:text%)) (define str (color-scheme-example color-scheme)) (send t insert str) - (define ec (new editor-canvas% - [parent hp] - [style '(auto-hscroll no-vscroll)] + (define inner-hp (new-horizontal-panel% + [parent vp] + [stretchable-height #f])) + (define spacer (new panel% + [parent inner-hp] + [stretchable-width #f])) + (send spacer min-width 40) + (define ec (new editor-canvas% + [parent inner-hp] + [style '(no-border auto-hscroll no-vscroll)] [editor t])) - (define (update-colors defaults?) - (define bkg-name 'framework:basic-canvas-background) - (send ec set-canvas-background - (lookup-in-color-scheme/given-mapping - bkg-name - (if defaults? - (hash) - (preferences:get (color-scheme-entry-name->pref-name bkg-name))) - color-scheme)) - (send t set-style-list (color-scheme->style-list color-scheme defaults?))) (send ec set-line-count (+ 1 (for/sum ([c (in-string str)]) (if (equal? c #\newline) 1 0)))) - (define bp (new-vertical-panel% [parent hp] - [stretchable-height #f] - [stretchable-width #f])) - (define defaults? #f) - (define btn - (new button% - [label (color-scheme-button-label color-scheme)] - [parent bp] - [callback (λ (x y) - (set-current-color-scheme - (color-scheme-name color-scheme)) - (when (and default-checkbox - (send default-checkbox get-value)) - (revert-to-color-scheme-defaults color-scheme)))])) - (define default-checkbox - (new check-box% - [stretchable-width #t] - [label "Revert to\ndefault colors"] - [parent bp] - [callback - (λ (x y) - (update-colors (send default-checkbox get-value)))])) - (update-colors #f) - btn)) - (define wid (apply max (map (λ (x) (send x get-width)) buttons))) - (for ([b (in-list buttons)]) - (send b min-width wid)) + (define bkg-name 'framework:basic-canvas-background) + (send ec set-canvas-background + (lookup-in-color-scheme/given-mapping + bkg-name + (preferences:get (color-scheme-entry-name->pref-name bkg-name)) + color-scheme)) + (send t set-style-list (color-scheme->style-list color-scheme #f)))) + + (define dark-panel (new vertical-panel% + [parent color-scheme-examples-vp] + [stretchable-height #f] + [style '(border)])) + (define light-panel (new vertical-panel% + [parent color-scheme-examples-vp] + [stretchable-height #f] + [style '(border)])) + (new message% + [parent dark-panel] + [label (string-constant dark-color-scheme)]) + (new message% + [parent light-panel] + [label (string-constant light-color-scheme)]) + (mk-color-scheme-radio-buttons #t dark-panel 'framework:color-scheme-dark) + (mk-color-scheme-radio-buttons #f light-panel 'framework:color-scheme-light) + + (update-dark-light-preferences-panel-ordering + (white-on-black-color-scheme?)) + + (define revert-button% + (new button% + [label (string-constant revert-colors-to-color-scheme-defaults)] + [parent vp] + [callback + (λ (x y) + (revert-to-color-scheme-defaults + (get-current-color-scheme + #:wob? + (white-on-black-color-scheme?))))])) + (extras vp) (void)))) (define (revert-to-color-scheme-defaults color-scheme) diff --git a/gui-lib/framework/private/color.rkt b/gui-lib/framework/private/color.rkt index f4cfe4231..f6575f45f 100644 --- a/gui-lib/framework/private/color.rkt +++ b/gui-lib/framework/private/color.rkt @@ -10,10 +10,12 @@ added get-regions (require racket/class racket/unit racket/gui/base + racket/match syntax-color/token-tree syntax-color/paren-tree syntax-color/default-lexer syntax-color/lexer-contract + syntax-color/color-textoid string-constants "../preferences.rkt" "sig.rkt" @@ -40,16 +42,39 @@ added get-regions (define (should-color-type? type) (not (memq type '(no-color)))) -(define (make-data type mode backup-delta) +(define (make-data attribs mode backup-delta) (if (zero? backup-delta) - (cons type mode) - (vector type mode backup-delta))) -(define (data-type data) (if (pair? data) (car data) (vector-ref data 0))) + (cons attribs mode) + (vector attribs mode backup-delta))) +(define (data-attribs data) (if (pair? data) (car data) (vector-ref data 0))) +(define (data-type data) (attribs->type (data-attribs data))) +(define (data-color-type data) (attribs->color-type (data-attribs data))) (define (data-lexer-mode data) (if (pair? data) (cdr data) (vector-ref data 1))) (define (data-backup-delta data) (if (vector? data) (vector-ref data 2) 0)) +(define (attribs->type attribs) + (if (symbol? attribs) + attribs + (hash-ref attribs 'type 'unknown))) +(define (attribs->color-type attribs) + (if (symbol? attribs) + attribs + (or (hash-ref attribs 'color #f) + (hash-ref attribs 'type 'unknown)))) + (define (attribs->invisible attribs) + (cond + [(symbol? attribs) + (values 0 0)] + [else + (values (hash-ref attribs 'invisible-open-count 0) + (hash-ref attribs 'invisible-close-count 0))])) +(define (attribs->table attribs) + (if (symbol? attribs) + (hasheq 'type attribs) + attribs)) + (define -text<%> - (interface (text:basic<%>) + (interface (text:basic<%> color-textoid<%>) start-colorer stop-colorer force-stop-colorer @@ -61,21 +86,25 @@ added get-regions reset-region reset-regions - get-regions is-lexer-valid? on-lexer-valid get-matching-paren-string - - skip-whitespace - backward-match - backward-containing-sexp - forward-match + + ;; Thse are in color-textoid<%>: + ;; skip-whitespace + ;; backward-match + ;; backward-containing-sexp + ;; forward-match + ;; classify-position + ;; classify-position* + ;; get-token-range + ;; get-backward-navigation-limit + ;; get-regions + insert-close-paren - classify-position - get-token-range - + set-spell-check-strings get-spell-check-strings set-spell-check-text @@ -285,7 +314,7 @@ added get-regions (inherit change-style begin-edit-sequence end-edit-sequence highlight-range get-style-list in-edit-sequence? get-start-position get-end-position local-edit-sequence? get-styles-fixed has-focus? - get-fixed-style get-text) + get-fixed-style get-text default-style-name) (define lexers-all-valid? #t) (define/private (update-lexer-state-observers) @@ -366,7 +395,7 @@ added get-regions #f] [else (define-values (_line1 _col1 pos-before) (port-next-location in)) - (define-values (lexeme type data new-token-start new-token-end + (define-values (lexeme attribs paren new-token-start new-token-end backup-delta new-lexer-mode/cont) (get-token in in-start-pos lexer-mode)) (define-values (_line2 _col2 pos-after) (port-next-location in)) @@ -374,34 +403,36 @@ added get-regions (dont-stop-val new-lexer-mode/cont) new-lexer-mode/cont)) (define next-ok-to-stop? (not (dont-stop? new-lexer-mode/cont))) + (check-colorer-results-match-port-before-and-after + 'color:text<%> + (attribs->type attribs) pos-before new-token-start new-token-end pos-after) (cond - [(eq? 'eof type) + [(eq? 'eof attribs) (set-lexer-state-up-to-date?! ls #t) (re-tokenize-move-to-next-ls start-time next-ok-to-stop?)] [else - (unless (<= pos-before new-token-start pos-after) - (error 'color:text<%> - "expected the token start to be between ~s and ~s, got ~s" - pos-before pos-after new-token-start)) - (unless (<= pos-before new-token-end pos-after) - (error 'color:text<%> - "expected the token end to be between ~s and ~s, got ~s" - pos-before pos-after new-token-end)) (let ((len (- new-token-end new-token-start))) (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)) + (define color-type (attribs->color-type attribs)) + ;; note: `should-color-type?` test here means that spelling is not checked + ;; for 'no-color text, which is maybe not the right choice + (when (and should-color? (should-color-type? color-type) (not frozen?)) + (add-colorings attribs color-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! tokens (new token-tree% (length len) (data attribs))) (insert-last-spec! (lexer-state-tokens ls) len - (make-data type new-lexer-mode backup-delta)) + (make-data attribs new-lexer-mode backup-delta)) #; (show-tree (lexer-state-tokens ls)) - (send (lexer-state-parens ls) add-token data len) + (define-values (invisible-opens invisible-closes) + (attribs->invisible attribs)) + (send (lexer-state-parens ls) add-token paren len + #:invisible-opens invisible-opens + #:invisible-closes invisible-closes) (cond [(and (not (send (lexer-state-invalid-tokens ls) is-empty?)) (= (lexer-state-invalid-tokens-start ls) @@ -420,13 +451,16 @@ added get-regions (continue-re-tokenize start-time next-ok-to-stop? ls in in-start-pos new-lexer-mode)]))])])) - (define/private (add-colorings type in-start-pos new-token-start new-token-end) + (define/private (add-colorings attribs color-type in-start-pos new-token-start new-token-end) (define sp (+ in-start-pos (sub1 new-token-start))) (define ep (+ in-start-pos (sub1 new-token-end))) - (define style-name (token-sym->style type)) - (define color (send (get-style-list) find-named-style style-name)) + (define style-name (token-sym->style color-type)) + (define base-color (send (get-style-list) find-named-style style-name)) + (define color (if (and (hash? attribs) (hash-ref attribs 'comment? #f)) + (color-style->comment-style base-color) + base-color)) (cond - [(do-spell-check? type) + [(do-spell-check? (attribs->type attribs)) (define misspelled-color (send (get-style-list) find-named-style misspelled-text-color-style-name)) (cond @@ -444,6 +478,14 @@ added get-regions [else (add-coloring color sp ep)])) + (define/private (color-style->comment-style base-color) + (let ([d (new style-delta%)] + [base-color (or base-color (send (get-style-list) find-named-style (default-style-name)))]) + ;; 50% transparency: + (send (send d get-foreground-mult) set-a 0.5) + (and base-color + (send (get-style-list) find-or-create-style base-color d)))) + (define/private (do-spell-check? type) (or (and (equal? type 'string) spell-check-strings?) (and (equal? type 'text) spell-check-text?))) @@ -648,9 +690,9 @@ added get-regions get-token- ;; Old interface: no offset, backup delta, or mode (lambda (in offset mode) - (let-values ([(lexeme type data new-token-start new-token-end) + (let-values ([(lexeme attribs paren new-token-start new-token-end) (get-token- in)]) - (values lexeme type data new-token-start new-token-end 0 #f))))) + (values lexeme attribs paren new-token-start new-token-end 0 #f))))) (set! pairs pairs-) (for-each (lambda (ls) @@ -723,13 +765,18 @@ added get-regions [start-pos (lexer-state-start-pos ls)]) (send tokens for-each (λ (start len data) - (let ([type (data-type data)]) - (when (should-color-type? type) - (let ((color (send (get-style-list) find-named-style - (token-sym->style type))) + (let ([color-type (data-color-type data)] + [comment? (let ([attribs (data-attribs data)]) + (and (hash? attribs) (hash-ref attribs 'comment? #f)))]) + (when (should-color-type? color-type) + (let ((base-color (send (get-style-list) find-named-style + (token-sym->style color-type))) (sp (+ start-pos start)) (ep (+ start-pos (+ start len)))) - (change-style color sp ep #f)))))))) + (let ([color (if comment? + (color-style->comment-style base-color) + base-color)]) + (change-style color sp ep #f))))))))) lexer-states)) (end-edit-sequence)))))))) @@ -759,8 +806,6 @@ added get-regions (define clear-old-locations void) (define mismatch-color (make-object color% "PINK")) - (define/private (get-match-color) - (color-prefs:lookup-in-color-scheme 'framework:paren-match-color)) ;; See docs ;; String Symbol -> (U String False) @@ -780,15 +825,20 @@ added get-regions ;; higlight : number number number (or/c color any) ;; if color is a color, then it uses that color to higlight - ;; Otherwise, it treats it like a boolean, where a true value + ;; if color is a color-prefs:color-scheme-color-name?, ditto + ;; Otherwise, it must be a boolean, where #t ;; means the normal paren color and #f means an error color. - ;; numbers are expected to have zero be start-pos. + ;; start and end expected to have zero be start-pos, that is, relative + ;; to the starting position of `ls` (define/private (highlight ls start end caret-pos color [priority 'low]) (let* ([start-pos (lexer-state-start-pos ls)] [off (highlight-range (+ start-pos start) (+ start-pos end) - (if (is-a? color color%) - color - (if color mismatch-color (get-match-color))) + (cond + [(is-a? color color%) color] + [(color-prefs:color-scheme-color-name? color) color] + [(boolean? color) + (if color mismatch-color 'framework:paren-match-color)] + [else (error 'highlight "unknown color ~s" color)]) (= caret-pos (+ start-pos start)) priority)]) (set! clear-old-locations @@ -815,78 +865,169 @@ added get-regions ;; This leads to the nice behavior that we don't have to block to ;; highlight parens, and the parens will be highlighted as soon as ;; possible. - (define/private match-parens - (lambda ([just-clear? #f]) - ;;(printf "(match-parens ~a)\n" just-clear?) - (when (and (not in-match-parens?) - ;; Trying to match open parens while the - ;; background thread is going slows it down. - ;; The random number slows down how often it - ;; tries. - (or just-clear? - (andmap lexer-state-up-to-date? lexer-states) - (= 0 (random 5)))) - (set! in-match-parens? #t) - (begin-edit-sequence #f #f) - (clear-old-locations) - (set! clear-old-locations void) - (when (and (preferences:get 'framework:highlight-parens) - (not just-clear?) - (not stopped?)) - (let* ((here (get-start-position))) - (when (= here (get-end-position)) - (let ([ls (find-ls here)]) - (when ls - (let-values (((start-f end-f error-f) - (send (lexer-state-parens ls) match-forward - (- here (lexer-state-start-pos ls))))) - (when (and (not (f-match-false-error ls start-f end-f error-f)) - start-f end-f) - (if error-f - (highlight ls start-f end-f here error-f) - (highlight-nested-region ls start-f end-f here)))) - (let-values (((start-b end-b error-b) - (send (lexer-state-parens ls) match-backward - (- here (lexer-state-start-pos ls))))) - (when (and start-b end-b) - (if error-b - (highlight ls start-b end-b here error-b) - (highlight-nested-region ls start-b end-b here))))))))) - (end-edit-sequence) - (set! in-match-parens? #f)))) + ;; this is actually a private method; it is a local member name used to give acces to the test suite + (define/public (match-parens [just-clear? #f]) + ;; (printf "(match-parens ~a)\n" just-clear?) + (when (and (not in-match-parens?) + ;; Trying to match open parens while the + ;; background thread is going slows it down. + ;; The random number slows down how often it + ;; tries. + (or just-clear? + (andmap lexer-state-up-to-date? lexer-states) + (= 0 (random 5)))) + (set! in-match-parens? #t) + (begin-edit-sequence #f #f) + (clear-old-locations) + (set! clear-old-locations void) + (when (and (preferences:get 'framework:highlight-parens) + (not just-clear?) + (not stopped?)) + (define caret-pos (get-start-position)) + (when (= caret-pos (get-end-position)) + (define ls (find-ls caret-pos)) + (define consider-invisible-parens? + (not (= 1 (vector-length (get-parenthesis-colors))))) + (when ls + (define-values (start-f end-f error-f) + (send (lexer-state-parens ls) match-forward + (- caret-pos (lexer-state-start-pos ls)) + #:invisible (if consider-invisible-parens? 'all #f))) + (when (and (not (f-match-false-error ls start-f end-f error-f)) + start-f end-f) + (if error-f + (highlight ls start-f end-f caret-pos (and error-f #t)) + (highlight-nested-region ls start-f end-f caret-pos #f))) + (define-values (start-b end-b error-b) + (send (lexer-state-parens ls) match-backward + (- caret-pos (lexer-state-start-pos ls)) + #:invisible (if consider-invisible-parens? 'all #f))) + (when (and start-b end-b) + (cond + [error-b + (highlight ls start-b end-b caret-pos (and error-b #t))] + [else + (define-values (total-opens total-closes) + (send (lexer-state-parens ls) get-invisible-count start-b)) + (define opens + (let loop ([opens (if consider-invisible-parens? total-opens 0)]) + (cond + [(zero? opens) + ;; if we don't find a match to the close where we started, + ;; just try all of the opens here (which might be because + ;; there are no invisible opens here at all) + #f] + [else + (define-values (start-pos end-pos is-error) + (send (lexer-state-parens ls) match-forward + start-b + #:invisible opens)) + (cond + [(and (not is-error) (equal? end-pos end-b)) opens] + [else (loop (- opens 1))])]))) + (highlight-nested-region ls start-b end-b caret-pos opens)]))))) + (end-edit-sequence) + (set! in-match-parens? #f))) ;; highlight-nested-region : lexer-state number number number -> void ;; colors nested regions of parentheses. - (define/private (highlight-nested-region ls orig-start orig-end here) + ;; + ;; coordinates of orig-start and orig-end are relative to the start of `ls`, so use, eg, + ;; (+ orig-start (lexer-state-start-pos ls)) to get coordinates in the text object + (define/private (highlight-nested-region ls orig-start orig-end caret-pos opens-to-start) (define priority (get-parenthesis-priority)) (define paren-colors (get-parenthesis-colors)) - (let paren-loop ([start orig-start] - [end orig-end] - [depth 0]) - (when (< depth (vector-length paren-colors)) - - ;; when there is at least one more color in the vector we'll look - ;; for regions to color at that next level - (when (< (+ depth 1) (vector-length paren-colors)) - (let seq-loop ([inner-sequence-start (+ start 1)]) - (define ls-start (lexer-state-start-pos ls)) - (when (< inner-sequence-start end) - (let ([post-whitespace - (- (skip-whitespace (+ inner-sequence-start ls-start) - 'forward #t) - ls-start)]) - (let-values ([(start-inner end-inner error-inner) - (send (lexer-state-parens ls) match-forward post-whitespace)]) - (cond - [(and start-inner end-inner (not error-inner)) - (paren-loop start-inner end-inner (+ depth 1)) - (seq-loop end-inner)] - [(skip-past-token ls (+ post-whitespace ls-start)) - => - (λ (after-non-paren-thing) - (seq-loop (- after-non-paren-thing ls-start)))])))))) - - (highlight ls start end here (vector-ref paren-colors depth) priority)))) + + ;; this goes over a range at a specific depth, highlighting + ;; of the the parens it finds at that depth and calling `single-spot-loop` to go deeper inside + ;; start and end are lexer-state coordinates (like orig-start argument to highlight-nested-region) + (define (seq-loop start end depth) + (when start + (when (< depth (vector-length paren-colors)) + (define color (vector-ref paren-colors depth)) + (let loop ([start start]) + (when (< start end) + (define afterwards (or (single-spot-loop start depth #f) + (skip-past-token/ls-relative ls start))) + (when afterwards + (loop afterwards))))))) + + ;; single-spot-loop : natural natural -> void + ;; loops over the parens that open at `start` and inside + ;; the region from `start` to its outermost close paren + ;; + ;; instead of a more conventional traversal that would go over the + ;; parens at the current level and then goes across the positions + ;; inside the parens, looking for parens inside, we instead view the + ;; parens all starting at `start` as a series of nested parens that + ;; might look something like this, where the first three parens are + ;; all starting at the same spot. + ;; ((( ) ) ) + ;; 12344433333222221 + ;; This function loops over those first three parens (via the result + ;; of get-spot-parens) and, at each iteration, also considers the region + ;; following the close paren out to the enclosing close paren. That is, + ;; when we're looking at the paren labelled with a 2 in the diagram + ;; above, we'll recur with depth+1 to handle depth 3 (and eventually + ;; depth 4) and then use `seq-loop` to go over the region with the 2s + ;; underneath it, between the last two parens. + ;; start is in lexer-state coordinates (like orig-start argument to highlight-nested-region) + (define (single-spot-loop start depth opens-to-start) + (define-values (invisible-paren-opens invisible-paren-closes) + (send (lexer-state-parens ls) get-invisible-count start)) + (cond + [(or (not (zero? invisible-paren-opens)) + (not (zero? invisible-paren-closes)) + (send (lexer-state-parens ls) is-open-pos? start)) + (define invisible-paren-count (+ (or opens-to-start invisible-paren-opens) + invisible-paren-closes)) + (define-values (outermost-start outermost-end error-outermost) + (send (lexer-state-parens ls) match-forward start #:invisible invisible-paren-count)) + (define ls-start (lexer-state-start-pos ls)) + (cond + [(and outermost-start (not error-outermost)) + (let loop ([invisible-paren-count invisible-paren-count] + [end-position outermost-end] + [depth depth] + [enclosing-highlight #f]) + (when (< depth (vector-length paren-colors)) + (define color (vector-ref paren-colors depth)) + (cond + [(zero? invisible-paren-count) + (define-values (start-inner end-inner error-inner) + (send (lexer-state-parens ls) match-forward start)) + (when (or (not (zero? invisible-paren-opens)) + (not (zero? invisible-paren-closes)) + start-inner) + (cond + [start-inner + (seq-loop (skip-past-token/ls-relative ls start-inner) (- end-inner 1) (+ depth 1)) + (seq-loop (skip-past-token/ls-relative ls end-inner) (- end-position 1) depth)] + [else + (seq-loop (skip-past-token/ls-relative ls start) (- end-position 1) depth)])) + (unless error-inner + (when (and start-inner end-inner) + (highlight ls start-inner end-inner caret-pos color priority)))] + [else + (define-values (start-inner end-inner error-inner) + (send (lexer-state-parens ls) match-forward + start + #:invisible invisible-paren-count)) + (unless error-inner + (cond + [(equal? enclosing-highlight (cons start-inner end-inner)) + (loop (- invisible-paren-count 1) end-inner depth enclosing-highlight)] + [start-inner + (seq-loop (skip-past-token/ls-relative ls end-inner) (- end-position 1) depth) + (loop (- invisible-paren-count 1) end-inner (+ depth 1) (cons start-inner end-inner)) + (highlight ls start-inner end-inner caret-pos color priority)] + [else + (loop (- invisible-paren-count 1) end-inner (+ depth 1) enclosing-highlight)]))]))) + outermost-end] + [else #f])] + [else #f])) + + (single-spot-loop orig-start 0 opens-to-start)) ;; See docs (define/public (forward-match position cutoff) @@ -917,19 +1058,19 @@ added get-regions (skip-past-token ls position)))))))) (define/private (skip-past-token ls position) - (let-values (((tok-start tok-end) - (begin - (tokenize-to-pos ls position) - (send (lexer-state-tokens ls) search! - (- position (lexer-state-start-pos ls))) - (values (send (lexer-state-tokens ls) get-root-start-position) - (send (lexer-state-tokens ls) get-root-end-position))))) - (cond - ((or (send (lexer-state-parens ls) is-close-pos? tok-start) - (= (+ (lexer-state-start-pos ls) tok-end) position)) - #f) - (else - (+ (lexer-state-start-pos ls) tok-end))))) + (define pos (skip-past-token/ls-relative ls (- position (lexer-state-start-pos ls)))) + (and pos (+ pos (lexer-state-start-pos ls)))) + + (define/private (skip-past-token/ls-relative ls position) + (tokenize-to-pos ls (+ (lexer-state-start-pos ls) position)) + (send (lexer-state-tokens ls) search! position) + (define tok-start (send (lexer-state-tokens ls) get-root-start-position)) + (define tok-end (send (lexer-state-tokens ls) get-root-end-position)) + (cond + [(or (send (lexer-state-parens ls) is-close-pos? tok-start) + (= tok-end position)) + #f] + [else tok-end])) ;; See docs (define/public (backward-match position cutoff) @@ -937,6 +1078,8 @@ added get-regions (cond ((or (eq? x 'open) (eq? x 'beginning)) #f) (else x)))) + + (define/public (get-backward-navigation-limit pos) 0) (define/private (internal-backward-match position cutoff) (when stopped? @@ -995,7 +1138,14 @@ added get-regions (and tokens (let ([root-data (send tokens get-root-data)]) (and root-data - (data-type root-data))))) + (attribs->type (data-attribs root-data)))))) + + (define/public (classify-position* position) + (define-values (tokens ls) (get-tokens-at-position 'classify-position* position)) + (and tokens + (let ([root-data (send tokens get-root-data)]) + (and root-data + (attribs->table (data-attribs root-data)))))) (define/public (get-token-range position) (define-values (tokens ls) (get-tokens-at-position 'get-token-range position)) @@ -1331,7 +1481,7 @@ added get-regions 'low)))) (cons (list 'basic-grey (string-constant paren-color-basic-grey) - (vector (color-prefs:lookup-in-color-scheme 'framework:paren-match-color)) + (vector 'framework:paren-match-color) 'high) parenthesis-color-table)) @@ -1361,7 +1511,7 @@ added get-regions (define -text% (text-mixin text:keymap%)) -(define -text-mode<%> (interface () set-get-token)) +(define -text-mode<%> (interface () set-get-token set-matches)) (define text-mode-mixin (mixin (mode:surrogate-text<%>) (-text-mode<%>) @@ -1381,6 +1531,9 @@ added get-regions (define/public (set-get-token _get-token) (set! get-token _get-token)) + + (define/public (set-matches _matches) + (set! matches _matches)) (super-new))) diff --git a/gui-lib/framework/private/comment-box.rkt b/gui-lib/framework/private/comment-box.rkt index eb0f4b140..b5695fcea 100644 --- a/gui-lib/framework/private/comment-box.rkt +++ b/gui-lib/framework/private/comment-box.rkt @@ -15,14 +15,15 @@ (define-unit comment-box@ (import [prefix racket: framework:racket^] - [prefix keymap: framework:keymap^]) + [prefix keymap: framework:keymap^] + [prefix text: framework:text^]) (export (rename framework:comment-box^ (-snip% snip%))) (define snipclass% (class decorated-editor-snipclass% (define/override (make-snip stream-in) (instantiate -snip% ())) - (super-instantiate ()))) + (super-new))) (define snipclass (make-object snipclass%)) (send snipclass set-version 1) @@ -35,7 +36,7 @@ (define (get-scheme+copy-self%) (unless scheme+copy-self% (set! scheme+copy-self% - (class racket:text% + (class (text:searching-embedded-mixin racket:text%) (inherit copy-self-to) (define/override (copy-self) (let ([ed (new scheme+copy-self%)]) @@ -119,6 +120,6 @@ (define/public (read-special source line column position) (make-special-comment "comment")) - (super-instantiate ()) + (super-new) (inherit set-snipclass) (set-snipclass snipclass)))) diff --git a/gui-lib/framework/private/decorated-editor-snip.rkt b/gui-lib/framework/private/decorated-editor-snip.rkt index 39a322df9..3014403c8 100644 --- a/gui-lib/framework/private/decorated-editor-snip.rkt +++ b/gui-lib/framework/private/decorated-editor-snip.rkt @@ -1,7 +1,8 @@ #lang scheme/base (require scheme/gui/base - racket/class) + racket/class + "wob-color-scheme.rkt") (provide editor-snip:decorated% editor-snip:decorated-snipclass% @@ -29,7 +30,7 @@ (define/public (get-corner-bitmap) #f) ;; get-color : -> (union string (is-a?/c color%)) - (define/public (get-color) (if (preferences:get 'framework:white-on-black?) "white" "black")) + (define/public (get-color) (if (white-on-black-color-scheme?) "white" "black")) ;; get-menu : -> (union #f (is-a?/c popup-menu%)) ;; returns the popup menu that should appear @@ -103,7 +104,7 @@ (super draw dc x y left top right bottom dx dy draw-caret) (let* ([old-pen (send dc get-pen)] [old-brush (send dc get-brush)] - [white-on-black? (preferences:get 'framework:white-on-black?)]) + [white-on-black? (white-on-black-color-scheme?)]) (send dc set-pen (send the-pen-list find-or-create-pen (if white-on-black? "black" "white") diff --git a/gui-lib/framework/private/editor-autoload.rkt b/gui-lib/framework/private/editor-autoload.rkt new file mode 100644 index 000000000..ee63917bb --- /dev/null +++ b/gui-lib/framework/private/editor-autoload.rkt @@ -0,0 +1,403 @@ +#lang racket/unit + +(require "sig.rkt" + "editor-sig.rkt" + "../preferences.rkt" + "focus-table.rkt" + string-constants + mred/mred-sig + racket/class + racket/match + file/sha1) + +(import mred^ + [prefix frame: framework:frame^] + [prefix editor: editor-misc^]) +(export editor-autoload^) +(init-depend mred^) + +(define autoload<%> + (interface (editor:basic<%>))) + +(define-local-member-name autoload-file-changed autoload-do-revert) + +;; open-dialogs : hash[tlw -o> (cons/c dialog boolean)] +;; the dialogs that are currently being shown, paired with +;; a boolean that indicates if the initial dialog has a checkbox +(define open-dialogs (make-hash)) + +;; pending-editors : hash[tlw -o> (listof editor<%>)] +;; editors where we are waiting for a reply from the user +(define pending-editors (make-hash)) + +;; invariant: +;; (hash-ref pending-editors tlw '()) = (cons ed eds) +;; ⟺ +;; (hash-ref open-dialogs tlw #f) ≠ #f + + +;; only called if we have to ask the user about what to do, +;; so we know that the `ask preference is set or window was dirty +(define (handle-autoload-file-changed&need-dialog editor) + (define tlw (send editor get-top-level-window)) + (define already-pending-editors (hash-ref pending-editors tlw '())) ;; when tlw=#f, this will be '() + (unless (member editor already-pending-editors) + (define all-pending-editors (cons editor already-pending-editors)) + (when tlw (hash-set! pending-editors tlw all-pending-editors)) + (cond + [(and (null? (cdr all-pending-editors)) + (send (car all-pending-editors) is-modified?)) + ;; first one => need to open the dialog, and it is dirty + (define dlg + (message-box/custom + (string-constant warning) + (get-autoload-warning-message all-pending-editors) + (string-constant revert) + (string-constant ignore) + #f + tlw + '(caution no-default) + 2 + #:return-the-dialog? #t + #:dialog-mixin frame:focus-table-mixin)) + (when tlw + (hash-set! open-dialogs tlw (cons dlg #f)) + (hash-set! pending-editors tlw (list editor))) + (define revert? (case (send dlg show-and-return-results) + [(1) #t] + [(2) #f])) + (handle-dialog-closed tlw editor revert?)] + [(null? (cdr all-pending-editors)) + ;; first one => need to open the dialog, but it isn't dirty + (define dlg + (message+check-box/custom + (string-constant warning) + (get-autoload-warning-message all-pending-editors) + (string-constant dont-ask-again-always-current) + (string-constant revert) + (string-constant ignore) + #f + tlw + '(caution no-default) + 2 + #:return-the-dialog? #t + #:dialog-mixin frame:focus-table-mixin)) + (when tlw + (hash-set! open-dialogs tlw (cons dlg #t)) + (hash-set! pending-editors tlw (list editor))) + (define-values (button checked?) (send dlg show-and-return-results)) + (define revert? (case button + [(1) #t] + [(2) #f])) + (when checked? + ;; setting the preference will start the monitor + ;; if `answer` is #t + (preferences:set 'framework:autoload revert?)) + (handle-dialog-closed tlw editor revert?)] + [else + ;; dialog is already open, see if we need to tweak the text + ;; here we know that tlw ≠ #f + (match-define (cons dlg has-check?) (hash-ref open-dialogs tlw)) + (hash-set! pending-editors tlw all-pending-editors) + (define any-existing-modified? + (for/or ([ed (in-list already-pending-editors)]) + (send ed is-modified?))) + (define this-one-modified? (send editor is-modified?)) + (when has-check? ;; here we know that at least one is clean + (when this-one-modified? ;; here we know that we are dirty + (unless any-existing-modified? ;; here we know we are the first dirty one + ;; which means we need to update the label of the checkbox + (send dlg set-check-label + (string-constant + dont-ask-again-always-current/clean-buffer))))) + (define new-dialog-message + (get-autoload-warning-message all-pending-editors)) + (send dlg set-message new-dialog-message)]))) + +(define (get-autoload-warning-message currently-pending-editors) + (define number-of-pending-editors (length currently-pending-editors)) + (define all-dirty? + (for/and ([ed (in-list currently-pending-editors)]) + (send ed is-modified?))) + (define any-dirty? + (for/or ([ed (in-list currently-pending-editors)]) + (send ed is-modified?))) + (cond + [(not any-dirty?) + ;; none are dirty + (cond + [(= 1 number-of-pending-editors) + (format + (string-constant autoload-file-changed-on-disk/with-name) + (send (car currently-pending-editors) get-filename))] + [else + (apply + string-append + (string-constant autoload-files-changed-on-disk/with-name) + (for/list ([f (in-list currently-pending-editors)]) + (format "\n ~a" (send f get-filename))))])] + [all-dirty? + (cond + [(= 1 number-of-pending-editors) + (format + (string-constant autoload-file-changed-on-disk-editor-dirty/with-name) + (send (car currently-pending-editors) get-filename))] + [else + (apply + string-append + (string-constant autoload-files-changed-on-disk-editor-dirty/with-name) + (for/list ([f (in-list currently-pending-editors)]) + (format "\n ~a" (send f get-filename))))])] + [else + ;; mixture of clean and dirty .. in this case we know there isn't just one file + (apply + string-append + (string-constant autoload-files-changed-on-disk-editor-dirty&clean/with-name) + (for/list ([f (in-list currently-pending-editors)]) + (format "\n ~a~a" + (send f get-filename) + (if (send f is-modified?) + " ◇" + ""))))])) + +(define (handle-dialog-closed tlw editor revert?) + (cond + [tlw + (define all-pending-editors (hash-ref pending-editors tlw)) + (hash-remove! open-dialogs tlw) + (hash-remove! pending-editors tlw) + (when revert? + (for ([ed (in-list all-pending-editors)]) + (send ed autoload-do-revert)))] + [else + (when revert? + (send editor autoload-do-revert))])) + +(define autoload-mixin + (mixin (editor:basic<%>) (autoload<%>) + (inherit get-filename load-file + begin-edit-sequence end-edit-sequence + is-modified?) + + (define/augment (on-load-file path format) + (on-load/save-file path) + (inner (void) on-load-file path format)) + + (define/augment (after-load-file success?) + (after-load/save-file) + (inner (void) after-load-file success?)) + + (define/augment (on-save-file path format) + (on-load/save-file path) + (inner (void) on-load-file path format)) + + (define/augment (after-save-file success?) + (after-load/save-file) + (inner (void) after-load-file success?)) + + (define on/after-communication-channel #f) + + (define/private (on-load/save-file path) + (unless (editor:doing-autosave?) + (define evt + (and (preferences:get 'framework:autoload) + (filesystem-change-evt path (λ () #f)))) + (when evt (monitored-file-sha1-will-change this)) + (set! on/after-communication-channel + (vector path evt)))) + + (define/private (after-load/save-file) + (unless (editor:doing-autosave?) + (match on/after-communication-channel + [(vector path (? filesystem-change-evt? evt)) + (monitor-a-file this path evt (current-eventspace))] + [(vector path #f) + ;; event creation failed or the preference is turned off + (void)]) + (set! on/after-communication-channel #f))) + + (define/override (set-filename filename [temporary? #f]) + (unless on/after-communication-channel + ;; if the filename changes but we aren't doing a + ;; save or a load, then, well, just give up + ;; if the file is saved, later on, we'll start + ;; the monitoring process again + (un-monitor-a-file this)) + (super set-filename filename temporary?)) + + (define/override (update-sha1? path) + (cond + [(editor:doing-autosave?) #f] + [else (super update-sha1? path)])) + + (define/augment (on-close) + (un-monitor-a-file this) + (inner (void) on-close)) + + ;; intentionally not a method; ensures + ;; the callback stays registered with the + ;; preferences system as as long as `this` + ;; is held onto + (define pref-callback + (λ (p v) + (case v + [(#f) (un-monitor-a-file this)] + [(#t ask) + (define path (get-filename)) + (when path + (monitor-a-file this + path + (filesystem-change-evt path (λ () #f)) + (current-eventspace)))]))) + (preferences:add-callback 'framework:autoload pref-callback #t) + + (define/public (autoload-file-changed) + (define pref (preferences:get 'framework:autoload)) + (cond + [(or (is-modified?) (equal? 'ask pref)) + (handle-autoload-file-changed&need-dialog this)] + [pref + (autoload-do-revert)] + [else + (un-monitor-a-file this)])) + + (define/public (autoload-do-revert) + (define b (box #f)) + (define filename (get-filename b)) + (when (and filename + (not (unbox b))) + (define start + (if (is-a? this text%) + (send this get-start-position) + #f)) + (begin-edit-sequence) + (define failed? + (with-handlers ([exn:fail? (λ (x) #t)]) + (load-file filename 'guess #f) + #f)) + (unless failed? + (when (is-a? this text%) + (send this set-position start start))) + (end-edit-sequence))) + + (super-new) + (inherit enable-sha1) + (enable-sha1))) + +(define (monitor-a-file txt path evt eventspace) + (define the-sha1 (send txt get-file-sha1)) + (channel-put monitor-a-file-chan (vector txt path the-sha1 evt eventspace))) +(define monitor-a-file-chan (make-channel)) + +(define (monitored-file-sha1-will-change txt) + (channel-put sha1-will-change-chan txt)) +(define sha1-will-change-chan (make-channel)) + +(define (un-monitor-a-file txt) + (channel-put unmonitor-a-file-chan txt)) +(define unmonitor-a-file-chan (make-channel)) + +(void + (thread + (λ () + ;; path: path-string? + ;; evt: filesystem-change-evt? + ;; the-sha1: (or/c 'unknown-check 'unknown-no-check bytes?) + ;; -- the two symbols mean we don't know the sha1 should be + ;; 'unknown-check means the evt has woken up and so when + ;; we get the sha1 we should check the file and + ;; 'unknown-no-check means that the evt hasn't yet woken up + ;; bytes? is the sha1 + ;; eventspace: eventspace? + (struct monitored (path evt the-sha1 eventspace) #:transparent) + + ;; state : hash[txt -o> monitored?] + (let loop ([state (hash)]) + (apply + sync + (handle-evt + unmonitor-a-file-chan + (λ (txt) + (define old (hash-ref state txt #f)) + (when old (filesystem-change-evt-cancel (monitored-evt old))) + (loop (hash-remove state txt)))) + + (handle-evt + monitor-a-file-chan + (λ (txt+path+eventspace) + (match-define (vector txt path the-sha1 evt eventspace) + txt+path+eventspace) + (define old (hash-ref state txt #f)) + (when old (filesystem-change-evt-cancel (monitored-evt old))) + (loop (hash-set state + txt + (monitored path evt + the-sha1 + eventspace))))) + + (handle-evt + sha1-will-change-chan + (λ (txt) + (match (hash-ref state txt #f) + [(? monitored? old) + (loop (hash-set state txt + (struct-copy monitored old + [the-sha1 'unknown-no-check])))] + [#f (loop state)]))) + + (for/list ([(txt a-monitored) (in-hash state)]) + (match-define (monitored path evt the-sha1 eventspace) + a-monitored) + (handle-evt + evt + (λ (_) + ;; create the new evt before we look at the file's + ;; sha1 to avoid any moment where the file might + ;; be unmonitored. + (define new-evt (filesystem-change-evt path (λ () #f))) + + (define state-of-file + (with-handlers ([exn:fail:filesystem? (λ (x) 'failed)]) + (cond + [(symbol? the-sha1) 'need-to-wait] + [(equal? the-sha1 (call-with-input-file path sha1-bytes)) + 'unchanged] + [else 'changed]))) + (match state-of-file + ['need-to-wait + (cond + [new-evt + (loop (hash-set state txt + (struct-copy monitored a-monitored + [the-sha1 'unknown-check] + [evt new-evt])))] + [else + ;; we failed to create an evt; give up on + ;; monitoring this file (can we do better?) + (loop (hash-remove state txt))])] + ['unchanged + ;; this appears to be a spurious wakeup + ;; use the new evt to wait again + (cond + [new-evt + (loop (hash-set state txt + (struct-copy monitored a-monitored + [evt new-evt])))] + [else + (loop (hash-remove state txt))])] + ['failed + ;; an exception was raised above so we don't notify, + ;; but also stop monitoring the file + (when new-evt (filesystem-change-evt-cancel new-evt)) + (loop (hash-remove state txt))] + ['changed + ;; here we know that the content has a new hash + ;; so it seems safe to safe to reload the buffer. + (parameterize ([current-eventspace eventspace]) + (queue-callback + (λ () + (send txt autoload-file-changed)))) + ;; we also reenable the monitor here + (loop (hash-set state txt + (struct-copy monitored a-monitored + [evt new-evt])))]))))))))) diff --git a/gui-lib/framework/private/editor-misc.rkt b/gui-lib/framework/private/editor-misc.rkt new file mode 100644 index 000000000..77eacf99f --- /dev/null +++ b/gui-lib/framework/private/editor-misc.rkt @@ -0,0 +1,893 @@ +#lang racket/unit + +(require string-constants + "sig.rkt" + "editor-sig.rkt" + "../preferences.rkt" + "../gui-utils.rkt" + "interfaces.rkt" + "focus-table.rkt" + mzlib/etc + mred/mred-sig + racket/class + racket/path + racket/contract + racket/format + mrlib/panel-wob) + +(import mred^ + [prefix autosave: framework:autosave^] + [prefix finder: framework:finder^] + [prefix path-utils: framework:path-utils^] + [prefix keymap: framework:keymap^] + [prefix text: framework:text^] + [prefix pasteboard: framework:pasteboard^] + [prefix frame: framework:frame^] + [prefix handler: framework:handler^] + [prefix color-prefs: framework:color-prefs^]) +(export (rename editor-misc^ + [-keymap<%> keymap<%>])) +(init-depend mred^ framework:autosave^) + +;; renaming, for editor-mixin where get-file is shadowed by a method. +(define mred:get-file get-file) + +(define basic<%> editor:basic<%>) + +(define basic-mixin + (mixin (editor<%>) (basic<%>) + (inherit begin-edit-sequence end-edit-sequence) + + (define/pubment (can-close?) (inner #t can-close?)) + (define/pubment (on-close) (inner (void) on-close)) + (define/public (close) (if (can-close?) + (begin (on-close) #t) + #f)) + + (define/public (get-pos/text event) + (get-pos/text-dc-location (send event get-x) (send event get-y))) + + (define/public (get-pos/text-dc-location event-x event-y) + (let ([on-it? (box #f)]) + (let loop ([editor this]) + (let-values ([(x y) (send editor dc-location-to-editor-location event-x event-y)]) + (cond + [(is-a? editor text%) + (let ([pos (send editor find-position x y #f on-it?)]) + (cond + [(not (unbox on-it?)) (values #f #f)] + [else + (let ([snip (send editor find-snip pos 'after-or-none)]) + (if (and snip + (is-a? snip editor-snip%)) + (loop (send snip get-editor)) + (values pos editor)))]))] + [(is-a? editor pasteboard%) + (let ([snip (send editor find-snip x y)]) + (if (and snip + (is-a? snip editor-snip%)) + (loop (send snip get-editor)) + (values #f editor)))] + [else (values #f #f)]))))) + + ;; get-filename/untitled-name : -> string + ;; returns a string representing the visible name for this file, + ;; or "Untitled " for some n. + (define untitled-name #f) + (define/public (get-filename/untitled-name) + (let ([filename (get-filename)]) + (if filename + (path->string filename) + (begin + (unless untitled-name + (set! untitled-name (gui-utils:next-untitled-name))) + untitled-name)))) + + (inherit get-filename save-file) + (define/public save-file/gui-error + (opt-lambda ([input-filename #f] + [fmt 'same] + [show-errors? #t]) + (let ([filename (if (or (not input-filename) + (equal? input-filename "")) + (let ([internal-filename (get-filename)]) + (if (or (not internal-filename) + (equal? internal-filename "")) + (put-file #f #f) + internal-filename)) + input-filename)]) + (with-handlers ([exn:fail? + (λ (exn) + (message-box + (string-constant error-saving) + (string-append + (format (string-constant error-saving-file/name) + filename) + "\n\n" + (format-error-message exn)) + (find-parent/editor this) + '(stop ok)) + #f)]) + (when filename + (save-file filename fmt #f)) + (and filename #t))))) + + (inherit load-file) + (define/public load-file/gui-error + (opt-lambda ([input-filename #f] + [fmt 'guess] + [show-errors? #t]) + (let ([filename (if (or (not input-filename) + (equal? input-filename "")) + (let ([internal-filename (get-filename)]) + (if (or (not internal-filename) + (equal? internal-filename "")) + (get-file #f) + internal-filename)) + input-filename)]) + (with-handlers ([exn:fail? + (λ (exn) + ((error-display-handler) + (exn-message exn) + exn) + (message-box + (string-constant error-loading) + (string-append + (format (string-constant error-loading-file/name) + filename) + "\n\n" + (format-error-message exn)) + (find-parent/editor this) + '(stop ok)) + #f)]) + (load-file input-filename fmt show-errors?) + #t)))) + + (define/public (revert/gui-error) + (define b (box #f)) + (define filename (get-filename b)) + (cond + [(and filename + (not (unbox b))) + (define start + (if (is-a? this text%) + (send this get-start-position) + #f)) + (begin-edit-sequence) + (define status (load-file/gui-error filename 'guess #f)) + (when status + (when (is-a? this text%) + (send this set-position start start))) + (end-edit-sequence) + status] + [else #t])) + + (inherit refresh-delayed? + get-canvas + get-admin) + + (define/augment (can-save-file? filename format) + (define (ask-users-opinion) + (cond + [(or (silent-cancel-on-save-file-out-of-date?) (doing-autosave?)) + ;; opt for the effect of + ;; clicking on the `cancel` + ;; button + #f] + [else + (gui-utils:get-choice + (string-constant file-has-been-modified) + (string-constant overwrite-file-button-label) + (string-constant cancel) + (string-constant warning) + #f + (get-top-level-window) + #:dialog-mixin frame:focus-table-mixin)])) + (define result + (and (if (equal? filename (get-filename)) + (if (save-file-out-of-date?) + (ask-users-opinion) + #t) + #t) + (inner #t can-save-file? filename format))) + (when result (set! can-save-file-filename filename)) + result) + + (define can-save-file-filename #f) + (define last-saved-file-time #f) + + (define/augment (after-save-file success?) + (define temp-b (box #f)) + (define filename (get-filename temp-b)) + + ;; update recently opened file names + (unless (unbox temp-b) + (when filename + (handler:add-to-recent filename))) + + ;; if the filenames are different, then the save + ;; was an auto-save to a temporary file so we + ;; don't want to update the last-saved-file-time + (when (equal? filename can-save-file-filename) + (unless (unbox temp-b) + (when success? + (set! last-saved-file-time + (and filename + (file-exists? filename) + (file-or-directory-modify-seconds filename)))))) + + (set! can-save-file-filename #f) + + (handler:update-currently-open-files) + (inner (void) after-save-file success?)) + + (define/augment (after-load-file success?) + (when success? + (define temp-b (box #f)) + (define filename (get-filename temp-b)) + (unless (unbox temp-b) + (set! last-saved-file-time + (and filename + (file-exists? filename) + (file-or-directory-modify-seconds filename)))) + (handler:update-currently-open-files)) + (inner (void) after-load-file success?)) + + (define/public (save-file-out-of-date?) + (and last-saved-file-time + (let ([fn (get-filename)]) + (and fn + (file-exists? fn) + (let ([ms (file-or-directory-modify-seconds fn)]) + (< last-saved-file-time ms)))))) + + (define has-focus #f) + (define/override (on-focus x) + (set! has-focus x) + (super on-focus x)) + (define/public (has-focus?) has-focus) + + (define/public (get-top-level-window) + (let loop ([text this]) + (let ([editor-admin (send text get-admin)]) + (cond + [(is-a? editor-admin editor-snip-editor-admin<%>) + (let* ([snip (send editor-admin get-snip)] + [snip-admin (send snip get-admin)]) + (loop (send snip-admin get-editor)))] + [(send text get-canvas) + => + (λ (canvas) + (send canvas get-top-level-window))] + [else #f])))) + + [define edit-sequence-queue null] + [define edit-sequence-ht (make-hasheq)] + [define in-local-edit-sequence? #f] + [define/public local-edit-sequence? (λ () in-local-edit-sequence?)] + [define/public run-after-edit-sequence + (case-lambda + [(t) (run-after-edit-sequence t #f)] + [(t sym) + (unless (and (procedure? t) + (= 0 (procedure-arity t))) + (error 'editor:basic::run-after-edit-sequence + "expected procedure of arity zero, got: ~s\n" t)) + (unless (or (symbol? sym) (not sym)) + (error 'editor:basic::run-after-edit-sequence + "expected second argument to be a symbol or #f, got: ~s\n" + sym)) + (if (refresh-delayed?) + (if in-local-edit-sequence? + (cond + [(symbol? sym) + (hash-set! edit-sequence-ht sym t)] + [else (set! edit-sequence-queue + (cons t edit-sequence-queue))]) + (let ([snip-admin (get-admin)]) + (cond + [(not snip-admin) + (t)] ;; refresh-delayed? is always #t when there is no admin. + [(is-a? snip-admin editor-snip-editor-admin<%>) + (let loop ([ed this]) + (let ([snip-admin (send ed get-admin)]) + (if (is-a? snip-admin editor-snip-editor-admin<%>) + (let ([up-one + (send (send (send snip-admin get-snip) get-admin) get-editor)]) + (if (is-a? up-one basic<%>) + (send up-one run-after-edit-sequence t sym) + (loop up-one))) + + ;; here we are in an embdedded editor that is not + ;; in an edit sequence and the "parents" of the embdedded editor + ;; are all non-basic<%> objects, so we just run the thunk now. + (t))))] + [else + '(message-box "run-after-edit-sequence error" + (format "refresh-delayed? is #t but snip admin, ~s, is not an editor-snip-editor-admin<%>" + snip-admin)) + '(t) + (void)]))) + (t)) + (void)])] + [define/public extend-edit-sequence-queue + (λ (l ht) + (hash-for-each ht (λ (k t) (hash-set! edit-sequence-ht k t))) + (set! edit-sequence-queue (append l edit-sequence-queue)))] + (define/augment (on-edit-sequence) + (set! in-local-edit-sequence? #t) + (inner (void) on-edit-sequence)) + (define/augment (after-edit-sequence) + (set! in-local-edit-sequence? #f) + (let ([queue edit-sequence-queue] + [ht edit-sequence-ht] + [find-enclosing-editor + (λ (editor) + (let ([admin (send editor get-admin)]) + (cond + [(is-a? admin editor-snip-editor-admin<%>) + (send (send (send admin get-snip) get-admin) get-editor)] + [else #f])))]) + (set! edit-sequence-queue null) + (set! edit-sequence-ht (make-hash)) + (let loop ([editor (find-enclosing-editor this)]) + (cond + [(and editor + (is-a? editor basic<%>) + (not (send editor local-edit-sequence?))) + (loop (find-enclosing-editor editor))] + [(and editor + (is-a? editor basic<%>)) + (send editor extend-edit-sequence-queue queue ht)] + [else + (hash-for-each ht (λ (k t) (t))) + (for-each (λ (t) (t)) queue)]))) + (inner (void) after-edit-sequence)) + + (define/override (on-new-box type) + (cond + [(eq? type 'text) (make-object editor-snip% (make-object text:basic%))] + [else (make-object editor-snip% (make-object pasteboard:basic%))])) + + (define/override (on-new-image-snip filename kind relative-path? inline?) + (super on-new-image-snip + filename + (if (eq? kind 'unknown) 'unknown/mask kind) + relative-path? + inline?)) + + (define/override (get-file d) + (parameterize ([finder:dialog-parent-parameter + (get-top-level-window)]) + (finder:get-file d))) + (define/override (put-file d f) + (parameterize ([finder:dialog-parent-parameter + (get-top-level-window)]) + (finder:put-file f d))) + + (super-new))) + +(define (format-error-message exn) + (if (exn? exn) + (apply + string-append + (format "~a\n\ncontext:" (exn-message exn)) + (for/list ([context (in-list (continuation-mark-set->context + (exn-continuation-marks exn)))]) + (format "\n ~s" context))) + (format "uncaught exn: ~s" exn))) + +(define standard-style-list (new style-list%)) +(define (get-standard-style-list) standard-style-list) + +;; this name can never change as the name is used directly in mrlib +;; and we cannot add a dependency from mrlib to the framework +(define default-color-style-name "framework:default-color") +(define (get-default-color-style-name) default-color-style-name) + +(let ([delta (make-object style-delta% 'change-normal)]) + (send delta set-delta 'change-family 'modern) + (let ([style (send standard-style-list find-named-style "Standard")]) + (if style + (send style set-delta delta) + (send standard-style-list new-named-style "Standard" + (send standard-style-list find-or-create-style + (send standard-style-list basic-style) + delta))))) + +(let ([delta (make-object style-delta%)] + [style (send standard-style-list find-named-style default-color-style-name)]) + (if style + (send style set-delta delta) + (send standard-style-list new-named-style default-color-style-name + (send standard-style-list find-or-create-style + (send standard-style-list find-named-style "Standard") + delta)))) + +(define (set-default-font-color color [bg-color #f]) + (define the-standard (send standard-style-list find-named-style default-color-style-name)) + (define the-delta (make-object style-delta%)) + (send the-standard get-delta the-delta) + (send the-delta set-delta-foreground color) + (when bg-color (send the-delta set-delta-background bg-color)) + (send the-standard set-delta the-delta)) + +(define (set-font-size size) + (update-standard-style + (λ (the-delta) + (send the-delta set-size-mult 0) + (send the-delta set-size-add size)))) + +(define (set-font-name name) + (update-standard-style + (λ (the-delta) + (send the-delta set-delta-face name) + (send the-delta set-family 'modern)))) + +(define (set-font-smoothing sym) + (update-standard-style + (λ (the-delta) + (send the-delta set-smoothing-on sym)))) + +(define (set-font-weight sym) + (update-standard-style + (λ (the-delta) + (send the-delta set-weight-on sym)))) + +(define (update-standard-style cng-delta) + (let* ([the-standard (send standard-style-list find-named-style "Standard")] + [the-delta (make-object style-delta%)]) + (send the-standard get-delta the-delta) + (cng-delta the-delta) + (send the-standard set-delta the-delta))) + +(define standard-style-list<%> + (interface (editor<%>) + )) + +(define standard-style-list-mixin + (mixin (editor<%>) (standard-style-list<%>) + (super-new) + (inherit set-style-list set-load-overwrites-styles) + (set-style-list standard-style-list) + (set-load-overwrites-styles #f))) + + +;; the 'set-font-size' function can be slow, +;; as it involves redrawing every frame +;; so we do the change on a low-priority +;; callback so we don't get too many of these +;; piling up. +(define (set-font-size/callback size) + (set! set-font-size-callback-size size) + (unless set-font-size-callback-running? + (set! set-font-size-callback-running? #t) + (queue-callback + (λ () + (set-font-size set-font-size-callback-size) + (set! set-font-size-callback-running? #f)) + #f) + (set! set-font-size-callback-running? #t))) +(define set-font-size-callback-running? #f) +(define set-font-size-callback-size #f) + +(define (set-standard-style-list-pref-callbacks) + (set-font-size (get-current-preferred-font-size)) + (set-font-name (preferences:get 'framework:standard-style-list:font-name)) + (set-font-smoothing (preferences:get 'framework:standard-style-list:smoothing)) + (set-font-weight (preferences:get 'framework:standard-style-list:weight)) + (preferences:add-callback 'framework:standard-style-list:font-size + (λ (p v) + (set-font-size/callback (font-size-pref->current-font-size v)))) + (preferences:add-callback 'framework:standard-style-list:font-name (λ (p v) (set-font-name v))) + (preferences:add-callback 'framework:standard-style-list:smoothing + (λ (p v) (set-font-smoothing v))) + (preferences:add-callback 'framework:standard-style-list:weight (λ (p v) (set-font-weight v))) + (define fl (get-face-list)) + (unless (member (preferences:get 'framework:standard-style-list:font-name) fl) + (define preferred-font + (cond + [(equal? (system-type) 'macosx) + (define preferred-font "Menlo") + (if (member preferred-font fl) + preferred-font + (get-family-builtin-face 'modern))] + [else (get-family-builtin-face 'modern)])) + (preferences:set 'framework:standard-style-list:font-name preferred-font))) + +(define (get-current-preferred-font-size) + (font-size-pref->current-font-size (preferences:get 'framework:standard-style-list:font-size))) + +(define (font-size-pref->current-font-size v) + (define default-size (vector-ref v 1)) + (cond + [change-font-size-when-monitors-change? + (define monitor-sizes (get-current-monitor-sizes)) + (hash-ref (vector-ref v 0) monitor-sizes default-size)] + [else + default-size])) + +(define change-font-size-when-monitors-change? #f) +(define (get-change-font-size-when-monitors-change?) + change-font-size-when-monitors-change?) +(define (set-change-font-size-when-monitors-change? b?) + (unless (equal? change-font-size-when-monitors-change? b?) + (set! change-font-size-when-monitors-change? b?) + (set-current-preferred-font-size + (get-current-preferred-font-size)))) + + +(define (set-current-preferred-font-size new-size) + (unless (exact-nonnegative-integer? new-size) + (raise-argument-error 'set-current-preferred-font-size + "exact-nonnegative-integer?" + new-size)) + (define old-pref (preferences:get 'framework:standard-style-list:font-size)) + (define current-mons (get-current-monitor-sizes)) + (define new-monitor-sizes + (hash-set (vector-ref old-pref 0) + current-mons + new-size)) + (preferences:set 'framework:standard-style-list:font-size + (vector new-monitor-sizes new-size))) + +(define (get-current-monitor-sizes) + (let loop ([m (get-display-count)] + [sizes '()]) + (cond + [(zero? m) sizes] + [else + (define-values (w h) (get-display-size #:monitor (- m 1))) + (loop (- m 1) + (if (and w h) + (cons (list w h) sizes) + sizes))]))) + +;; set-standard-style-list-delta : string (is-a?/c style-delta<%>) -> void +(define (set-standard-style-list-delta name delta) + (let* ([style-list (get-standard-style-list)] + [style (send style-list find-named-style name)]) + (if style + (send style set-delta delta) + (send style-list new-named-style name + (send style-list find-or-create-style + (send style-list find-named-style "Standard") + delta))) + (void))) + +(define -keymap<%> editor:keymap<%>) +(define keymap-mixin + (mixin (basic<%>) (-keymap<%>) + (define/public (get-keymaps) + (list (keymap:get-user) (keymap:get-global))) + (inherit set-keymap) + + (super-new) + (let ([keymap (make-object keymap:aug-keymap%)]) + (set-keymap keymap) + (for-each (λ (k) (send keymap chain-to-keymap k #f)) + (get-keymaps))))) + +(define (add-after-user-keymap km kms) + (let loop ([kms kms]) + (cond + [(null? kms) (list km)] + [else + (let ([f (car kms)]) + (if (eq? f (keymap:get-user)) + (list* f km (cdr kms)) + (cons f (loop (cdr kms)))))]))) + +(define autowrap<%> (interface (basic<%>))) +(define autowrap-mixin + (mixin (basic<%>) (autowrap<%>) + (inherit auto-wrap) + (super-instantiate ()) + (auto-wrap + (preferences:get + 'framework:auto-set-wrap?)))) + +(define file<%> + (interface (-keymap<%>) + get-can-close-parent + update-frame-filename + allow-close-with-no-filename?)) + +(define file-mixin + (mixin (-keymap<%>) (file<%>) + (inherit get-filename lock get-style-list + is-modified? set-modified + get-top-level-window) + + (inherit get-canvases get-filename/untitled-name) + (define/public (update-frame-filename) + (let* ([filename (get-filename)] + [name (if filename + (path->string + (file-name-from-path + filename)) + (get-filename/untitled-name))]) + (for-each (λ (canvas) + (let ([tlw (send canvas get-top-level-window)]) + (when (and (is-a? tlw frame:editor<%>) + (eq? this (send tlw get-editor))) + (send tlw set-label name)))) + (get-canvases)))) + + (define/override set-filename + (case-lambda + [(name) (set-filename name #f)] + [(name temp?) + (super set-filename name temp?) + (unless temp? + (update-frame-filename))])) + + (inherit save-file) + (define/public (allow-close-with-no-filename?) #f) + (define/augment (can-close?) + (and (user-saves-or-not-modified?) + (inner #t can-close?))) + + (define/public (user-saves-or-not-modified? [allow-cancel? #t]) + (or (not (is-modified?)) + (and (not (get-filename)) + (allow-close-with-no-filename?)) + (case (gui-utils:unsaved-warning + (get-filename/untitled-name) + (string-constant dont-save) + #t + (or (get-top-level-window) + (get-can-close-parent)) + allow-cancel? + #:dialog-mixin frame:focus-table-mixin) + [(continue) #t] + [(save) (save-file)] + [else #f]))) + + (define/public (get-can-close-parent) #f) + + (define/override (get-keymaps) + (add-after-user-keymap (keymap:get-file) (super get-keymaps))) + (super-new))) + +(define backup-autosave<%> + (interface (basic<%>) + backup? + autosave? + do-autosave + remove-autosave)) + +(define doing-autosave? (make-parameter #f)) +(define silent-cancel-on-save-file-out-of-date? (make-parameter #f)) + +(define backup-autosave-mixin + (mixin (basic<%>) (backup-autosave<%> autosave:autosavable<%>) + (inherit is-modified? get-filename save-file find-first-snip) + [define auto-saved-name #f] + [define auto-save-out-of-date? #t] + [define auto-save-error? #f] + (define/private (file-old? filename) + (if (and filename + (file-exists? filename)) + (let ([modified-seconds (file-or-directory-modify-seconds filename)] + [old-seconds (- (current-seconds) (* 7 24 60 60))]) + (< modified-seconds old-seconds)) + #t)) + (define/public (backup?) (preferences:get 'framework:backup-files?)) + (define/augment (on-save-file name format) + (when (and (backup?) + (not (eq? format 'copy)) + (file-exists? name)) + (let ([back-name (path-utils:generate-backup-name name)]) + (when (or (not (file-exists? back-name)) + (file-old? back-name)) + (with-handlers ([exn:fail? + (λ (exn) + (log-debug "failed to clean up autosave file.1: ~a" back-name))]) + (when (file-exists? back-name) + (delete-file back-name)) + (copy-file name back-name))))) + (inner (void) on-save-file name format)) + (define/augment (after-save-file success?) + (when success? + (set! auto-save-error? #f)) + (inner (void) after-save-file success?)) + + (define/augment (on-close) + (remove-autosave) + (handler:update-currently-open-files) + (set! do-autosave? #f) + (inner (void) on-close)) + (define/augment (on-change) + (set! auto-save-out-of-date? #t) + (inner (void) on-change)) + (define/override (set-modified modified?) + (when auto-saved-name + (if modified? + (set! auto-save-out-of-date? #t) + (remove-autosave))) + (super set-modified modified?)) + + [define do-autosave? #t] + (define/public (autosave?) do-autosave?) + + (define/public (do-autosave) + (cond + [(and (autosave?) + (not auto-save-error?) + (is-modified?) + (or (not auto-saved-name) + auto-save-out-of-date?)) + (let* ([orig-name (get-filename)] + [old-auto-name auto-saved-name] + [auto-name (path-utils:generate-autosave-name orig-name)] + [orig-format (and (is-a? this text%) + (send this get-file-format))]) + (when (is-a? this text%) + (define all-string-snips? + (let loop ([s (find-first-snip)]) + (cond + [(not s) #t] + [(is-a? s string-snip%) + (loop (send s next))] + [else #f]))) + (send this set-file-format (if all-string-snips? 'text 'standard))) + (with-handlers ([exn:fail? + (λ (exn) + (show-autosave-error exn orig-name) + (set! auto-save-error? #t) + (when (is-a? this text%) + (send this set-file-format orig-format)) + #f)]) + (parameterize ([doing-autosave? #t]) + (save-file auto-name 'copy #f)) + (when (is-a? this text%) + (send this set-file-format orig-format)) + (when old-auto-name + (when (file-exists? old-auto-name) + (delete-file old-auto-name))) + (set! auto-saved-name auto-name) + (set! auto-save-out-of-date? #f) + auto-name))] + [else auto-saved-name])) + + ;; show-autosave-error : any (union #f string) -> void + ;; opens a message box displaying the exn and the filename + ;; to the user. + (define/private (show-autosave-error exn orig-name) + (message-box + (string-constant warning) + (apply + string-append + (format (string-constant error-autosaving) + (or orig-name (string-constant untitled))) + "\n" + (string-constant autosaving-turned-off) + "\n\n" + (format-error-message exn) + "\n\n" + (if (and (exn? exn) + (continuation-mark-set? (exn-continuation-marks exn))) + (for/list ([fr (in-list (continuation-mark-set->context + (exn-continuation-marks exn)))]) + (format " ~s\n" fr)) + '())) + (find-parent/editor this) + '(caution ok))) + + (define/public (remove-autosave) + (when auto-saved-name + (when (file-exists? auto-saved-name) + (with-handlers ([exn:fail? + (λ (exn) + (log-debug "failed to clean up autosave file.2: ~a" + auto-saved-name))]) + (delete-file auto-saved-name) + (set! auto-saved-name #f))))) + (super-new) + (autosave:register this))) + + +(define info<%> (interface (basic<%>))) +(define info-mixin + (mixin (basic<%>) (info<%>) + (inherit get-top-level-window run-after-edit-sequence) + (define callback-running? #f) + (define/override (lock x) + (super lock x) + (run-after-edit-sequence + (rec send-frame-update-lock-icon + (λ () + (unless callback-running? + (set! callback-running? #t) + (queue-callback + (λ () + (let ([frame (get-top-level-window)]) + (when (is-a? frame frame:info<%>) + (send frame lock-status-changed))) + (set! callback-running? #f)) + #f)))) + 'framework:update-lock-icon)) + (super-new))) + +(define font-size-message% + (class canvas% + (init message + [stretchable-height #f]) + (init-field [text-alignment 'center]) + (define msgs + (cond + [(string? message) (regexp-split #rx"\n" message)] + [((listof string?) message) message] + [else + (raise-argument-error 'editor:font-size-message% + (~s '(or/c string? (listof string?))) + message)])) + (unless (member text-alignment '(left center right)) + (raise-argument-error 'editor:font-size-message% + (~s '(or/c 'left 'center 'right)) + text-alignment)) + (inherit refresh get-dc get-client-size popup-menu) + (define/public (set-message message) + (set! msgs + (cond + [(string? message) (regexp-split #rx"\n" message)] + [((listof string?) message) message] + [else + (raise-argument-error 'editor:font-size-message%::set-label + (~s '(or/c string? (listof string?))) + message)])) + (refresh)) + (define/override (on-paint) + (define dc (get-dc)) + (define text-foreground (send dc get-text-foreground)) + (when (color-prefs:white-on-black-color-scheme?) + (send dc set-text-foreground "white")) + (define-values (cw ch) (get-client-size)) + (define-values (tot-th tot-tw) + (for/fold ([tot-th 0] [tot-tw 0]) + ([msg (in-list msgs)]) + (define-values (tw th td ta) (send dc get-text-extent msg)) + (values (+ tot-th th) (max tot-tw tw)))) + (for/fold ([y (- (/ ch 2) (/ tot-th 2))]) ([msg (in-list msgs)]) + (define-values (tw th td ta) (send dc get-text-extent msg)) + (define x + (case text-alignment + [(center) (- (/ cw 2) (/ tw 2))] + [(left) 2] + [(right) (- cw 2)])) + (send dc draw-text msg x y) + (+ y th)) + (send dc set-text-foreground text-foreground)) + (super-new [style '(transparent)][stretchable-height stretchable-height]) + + ;; need object to hold onto this function, so this is + ;; intentionally a private field, not a method + (define (font-size-changed-callback _ new-prefs) + (define new-size (font-size-pref->current-font-size new-prefs)) + (set-the-height/dc-font new-size) + (refresh)) + (preferences:add-callback + 'framework:standard-style-list:font-size + font-size-changed-callback + #t) + + (define/private (set-the-height/dc-font font-size) + (define dc (get-dc)) + (send dc set-font + (send the-font-list find-or-create-font + font-size + (send normal-control-font get-family) + (send normal-control-font get-style) + (send normal-control-font get-weight) + (send normal-control-font get-underlined) + (send normal-control-font get-smoothing))) + (define tot-th + (for/sum ([msg (in-list msgs)]) + (define-values (tw th td ta) (send dc get-text-extent msg)) + th)) + (min-height (inexact->exact (ceiling tot-th)))) + + (inherit min-height) + (set-the-height/dc-font + (get-current-preferred-font-size)))) diff --git a/gui-lib/framework/private/editor-sig.rkt b/gui-lib/framework/private/editor-sig.rkt new file mode 100644 index 000000000..f9034de4f --- /dev/null +++ b/gui-lib/framework/private/editor-sig.rkt @@ -0,0 +1,49 @@ +#lang racket/base +(require racket/unit) + +(provide editor-misc-class^ + editor-misc^ + editor-misc-functions^ + editor-autoload^) + +(define-signature editor-misc-class^ + (basic<%> + standard-style-list<%> + keymap<%> + autowrap<%> + info<%> + file<%> + backup-autosave<%> + basic-mixin + standard-style-list-mixin + keymap-mixin + autowrap-mixin + info-mixin + file-mixin + backup-autosave-mixin + font-size-message%)) + +(define-signature editor-misc-functions^ + (get-standard-style-list + set-standard-style-list-pref-callbacks + set-standard-style-list-delta + set-default-font-color + get-default-color-style-name + add-after-user-keymap + get-current-preferred-font-size + set-current-preferred-font-size + font-size-pref->current-font-size + set-change-font-size-when-monitors-change? + get-change-font-size-when-monitors-change? + doing-autosave? + silent-cancel-on-save-file-out-of-date?)) + +(define-signature editor-misc^ + ((open editor-misc-class^) + (open editor-misc-functions^))) + +(define-signature editor-autoload^ + (autoload-mixin + autoload<%>)) + + diff --git a/gui-lib/framework/private/editor.rkt b/gui-lib/framework/private/editor.rkt index b95126618..1d932f291 100644 --- a/gui-lib/framework/private/editor.rkt +++ b/gui-lib/framework/private/editor.rkt @@ -1,1114 +1,54 @@ -#lang racket/unit - - (require mzlib/class - string-constants - "sig.rkt" - "../preferences.rkt" - "../gui-utils.rkt" - "interfaces.rkt" - mzlib/etc - mred/mred-sig - racket/path - racket/contract - racket/format - racket/match - mrlib/panel-wob) - - (import mred^ - [prefix autosave: framework:autosave^] - [prefix finder: framework:finder^] - [prefix path-utils: framework:path-utils^] - [prefix keymap: framework:keymap^] - [prefix icon: framework:icon^] - [prefix text: framework:text^] - [prefix pasteboard: framework:pasteboard^] - [prefix frame: framework:frame^] - [prefix handler: framework:handler^]) - (export (rename framework:editor^ - [-keymap<%> keymap<%>])) - (init-depend mred^ framework:autosave^) - - ;; renaming, for editor-mixin where get-file is shadowed by a method. - (define mred:get-file get-file) - - (define basic<%> editor:basic<%>) - - (define basic-mixin - (mixin (editor<%>) (basic<%>) - (inherit begin-edit-sequence end-edit-sequence) - - (define/pubment (can-close?) (inner #t can-close?)) - (define/pubment (on-close) (inner (void) on-close)) - (define/public (close) (if (can-close?) - (begin (on-close) #t) - #f)) - - (define/public (get-pos/text event) - (get-pos/text-dc-location (send event get-x) (send event get-y))) - - (define/public (get-pos/text-dc-location event-x event-y) - (let ([on-it? (box #f)]) - (let loop ([editor this]) - (let-values ([(x y) (send editor dc-location-to-editor-location event-x event-y)]) - (cond - [(is-a? editor text%) - (let ([pos (send editor find-position x y #f on-it?)]) - (cond - [(not (unbox on-it?)) (values #f #f)] - [else - (let ([snip (send editor find-snip pos 'after-or-none)]) - (if (and snip - (is-a? snip editor-snip%)) - (loop (send snip get-editor)) - (values pos editor)))]))] - [(is-a? editor pasteboard%) - (let ([snip (send editor find-snip x y)]) - (if (and snip - (is-a? snip editor-snip%)) - (loop (send snip get-editor)) - (values #f editor)))] - [else (values #f #f)]))))) - - ;; get-filename/untitled-name : -> string - ;; returns a string representing the visible name for this file, - ;; or "Untitled " for some n. - (define untitled-name #f) - (define/public (get-filename/untitled-name) - (let ([filename (get-filename)]) - (if filename - (path->string filename) - (begin - (unless untitled-name - (set! untitled-name (gui-utils:next-untitled-name))) - untitled-name)))) - - (inherit get-filename save-file) - (define/public save-file/gui-error - (opt-lambda ([input-filename #f] - [fmt 'same] - [show-errors? #t]) - (let ([filename (if (or (not input-filename) - (equal? input-filename "")) - (let ([internal-filename (get-filename)]) - (if (or (not internal-filename) - (equal? internal-filename "")) - (put-file #f #f) - internal-filename)) - input-filename)]) - (with-handlers ([exn:fail? - (λ (exn) - (message-box - (string-constant error-saving) - (string-append - (format (string-constant error-saving-file/name) - filename) - "\n\n" - (format-error-message exn)) - (find-parent/editor this) - '(stop ok)) - #f)]) - (when filename - (save-file filename fmt #f)) - (and filename #t))))) - - (inherit load-file) - (define/public load-file/gui-error - (opt-lambda ([input-filename #f] - [fmt 'guess] - [show-errors? #t]) - (let ([filename (if (or (not input-filename) - (equal? input-filename "")) - (let ([internal-filename (get-filename)]) - (if (or (not internal-filename) - (equal? internal-filename "")) - (get-file #f) - internal-filename)) - input-filename)]) - (with-handlers ([exn:fail? - (λ (exn) - (message-box - (string-constant error-loading) - (string-append - (format (string-constant error-loading-file/name) - filename) - "\n\n" - (format-error-message exn)) - (find-parent/editor this) - '(stop ok)) - #f)]) - (load-file input-filename fmt show-errors?) - #t)))) - - (define/public (revert/gui-error) - (define b (box #f)) - (define filename (get-filename b)) - (cond - [(and filename - (not (unbox b))) - (define start - (if (is-a? this text%) - (send this get-start-position) - #f)) - (begin-edit-sequence) - (define status (load-file/gui-error filename 'guess #f)) - (when status - (when (is-a? this text%) - (send this set-position start start))) - (end-edit-sequence) - status] - [else #t])) - - (define/private (format-error-message exn) - (if (exn? exn) - (format "~a" (exn-message exn)) - (format "uncaught exn: ~s" exn))) - - (inherit refresh-delayed? - get-canvas - get-admin) - - (define/augment (can-save-file? filename format) - (define (ask-users-opinion) - (cond - [(doing-autosave?) - ;; opt for the effect of - ;; clicking on the `cancel` - ;; button - #f] - [else - (gui-utils:get-choice - (string-constant file-has-been-modified) - (string-constant overwrite-file-button-label) - (string-constant cancel) - (string-constant warning) - #f - (get-top-level-window) - #:dialog-mixin frame:focus-table-mixin)])) - (define result - (and (if (equal? filename (get-filename)) - (if (save-file-out-of-date?) - (ask-users-opinion) - #t) - #t) - (inner #t can-save-file? filename format))) - (when result (set! can-save-file-filename filename)) - result) - - (define can-save-file-filename #f) - (define last-saved-file-time #f) - - (define/augment (after-save-file success?) - (define temp-b (box #f)) - (define filename (get-filename temp-b)) - - ;; update recently opened file names - (unless (unbox temp-b) - (when filename - (handler:add-to-recent filename))) - - ;; if the filenames are different, then the save - ;; was an auto-save to a temporary file so we - ;; don't want to update the last-saved-file-time - (when (equal? filename can-save-file-filename) - (unless (unbox temp-b) - (when success? - (set! last-saved-file-time - (and filename - (file-exists? filename) - (file-or-directory-modify-seconds filename)))))) - - (set! can-save-file-filename #f) - (inner (void) after-save-file success?)) - - (define/augment (after-load-file success?) - (when success? - (define temp-b (box #f)) - (define filename (get-filename temp-b)) - (unless (unbox temp-b) - (set! last-saved-file-time - (and filename - (file-exists? filename) - (file-or-directory-modify-seconds filename))))) - (inner (void) after-load-file success?)) - - (define/public (save-file-out-of-date?) - (and last-saved-file-time - (let ([fn (get-filename)]) - (and fn - (file-exists? fn) - (let ([ms (file-or-directory-modify-seconds fn)]) - (< last-saved-file-time ms)))))) - - (define has-focus #f) - (define/override (on-focus x) - (set! has-focus x) - (super on-focus x)) - (define/public (has-focus?) has-focus) - - (define/public (get-top-level-window) - (let loop ([text this]) - (let ([editor-admin (send text get-admin)]) - (cond - [(is-a? editor-admin editor-snip-editor-admin<%>) - (let* ([snip (send editor-admin get-snip)] - [snip-admin (send snip get-admin)]) - (loop (send snip-admin get-editor)))] - [(send text get-canvas) - => - (λ (canvas) - (send canvas get-top-level-window))] - [else #f])))) - - [define edit-sequence-queue null] - [define edit-sequence-ht (make-hasheq)] - [define in-local-edit-sequence? #f] - [define/public local-edit-sequence? (λ () in-local-edit-sequence?)] - [define/public run-after-edit-sequence - (case-lambda - [(t) (run-after-edit-sequence t #f)] - [(t sym) - (unless (and (procedure? t) - (= 0 (procedure-arity t))) - (error 'editor:basic::run-after-edit-sequence - "expected procedure of arity zero, got: ~s\n" t)) - (unless (or (symbol? sym) (not sym)) - (error 'editor:basic::run-after-edit-sequence - "expected second argument to be a symbol or #f, got: ~s\n" - sym)) - (if (refresh-delayed?) - (if in-local-edit-sequence? - (cond - [(symbol? sym) - (hash-set! edit-sequence-ht sym t)] - [else (set! edit-sequence-queue - (cons t edit-sequence-queue))]) - (let ([snip-admin (get-admin)]) - (cond - [(not snip-admin) - (t)] ;; refresh-delayed? is always #t when there is no admin. - [(is-a? snip-admin editor-snip-editor-admin<%>) - (let loop ([ed this]) - (let ([snip-admin (send ed get-admin)]) - (if (is-a? snip-admin editor-snip-editor-admin<%>) - (let ([up-one - (send (send (send snip-admin get-snip) get-admin) get-editor)]) - (if (is-a? up-one basic<%>) - (send up-one run-after-edit-sequence t sym) - (loop up-one))) - - ;; here we are in an embdedded editor that is not - ;; in an edit sequence and the "parents" of the embdedded editor - ;; are all non-basic<%> objects, so we just run the thunk now. - (t))))] - [else - '(message-box "run-after-edit-sequence error" - (format "refresh-delayed? is #t but snip admin, ~s, is not an editor-snip-editor-admin<%>" - snip-admin)) - '(t) - (void)]))) - (t)) - (void)])] - [define/public extend-edit-sequence-queue - (λ (l ht) - (hash-for-each ht (λ (k t) (hash-set! edit-sequence-ht k t))) - (set! edit-sequence-queue (append l edit-sequence-queue)))] - (define/augment (on-edit-sequence) - (set! in-local-edit-sequence? #t) - (inner (void) on-edit-sequence)) - (define/augment (after-edit-sequence) - (set! in-local-edit-sequence? #f) - (let ([queue edit-sequence-queue] - [ht edit-sequence-ht] - [find-enclosing-editor - (λ (editor) - (let ([admin (send editor get-admin)]) - (cond - [(is-a? admin editor-snip-editor-admin<%>) - (send (send (send admin get-snip) get-admin) get-editor)] - [else #f])))]) - (set! edit-sequence-queue null) - (set! edit-sequence-ht (make-hash)) - (let loop ([editor (find-enclosing-editor this)]) - (cond - [(and editor - (is-a? editor basic<%>) - (not (send editor local-edit-sequence?))) - (loop (find-enclosing-editor editor))] - [(and editor - (is-a? editor basic<%>)) - (send editor extend-edit-sequence-queue queue ht)] - [else - (hash-for-each ht (λ (k t) (t))) - (for-each (λ (t) (t)) queue)]))) - (inner (void) after-edit-sequence)) - - (define/override (on-new-box type) - (cond - [(eq? type 'text) (make-object editor-snip% (make-object text:basic%))] - [else (make-object editor-snip% (make-object pasteboard:basic%))])) - - (define/override (on-new-image-snip filename kind relative-path? inline?) - (super on-new-image-snip - filename - (if (eq? kind 'unknown) 'unknown/mask kind) - relative-path? - inline?)) - - (define/override (get-file d) - (parameterize ([finder:dialog-parent-parameter - (get-top-level-window)]) - (finder:get-file d))) - (define/override (put-file d f) - (parameterize ([finder:dialog-parent-parameter - (get-top-level-window)]) - (finder:put-file f d))) - - (super-new))) - - (define standard-style-list (new style-list%)) - (define (get-standard-style-list) standard-style-list) - -;; this name can never change as the name is used directly in mrlib -;; and we cannot add a dependency from mrlib to the framework - (define default-color-style-name "framework:default-color") - (define (get-default-color-style-name) default-color-style-name) - - (let ([delta (make-object style-delta% 'change-normal)]) - (send delta set-delta 'change-family 'modern) - (let ([style (send standard-style-list find-named-style "Standard")]) - (if style - (send style set-delta delta) - (send standard-style-list new-named-style "Standard" - (send standard-style-list find-or-create-style - (send standard-style-list basic-style) - delta))))) - - (let ([delta (make-object style-delta%)] - [style (send standard-style-list find-named-style default-color-style-name)]) - (if style - (send style set-delta delta) - (send standard-style-list new-named-style default-color-style-name - (send standard-style-list find-or-create-style - (send standard-style-list find-named-style "Standard") - delta)))) - -(define (set-default-font-color color [bg-color #f]) - (define the-standard (send standard-style-list find-named-style default-color-style-name)) - (define the-delta (make-object style-delta%)) - (send the-standard get-delta the-delta) - (send the-delta set-delta-foreground color) - (when bg-color (send the-delta set-delta-background bg-color)) - (send the-standard set-delta the-delta)) - - (define (set-font-size size) - (update-standard-style - (λ (the-delta) - (send the-delta set-size-mult 0) - (send the-delta set-size-add size)))) - - (define (set-font-name name) - (update-standard-style - (λ (the-delta) - (send the-delta set-delta-face name) - (send the-delta set-family 'modern)))) - - (define (set-font-smoothing sym) - (update-standard-style - (λ (the-delta) - (send the-delta set-smoothing-on sym)))) - - (define (set-font-weight sym) - (update-standard-style - (λ (the-delta) - (send the-delta set-weight-on sym)))) - - (define (update-standard-style cng-delta) - (let* ([the-standard (send standard-style-list find-named-style "Standard")] - [the-delta (make-object style-delta%)]) - (send the-standard get-delta the-delta) - (cng-delta the-delta) - (send the-standard set-delta the-delta))) - - (define standard-style-list<%> - (interface (editor<%>) - )) - - (define standard-style-list-mixin - (mixin (editor<%>) (standard-style-list<%>) - (super-new) - (inherit set-style-list set-load-overwrites-styles) - (set-style-list standard-style-list) - (set-load-overwrites-styles #f))) - - - ;; the 'set-font-size' function can be slow, - ;; as it involves redrawing every frame - ;; so we do the change on a low-priority - ;; callback so we don't get too many of these - ;; piling up. - (define (set-font-size/callback size) - (set! set-font-size-callback-size size) - (unless set-font-size-callback-running? - (set! set-font-size-callback-running? #t) - (queue-callback - (λ () - (set-font-size set-font-size-callback-size) - (set! set-font-size-callback-running? #f)) - #f) - (set! set-font-size-callback-running? #t))) - (define set-font-size-callback-running? #f) - (define set-font-size-callback-size #f) - - (define (set-standard-style-list-pref-callbacks) - (set-font-size (get-current-preferred-font-size)) - (set-font-name (preferences:get 'framework:standard-style-list:font-name)) - (set-font-smoothing (preferences:get 'framework:standard-style-list:smoothing)) - (set-font-weight (preferences:get 'framework:standard-style-list:weight)) - (preferences:add-callback 'framework:standard-style-list:font-size - (λ (p v) - (set-font-size/callback (font-size-pref->current-font-size v)))) - (preferences:add-callback 'framework:standard-style-list:font-name (λ (p v) (set-font-name v))) - (preferences:add-callback 'framework:standard-style-list:smoothing - (λ (p v) (set-font-smoothing v))) - (preferences:add-callback 'framework:standard-style-list:weight (λ (p v) (set-font-weight v))) - (define fl (get-face-list)) - (unless (member (preferences:get 'framework:standard-style-list:font-name) fl) - (define preferred-font - (cond - [(equal? (system-type) 'macosx) - (define preferred-font "Menlo") - (if (member preferred-font fl) - preferred-font - (get-family-builtin-face 'modern))] - [else (get-family-builtin-face 'modern)])) - (preferences:set 'framework:standard-style-list:font-name preferred-font))) - - (define (get-current-preferred-font-size) - (font-size-pref->current-font-size (preferences:get 'framework:standard-style-list:font-size))) - - (define (font-size-pref->current-font-size v) - (define default-size (vector-ref v 1)) - (cond - [change-font-size-when-monitors-change? - (define monitor-sizes (get-current-monitor-sizes)) - (hash-ref (vector-ref v 0) monitor-sizes default-size)] - [else - default-size])) - - (define change-font-size-when-monitors-change? #f) - (define (get-change-font-size-when-monitors-change?) - change-font-size-when-monitors-change?) - (define (set-change-font-size-when-monitors-change? b?) - (unless (equal? change-font-size-when-monitors-change? b?) - (set! change-font-size-when-monitors-change? b?) - (set-current-preferred-font-size - (get-current-preferred-font-size)))) - - - (define (set-current-preferred-font-size new-size) - (unless (exact-nonnegative-integer? new-size) - (raise-argument-error 'set-current-preferred-font-size - "exact-nonnegative-integer?" - new-size)) - (define old-pref (preferences:get 'framework:standard-style-list:font-size)) - (define current-mons (get-current-monitor-sizes)) - (define new-monitor-sizes - (hash-set (vector-ref old-pref 0) - current-mons - new-size)) - (preferences:set 'framework:standard-style-list:font-size - (vector new-monitor-sizes new-size))) - - (define (get-current-monitor-sizes) - (let loop ([m (get-display-count)] - [sizes '()]) - (cond - [(zero? m) sizes] - [else - (define-values (w h) (get-display-size #:monitor (- m 1))) - (loop (- m 1) - (if (and w h) - (cons (list w h) sizes) - sizes))]))) - - ;; set-standard-style-list-delta : string (is-a?/c style-delta<%>) -> void - (define (set-standard-style-list-delta name delta) - (let* ([style-list (get-standard-style-list)] - [style (send style-list find-named-style name)]) - (if style - (send style set-delta delta) - (send style-list new-named-style name - (send style-list find-or-create-style - (send style-list find-named-style "Standard") - delta))) - (void))) - - (define -keymap<%> editor:keymap<%>) - (define keymap-mixin - (mixin (basic<%>) (-keymap<%>) - (define/public (get-keymaps) - (list (keymap:get-user) (keymap:get-global))) - (inherit set-keymap) - - (super-new) - (let ([keymap (make-object keymap:aug-keymap%)]) - (set-keymap keymap) - (for-each (λ (k) (send keymap chain-to-keymap k #f)) - (get-keymaps))))) - - (define (add-after-user-keymap km kms) - (let loop ([kms kms]) - (cond - [(null? kms) (list km)] - [else - (let ([f (car kms)]) - (if (eq? f (keymap:get-user)) - (list* f km (cdr kms)) - (cons f (loop (cdr kms)))))]))) - - (define autowrap<%> (interface (basic<%>))) - (define autowrap-mixin - (mixin (basic<%>) (autowrap<%>) - (inherit auto-wrap) - (super-instantiate ()) - (auto-wrap - (preferences:get - 'framework:auto-set-wrap?)))) - - (define file<%> - (interface (-keymap<%>) - get-can-close-parent - update-frame-filename - allow-close-with-no-filename?)) - - (define file-mixin - (mixin (-keymap<%>) (file<%>) - (inherit get-filename lock get-style-list - is-modified? set-modified - get-top-level-window) - - (inherit get-canvases get-filename/untitled-name) - (define/public (update-frame-filename) - (let* ([filename (get-filename)] - [name (if filename - (path->string - (file-name-from-path - filename)) - (get-filename/untitled-name))]) - (for-each (λ (canvas) - (let ([tlw (send canvas get-top-level-window)]) - (when (and (is-a? tlw frame:editor<%>) - (eq? this (send tlw get-editor))) - (send tlw set-label name)))) - (get-canvases)))) - - (define/override set-filename - (case-lambda - [(name) (set-filename name #f)] - [(name temp?) - (super set-filename name temp?) - (unless temp? - (update-frame-filename))])) - - (inherit save-file) - (define/public (allow-close-with-no-filename?) #f) - (define/augment (can-close?) - (and (user-saves-or-not-modified?) - (inner #t can-close?))) - - (define/public (user-saves-or-not-modified? [allow-cancel? #t]) - (or (not (is-modified?)) - (and (not (get-filename)) - (allow-close-with-no-filename?)) - (case (gui-utils:unsaved-warning - (get-filename/untitled-name) - (string-constant dont-save) - #t - (or (get-top-level-window) - (get-can-close-parent)) - allow-cancel? - #:dialog-mixin frame:focus-table-mixin) - [(continue) #t] - [(save) (save-file)] - [else #f]))) - - (define/public (get-can-close-parent) #f) - - (define/override (get-keymaps) - (add-after-user-keymap (keymap:get-file) (super get-keymaps))) - (super-new))) - - (define backup-autosave<%> - (interface (basic<%>) - backup? - autosave? - do-autosave - remove-autosave)) - - (define doing-autosave? (make-parameter #f)) - - (define backup-autosave-mixin - (mixin (basic<%>) (backup-autosave<%> autosave:autosavable<%>) - (inherit is-modified? get-filename save-file) - [define auto-saved-name #f] - [define auto-save-out-of-date? #t] - [define auto-save-error? #f] - (define/private (file-old? filename) - (if (and filename - (file-exists? filename)) - (let ([modified-seconds (file-or-directory-modify-seconds filename)] - [old-seconds (- (current-seconds) (* 7 24 60 60))]) - (< modified-seconds old-seconds)) - #t)) - (define/public (backup?) (preferences:get 'framework:backup-files?)) - (define/augment (on-save-file name format) - (when (and (backup?) - (not (eq? format 'copy)) - (file-exists? name)) - (let ([back-name (path-utils:generate-backup-name name)]) - (when (or (not (file-exists? back-name)) - (file-old? back-name)) - (with-handlers ([exn:fail? - (λ (exn) - (log-debug "failed to clean up autosave file.1: ~a" back-name))]) - (when (file-exists? back-name) - (delete-file back-name)) - (copy-file name back-name))))) - (inner (void) on-save-file name format)) - (define/augment (after-save-file success?) - (when success? - (set! auto-save-error? #f)) - (inner (void) after-save-file success?)) - - (define/augment (on-close) - (remove-autosave) - (set! do-autosave? #f) - (inner (void) on-close)) - (define/augment (on-change) - (set! auto-save-out-of-date? #t) - (inner (void) on-change)) - (define/override (set-modified modified?) - (when auto-saved-name - (if modified? - (set! auto-save-out-of-date? #t) - (remove-autosave))) - (super set-modified modified?)) - - [define do-autosave? #t] - (define/public (autosave?) do-autosave?) - - (define/public (do-autosave) - (cond - [(and (autosave?) - (not auto-save-error?) - (is-modified?) - (or (not auto-saved-name) - auto-save-out-of-date?)) - (let* ([orig-name (get-filename)] - [old-auto-name auto-saved-name] - [auto-name (path-utils:generate-autosave-name orig-name)] - [orig-format (and (is-a? this text%) - (send this get-file-format))]) - (when (is-a? this text%) - (send this set-file-format 'standard)) - (with-handlers ([exn:fail? - (λ (exn) - (show-autosave-error exn orig-name) - (set! auto-save-error? #t) - (when (is-a? this text%) - (send this set-file-format orig-format)) - #f)]) - (parameterize ([doing-autosave? #t]) - (save-file auto-name 'copy #f)) - (when (is-a? this text%) - (send this set-file-format orig-format)) - (when old-auto-name - (when (file-exists? old-auto-name) - (delete-file old-auto-name))) - (set! auto-saved-name auto-name) - (set! auto-save-out-of-date? #f) - auto-name))] - [else auto-saved-name])) - - ;; show-autosave-error : any (union #f string) -> void - ;; opens a message box displaying the exn and the filename - ;; to the user. - (define/private (show-autosave-error exn orig-name) - (message-box - (string-constant warning) - (apply - string-append - (format (string-constant error-autosaving) - (or orig-name (string-constant untitled))) - "\n" - (string-constant autosaving-turned-off) - "\n\n" - (if (exn? exn) - (format "~a" (exn-message exn)) - (format "~s" exn)) - "\n\n" - (if (and (exn? exn) - (continuation-mark-set? (exn-continuation-marks exn))) - (for/list ([fr (in-list (continuation-mark-set->context - (exn-continuation-marks exn)))]) - (format " ~s\n" fr)) - '())) - (find-parent/editor this) - '(caution ok))) - - (define/public (remove-autosave) - (when auto-saved-name - (when (file-exists? auto-saved-name) - (with-handlers ([exn:fail? - (λ (exn) - (log-debug "failed to clean up autosave file.2: ~a" - auto-saved-name))]) - (delete-file auto-saved-name) - (set! auto-saved-name #f))))) - (super-new) - (autosave:register this))) - -(define-local-member-name autoload-file-changed) - -(define autoload<%> - (interface (basic<%>))) - -(define autoload-mixin - (mixin (basic<%>) (autoload<%>) - (inherit get-filename load-file - begin-edit-sequence end-edit-sequence - is-modified?) - - (define/override (set-filename filename [temporary? #f]) - (unless (equal? #f (preferences:get 'framework:autoload)) - (unless temporary? - (start-the-monitor filename))) - (super set-filename filename temporary?)) - - (define/augment (on-close) - (stop-the-monitor) - (inner (void) on-close)) - - (define/augment (on-save-file filename format) - (stop-the-monitor) - (inner (void) on-save-file filename format)) - - (define/augment (after-save-file success?) - (inner (void) after-save-file success?) - (unless (equal? #f (preferences:get 'framework:autoload)) - (start-the-monitor #f))) - - (define/private (start-the-monitor _filename) - (define filename - (or _filename - (let ([b (box #f)]) - (define f (get-filename b)) - (and (not (unbox b)) f)))) - (when filename - (monitor-a-file this filename (current-eventspace)))) - (define/private (stop-the-monitor) - (un-monitor-a-file this)) - - ;; not supposed to be a method to ensure - ;; the callback stays registered with the - ;; preferences system as as long as `this` - ;; is held onto - (define pref-callback - (λ (p v) - (case v - [(#f) (stop-the-monitor)] - [(#t) (start-the-monitor #f)] - [(ask) (start-the-monitor #f)]))) - (preferences:add-callback 'framework:autoload pref-callback #t) - - (define/public (autoload-file-changed) - (when (ask-can-revert-and-maybe-restart-monitor) - (define b (box #f)) - (define filename (get-filename b)) - (when (and filename - (not (unbox b))) - (define start - (if (is-a? this text%) - (send this get-start-position) - #f)) - (begin-edit-sequence) - (define failed? - (with-handlers ([exn:fail? (λ (x) #t)]) - (load-file filename 'guess #f) - #f)) - (unless failed? - (when (is-a? this text%) - (send this set-position start start))) - (end-edit-sequence)))) - - (define/private (ask-can-revert-and-maybe-restart-monitor) - (cond - [(is-modified?) - (define button - (message-box/custom - (string-constant warning) - (string-constant autoload-file-changed-on-disk-editor-dirty) - (string-constant revert) - (string-constant ignore) - #f - (find-parent/editor this) - '(caution no-default) - 2 - #:dialog-mixin frame:focus-table-mixin)) - - ;; restart the monitor as long as there is a possibility - ;; we'll revert the buffer - (unless (equal? (preferences:get 'framework:autoload) #f) - (start-the-monitor #f)) - (case button - [(1) #t] - [(2) #f])] - [(equal? (preferences:get 'framework:autoload) 'ask) - (define-values (button checked?) - (message+check-box/custom - (string-constant warning) - (string-constant autoload-file-changed-on-disk) - (string-constant dont-ask-again-always-current) - (string-constant revert) - (string-constant ignore) - #f - (find-parent/editor this) - '(caution no-default) - 2 - #:dialog-mixin frame:focus-table-mixin)) - (define answer (case button - [(1) #t] - [(2) #f])) - (cond - [checked? - ;; setting the preference will start the monitor - ;; if `answer` is #t - (preferences:set 'framework:autoload answer)] - [else - ;; and thus we need to start it otherwise - (start-the-monitor #f)]) - answer] - [(equal? (preferences:get 'framework:autoload) #t) - (start-the-monitor #f) #t] - [(equal? (preferences:get 'framework:autoload) #f) - ;; here we don't want to restart the monitor - ;; as setting the preference to #t will do that - ;; (it is surprising it is on in this case actually) - #f])) - - (super-new))) - -(define (find-parent/editor editor) - (let loop ([editor editor]) - (define ed-admin (send editor get-admin)) - (cond - [(not ed-admin) #f] - [(is-a? ed-admin editor-snip-editor-admin<%>) - (define snip (send ed-admin get-snip)) - (define snip-admin (send snip get-admin)) - (loop (send snip-admin get-editor))] - [else - (define canvas (send editor get-canvas)) - (and canvas (find-parent/window canvas))]))) - -(define (find-parent/window win) - (let loop ([win win]) - (cond - [(or (is-a? win frame%) - (is-a? win dialog%)) - win] - [else - (define p (send win get-parent)) - (and p (loop p))]))) - -(define (monitor-a-file txt path eventspace) - ;; grab the monitoring event on the same event - ;; to facilitate testing - (define mod-time (file-or-directory-modify-seconds path)) - (define evt (filesystem-change-evt path #f)) - (define size (file-size path)) - (channel-put filename-changed-chan (vector txt path eventspace mod-time size evt))) -(define filename-changed-chan (make-channel)) -(define (un-monitor-a-file txt) - (define c (make-channel)) - (channel-put unmonitor-chan (cons c txt)) - (channel-get c)) -(define unmonitor-chan (make-channel)) -(void - (thread - (λ () - (struct monitored (path evt mod-time size eventspace) #:transparent) - ;; state : hash[txt -o> monitored?] - (let loop ([state (hash)]) - (apply - sync - (handle-evt - unmonitor-chan - (λ (c+txt) - (match-define (cons c txt) c+txt) - (define old (hash-ref state txt #f)) - (cond - [old - (filesystem-change-evt-cancel (monitored-evt old)) - (channel-put c (void)) - (loop (hash-remove state txt))] - [else (loop state)]))) - (handle-evt - filename-changed-chan - (λ (txt+path+eventspace) - (match-define (vector txt path eventspace mod-time size evt) - txt+path+eventspace) - (cond - [evt - (define old (hash-ref state txt #f)) - (when old (filesystem-change-evt-cancel (monitored-evt old))) - (loop (hash-set state - txt - (monitored path evt - mod-time size - eventspace)))] - [else - ;; failed to create an evt, so give up - ;; trying to monitor this file - (loop state)]))) - (for/list ([(txt a-monitored) (in-hash state)]) - (match-define (monitored path evt mod-time size eventspace) - a-monitored) - (handle-evt - evt - (λ (_) - (match-define (vector _1 _2 _3 can-track-file-level-changes?) - (system-type 'fs-change)) - (cond - [(or can-track-file-level-changes? - (< mod-time (file-or-directory-modify-seconds path)) - (not (= (file-size path) size))) - ;; the `or` above ensures that the file actually is changed, - ;; as it might not be on some platforms - (parameterize ([current-eventspace eventspace]) - (queue-callback - (λ () - (send txt autoload-file-changed)))) - (loop (hash-remove state txt))] - [else - ;; the file appears to not actually be modified. - ;; try to create a new evt to wait again - (define new-evt (filesystem-change-evt path #f)) - (cond - [evt - (loop (hash-set state - txt - (monitored - path - new-evt - mod-time - size - eventspace)))] - [else - ;; we failed to create an evt; give up on - ;; monitoring this file (can we do better?) - (loop (hash-remove state txt))])]))))))))) - - (define info<%> (interface (basic<%>))) - (define info-mixin - (mixin (basic<%>) (info<%>) - (inherit get-top-level-window run-after-edit-sequence) - (define callback-running? #f) - (define/override (lock x) - (super lock x) - (run-after-edit-sequence - (rec send-frame-update-lock-icon - (λ () - (unless callback-running? - (set! callback-running? #t) - (queue-callback - (λ () - (let ([frame (get-top-level-window)]) - (when (is-a? frame frame:info<%>) - (send frame lock-status-changed))) - (set! callback-running? #f)) - #f)))) - 'framework:update-lock-icon)) - (super-new))) - -(define font-size-message% - (class canvas% - (init message - [stretchable-height #f]) - (init-field [text-alignment 'center]) - (define msgs - (cond - [(string? message) (regexp-split #rx"\n" message)] - [((listof string?) message) message] - [else - (raise-argument-error 'editor:font-size-message% - (~s '(or/c string? (listof string?))) - message)])) - (unless (member text-alignment '(left center right)) - (raise-argument-error 'editor:font-size-message% - (~s '(or/c 'left 'center 'right)) - text-alignment)) - (inherit refresh get-dc get-client-size popup-menu) - (define/public (set-message message) - (set! msgs - (cond - [(string? message) (regexp-split #rx"\n" message)] - [((listof string?) message) message] - [else - (raise-argument-error 'editor:font-size-message%::set-label - (~s '(or/c string? (listof string?))) - message)])) - (refresh)) - (define/override (on-paint) - (define dc (get-dc)) - (define text-foreground (send dc get-text-foreground)) - (when (white-on-black-panel-scheme?) - (send dc set-text-foreground "white")) - (define-values (cw ch) (get-client-size)) - (define-values (tot-th tot-tw) - (for/fold ([tot-th 0] [tot-tw 0]) - ([msg (in-list msgs)]) - (define-values (tw th td ta) (send dc get-text-extent msg)) - (values (+ tot-th th) (max tot-tw tw)))) - (for/fold ([y (- (/ ch 2) (/ tot-th 2))]) ([msg (in-list msgs)]) - (define-values (tw th td ta) (send dc get-text-extent msg)) - (define x - (case text-alignment - [(center) (- (/ cw 2) (/ tw 2))] - [(left) 2] - [(right) (- cw 2)])) - (send dc draw-text msg x y) - (+ y th)) - (send dc set-text-foreground text-foreground)) - (super-new [style '(transparent)][stretchable-height stretchable-height]) - - ;; need object to hold onto this function, so this is - ;; intentionally a private field, not a method - (define (font-size-changed-callback _ new-prefs) - (define new-size (font-size-pref->current-font-size new-prefs)) - (set-the-height/dc-font new-size) - (refresh)) - (preferences:add-callback - 'framework:standard-style-list:font-size - font-size-changed-callback - #t) - - (define/private (set-the-height/dc-font font-size) - (define dc (get-dc)) - (send dc set-font - (send the-font-list find-or-create-font - font-size - (send normal-control-font get-family) - (send normal-control-font get-style) - (send normal-control-font get-weight) - (send normal-control-font get-underlined) - (send normal-control-font get-smoothing))) - (define tot-th - (for/sum ([msg (in-list msgs)]) - (define-values (tw th td ta) (send dc get-text-extent msg)) - th)) - (min-height (inexact->exact (ceiling tot-th)))) - - (inherit min-height) - (set-the-height/dc-font - (get-current-preferred-font-size)))) +#lang racket/base + +(require racket/unit + mred/mred-sig + "editor-misc.rkt" + "editor-autoload.rkt" + "editor-sig.rkt" + "sig.rkt") + +(provide editor@) + +(define-compound-unit/infer editor-cu@ + (import [mred : mred^] + [autosave : framework:autosave^] + [finder : framework:finder^] + [path-utils : framework:path-utils^] + [keymap : framework:keymap^] + [text : framework:text^] + [pasteboard : framework:pasteboard^] + [frame : framework:frame^] + [handler : framework:handler^] + [color-prefs : framework:color-prefs^]) + + (export editor-misc^ + editor-autoload^) + + (link editor-misc@ + editor-autoload@)) + +(define-unit/new-import-export editor@ + (import (prefix mred: mred^) + framework:autosave^ + (prefix finder: framework:finder^) + framework:path-utils^ + framework:keymap^ + (prefix text: framework:text^) + (prefix pasteboard: framework:pasteboard^) + (prefix frame: framework:frame^) + framework:handler^ + [prefix color-prefs: framework:color-prefs^] + ) + (export framework:editor^) + ((editor-misc^ editor-autoload^) + editor-cu@ + (prefix mred: mred^) + framework:autosave^ + (prefix finder: framework:finder^) + framework:path-utils^ + framework:keymap^ + (prefix text: framework:text^) + (prefix pasteboard: framework:pasteboard^) + (prefix frame: framework:frame^) + framework:handler^ + (prefix color-prefs: framework:color-prefs^))) diff --git a/gui-lib/framework/private/focus-table.rkt b/gui-lib/framework/private/focus-table.rkt index 159ef9055..509d8df6b 100644 --- a/gui-lib/framework/private/focus-table.rkt +++ b/gui-lib/framework/private/focus-table.rkt @@ -1,7 +1,9 @@ #lang racket/base -(require racket/gui/base) +(require racket/gui/base racket/class) (provide frame:lookup-focus-table - frame:set-focus-table) + frame:set-focus-table + find-parent/editor + find-parent/window) ;; focus-table : hash[eventspace -o> (listof frame)] (define focus-table (make-hash)) @@ -11,3 +13,26 @@ (if (null? new) (hash-remove! focus-table eventspace) (hash-set! focus-table eventspace new))) + +(define (find-parent/editor editor) + (let loop ([editor editor]) + (define ed-admin (send editor get-admin)) + (cond + [(not ed-admin) #f] + [(is-a? ed-admin editor-snip-editor-admin<%>) + (define snip (send ed-admin get-snip)) + (define snip-admin (send snip get-admin)) + (loop (send snip-admin get-editor))] + [else + (define canvas (send editor get-canvas)) + (and canvas (find-parent/window canvas))]))) + +(define (find-parent/window win) + (let loop ([win win]) + (cond + [(or (is-a? win frame%) + (is-a? win dialog%)) + win] + [else + (define p (send win get-parent)) + (and p (loop p))]))) diff --git a/gui-lib/framework/private/frame.rkt b/gui-lib/framework/private/frame.rkt index 51f97b88d..c14df7215 100644 --- a/gui-lib/framework/private/frame.rkt +++ b/gui-lib/framework/private/frame.rkt @@ -4,11 +4,11 @@ racket/class racket/contract/base racket/path + racket/dict "search.rkt" "sig.rkt" "../preferences.rkt" "../gui-utils.rkt" - "bday.rkt" "gen-standard-menus.rkt" "interfaces.rkt" "srcloc-panel.rkt" @@ -180,13 +180,15 @@ (exit) (exit:set-exiting #f)))) - (define/public (make-visible filename) (void)) + (define/public (make-visible filename #:start-pos [start-pos #f] #:end-pos [end-pos start-pos]) (void)) (define/public get-filename (case-lambda [() (get-filename #f)] [(b) #f])) (define/public (editing-this-file? filename) #f) + + (define/public (get-all-open-files) '()) (define/override (on-superwindow-show shown?) (send (group:get-the-frame-group) frame-shown/hidden this) @@ -364,8 +366,8 @@ (if (and l t mw mh) (values (- delta-x l) (- delta-y t) - (and (<= 0 l mw) - (<= 0 t mh))) + (and (<= 0 delta-x mw) + (<= 0 delta-y mh))) (values #f #f #f))] [else (values #f #f #f)])) @@ -511,7 +513,8 @@ (define/override (on-activate on?) (super on-activate on?) (when on? - (send (group:get-the-frame-group) set-active-frame this))) + (send (group:get-the-frame-group) set-active-frame this)) + (handler:update-currently-open-files)) (super-new) (send (group:get-the-frame-group) insert-frame this))) @@ -529,20 +532,20 @@ (refresh))) (inherit get-client-size get-dc) (define/override (on-paint) - (let* ([dc (get-dc)] - [draw - (λ (str bg-color bg-style line-color line-style) - (send dc set-font small-control-font) - (let-values ([(w h) (get-client-size)] - [(tw th _1 _2) (send dc get-text-extent str)]) - (send dc set-pen (send the-pen-list find-or-create-pen line-color 1 line-style)) - (send dc set-brush (send the-brush-list find-or-create-brush bg-color bg-style)) - (send dc draw-rectangle 0 0 w h) - (send dc draw-text str - (- (/ w 2) (/ tw 2)) - (- (/ h 2) (/ th 2)))))]) - (when locked? - (draw locked-message "yellow" 'solid "black" 'solid)))) + (define dc (get-dc)) + (define (draw str bg-color bg-style line-color line-style) + (send dc set-font small-control-font) + (define-values (w h) (get-client-size)) + (define-values (tw th _1 _2) (send dc get-text-extent str #f 'grapheme)) + (send dc set-pen (send the-pen-list find-or-create-pen line-color 1 line-style)) + (send dc set-brush (send the-brush-list find-or-create-brush bg-color bg-style)) + (send dc draw-rectangle 0 0 w h) + (send dc draw-text str + (- (/ w 2) (/ tw 2)) + (- (/ h 2) (/ th 2)) + 'grapheme)) + (when locked? + (draw locked-message "yellow" 'solid "black" 'solid))) (inherit get-parent min-width min-height stretchable-width stretchable-height) (define/private (setup-sizes) @@ -904,7 +907,7 @@ (set! memory-canvases (remq this-frames-memory-canvas memory-canvases)))) (send panel stretchable-width #f)) - (define gc-canvas (new bday-click-canvas% [parent (get-info-panel)] [style '(border no-focus)])) + (define gc-canvas (new gc-off-canvas% [parent (get-info-panel)] [style '(border no-focus)])) (define/private (register-gc-blit) (let ([onb (icon:get-gc-on-bitmap)] [offb (icon:get-gc-off-bitmap)]) @@ -994,18 +997,18 @@ (update-client-width str) (refresh)) (define/private (update-client-width str) - (let ([dc (get-dc)]) - (let-values ([(cw _4) (get-client-size)] - [(tw _1 _2 _3) (send dc get-text-extent str normal-control-font)]) - (when (< cw tw) - (min-client-width (inexact->exact (ceiling tw))))))) + (define dc (get-dc)) + (define-values (cw _4) (get-client-size)) + (define-values (tw _1 _2 _3) (send dc get-text-extent str normal-control-font 'grapheme)) + (when (< cw tw) + (min-client-width (inexact->exact (ceiling tw))))) (define/override (on-paint) (define dc (get-dc)) (send dc set-font normal-control-font) (send dc set-text-foreground (get-label-foreground-color)) (define-values (cw ch) (get-client-size)) (define-values (tw th _1 _2) (send dc get-text-extent str)) - (send dc draw-text str 0 (/ (- ch th) 2))) + (send dc draw-text str 0 (/ (- ch th) 2) 'grapheme)) (define/override (on-event evt) (when button-up (when (send evt button-up?) @@ -1064,7 +1067,8 @@ (λ (p v) (editor-position-changed-offset/numbers v - (preferences:get 'framework:display-line-numbers)) + (preferences:get 'framework:display-line-numbers) + (preferences:get 'framework:display-character-offsets?)) #t))) (define remove-second (preferences:add-callback @@ -1072,50 +1076,68 @@ (λ (p v) (editor-position-changed-offset/numbers (preferences:get 'framework:col-offsets) + v + (preferences:get 'framework:display-character-offsets?)) + #t))) + (define remove-third + (preferences:add-callback + 'framework:display-character-offsets? + (λ (p v) + (editor-position-changed-offset/numbers + (preferences:get 'framework:col-offsets) + (preferences:get 'framework:display-line-numbers) v) #t))) (define/augment (on-close) (remove-first) (remove-second) + (remove-third) (inner (void) on-close)) [define last-start #f] [define last-end #f] [define last-params #f] - (define/private (editor-position-changed-offset/numbers offset? line-numbers?) - (let* ([edit (get-info-editor)] - [make-one - (λ (pos) - (if line-numbers? - (let* ([line (send edit position-paragraph pos)] - [col (find-col edit line pos)]) - (format "~a:~a" - (add1 line) - (if offset? - (add1 col) - col))) - (format "~a" pos)))]) + (define/private (editor-position-changed-offset/numbers offset? + line-numbers? + character-offsets?) + (when (object? position-canvas) + (define edit (get-info-editor)) + (define (make-one pos) + (define (line-numbers) + (define para (send edit position-paragraph pos)) + (define col (find-col edit para pos)) + (define para-start (send edit paragraph-start-position para)) + (format "~a:~a" + (add1 para) + (if offset? + (add1 col) + col))) + (cond + [(and line-numbers? character-offsets?) + (format "~a@~a" pos (line-numbers))] + [line-numbers? + (line-numbers)] + [else (format "~a" pos)])) (cond - [(not (object? position-canvas)) - (void)] [edit (unless (send position-canvas is-shown?) (send position-canvas show #t)) - (let ([start (send edit get-start-position)] - [end (send edit get-end-position)]) - (unless (and last-start - (equal? last-params (list offset? line-numbers?)) - (= last-start start) - (= last-end end)) - (set! last-params (list offset? line-numbers?)) - (set! last-start start) - (set! last-end end) - (when (object? position-canvas) - (change-position-edit-contents - (if (= start end) - (make-one start) - (string-append (make-one start) - "-" - (make-one end)))))))] + (define start (send edit get-start-position)) + (define end (send edit get-end-position)) + (define this-params (list offset? line-numbers? character-offsets?)) + (unless (and last-start + (equal? last-params this-params) + (= last-start start) + (= last-end end)) + (set! last-params this-params) + (set! last-start start) + (set! last-end end) + (change-position-edit-contents + (if (= start end) + (make-one start) + (string-append + (make-one start) + (if (and line-numbers? character-offsets?) " - " "-") + (make-one end)))))] [else (when (send position-canvas is-shown?) (send position-canvas show #f))]))) @@ -1209,7 +1231,8 @@ (define/public (editor-position-changed) (editor-position-changed-offset/numbers (preferences:get 'framework:col-offsets) - (preferences:get 'framework:display-line-numbers))) + (preferences:get 'framework:display-line-numbers) + (preferences:get 'framework:display-character-offsets?))) (define/public (overwrite-status-changed) (let ([info-edit (get-info-editor)] [failed @@ -1357,22 +1380,23 @@ (define/override (on-subwindow-event receiver evt) (cond [(send evt button-down?) - (let ([menu (new popup-menu%)] - [line-numbers? (preferences:get 'framework:display-line-numbers)]) - (new checkable-menu-item% - [parent menu] - [label (string-constant show-line-and-column-numbers)] - [callback (λ (x y) (preferences:set 'framework:display-line-numbers #t))] - [checked line-numbers?]) - (new checkable-menu-item% - [parent menu] - [label (string-constant show-character-offsets)] - [callback (λ (x y) (preferences:set 'framework:display-line-numbers #f))] - [checked (not line-numbers?)]) - (extra-menu-items menu) - (popup-menu menu - (+ 1 (send evt get-x)) - (+ 1 (send evt get-y)))) + (define menu (new popup-menu%)) + (define line-numbers? (preferences:get 'framework:display-line-numbers)) + (define character-offsets? (preferences:get 'framework:display-character-offsets?)) + (new checkable-menu-item% + [parent menu] + [label (string-constant show-line-and-column-numbers)] + [callback (λ (x y) (preferences:set 'framework:display-line-numbers (not line-numbers?)))] + [checked line-numbers?]) + (new checkable-menu-item% + [parent menu] + [label (string-constant show-character-offsets)] + [callback (λ (x y) (preferences:set 'framework:display-character-offsets? (not character-offsets?)))] + [checked character-offsets?]) + (extra-menu-items menu) + (popup-menu menu + (+ 1 (send evt get-x)) + (+ 1 (send evt get-y))) #t] [else (super on-subwindow-event receiver evt)])) @@ -1401,7 +1425,9 @@ save save-as get-canvas - get-editor)) + get-editor + + find-editor)) (define editor-mixin (mixin (standard-menus<%>) (-editor<%>) @@ -1424,9 +1450,23 @@ (with-handlers ((exn:fail? (λ (x) #f))) (equal? (normal-case-path (normalize-path x)) (normal-case-path (normalize-path y)))))]) - (let ([this-fn (get-filename)]) - (and this-fn - (path-equal? filename (get-filename)))))) + (define ed (get-editor)) + (cond + [(let ([fn (get-filename)]) + (and fn (path-equal? filename (get-filename)))) + ;; it would be nice to remove this case, as + ;; port-name-matches? is doing something similar. + ;; unfortunately, it isn't quite the same; here + ;; normalize-path is used and there it isn't. + #t] + [(is-a? ed text:basic<%>) + (send ed port-name-matches? filename)] + [else + #f]))) + + (define/override (get-all-open-files) + (with-handlers ((exn:fail? (λ (x) '()))) + (list (normalize-path (get-filename))))) (define/augment (on-close) (send (get-editor) on-close) @@ -1629,7 +1669,11 @@ (set! editor (make-editor)) (send (get-canvas) set-editor editor)) editor) - + (define/public (find-editor predicate) + (if (and editor + (predicate editor)) + editor + #f)) (cond [(and filename (file-exists? filename)) (let ([ed (get-editor)]) @@ -2028,13 +2072,13 @@ (λ (x) (insert x (last-position) (last-position))) (preferences:get pref-sym)) (end-edit-sequence) - - (define pref-callback + + (define pref-callback (λ (p v) (let ([c (get-canvas)]) (when (and c (send c get-line-count)) (send c set-editor (send c get-editor)))))) - + (preferences:add-callback 'framework:standard-style-list:font-size pref-callback #t))) (define find-text% @@ -2042,13 +2086,13 @@ (inherit get-canvas get-text last-position insert find-first-snip get-admin invalidate-bitmap-cache run-after-edit-sequence begin-edit-sequence end-edit-sequence get-top-level-window) - + (define/private (get-case-sensitive-search?) (let ([frame (get-top-level-window)]) (and frame (send frame get-case-sensitive-search?)))) - (define/override (on-focus on?) + (define/override (on-focus on?) (let ([frame (get-top-level-window)]) (when frame (let ([text-to-search (send frame get-text-to-search)]) @@ -2056,7 +2100,7 @@ (when on? (send text-to-search set-search-anchor (send text-to-search get-start-position))))))) (super on-focus on?)) - + (define/augment (after-insert x y) (update-searching-str/trigger-jump) (inner (void) after-insert x y)) @@ -2067,7 +2111,7 @@ (let ([tlw (get-top-level-window)]) (when tlw (send tlw search-string-changed))) - + ;; trigger-jump (when (preferences:get 'framework:anchored-search) (let ([frame (get-top-level-window)]) @@ -2082,118 +2126,122 @@ [else (search 'forward #t #t #f anchor-pos)]))))))))) - (define/private (get-searching-text) (let ([frame (get-top-level-window)]) (and frame (send frame get-text-to-search)))) - (define/public (search [searching-direction 'forward] + + (define/public (search [searching-direction 'forward] [beep? #t] [wrap? #t] [move-anchor? #t] [search-start-position #f]) - (let* ([string (get-text)] - [top-searching-edit (get-searching-text)]) - (when top-searching-edit - (let ([searching-edit - (let loop ([txt top-searching-edit]) - (define focus-snip (send txt get-focus-snip)) - (cond - [(and focus-snip (is-a? focus-snip editor-snip%)) - (loop (send focus-snip get-editor))] - [else txt]))] - - [not-found - (λ (found-edit skip-beep?) - (when (and beep? - (not skip-beep?)) - (bell)) - #f)] - [found - (λ (text first-pos) - (define (thunk) - (define last-pos ((if (eq? searching-direction 'forward) + -) - first-pos (string-length string))) - (define start-pos (min first-pos last-pos)) - (define end-pos (max first-pos last-pos)) - - (send text begin-edit-sequence #t #f) - (send text set-caret-owner #f 'display) - (send text set-position start-pos end-pos #f #f 'local) - - - ;; scroll to the middle if the search result isn't already visible - (let ([search-result-line (send text position-line (send text get-start-position))] - [bt (box 0)] - [bb (box 0)]) - (send text get-visible-line-range bt bb #f) - (unless (< (unbox bt) search-result-line (unbox bb)) - (let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))] - [last-pos (send text position-line (send text last-position))] - [top-pos (send text line-start-position - (max (min (- search-result-line half) last-pos) 0))] - [bottom-pos (send text line-start-position - (max 0 - (min (+ search-result-line half) - last-pos)))]) - (send text scroll-to-position - top-pos - #f - bottom-pos)))) - - (when move-anchor? - (when (is-a? text text:searching<%>) - (send text set-search-anchor - (if (eq? searching-direction 'forward) - end-pos - start-pos)))) - - (send text end-edit-sequence)) - - (define owner (or (send text get-active-canvas) - (send text get-canvas))) - (if owner - (send owner call-as-primary-owner thunk) - (thunk)) - #t)]) - - (if (string=? string "") - (not-found top-searching-edit #t) - (let-values ([(found-edit first-pos) - (find-string-embedded - (if search-start-position - top-searching-edit - searching-edit) - string - searching-direction - (or search-start-position - (if (eq? 'forward searching-direction) - (send searching-edit get-end-position) - (send searching-edit get-start-position))) - 'eof #t - (get-case-sensitive-search?) - #t)]) - (cond - [(not first-pos) - (if wrap? - (begin - (let-values ([(found-edit pos) - (find-string-embedded - top-searching-edit - string - searching-direction - (if (eq? 'forward searching-direction) - 0 - (send searching-edit last-position)) - 'eof #t - (get-case-sensitive-search?) - #f)]) - (if (not pos) - (not-found found-edit #f) - (found found-edit pos)))) - (not-found found-edit #f))] - [else - (found found-edit first-pos)]))))))) + (define str (get-text)) + (define top-searching-edit (get-searching-text)) + (when top-searching-edit + (define searching-edit (find-searching-edit top-searching-edit)) + (define (not-found) + (when beep? + (bell)) + #f) + (cond + [(string=? str "") + #f] + [else + (define-values (found-edit first-pos) + (find-string-embedded + (if search-start-position + top-searching-edit + searching-edit) + str + searching-direction + (or search-start-position + (if (eq? 'forward searching-direction) + (send searching-edit get-end-position) + (send searching-edit get-start-position))) + 'eof #t + (get-case-sensitive-search?) + #t + #:recur-inside? + (λ (x) (is-a? (send x get-editor) text:searching-embedded<%>)))) + (cond + [first-pos + (found found-edit first-pos str searching-direction move-anchor?)] + [else + (cond + [wrap? + (define-values (found-edit pos) + (find-string-embedded + top-searching-edit + str + searching-direction + (if (eq? 'forward searching-direction) + 0 + (send searching-edit last-position)) + 'eof #t + (get-case-sensitive-search?) + #f + #:recur-inside? + (λ (x) (is-a? (send x get-editor) text:searching-embedded<%>)))) + (if pos + (found found-edit pos str searching-direction move-anchor?) + (not-found))] + [else + (not-found)])])]))) + + (define/private (find-searching-edit top-searching-edit) + (let loop ([txt top-searching-edit]) + (define focus-snip (send txt get-focus-snip)) + (cond + [(and focus-snip (is-a? focus-snip editor-snip%)) + (loop (send focus-snip get-editor))] + [else txt]))) + + (define/private (found text first-pos str searching-direction move-anchor?) + (define (thunk) + (define last-pos ((if (eq? searching-direction 'forward) + -) + first-pos (string-length str))) + (define start-pos (min first-pos last-pos)) + (define end-pos (max first-pos last-pos)) + + (send text begin-edit-sequence #t #f) + (send text set-caret-owner #f 'display) + (send text set-position start-pos end-pos #f #f 'local) + + ;; scroll to the middle if the search result isn't already visible + (let ([search-result-line (send text position-line (send text get-start-position))] + [bt (box 0)] + [bb (box 0)]) + (send text get-visible-line-range bt bb #f) + (unless (< (unbox bt) search-result-line (unbox bb)) + (let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))] + [last-pos (send text position-line (send text last-position))] + [top-pos (send text line-start-position + (max (min (- search-result-line half) last-pos) 0))] + [bottom-pos (send text line-start-position + (max 0 + (min (+ search-result-line half) + last-pos)))]) + (send text scroll-to-position + top-pos + #f + bottom-pos)))) + + (when move-anchor? + (when (is-a? text text:searching<%>) + (send text set-search-anchor + (if (eq? searching-direction 'forward) + end-pos + start-pos)))) + + (send text end-edit-sequence)) + + (define owner (or (send text get-active-canvas) + (send text get-canvas))) + (if owner + (send owner call-as-primary-owner thunk) + (thunk)) + #t) (define/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?) @@ -2221,7 +2269,7 @@ (send dc draw-rectangle (+ dx view-x) (+ view-y dy) view-width view-height) (send dc set-pen pen) (send dc set-brush brush))))))) - + (super-new [pref-sym 'framework:search-string]))) (define replace-text% @@ -2278,7 +2326,7 @@ (let ([text-to-search (send tlw get-text-to-search)]) (when text-to-search (let ([anchor-pos (send text-to-search get-anchor-pos)]) - (when anchor-pos + (when anchor-pos (send text-to-search set-position anchor-pos)))))) (send tlw hide-search))))) @@ -2289,7 +2337,7 @@ (when tlw (send tlw unhide-search-and-toggle-focus))))) -(define searchable-canvas% +(define searchable-canvas% (class (canvas:color-mixin canvas:basic%) (inherit refresh get-dc get-client-size) (define red? #f) @@ -2403,7 +2451,12 @@ [root (make-object % s-root)]) (set! super-root s-root) root))) - + + (define/override (on-activate on?) + (super on-activate on?) + (when on? + (try-to-update-canvas-in-case-font-size-changed))) + (define text-to-search #f) (define/public-final (get-text-to-search) text-to-search) @@ -2474,12 +2527,15 @@ (when focus? (send find-edit set-position 0 (send find-edit last-position)) (send (send find-edit get-canvas) focus)) - (let ([c (send find-edit get-canvas)]) - (when (and c (send c get-line-count)) - ;; try to update the canvas so that the font size is correctly accounted for - (send c set-editor (send c get-editor)))) + (try-to-update-canvas-in-case-font-size-changed) (send find-edit end-edit-sequence))) - + + (define/private (try-to-update-canvas-in-case-font-size-changed) + (when find-edit + (define c (send find-edit get-canvas)) + (when (and c (send c get-line-count)) + (send c set-editor (send c get-editor))))) + (define/public (unhide-search-and-toggle-focus #:new-search-string-from-selection? [new-search-string-from-selection? #f]) (if hidden? (unhide-search #t #:new-search-string-from-selection? new-search-string-from-selection?) @@ -2517,10 +2573,14 @@ (define replacee-start-or-pair (send text-to-search get-replace-search-hit)) (when replacee-start-or-pair (define-values (text-to-replace-in replacee-start) - (cond - [(pair? replacee-start-or-pair) - (values (car replacee-start-or-pair) (cdr replacee-start-or-pair))] - [else (values text-to-search replacee-start-or-pair)])) + (let loop ([last-txt text-to-search] + [replacee-start-or-pair replacee-start-or-pair]) + (cond + [(pair? replacee-start-or-pair) + (loop (car replacee-start-or-pair) + (cdr replacee-start-or-pair))] + [else + (values last-txt replacee-start-or-pair)]))) (define replacee-end (+ replacee-start (send find-edit last-position))) (send text-to-replace-in begin-edit-sequence) (send text-to-search begin-edit-sequence) @@ -2549,36 +2609,39 @@ (define/public (replace-all) (unhide-search #f) - (let ([txt (get-text-to-search)]) - (when txt - (let ([search-str (send find-edit get-text)] - [ht (make-hasheq)]) - (send txt begin-edit-sequence) - (hash-set! ht txt #t) - (let loop ([txt (pop-all-the-way-out txt)] - [pos 0]) - (let-values ([(found-txt found-pos) (find-string-embedded txt - search-str - 'forward - pos - 'eof - #f - case-sensitive-search? - #t)]) - (when found-pos - (unless (hash-ref ht found-txt #f) - (hash-set! ht found-txt #t) - (send found-txt begin-edit-sequence)) - (let ([start (- found-pos (send find-edit last-position))]) - (define revision-before (send found-txt get-revision-number)) - (send found-txt delete start found-pos) - (define revision-after (send found-txt get-revision-number)) - (unless (= revision-before revision-after) - (copy-over replace-edit 0 (send replace-edit last-position) found-txt start)) - (loop found-txt (if (= revision-before revision-after) - found-pos - (+ start (send replace-edit last-position)))))))) - (hash-for-each ht (λ (txt _) (send txt end-edit-sequence))))))) + (define txt (get-text-to-search)) + (when txt + (define search-str (send find-edit get-text)) + (define ht (make-mutable-object=-hash)) + (send txt begin-edit-sequence) + (dict-set! ht txt #t) + (let loop ([txt (pop-all-the-way-out txt)] + [pos 0]) + (define-values (found-txt found-pos) + (find-string-embedded txt + search-str + 'forward + pos + 'eof + #f + case-sensitive-search? + #t + #:recur-inside? + (λ (x) (is-a? (send x get-editor) text:searching-embedded<%>)))) + (when found-pos + (unless (dict-ref ht found-txt #f) + (dict-set! ht found-txt #t) + (send found-txt begin-edit-sequence)) + (let ([start (- found-pos (send find-edit last-position))]) + (define revision-before (send found-txt get-revision-number)) + (send found-txt delete start found-pos) + (define revision-after (send found-txt get-revision-number)) + (unless (= revision-before revision-after) + (copy-over replace-edit 0 (send replace-edit last-position) found-txt start)) + (loop found-txt (if (= revision-before revision-after) + found-pos + (+ start (send replace-edit last-position))))))) + (dict-for-each ht (λ (txt _) (send txt end-edit-sequence))))) (define/private (pop-all-the-way-out txt) (let ([admin (send txt get-admin)]) @@ -2762,6 +2825,8 @@ (super-new))) +(define-custom-hash-types object=-hash #:key? object? object=? object=-hash-code) + (define (number->str/comma m) (list->string (reverse @@ -2784,18 +2849,11 @@ (define/override (get-editor%) (text:searching-mixin (super get-editor%))) (super-new))) -(define bday-click-canvas% +(define gc-off-canvas% (class canvas% (inherit get-dc) (define/override (on-paint) (send (get-dc) draw-bitmap (icon:get-gc-off-bitmap) 0 0)) - (define/override (on-event evt) - (cond - [(and (mrf-bday?) - (send evt button-up?)) - (message-box (string-constant drscheme) - (string-constant happy-birthday-matthew))] - [else (super on-event evt)])) (super-new))) (define pref-save-canvas% diff --git a/gui-lib/framework/private/group.rkt b/gui-lib/framework/private/group.rkt index 6e3169dbf..6eccb4490 100644 --- a/gui-lib/framework/private/group.rkt +++ b/gui-lib/framework/private/group.rkt @@ -1,6 +1,7 @@ #lang racket/base (require string-constants + racket/match racket/class "sig.rkt" "../preferences.rkt" @@ -48,7 +49,6 @@ (define % (class object% - [define active-frame #f] [define most-recent-window-box (make-weak-box #f)] [define frame-counter 0] [define frames null] @@ -195,30 +195,49 @@ (define/public (get-active-frame) (cond - [active-frame active-frame] [(null? frames) #f] [else (frame-frame (car frames))])) (define/public (set-active-frame f) + (define active-frame (get-active-frame)) (when (and active-frame (not (eq? active-frame f))) (set! most-recent-window-box (make-weak-box active-frame))) - (set! active-frame f)) - + (move-to-front f)) + (define/public (insert-frame new-frame) - (unless (memf (λ (fr) (eq? (frame-frame fr) new-frame)) - frames) + (define already-has-new-frame? (move-to-front new-frame)) + (unless already-has-new-frame? (set! frame-counter (add1 frame-counter)) - (let ([new-frames (cons (make-frame new-frame frame-counter) - frames)]) - (set! frames new-frames) - (update-close-menu-item-state) - (insert-windows-menu new-frame)) + (set! frames (cons (make-frame new-frame frame-counter) frames)) + (update-close-menu-item-state) + (insert-windows-menu new-frame) (todo-to-new-frames new-frame))) + + ;; move-to-front : (is-a?/c frame%) -> boolean + ;; effect: changes `frames` so that the frame struct + ;; containing `f` is at the front, if there is one + ;; returns #t if `f` was in `frames` and #f otherwise + (define/private (move-to-front f) + (define-values (fst rst) + (let loop ([frames frames]) + (match frames + ['() (values #f '())] + [(cons fr frames) + (cond + [(object=? (frame-frame fr) f) + (values fr frames)] + [else + (define-values (fst more) (loop frames)) + (values fst (cons fr more))])]))) + (cond + [fst + (set! frames (cons fst rst)) + #t] + [else + #f])) (define/public (remove-frame f) - (when (eq? f active-frame) - (set! active-frame #f)) (let ([new-frames (remove f frames @@ -263,6 +282,11 @@ (if (test-frame frame) frame (loop (cdr frames))))])))) + + (define/public (get-all-open-files) + (define the-frames (map frame-frame frames)) + (for/list ([frame (in-list the-frames)]) + (send frame get-all-open-files))) (super-new))) diff --git a/gui-lib/framework/private/guide-struct.rkt b/gui-lib/framework/private/guide-struct.rkt new file mode 100644 index 000000000..83283dce5 --- /dev/null +++ b/gui-lib/framework/private/guide-struct.rkt @@ -0,0 +1,25 @@ +#lang racket/base +(require racket/class) +(provide (struct-out guide) get-guides draw-the-lines) + +;; these are internal definitions used by text-indent-guides +;; exported here for use in the test suite + +(struct guide (indent [x #:mutable] guides) #:transparent) +;; indent : natural? or #f +;; indicates how many spaces start this line +;; or #f to indicate that this is a blank line +;; for blank lines, sizing information can't be +;; gotten from the editor on this line, as there may +;; not be actual characters where the guides are +;; x : integer? or #f +;; this is the x (editor) coordinate for the guide +;; that starts at this line +;; if the guide is a blank line guide, then this is #f +;; guides : (sorted-listof natural?) +;; indicates the positions (from the start of this para) +;; where guides are coming down + +;; these are private methods, but are made public +;; to make it possible to write unit tests +(define-local-member-name get-guides draw-the-lines) diff --git a/gui-lib/framework/private/handler.rkt b/gui-lib/framework/private/handler.rkt index 2ed4de7e0..7f92202de 100644 --- a/gui-lib/framework/private/handler.rkt +++ b/gui-lib/framework/private/handler.rkt @@ -10,6 +10,7 @@ string-constants) (import mred^ + [prefix exit: framework:exit^] [prefix finder: framework:finder^] [prefix group: framework:group^] [prefix frame: framework:frame^]) @@ -74,7 +75,10 @@ frame)))) (define (edit-file filename [make-default - (λ () ((current-create-new-window) filename))]) + (λ () ((current-create-new-window) + (and (path? filename) filename)))] + #:start-pos [start-pos #f] + #:end-pos [end-pos #f]) (with-handlers ([(λ (x) #f) ;exn:fail? (λ (exn) (message-box @@ -96,14 +100,16 @@ filename)]) (cond [already-open - (send already-open make-visible filename) + (send already-open make-visible filename + #:start-pos start-pos #:end-pos end-pos) (send already-open show #t) already-open] [else (let ([handler (and (path? filename) (find-format-handler filename))]) - (add-to-recent filename) - (if handler (handler filename) (make-default)))])) + (when (path? filename) + (add-to-recent filename)) + (if (and (path? filename) handler) (handler filename) (make-default)))])) (make-default)))))) ;; type recent-list-item = (list/p string? number? number?) @@ -126,6 +132,13 @@ (preferences:get 'framework:recent-max-count))) (preferences:set 'framework:recently-opened-files/pos new-recent)) +(define (update-currently-open-files) + (unless (exit:exiting?) + (preferences:set + 'framework:last-opened-files + (send (group:get-the-frame-group) + get-all-open-files)))) + ;; same-enough-path? : path path -> boolean ;; used to determine if the open-recent-files menu item considers two paths to be the same (define (recently-opened-files-same-enough-path? p1 p2) diff --git a/gui-lib/framework/private/icon.rkt b/gui-lib/framework/private/icon.rkt index 20bdf4d89..b1d82c696 100644 --- a/gui-lib/framework/private/icon.rkt +++ b/gui-lib/framework/private/icon.rkt @@ -5,7 +5,6 @@ racket/promise racket/class racket/runtime-path - "bday.rkt" "sig.rkt" mred/mred-sig mrlib/panel-wob) @@ -29,7 +28,8 @@ (define-runtime-path left-right-csr-path '(lib "left-right-cursor.xbm" "icons")) (define-unit icon@ - (import mred^) + (import mred^ + [prefix color-prefs: framework:color-prefs^]) (export framework:icon^) (define eof-bitmap (delay/sync (let ([bm (make-object bitmap% eof-bitmap-path)]) @@ -87,16 +87,12 @@ (define (get-gc-on-bitmap) (force - (if (mrf-bday?) - mrf-on-bitmap - (if (white-on-black-panel-scheme?) - gc-wob-on-bitmap - gc-on-bitmap)))) + (if (color-prefs:white-on-black-color-scheme?) + gc-wob-on-bitmap + gc-on-bitmap))) (define (get-gc-off-bitmap) (force - (if (mrf-bday?) - mrf-off-bitmap - (if (white-on-black-panel-scheme?) - gc-wob-off-bitmap - gc-off-bitmap))))) + (if (color-prefs:white-on-black-color-scheme?) + gc-wob-off-bitmap + gc-off-bitmap)))) diff --git a/gui-lib/framework/private/interfaces.rkt b/gui-lib/framework/private/interfaces.rkt index a5761c861..8b182f801 100644 --- a/gui-lib/framework/private/interfaces.rkt +++ b/gui-lib/framework/private/interfaces.rkt @@ -12,7 +12,11 @@ frame:text-info<%> text:ascii-art-enlarge-boxes<%> do-draw-single-line - draw-separator) + draw-separator + get-fully-computed-finite-decimal-string) + +;; for use in the number-snip% test suite +(define-local-member-name get-fully-computed-finite-decimal-string) (define-local-member-name draw-separator do-draw-single-line) @@ -70,6 +74,7 @@ make-root-area-container close editing-this-file? + get-all-open-files get-filename make-visible)) diff --git a/gui-lib/framework/private/keymap-global.rkt b/gui-lib/framework/private/keymap-global.rkt index 0a13e82a5..9941ca2e0 100644 --- a/gui-lib/framework/private/keymap-global.rkt +++ b/gui-lib/framework/private/keymap-global.rkt @@ -53,14 +53,18 @@ (when (send event button-up?) (let ([a (send edit get-admin)]) (when a + (define-values (ed-x ed-y) + (send edit + dc-location-to-editor-location + (send event get-x) + (send event get-y))) (let ([m (make-object popup-menu%)]) ((keymap:add-to-right-button-menu/before) m edit event) (append-editor-operation-menu-items m #:popup-position - (list edit - (send edit find-position (send event get-x) (send event get-y)))) + (list edit (send edit find-position ed-x ed-y))) (for-each (λ (i) (when (is-a? i selectable-menu-item<%>) @@ -69,11 +73,7 @@ ((keymap:add-to-right-button-menu) m edit event) - (let-values ([(x y) (send edit - dc-location-to-editor-location - (send event get-x) - (send event get-y))]) - (send a popup-menu m (+ x 1) (+ y 1))))))))] + (send a popup-menu m (+ ed-x 1) (+ ed-y 1)))))))] [toggle-anchor (λ (edit event) @@ -664,9 +664,10 @@ (send text insert replacement) (send text end-edit-sequence))))))] + [roman-letters "abgdezhji klmnxopr stufqyw"] [greek-letters "αβγδεζηθι κλμνξοπρςστυφχψω"] [Greek-letters "ΑΒΓΔΕΖΗΘΙ ΚΛΜΝΞΟΠΡ ΣΤΥΦΧΨΩ"] - ;; don't have a capital ς, just comes out as \u03A2 (or junk) + ;; ς is Σ in word-final position, so it has no capital ("just comes out as \u03A2 (or junk)") [find-beginning-of-line @@ -827,11 +828,10 @@ (λ (greek-chars shift?) (let loop ([i 0]) (when (< i (string-length greek-chars)) - (let ([greek-char (string-ref greek-chars i)]) - (unless (equal? greek-char #\space) - (let ([roman-char - (integer->char - (+ (char->integer #\a) i))]) + (let ([greek-char (string-ref greek-chars i)] + [roman-char (string-ref roman-letters i)]) + (unless (or (equal? greek-char #\space) + (equal? roman-char #\space)) (map (format "a:g;~a~a" (if shift? "s:" "") roman-char) @@ -843,7 +843,7 @@ (map (format "c:x;c:g;~a~a" (if shift? "s:" "") roman-char) - (format "insert ~a" greek-char))))) + (format "insert ~a" greek-char)))) (loop (+ i 1)))))]) (setup-mappings greek-letters #f) (setup-mappings Greek-letters #t)) diff --git a/gui-lib/framework/private/main.rkt b/gui-lib/framework/private/main.rkt index ca34327fd..bf460705e 100644 --- a/gui-lib/framework/private/main.rkt +++ b/gui-lib/framework/private/main.rkt @@ -2,10 +2,12 @@ (require racket/class racket/contract racket/list + racket/match "sig.rkt" "../preferences.rkt" mred/mred-sig - mrlib/panel-wob) + mrlib/panel-wob + syntax-color/racket-indentation) (import mred^ [prefix preferences: framework:preferences^] @@ -13,19 +15,26 @@ [prefix group: framework:group^] [prefix handler: framework:handler^] [prefix editor: framework:editor^] - [prefix color-prefs: framework:color-prefs^] + [prefix color-prefs: framework:color-prefs/int^] [prefix racket: framework:racket^] [prefix early-init: framework:early-init^] [prefix color: framework:color^]) (export framework:main^) (init-depend framework:preferences^ framework:exit^ framework:editor^ - framework:color-prefs^ framework:racket^ framework:early-init^) + framework:color-prefs/int^ framework:racket^ framework:early-init^) (preferences:low-level-get-preference preferences:get-preference/gui) (preferences:low-level-put-preferences preferences:put-preferences/gui) (application-preferences-handler (λ () (preferences:show-dialog))) +(preferences:set-default 'framework:last-opened-files '() (listof (listof path?))) +(preferences:set-un/marshall 'framework:last-opened-files + (λ (x) (map (λ (x) (map path->bytes x)) x)) + (λ (x) (map (λ (x) (map bytes->path x)) x))) + +(preferences:set-default 'framework:caret-blink-disable? #f boolean?) + (preferences:set-default 'framework:editor-x-selection-mode #t boolean?) (when (equal? (system-type) 'unix) (preferences:add-callback @@ -34,12 +43,6 @@ (preferences:set-default 'framework:ascii-art-enlarge #f boolean?) -(preferences:set-default 'framework:color-scheme - (if (white-on-black-panel-scheme?) - 'white-on-black - 'classic) - symbol?) - (preferences:set-default 'framework:column-guide-width '(#f 102) (list/c boolean? (and/c exact-integer? (>=/c 2)))) @@ -217,7 +220,91 @@ (set-square-bracket-nonum-pref 'framework:square-bracket:for/fold for/folds) -(preferences:set-default 'framework:white-on-black? (white-on-black-panel-scheme?) boolean?) +;; this preference shouldn't be used any more; we keep it here +;; only so we can access it's old value +(preferences:set-default 'framework:color-scheme 'classic symbol?) + +(define dark-mode-with-previous-preferences-organization? + ;; all of the color schemes on the package server with + ;; 'white-on-black-base? set to #t + (and (member (preferences:get 'framework:color-scheme) + '(white-on-black + |Tol's White on Black| + |Catppuccin Frappe| + |Catppuccin Macchiato| + |Catppuccin Mocha| + |Dracula| + |Cyberpunk| + |Everforest Dark Hard| + |Everforest Dark Medium| + |Everforest Dark Low| + |Material| + |One Dark| + |Dark Green - blue style| + |Dark Green - orange style| + |Solarized Dark| + |Sonokai| + |fairyfloss| + |Funktionuckelt Dark| + + ;; these two have a #f set in the info.rkt file, but + ;; seems to actually intended to be dark color schemes + |ayu mirage| + |Zenburn| + )) + #t)) + +;; the name of the color scheme that the user prefers when in black-on-white mode +;; the default is based on the previous preferences organization, preserving the +;; chosen preference if we can. +(preferences:set-default 'framework:color-scheme-light + (if dark-mode-with-previous-preferences-organization? + 'classic + (preferences:get 'framework:color-scheme)) + symbol?) +;; the name of the color scheme that the user prefers when in white-on-black mode +(preferences:set-default 'framework:color-scheme-dark + (if dark-mode-with-previous-preferences-organization? + (preferences:get 'framework:color-scheme) + 'white-on-black) + symbol?) + + +;; either: +;; #t (meaning we always treat it as white-on-black aka dark mode) +;; #f (meaning we always treat it as black-on-white aka light mode), or +;; 'platform (meaning we use `white-on-black-panel-scheme?` to determine what to do) +(preferences:set-default 'framework:white-on-black-mode? + ;; in the past, the 'framework:color-scheme preference + ;; determined a single color scheme; use that scheme's + ;; dark/light mode category to determine the default + ;; preference for this preference, preferring 'platform + ;; if 'platform seems to make sense + (case (system-type) + [(windows) + dark-mode-with-previous-preferences-organization?] + [else + (cond + [(equal? dark-mode-with-previous-preferences-organization? + (white-on-black-panel-scheme?)) + 'platform] + [else dark-mode-with-previous-preferences-organization?])]) + (or/c boolean? 'platform)) + +;; this is an old setting that has been replaced with 'framework:white-on-black-mode? +;; we keep its value up to date for backwards compatibility +(preferences:set-default 'framework:white-on-black? + #f + boolean?) +(define (update-white-on-black-pref val) + (preferences:set 'framework:white-on-black? + (match val + ['platform (white-on-black-panel-scheme?)] + [#t #t] + [#f #f]))) +(preferences:add-callback 'framework:white-on-black-mode? + (λ (_ val) (update-white-on-black-pref val))) +(update-white-on-black-pref (preferences:get 'framework:white-on-black-mode?)) (preferences:set-default 'framework:case-sensitive-search? #f @@ -377,6 +464,7 @@ (preferences:set-default 'framework:verify-change-format #f boolean?) (preferences:set-default 'framework:auto-set-wrap? #f boolean?) (preferences:set-default 'framework:display-line-numbers #t boolean?) +(preferences:set-default 'framework:display-character-offsets? #f boolean?) (preferences:set-default 'framework:show-status-line #t boolean?) (preferences:set-default 'framework:col-offsets #f boolean?) @@ -389,95 +477,10 @@ (preferences:set-default 'framework:fixup-parens #t boolean?) (preferences:set-default 'framework:fixup-open-parens #f boolean?) (preferences:set-default 'framework:paren-match #t boolean?) -(let ([defaults-ht (make-hasheq)]) - (for-each (λ (x) (hash-set! defaults-ht x 'for/fold)) - '(for/fold for/fold: for*/fold for*/fold: - for/lists for/lists: for*/lists for*/lists:)) - (for-each (λ (x) (hash-set! defaults-ht x 'define)) - '(struct - local - - struct: define-struct: define-typed-struct define-struct/exec: - define: pdefine: - define-type define-predicate - match-define match-define-values)) - (for-each (λ (x) (hash-set! defaults-ht x 'begin)) - '(case-lambda case-lambda: pcase-lambda: - match-lambda match-lambda* - syntax-parser - cond - delay - unit compound-unit compound-unit/sig - public private override require - inherit sequence - ;; Explicitly indent these with- constructs using begin-like style - ;; for otherwise they will be captured by the regexp of lambda-like style - with-output-to-string with-output-to-bytes - with-module-reading-parameterization)) - (for-each (λ (x) (hash-set! defaults-ht x 'lambda)) - `( - cases - instantiate super-instantiate - syntax/loc quasisyntax/loc - datum-case - match match* match-let match-let* match-letrec - - λ lambda let let* letrec recur - lambda/kw - letrec-values - with-syntax with-syntax* - with-continuation-mark - module module* module+ - match match-let match-let* match-letrec - let/cc let/ec letcc catch - let-syntax letrec-syntax fluid-let-syntax letrec-syntaxes+values - - let: letrec: let*: - let-values: letrec-values: let*-values: - let/cc: let/ec: - lambda: λ: - plambda: opt-lambda: popt-lambda: - - splicing-let splicing-letrec splicing-let-values - splicing-letrec-values splicing-let-syntax - splicing-letrec-syntax splicing-let-syntaxes - splicing-letrec-syntaxes splicing-letrec-syntaxes+values - splicing-local splicing-parameterize splicing-syntax-parameterize - - do: - - kernel-syntax-case - syntax-case syntax-case* syntax-rules syntax-id-rules - syntax-parse - let-signature fluid-let - let-struct let-macro let-values let*-values - case when unless - let-enumerate - class class* class-asi class-asi* class*/names - class100 class100* class100-asi class100-asi* class100*/names - rec - make-object mixin - define-some do opt-lambda - send* with-method - define-record - catch shared - unit/sig unit/lang - with-handlers - interface - parameterize parameterize* syntax-parameterize - call-with-input-file call-with-input-file* with-input-from-file - with-input-from-string - with-input-from-port call-with-output-file - with-output-to-file with-output-to-port - - for-all - - big-bang - - type-case)) +(let ([defaults-ht (car racket-tabify-default-table)]) (preferences:set-default 'framework:tabify - (list defaults-ht #rx"^begin" #rx"^def" #rx"^(for\\*?(/|$)|with-)" #f) + racket-tabify-default-table (list/c (hash/c symbol? (or/c 'for/fold 'define 'begin 'lambda) #:flat? #t) (or/c #f regexp?) (or/c #f regexp?) (or/c #f regexp?) (or/c #f regexp?))) @@ -646,7 +649,56 @@ (λ () (send (group:get-the-frame-group) on-close-all))) -;; reset these -- they are only for the test suite. -;; they do not need to be set across starting up and shutting down -;; the application. -;(preferences:set 'framework:file-dialogs 'std) +(application-dark-mode-handler + (λ () + ;; under windows, this handler is never called + ;; and the decorations are never in white-on-black + ;; mode (alas). + (when (equal? (preferences:get 'framework:white-on-black-mode?) + 'platform) + (define pref + (if (white-on-black-panel-scheme?) + 'framework:color-scheme-dark + 'framework:color-scheme-light)) + (define scheme-name (preferences:get pref)) + (color-prefs:change-colors-to-match-color-scheme + (or (color-prefs:lookup-color-scheme scheme-name) + (if (white-on-black-panel-scheme?) + (color-prefs:built-in-wob-color-scheme) + (color-prefs:built-in-color-scheme))))) + + (color-prefs:update-dark-light-preferences-panel-ordering + (color-prefs:white-on-black-color-scheme?)))) + +(preferences:add-callback + 'framework:color-scheme-light + (λ (sym val) + (unless (color-prefs:white-on-black-color-scheme?) + (color-prefs:change-colors-to-match-color-scheme + (or (color-prefs:lookup-color-scheme val) + (color-prefs:built-in-color-scheme)))))) + +(preferences:add-callback + 'framework:color-scheme-dark + (λ (sym val) + (when (color-prefs:white-on-black-color-scheme?) + (color-prefs:change-colors-to-match-color-scheme + (or (color-prefs:lookup-color-scheme val) + (color-prefs:built-in-wob-color-scheme)))))) + +(preferences:add-callback + 'framework:white-on-black-mode? + (λ (sym val) + (define wob? + (match val + ['platform (white-on-black-panel-scheme?)] + [#t #t] + [#f #f])) + (define pref-name (if wob? 'framework:color-scheme-dark 'framework:color-scheme-light)) + (define pref-val (preferences:get pref-name)) + (define found-color-scheme (color-prefs:lookup-color-scheme pref-val)) + (color-prefs:change-colors-to-match-color-scheme + (or found-color-scheme + (if wob? + (color-prefs:built-in-wob-color-scheme) + (color-prefs:built-in-color-scheme)))))) diff --git a/gui-lib/framework/private/number-snip.rkt b/gui-lib/framework/private/number-snip.rkt index 367e1b053..1068e8be6 100644 --- a/gui-lib/framework/private/number-snip.rkt +++ b/gui-lib/framework/private/number-snip.rkt @@ -1,22 +1,61 @@ #lang racket/unit (require "sig.rkt" + "interfaces.rkt" mred/mred-sig racket/class + racket/pretty "../preferences.rkt" string-constants - file/convertible) + file/convertible + simple-tree-text-markup/text) (import mred^) (export (rename framework:number-snip/int^ [-snip-class% snip-class%])) (init-depend mred^) - + + (define (number->string/snip number + #:exact-prefix [exact-prefix 'never] #:inexact-prefix [inexact-prefix 'never] + #:fraction-view [fraction-view #f]) + (let ([fraction-view (or fraction-view (preferences:get 'framework:fraction-snip-style))]) + (cond + [(or (inexact? number) + (integer? number) + (not (real? number))) + (number-markup->string number + #:exact-prefix exact-prefix #:inexact-prefix inexact-prefix + #:fraction-view fraction-view)] + [else + (case fraction-view + [(#f) + (make-fraction-snip number (eq? exact-prefix 'always))] + [(mixed improper) + (define snip (make-fraction-snip number (eq? exact-prefix 'always))) + (send snip set-fraction-view fraction-view) + snip] + [(decimal) + (make-repeating-decimal-snip number (or (eq? exact-prefix 'always) + (eq? exact-prefix 'when-necessary)))])]))) + + (define (make-pretty-print-size #:exact-prefix [exact-prefix 'never] #:inexact-prefix [inexact-prefix 'never] + #:fraction-view [fraction-view #f]) + (lambda (number display? port) + (let ([fraction-view (or fraction-view (preferences:get 'framework:fraction-snip-style))]) + (cond + [(or (inexact? number) + (integer? number) + (not (real? number))) + (string-length (number-markup->string number + #:exact-prefix exact-prefix #:inexact-prefix inexact-prefix + #:fraction-view fraction-view))] + [else 1])))) + ;; make-repeating-decimal-snip : number boolean -> snip (define (make-repeating-decimal-snip number e-prefix?) (new number-snip% - [number number] - [decimal-prefix (if e-prefix? "#e" "")])) + [number number] + [decimal-prefix (if e-prefix? "#e" "")])) ;; make-fraction-snip : number boolean -> snip (define (make-fraction-snip number e-prefix?) @@ -345,6 +384,17 @@ improper-nums "/" dens)])])) + + ;; -> (or/c #f string?) + ;; returns a string if this would draw the same way as an ASCII version of the number + (define/public (get-fully-computed-finite-decimal-string) + (case fraction-view + [(mixed) #f] + [(decimal) + (and (not barred-portion) + (not clickable-portion) + unbarred-portion)] + [(improper) #f])) (define/override (write f) (send f put (string->bytes/utf-8 (number->string number))) @@ -353,16 +403,17 @@ (send f put (string->bytes/utf-8 (number->string expansions)))) (define/override (copy) - (let ([snip (new number-snip% - [number number] - [decimal-prefix decimal-prefix])]) - (send snip iterate (max 0 (- expansions 1))) ;; one iteration is automatic - (send snip set-fraction-view fraction-view) - snip)) + (define snip + (new number-snip% + [number number] + [decimal-prefix decimal-prefix])) + (send snip iterate (max 0 (- expansions 1))) ;; one iteration is automatic + (send snip set-fraction-view fraction-view) + snip) (inherit get-style) - - (define/override (get-extent dc x y wb hb descent space lspace rspace) + + (define/override (get-extent dc x y [wb #f] [hb #f] [descent #f] [space #f] [lspace #f] [rspace #f]) (case fraction-view [(decimal) (get-decimal-extent dc x y wb hb descent space lspace rspace)] @@ -554,3 +605,33 @@ (set-flags (cons 'handles-events (get-flags))) (set-snipclass number-snipclass) (iterate 1))) ;; calc first digits + +(define remove-decimal-looking-number-snips-on-insertion-mixin + (mixin ((class->interface text%)) () + (inherit begin-edit-sequence end-edit-sequence + insert split-snip find-snip get-snip-position) + (define/augment (on-insert start len) + (inner (void) on-insert start len) + (begin-edit-sequence)) + (define/augment (after-insert start len) + (inner (void) after-insert start len) + (split-snip start) + (let loop ([snip (find-snip start 'after-or-none)] + [snip-pos start]) + (when snip + (when (< snip-pos (+ start len)) + (define str + (and (is-a? snip number-snip%) + (send snip get-fully-computed-finite-decimal-string))) + (cond + [str + (send snip release-from-owner) + (insert str snip-pos snip-pos) + (define next-snip-pos (+ snip-pos (string-length str))) + (split-snip next-snip-pos) + (loop (find-snip next-snip-pos 'after-or-none) + next-snip-pos)] + [else (loop (send snip next) + (get-snip-position snip))])))) + (end-edit-sequence)) + (super-new))) diff --git a/gui-lib/framework/private/preferences.rkt b/gui-lib/framework/private/preferences.rkt index 7f4df40bd..92674b902 100644 --- a/gui-lib/framework/private/preferences.rkt +++ b/gui-lib/framework/private/preferences.rkt @@ -259,7 +259,19 @@ the state transitions / contracts are: (define on-close-dialog-callbacks null) (define can-close-dialog-callbacks null) - + +;; labels->panel-visibility-thunk : hash[(listof string?) -o> (-> void?)] +;; maps the sequence of strings naming a path into the preferences +;; dialog into a function that makes the corresponding panel visible +(define labels->panel-visibility-thunk (make-hash)) + +(define (show-tab-panel panel-paths) + (show-dialog) + (define pth (hash-ref labels->panel-visibility-thunk panel-paths #f)) + (unless pth + (error 'show-tab-panel "did not find the path\n path: ~e" panel-paths)) + (pth)) + (define (make-preferences-dialog) (letrec ([stashed-prefs (preferences:get-prefs-snapshot)] [cancelled? #f] @@ -288,32 +300,39 @@ the state transitions / contracts are: [label (string-constant preferences)] [height 200])] [build-ppanel-tree - (λ (ppanel tab-panel single-panel) + (λ (ppanel tab-panel single-panel parents thunk) (send tab-panel append (ppanel-name ppanel)) (cond - [(ppanel-leaf? ppanel) + [(ppanel-leaf? ppanel) + (hash-set! labels->panel-visibility-thunk (cons (ppanel-name ppanel) parents) thunk) ((ppanel-leaf-maker ppanel) single-panel)] [(ppanel-interior? ppanel) - (let-values ([(tab-panel single-panel) (make-tab/single-panel single-panel #t)]) - (for-each - (λ (ppanel) (build-ppanel-tree ppanel tab-panel single-panel)) - (ppanel-interior-children ppanel)))]))] + (define-values (tab-panel next-single-panel) (make-tab/single-panel single-panel #t)) + (define (next-thunk) + (thunk) + (tab-panel-callback next-single-panel tab-panel)) + (for ([child-ppanel (in-list (ppanel-interior-children ppanel))] + [i (in-naturals)]) + (build-ppanel-tree child-ppanel tab-panel next-single-panel + (cons (ppanel-name ppanel) parents) + (λ () + (send tab-panel set-selection i) + (next-thunk))))]))] [make-tab/single-panel (λ (parent inset?) - (letrec ([spacer (and inset? - (instantiate vertical-panel% () - (parent parent) - (border 10)))] - [tab-panel (instantiate tab-panel% () - (choices null) - (parent (if inset? spacer parent)) - (callback (λ (_1 _2) - (tab-panel-callback - single-panel - tab-panel))))] - [single-panel (instantiate panel:single% () - (parent tab-panel))]) - (values tab-panel single-panel)))] + (define spacer (and inset? + (new vertical-panel% + [parent parent] + [border 10]))) + (define tab-panel (new tab-panel% + [choices null] + [parent (if inset? spacer parent)] + [callback (λ (_1 _2) + (tab-panel-callback + single-panel + tab-panel))])) + (define single-panel (new panel:single% [parent tab-panel])) + (values tab-panel single-panel))] [tab-panel-callback (λ (single-panel tab-panel) (send single-panel active-child @@ -321,10 +340,15 @@ the state transitions / contracts are: (send tab-panel get-selection))))] [panel (make-object vertical-panel% (send frame get-area-container))] [_ (let-values ([(tab-panel single-panel) (make-tab/single-panel panel #f)]) - (for-each - (λ (ppanel) - (build-ppanel-tree ppanel tab-panel single-panel)) - ppanels) + (for ([ppanel (in-list ppanels)] + [i (in-naturals)]) + (build-ppanel-tree ppanel tab-panel single-panel + '() + (λ () + (send tab-panel set-selection i) + (tab-panel-callback + single-panel + tab-panel)))) (let ([single-panel-children (send single-panel get-children)]) (unless (null? single-panel-children) (send single-panel active-child (car single-panel-children)) @@ -462,42 +486,55 @@ the state transitions / contracts are: (list (string-constant editor-prefs-panel-label) (string-constant editor-general-prefs-panel-label)) (λ (editor-panel) - (add-check editor-panel 'framework:delete-forward? + (define narrow-checkboxes-hp + (new horizontal-panel% [parent editor-panel] [stretchable-height #f] [alignment '(left top)])) + (define narrow-checkboxes-left + (new vertical-panel% [parent narrow-checkboxes-hp] [stretchable-height #f] [alignment '(left top)])) + (define narrow-checkboxes-right + (new vertical-panel% [parent narrow-checkboxes-hp] [stretchable-height #f] [alignment '(left top)])) + ;; start narrow ones; the left should have more than the right on all platforms + ;; macos, left: 5, right: 4 + ;; linux, left: 4, right: 3 + ;; win, left: 5, right: 3 + (add-check narrow-checkboxes-left 'framework:delete-forward? (string-constant map-delete-to-backspace) not not) - (add-check editor-panel + (add-check narrow-checkboxes-left 'framework:auto-set-wrap? (string-constant wrap-words-in-editor-buffers)) - - (add-check editor-panel - 'framework:menu-bindings - (string-constant enable-keybindings-in-menus)) + (add-check narrow-checkboxes-left + 'framework:caret-blink-disable? + (string-constant disable-caret-blinking)) (when (memq (system-type) '(macosx)) - (add-check editor-panel + (add-check narrow-checkboxes-left 'framework:alt-as-meta (string-constant alt-as-meta)) - (add-check editor-panel + (add-check narrow-checkboxes-left 'framework:special-meta-key (string-constant command-as-meta))) - (when (memq (system-type) '(windows)) - (add-check editor-panel + (add-check narrow-checkboxes-left 'framework:any-control+alt-is-altgr (string-constant any-control+alt-is-altgr))) - - (add-check editor-panel + (add-check (if (equal? (system-type) 'macosx) + narrow-checkboxes-right + narrow-checkboxes-left) 'framework:coloring-active (string-constant online-coloring-active)) - - (add-check editor-panel + (add-check narrow-checkboxes-right 'framework:anchored-search (string-constant find-anchor-based)) - (add-check editor-panel + (add-check narrow-checkboxes-right 'framework:do-paste-normalization (string-constant normalize-string-preference)) - (add-check editor-panel + (add-check narrow-checkboxes-right 'framework:overwrite-mode-keybindings (string-constant enable-overwrite-mode-keybindings)) + ;; end narrow ones + + (add-check editor-panel + 'framework:menu-bindings + (string-constant enable-keybindings-in-menus)) (add-check editor-panel 'framework:automatic-parens (string-constant enable-automatic-parens)) @@ -513,7 +550,6 @@ the state transitions / contracts are: 'framework:column-guide-width (string-constant maximum-char-width-guide-pref-check-box) (λ (n) (and (exact-integer? n) (>= n 2)))) - (when (equal? (system-type) 'unix) (add-check editor-panel 'framework:editor-x-selection-mode @@ -565,6 +601,31 @@ the state transitions / contracts are: (cadr current))))) (update-tf-bkg)) +(define (add-boolean-option-with-ask-me parent label option1 option2 pref-key) + (define rb + (new radio-box% + [label label] + [parent parent] + [choices (list option1 + option2 + (string-constant ask-me-each-time))] + [callback + (λ (rb evt) + (preferences:set pref-key + (case (send rb get-selection) + [(0) #t] + [(1) #f] + [(2) 'ask])))])) + (define (update-rb what) + (send rb set-selection + (case what + [(#t) 0] + [(#f) 1] + [(ask) 2]))) + (update-rb (preferences:get pref-key)) + (preferences:add-callback pref-key (λ (p v) (update-rb v))) + (void)) + (define (add-general-checkbox-panel) (add-general-checkbox-panel/real)) (define (add-general-checkbox-panel/real) (set! add-general-checkbox-panel/real void) @@ -574,30 +635,21 @@ the state transitions / contracts are: (make-recent-items-slider editor-panel) (add-check editor-panel 'framework:autosaving-on? - (string-constant auto-save-files)) - (add-check editor-panel 'framework:backup-files? (string-constant backup-files)) - (define auto-load-rb - (new radio-box% - [label (string-constant autoload-automatically-reload)] - [parent editor-panel] - [choices (list (string-constant autoload-when-the-editor-isnt-dirty) - (string-constant autoload-never-revert) - (string-constant autoload-ask-about-reverting))] - [callback - (λ (rb evt) - (preferences:set 'framework:autoload - (case (send rb get-selection) - [(0) #t] - [(1) #f] - [(2) 'ask])))])) - (define (update-auto-load-rb what) - (send auto-load-rb set-selection - (case what - [(#t) 0] - [(#f) 1] - [(ask) 2]))) - (update-auto-load-rb (preferences:get 'framework:autoload)) - (preferences:add-callback 'framework:autoload (λ (p v) (update-auto-load-rb v))) + (string-constant backup-unsaved-files)) + (add-check editor-panel 'framework:backup-files? (string-constant first-change-files)) + + (add-boolean-option-with-ask-me + editor-panel + (string-constant autoload-automatically-reload) + (string-constant autoload-when-the-editor-isnt-dirty) + (string-constant autoload-never-revert) + 'framework:autoload) + + (unless (equal? (system-type) 'unix) + (define (bool->pref b) (if b 'std 'common)) + (define (pref->bool p) (equal? p 'std)) + (add-check editor-panel 'framework:file-dialogs (string-constant use-platform-specific-file-dialogs) + bool->pref pref->bool)) (add-check editor-panel 'framework:show-status-line (string-constant show-status-line)) ;; does this not belong here? diff --git a/gui-lib/framework/private/racket.rkt b/gui-lib/framework/private/racket.rkt index 997269cda..ddb4fd61a 100644 --- a/gui-lib/framework/private/racket.rkt +++ b/gui-lib/framework/private/racket.rkt @@ -6,8 +6,12 @@ (require string-constants racket/class racket/string + racket/promise mred/mred-sig syntax-color/module-lexer + syntax-color/racket-lexer + syntax-color/racket-indentation + syntax-color/racket-navigation "collapsed-snipclass-helpers.rkt" "sig.rkt" "srcloc-panel.rkt" @@ -37,7 +41,7 @@ (init-depend mred^ framework:keymap^ framework:color^ framework:mode^ framework:text^ framework:editor^) -(define-local-member-name +(define-local-member-name stick-to-next-sexp? get-private-racket-container-keymap) @@ -46,7 +50,7 @@ ("[" . "]") ("{" . "}"))) -(define text-balanced? +(define text-balanced? (lambda (text [start 0] [in-end #f]) (let* ([end (or in-end (send text last-position))] [port (open-input-text-editor text start end)]) @@ -79,7 +83,7 @@ (init-field left-bracket right-bracket saved-snips) (define/public (get-saved-snips) saved-snips) (field [sizing-text (format "~a ~a" left-bracket right-bracket)]) - + (define/public (read-special file line col pos) (let ([text (make-object text:basic%)]) (for-each @@ -91,7 +95,7 @@ #f (read (open-input-text-editor text)) (list file line col pos 1)))) - + (define/override get-text (lambda (offset num [flattened? #f]) (if flattened? @@ -100,13 +104,13 @@ (send snip get-text 0 (send snip get-count) flattened?)) saved-snips)) (super get-text offset num flattened?)))) - + (define/override (copy) (instantiate sexp-snip% () (left-bracket left-bracket) (right-bracket right-bracket) (saved-snips saved-snips))) - + (define/override (write stream-out) (send stream-out put (bytes (char->integer left-bracket))) (send stream-out put (bytes (char->integer right-bracket))) @@ -120,7 +124,7 @@ (send stream-out put (string->bytes/utf-8 (send snipclass get-classname))) (send snip write stream-out)) (loop (cdr snips))]))) - + (define/override (draw dc x y left top right bottom dx dy draw-caret) (send dc draw-text sizing-text x y) (let-values ([(lpw lph lpa lpd) (send dc get-text-extent (string left-bracket))] @@ -135,7 +139,7 @@ (send dc draw-rectangle dt1x dty 2 2) (send dc draw-rectangle dt2x dty 2 2) (send dc draw-rectangle dt3x dty 2 2)))) - + (inherit get-style) (define/override (get-extent dc x y wb hb descentb spaceb lspaceb rspaceb) (let-values ([(w h d a) (send dc get-text-extent sizing-text (send (get-style) get-font))]) @@ -182,7 +186,7 @@ (when (and (is-a? text -text<%>) (not (send text is-stopped?))) (let* ([on-it-box (box #f)] - [click-pos + [click-pos (call-with-values (λ () (send text dc-location-to-editor-location @@ -212,10 +216,10 @@ (let ([left-pos (min pos other-pos)] [right-pos (max pos other-pos)]) (make-collapse-item text left-pos right-pos menu))))] - [else + [else ;; clicking on some other text -> collapse containing sexp (let ([up-sexp (send text find-up-sexp click-pos)]) - (when up-sexp + (when up-sexp (let ([fwd (send text get-forward-sexp up-sexp)]) (when fwd (make-collapse-item text up-sexp fwd menu)))))])))) @@ -266,7 +270,7 @@ null] [else (cons (send snip copy) (loop (send snip next)))]))]) (send text delete left-pos right-pos) - (send text insert (instantiate sexp-snip% () + (send text insert (instantiate sexp-snip% () (left-bracket left-bracket) (right-bracket right-bracket) (saved-snips snips)) @@ -319,7 +323,7 @@ (hash-colon-keyword ,(make-object color% 151 69 43)) (parenthesis ,(make-object color% 151 69 43)) (other ,(make-object color% "white")))]) - (map + (map (λ (line) (let ([new (assoc (car line) new-entries)]) (if new @@ -355,7 +359,7 @@ (for-each (λ (line) (let ([sym (car line)]) - (color-prefs:build-color-selection-panel + (color-prefs:build-color-selection-panel parent (short-sym->pref-name sym) (short-sym->style-name sym) @@ -371,11 +375,21 @@ tabify-on-return? tabify tabify-selection + tabify-selection/reverse-choices tabify-all insert-return - box-comment-out-selection + comment-out-selection + box-comment-out-selection + region-comment-out-selection + uncomment-box/selection uncomment-selection + uncomment-selection/region + uncomment-selection/line + uncomment-selection/box + commented-out/line? + commented-out/region? + get-forward-sexp remove-sexp forward-sexp @@ -388,7 +402,7 @@ find-down-sexp down-sexp remove-parens-forward - + select-forward-sexp select-backward-sexp select-up-sexp @@ -397,7 +411,7 @@ mark-matching-parenthesis get-tab-size set-tab-size - + introduce-let-ans move-sexp-out kill-enclosing-parens @@ -421,7 +435,7 @@ (define (get-wordbreak-map) wordbreak-map) (init-wordbreak-map wordbreak-map) -(define matching-parenthesis-style +(define matching-parenthesis-style (let ([matching-parenthesis-delta (make-object style-delta% 'change-bold)] [style-list (editor:get-standard-style-list)]) (send matching-parenthesis-delta set-delta-foreground "forest green") @@ -471,18 +485,18 @@ skip-whitespace insert-close-paren classify-position) - + (inherit get-styles-fixed) (inherit has-focus? find-snip split-snip position-location get-dc) - + (define private-racket-container-keymap (new keymap:aug-keymap%)) (define/public (get-private-racket-container-keymap) private-racket-container-keymap) - + (define/override (get-keymaps) - (editor:add-after-user-keymap private-racket-container-keymap + (editor:add-after-user-keymap private-racket-container-keymap (super get-keymaps))) - + (define/override (get-word-at current-pos) (let ([no-word ""]) (cond @@ -491,25 +505,26 @@ [else (let ([type (classify-position (max 0 (- current-pos 1)))]) (cond - [(memq type '(symbol keyword)) + [(memq type '(symbol keyword)) (get-text (look-for-non-symbol/non-kwd (max 0 (- current-pos 1))) current-pos)] [else no-word]))]))) - + (define/private (look-for-non-symbol/non-kwd start) (let loop ([i start]) (cond - [(< i 0) + [(< i 0) 0] [(memq (classify-position i) '(symbol keyword)) (loop (- i 1))] [else (+ i 1)]))) - + (define/public (get-limit pos) 0) - + (define/override (get-backward-navigation-limit pos) (get-limit pos)) + (define/public (balance-parens key-event [smart-skip #f]) - (insert-close-paren (get-start-position) + (insert-close-paren (get-start-position) (send key-event get-key-code) (preferences:get 'framework:paren-match) (preferences:get 'framework:fixup-parens) @@ -517,53 +532,56 @@ (and (preferences:get 'framework:automatic-parens) (not (in-string/comment? this)) 'adjacent)))) - + (define/public (tabify-on-return?) #t) (define/public (tabify [pos (get-start-position)]) (define amt (compute-amount-to-indent pos)) (define (do-indent amt) (define para (position-paragraph pos)) (define end (paragraph-start-position para)) - (define-values (gwidth curr-offset tab-char?) (find-offset end)) + (define-values (curr-offset tab-char?) (find-offset end)) (unless (and (not tab-char?) (= amt (- curr-offset end))) (delete end curr-offset) (insert (make-string amt #\space) end))) (when amt (do-indent amt))) - - (define/private (find-offset start-pos) - (define tab-char? #f) - (define end-pos - (let loop ([p start-pos]) - (let ([c (get-character p)]) - (cond - [(char=? c #\tab) - (set! tab-char? #t) - (loop (add1 p))] - [(char=? c #\newline) - p] - [(char-whitespace? c) - (loop (add1 p))] - [else - p])))) - (define sizing-dc (get-dc)) - (define gwidth - (cond - [sizing-dc - (define start-x (box 0)) - (define end-x (box 0)) - (position-location start-pos start-x #f #t #t) - (position-location end-pos end-x #f #t #t) - (define-values (w _1 _2 _3) - (send sizing-dc get-text-extent "x" - (send (send (get-style-list) - find-named-style "Standard") - get-font))) - (inexact->exact (floor (/ (- (unbox end-x) (unbox start-x)) w)))] - [else - ;; if there is no display available, approximate the graphical - ;; width on the assumption that we are using a fixed-width font - (- end-pos start-pos)])) - (values gwidth end-pos tab-char?)) + + (define/private (find-offset start-pos) + (define tab-char? #f) + (define end-pos + (let loop ([p start-pos]) + (let ([c (get-character p)]) + (cond + [(char=? c #\tab) + (set! tab-char? #t) + (loop (add1 p))] + [(char=? c #\newline) + p] + [(char-whitespace? c) + (loop (add1 p))] + [else + p])))) + (values end-pos tab-char?)) + + (define/private (graphical-width start-pos end-pos) + (define sizing-dc (get-dc)) + (cond + [sizing-dc + (define start-x (box 0)) + (define start-y (box 0)) + (define end-x (box 0)) + (define end-y (box 0)) + (position-location start-pos start-x start-y #f #t) + (position-location end-pos end-x end-y #t #t) + (cond + [(= (unbox start-y) (unbox end-y)) + (define-values (w _1 _2 _3) + (send sizing-dc get-text-extent "x" + (send (send (get-style-list) + find-named-style "Standard") + get-font))) + (inexact->exact (floor (/ (- (unbox end-x) (unbox start-x)) w)))] + [else #f])] + [else #f])) (define/pubment (compute-amount-to-indent pos) (inner (compute-racket-amount-to-indent pos) compute-amount-to-indent pos)) @@ -576,166 +594,10 @@ (λ (text) (or (_get-head-sexp-type text) (get-head-sexp-type-from-prefs text tabify-prefs))))) - (define last-pos (last-position)) - (define para (position-paragraph pos)) - (define is-tabbable? - (and (> para 0) - (not (memq (classify-position (- (paragraph-start-position para) 1)) - '(comment string error))))) - (define end (if is-tabbable? (paragraph-start-position para) 0)) - (define limit (get-limit pos)) - - ;; "contains" is the start of the initial sub-S-exp - ;; in the S-exp that contains "pos". If pos is outside - ;; all S-exps, this will be the start of the initial - ;; S-exp - (define contains - (if is-tabbable? - (backward-containing-sexp end limit) - #f)) - (define contain-para (and contains - (position-paragraph contains))) - - ;; last is the start of the S-exp just before "pos" - (define last - (if contains - (let ([p (get-backward-sexp end)]) - (if (and p (p . >= . limit)) - p - (backward-match end limit))) - #f)) - (define last-para (and last (position-paragraph last))) - - ;; last2 is the start of the S-exp just before the one before "pos" - (define last2 - (if last - (let ([p (get-backward-sexp last)]) - (if (and p (p . >= . limit)) - p - (backward-match last limit))) - #f)) - - (define (visual-offset pos) - (let loop ([p (sub1 pos)]) - (if (= p -1) - 0 - (let ([c (get-character p)]) - (cond - [(char=? c #\null) 0] - [(char=? c #\tab) - (let ([o (loop (sub1 p))]) - (+ o (- 8 (modulo o 8))))] - [(char=? c #\newline) 0] - [else (add1 (loop (sub1 p)))]))))) - - (define (get-proc) - (define id-end (get-forward-sexp contains)) - (and (and id-end (> id-end contains)) - (let ([text (get-text contains id-end)]) - (cond - [(member (classify-position contains) '(keyword symbol)) - (get-head-sexp-type text)] - [else - 'other])))) - (define (procedure-indent) - (case (get-proc) - [(begin define) 1] - [(lambda) 3] - [else 0])) - (define (define-or-lambda-style?) - (define proc-name (get-proc)) - (or (equal? proc-name 'define) - (equal? proc-name 'lambda))) - (define (for/fold-style?) - (define proc-name (get-proc)) - (equal? proc-name 'for/fold)) - - (define (indent-first-arg start) - (define-values (gwidth curr-offset tab-char?) (find-offset start)) - gwidth) - - (when (and is-tabbable? - (not (char=? (get-character (sub1 end)) - #\newline))) - (insert #\newline (paragraph-start-position para))) - - (define amt-to-indent - (cond - [(not is-tabbable?) - (if (= para 0) - 0 - #f)] - [(let-values ([(gwidth real-start tab-char?) (find-offset end)]) - (and (<= (+ 3 real-start) (last-position)) - (string=? ";;;" - (get-text real-start - (+ 2 real-start))))) - #f] - [(not contains) - ;; Something went wrong matching. Should we get here? - 0] - [(not last) - ;; We can't find a match backward from pos, - ;; but we seem to be inside an S-exp, so - ;; go "up" an S-exp, and move forward past - ;; the associated paren - (define enclosing (find-up-sexp pos)) - (if enclosing - (+ (visual-offset enclosing) 1) - 0)] - [(= contains last) - ;; this is the first expression in the define - (+ (visual-offset contains) - (procedure-indent))] - [(and (for/fold-style?) - last2 - (= contains last2)) - (- last (paragraph-start-position last-para))] - [(or (define-or-lambda-style?) - (for/fold-style?)) - ;; In case of "define", etc., ignore the position of last - ;; and just indent under the "define" - (add1 (visual-offset contains))] - [(= contain-para last-para) - ;; So far, the S-exp containing "pos" was all on - ;; one line (possibly not counting the opening paren), - ;; so indent to follow the first S-exp's end - ;; unless - ;; - there are just two sexps earlier and the second is an ellipsis. - ;; in that case, we just ignore the ellipsis or - ;; - the sexp we are indenting is a bunch of hypens; - ;; in that case, we match the opening paren - (define id-end (get-forward-sexp contains)) - (define name-length - (if id-end - (- id-end contains) - 0)) - (cond - [(or (first-sexp-is-keyword? contains) - (sexp-is-all-hyphens? contains)) - (visual-offset contains)] - [(second-sexp-is-ellipsis? contains) - (visual-offset contains)] - [(sexp-is-all-hyphens? pos) - (visual-offset contains)] - [(not (find-up-sexp pos)) - (visual-offset contains)] - [else - (+ (visual-offset contains) - name-length - (indent-first-arg (+ contains - name-length)))])] - [else - ;; No particular special case, so indent to match first - ;; S-expr that starts on the previous line - (let loop ([last last][last-para last-para]) - (let* ([next-to-last (backward-match last limit)] - [next-to-last-para (and next-to-last - (position-paragraph next-to-last))]) - (if (equal? last-para next-to-last-para) - (loop next-to-last next-to-last-para) - (visual-offset last))))])) - amt-to-indent])) + (racket-amount-to-indent this pos + #:head-sexp-type get-head-sexp-type + #:graphical-width + (λ (t start end) (graphical-width start end)))])) ;; returns #t if `pos` is in a symbol (or keyword) that consists entirely ;; of hyphens and has at least three hyphens; returns #f otherwise @@ -751,7 +613,7 @@ [(< i fst-end) (and (equal? #\- (get-character i)) (loop (+ i 1)))] [else #t])))))) - + ;; returns #t if `contains' is at a position on a line with an sexp, an ellipsis and nothing else. ;; otherwise, returns #f (define/private (second-sexp-is-ellipsis? contains) @@ -774,17 +636,17 @@ (let ([fst-start (get-backward-sexp fst-end)]) (and fst-start (equal? (classify-position fst-start) 'hash-colon-keyword)))))) - + (define/public (tabify-selection [start-pos (get-start-position)] [end-pos (get-end-position)]) - (unless (is-stopped?) + (unless (is-stopped?) (define first-para (position-paragraph start-pos)) (define end-para (position-paragraph end-pos)) (define tabifying-multiple-paras? (not (= first-para end-para))) (with-handlers ([exn:break? (λ (x) #t)]) (dynamic-wind - (λ () + (λ () (when (< first-para end-para) (begin-busy-cursor)) (begin-edit-sequence)) @@ -804,7 +666,7 @@ (when (and (>= (position-paragraph start-pos) end-para) (<= (skip-whitespace (get-start-position) 'backward #f) (paragraph-start-position first-para))) - (set-position + (set-position (let loop ([new-pos (get-start-position)]) (if (let ([next (get-character new-pos)]) (and (char-whitespace? next) @@ -815,7 +677,11 @@ (end-edit-sequence) (when (< first-para end-para) (end-busy-cursor))))))) - + + (define/public (tabify-selection/reverse-choices [start-pos (get-start-position)] + [end-pos (get-end-position)]) + (tabify-selection start-pos end-pos)) + (define/public (tabify-all) (tabify-selection 0 (last-position))) (define/public (insert-return) (begin-edit-sequence #t #f) @@ -840,7 +706,7 @@ (loop (add1 new-pos)) new-pos)))) (end-edit-sequence)) - + (define/public (calc-last-para last-pos) (let ([last-para (position-paragraph last-pos #t)]) (if (and (> last-pos 0) @@ -851,111 +717,284 @@ (- last-para 1) last-para))) last-para))) - - (define/public (comment-out-selection [start-pos (get-start-position)] - [end-pos (get-end-position)]) - (begin-edit-sequence) - (let ([first-pos-is-first-para-pos? - (= (paragraph-start-position (position-paragraph start-pos)) - start-pos)]) - (let* ([first-para (position-paragraph start-pos)] - [last-para (calc-last-para end-pos)]) - (let para-loop ([curr-para first-para]) - (when (<= curr-para last-para) - (let ([first-on-para (paragraph-start-position curr-para)]) - (insert #\; first-on-para) - (para-loop (add1 curr-para)))))) - (when first-pos-is-first-para-pos? - (set-position - (paragraph-start-position (position-paragraph (get-start-position))) - (get-end-position)))) - (end-edit-sequence) - #t) - + + (define/public (region-comment-out-selection [start-pos (get-start-position)] + [end-pos (get-end-position)] + #:start [start "#|"] + #:end [end "|#"] + #:continue [continue ""] + #:padding [padding " "]) + (begin-edit-sequence) + (define start-para (position-paragraph start-pos)) + (define end-para (position-paragraph end-pos)) + (insert end end-pos) + (insert padding end-pos) + (insert padding start-pos) + (insert start start-pos) + (for ([i (in-range (+ start-para 1) end-para)]) + (define para-start (paragraph-start-position i)) + (insert padding para-start) + (insert continue para-start)) + (end-edit-sequence) + #t) + + (define/public (comment-out-selection [start-pos (get-start-position)] + [end-pos (get-end-position)] + #:start [start-comment ";"] + #:padding [padding ""]) + (begin-edit-sequence) + (define first-pos-is-first-para-pos? + (= (paragraph-start-position (position-paragraph start-pos)) + start-pos)) + (define first-para (position-paragraph start-pos)) + (define last-para (calc-last-para end-pos)) + (let para-loop ([curr-para first-para]) + (when (<= curr-para last-para) + (define first-on-para (paragraph-start-position curr-para)) + (insert padding first-on-para) + (insert start-comment first-on-para) + (para-loop (add1 curr-para)))) + (when first-pos-is-first-para-pos? + (set-position + (paragraph-start-position (position-paragraph (get-start-position))) + (get-end-position))) + (end-edit-sequence) + #t) + (define/public (box-comment-out-selection [_start-pos 'start] [_end-pos 'end]) - (let ([start-pos (if (eq? _start-pos 'start) - (get-start-position) - _start-pos)] - [end-pos (if (eq? _end-pos 'end) - (get-end-position) - _end-pos)]) - (begin-edit-sequence) - (split-snip start-pos) - (split-snip end-pos) - (let* ([cb (instantiate comment-box:snip% ())] - [text (send cb get-editor)]) - (let loop ([snip (find-snip start-pos 'after-or-none)]) - (cond - [(not snip) (void)] - [((get-snip-position snip) . >= . end-pos) (void)] - [else - (send text insert (send snip copy) - (send text last-position) - (send text last-position)) - (loop (send snip next))])) - (delete start-pos end-pos) - (insert cb start-pos) - (set-position start-pos start-pos)) - (end-edit-sequence) - #t)) - + (define start-pos (if (eq? _start-pos 'start) + (get-start-position) + _start-pos)) + (define end-pos (if (eq? _end-pos 'end) + (get-end-position) + _end-pos)) + (begin-edit-sequence) + (split-snip start-pos) + (split-snip end-pos) + (define cb (new comment-box:snip%)) + (define text (send cb get-editor)) + (let loop ([snip (find-snip start-pos 'after-or-none)]) + (cond + [(not snip) (void)] + [((get-snip-position snip) . >= . end-pos) (void)] + [else + (send text insert (send snip copy) + (send text last-position) + (send text last-position)) + (loop (send snip next))])) + (delete start-pos end-pos) + (insert cb start-pos) + (set-position start-pos start-pos) + (end-edit-sequence) + #t) + ;; uncomment-box/selection : -> void ;; uncomments a comment box, if the focus is inside one. ;; otherwise, calls uncomment selection to uncomment ;; something else. (inherit get-focus-snip) - (define/public (uncomment-box/selection) + (define/public (uncomment-box/selection #:start [start ";"] #:padding [padding ""]) (begin-edit-sequence) - (let ([focus-snip (get-focus-snip)]) - (cond - [(not focus-snip) (uncomment-selection)] - [(is-a? focus-snip comment-box:snip%) - (extract-contents - (get-snip-position focus-snip) - focus-snip)] - [else (uncomment-selection)])) + (define focus-snip (get-focus-snip)) + (cond + [(not focus-snip) (uncomment-selection #:start start #:padding padding)] + [(is-a? focus-snip comment-box:snip%) + (extract-contents + (get-snip-position focus-snip) + focus-snip)] + [else (uncomment-selection #:start start #:padding padding)]) (end-edit-sequence) #t) - + (define/public (uncomment-selection [start-pos (get-start-position)] - [end-pos (get-end-position)]) - (let ([snip-before (find-snip start-pos 'before-or-none)] - [snip-after (find-snip start-pos 'after-or-none)]) - + [end-pos (get-end-position)] + #:start [start-comment ";"] + #:padding [padding ""]) + (or (uncomment-selection/box start-pos end-pos) + (uncomment-selection/line start-pos end-pos + #:start start-comment + #:padding padding)) + #t) + + (define/public (uncomment-selection/region [start-pos (get-start-position)] + [end-pos (get-end-position)] + #:start [start "#|"] + #:end [end "|#"] + #:continue [continue ""] + #:padding [padding " "]) + (define info + (looks-region-commented start-pos end-pos + #:start start + #:end end + #:continue continue + #:padding padding)) + (when info (begin-edit-sequence) + (for ([region-to-remove (in-list info)]) + (delete (car region-to-remove) (cdr region-to-remove))) + (end-edit-sequence)) + #t) + + (define/public (uncomment-selection/line [start-pos (get-start-position)] + [end-pos (get-end-position)] + #:start [start-comment ";"] + #:padding [padding ""]) + (begin-edit-sequence) + (define last-pos (last-position)) + (define first-para (position-paragraph start-pos)) + (define last-para (calc-last-para end-pos)) + (for ([curr-para (in-range first-para (+ last-para 1))]) + (define commented (looks-line-commented curr-para + #:start start-comment + #:padding padding)) + (when commented + (delete (car commented) (cdr commented)))) + (end-edit-sequence) + #t) + + (define/public (uncomment-selection/box [start-pos (get-start-position)] + [end-pos (get-end-position)]) + (define snip-before (find-snip start-pos 'before-or-none)) + (define snip-after (find-snip start-pos 'after-or-none)) + (begin-edit-sequence) + (begin0 (cond [(and (= start-pos end-pos) snip-before (is-a? snip-before comment-box:snip%)) - (extract-contents start-pos snip-before)] + (extract-contents start-pos snip-before) + #t] [(and (= start-pos end-pos) snip-after (is-a? snip-after comment-box:snip%)) - (extract-contents start-pos snip-after)] + (extract-contents start-pos snip-after) + #t] [(and (= (+ start-pos 1) end-pos) snip-after (is-a? snip-after comment-box:snip%)) - (extract-contents start-pos snip-after)] - [else - (let* ([last-pos (last-position)] - [first-para (position-paragraph start-pos)] - [last-para (calc-last-para end-pos)]) - (let para-loop ([curr-para first-para]) - (when (<= curr-para last-para) - (let ([first-on-para - (skip-whitespace (paragraph-start-position curr-para) - 'forward - #f)]) - (split-snip first-on-para) - (when (and (< first-on-para last-pos) - (char=? #\; (get-character first-on-para)) - (is-a? (find-snip first-on-para 'after-or-none) string-snip%)) - (delete first-on-para (+ first-on-para 1))) - (para-loop (add1 curr-para))))))]) - (end-edit-sequence)) - #t) - + (extract-contents start-pos snip-after) + #t] + [else #f]) + (end-edit-sequence))) + + (define/public (commented-out/line? [start-pos (get-start-position)] + [end-pos (get-end-position)] + #:start [start-comment ";"] + #:padding [padding ""]) + (define first-para (position-paragraph start-pos)) + (define last-para (calc-last-para end-pos)) + (and (for/or ([curr-para (in-range first-para (+ last-para 1))]) + (looks-line-commented curr-para + #:start start-comment + #:padding padding)) + #t)) + + (define/public (commented-out/region? [start-pos (get-start-position)] + [end-pos (get-end-position)] + #:start [start "#|"] + #:end [end "|#"] + #:continue [continue ""]) + (and (looks-region-commented start-pos end-pos + #:start start + #:end end + #:continue continue + #:padding "") + #t)) + + ;; -> (or/c (cons/c natural? natural?) #f) + ;; if #f, it doesn't look like the paragraph is commented out + ;; if a natural, it does, and the comment start at the result + (define/private (looks-line-commented curr-para + #:start start-comment + #:padding padding) + (define first-on-para + (skip-whitespace (paragraph-start-position curr-para) + 'forward + #f)) + (define last-on-para (paragraph-end-position curr-para)) + (define end-of-potential-comment + (+ first-on-para (string-length start-comment))) + (cond + [(has-the-string-at? first-on-para start-comment) + (extend-region-with-padding (cons first-on-para end-of-potential-comment) + padding)] + [else #f])) + + (define/private (looks-region-commented start-pos end-pos + #:start start + #:end end + #:continue continue + #:padding padding) + (define start-para (position-paragraph start-pos)) + (define end-para (position-paragraph end-pos)) + (define start-comment-pos + (find-string start 'forward + (paragraph-start-position start-para) + (paragraph-end-position start-para))) + (define end-comment-pos + (find-string end 'forward + (paragraph-start-position end-para) + (paragraph-end-position end-para))) + (cond + [(and start-comment-pos end-comment-pos) + (define middles + (for/list ([para (in-range (+ start-para 1) end-para)]) + (define start-pos (paragraph-start-position para)) + (define rgn + (and (has-the-string-at? start-pos continue) + (cons start-pos (+ start-pos (string-length continue))))) + (and rgn (extend-region-with-padding rgn padding)))) + (append + (list (extend-region-with-padding + (cons end-comment-pos (+ end-comment-pos (string-length end))) + padding + #:prefix? #t)) + (filter values middles) + (list (extend-region-with-padding + (cons start-comment-pos (+ start-comment-pos (string-length start))) + padding)))] + [else #f])) + + (define/private (extend-region-with-padding region padding #:prefix? [prefix? #f]) + (match-define (cons start end) region) + (cond + [prefix? + (define start-before-padding (- start (string-length padding))) + (cond + [(and (0 . <= . start-before-padding) + (has-the-string-at? start-before-padding padding)) + (cons start-before-padding end)] + [else region])] + [else + (define end-after-padding (+ end (string-length padding))) + (cond + [(has-the-string-at? end padding) + (cons start end-after-padding)] + [else region])])) + + (define/private (has-the-string-at? start str) + (define end (+ start (string-length str))) + (split-snip start) + (split-snip end) + (define all-string-snips? + (let loop ([snip (find-snip start 'after-or-none)]) + (cond + [snip + (define snip-pos (get-snip-position snip)) + (cond + [(= snip-pos end) #t] + [(< snip-pos end) + (and (is-a? snip string-snip%) + (loop (send snip next)))] + [else + (error 'racket.rkt::internal-error + "went too far, but did a split-snip first which seems strange")])] + [else #t]))) + (and all-string-snips? + (equal? (get-text start (+ start (string-length str))) + str))) + ;; extract-contents : number (is-a?/c comment-box:snip%) -> void ;; copies the contents of the comment-box-snip out of the snip ;; and into this editor as `pos'. Deletes the comment box snip @@ -977,24 +1016,24 @@ '("'" "," ",@" "`" "#'" "#," "#`" "#,@" "#&" "#;" "#hash" "#hasheq" "#ci" "#cs")) (define stick-to-patterns-union - (regexp (string-append + (regexp (string-append "^(" (string-join (map regexp-quote stick-to-patterns) "|") ")"))) (define stick-to-patterns-union-anchored - (regexp (string-append + (regexp (string-append "^(" (string-join (map regexp-quote stick-to-patterns) "|") ")$"))) - (define stick-to-max-pattern-length + (define stick-to-max-pattern-length (apply max (map string-length stick-to-patterns))) (define/public (stick-to-next-sexp? start-pos) ;; Optimization: speculatively check whether the string will ;; match the patterns; at time of writing, forward-match can be ;; really expensive. - (define snippet - (get-text start-pos - (min (last-position) + (define snippet + (get-text start-pos + (min (last-position) (+ start-pos stick-to-max-pattern-length)))) (and (regexp-match stick-to-patterns-union snippet) (let ([end-pos (forward-match start-pos (last-position))]) @@ -1002,60 +1041,30 @@ (regexp-match stick-to-patterns-union-anchored (get-text start-pos end-pos)) #t)))) - - (define/public (get-forward-sexp start-pos) - ;; loop to work properly with quote, etc. - (let loop ([one-forward (forward-match start-pos (last-position))]) - (cond - [(and one-forward (not (= 0 one-forward))) - (let ([bw (backward-match one-forward 0)]) - (cond - [(and bw - (stick-to-next-sexp? bw)) - (let ([two-forward (forward-match one-forward (last-position))]) - (if two-forward - (loop two-forward) - one-forward))] - [else - one-forward]))] - [else one-forward]))) - + + (define/public (get-forward-sexp start-pos) + (racket-forward-sexp this start-pos)) + (define/public (remove-sexp start-pos) (let ([end-pos (get-forward-sexp start-pos)]) - (if end-pos + (if end-pos (kill 0 start-pos end-pos) (bell))) #t) (define/public (forward-sexp start-pos) (let ([end-pos (get-forward-sexp start-pos)]) - (if end-pos + (if end-pos (set-position end-pos) (bell)) #t)) (define/public (flash-forward-sexp start-pos) (let ([end-pos (get-forward-sexp start-pos)]) - (if end-pos + (if end-pos (flash-on end-pos (add1 end-pos)) - (bell)) + (bell)) #t)) (define/public (get-backward-sexp start-pos) - (let* ([limit (get-limit start-pos)] - [end-pos (backward-match start-pos limit)] - [min-pos (backward-containing-sexp start-pos limit)]) - (if (and end-pos - (or (not min-pos) - (end-pos . >= . min-pos))) - ;; Can go backward, but check for preceding quote, unquote, etc. - (let loop ([end-pos end-pos]) - (let ([next-end-pos (backward-match end-pos limit)]) - (if (and next-end-pos - (or (not min-pos) - (end-pos . >= . min-pos)) - (stick-to-next-sexp? next-end-pos)) - (loop next-end-pos) - end-pos))) - ;; can't go backward at all: - #f))) + (racket-backward-sexp this start-pos)) (define/public (flash-backward-sexp start-pos) (let ([end-pos (get-backward-sexp start-pos)]) (if end-pos @@ -1069,31 +1078,7 @@ (bell)) #t)) (define/public (find-up-sexp start-pos) - (let* ([limit-pos (get-limit start-pos)] - [exp-pos - (backward-containing-sexp start-pos limit-pos)]) - - (if (and exp-pos (> exp-pos limit-pos)) - (let* ([in-start-pos (skip-whitespace exp-pos 'backward #t)] - [paren-pos - (λ (paren-pair) - (find-string - (car paren-pair) - 'backward - in-start-pos - limit-pos))]) - (let ([poss (let loop ([parens (racket-paren:get-paren-pairs)]) - (cond - [(null? parens) null] - [else - (let ([pos (paren-pos (car parens))]) - (if pos - (cons pos (loop (cdr parens))) - (loop (cdr parens))))]))]) - (if (null? poss) ;; all finds failed - #f - (- (apply max poss) 1)))) ;; subtract one to move outside the paren - #f))) + (racket-up-sexp this start-pos)) (define/public (up-sexp start-pos) (let ([exp-pos (find-up-sexp start-pos)]) (if exp-pos @@ -1101,16 +1086,7 @@ (bell)) #t)) (define/public (find-down-sexp start-pos) - (let loop ([pos start-pos]) - (let ([next-pos (get-forward-sexp pos)]) - (if (and next-pos (> next-pos pos)) - (let ([back-pos - (backward-containing-sexp (sub1 next-pos) pos)]) - (if (and back-pos - (> back-pos pos)) - back-pos - (loop next-pos))) - #f)))) + (racket-down-sexp this start-pos)) (define/public (down-sexp start-pos) (let ([pos (find-down-sexp start-pos)]) (if pos @@ -1123,7 +1099,7 @@ [paren? (or (char=? first-char #\() (char=? first-char #\[) (char=? first-char #\{))] - [closer (and paren? + [closer (and paren? (get-forward-sexp pos))]) (if (and paren? closer) (begin (begin-edit-sequence #t #f) @@ -1132,7 +1108,7 @@ (end-edit-sequence)) (bell)) #t)) - + (define/private (select-text f forward?) (define start-pos (get-start-position)) (define end-pos (get-end-position)) @@ -1144,7 +1120,7 @@ (if (= (get-extend-end-position) end-pos) (f start-pos) (f end-pos)))) - (if new-pos + (if new-pos (extend-position new-pos) (bell)) #t) @@ -1153,7 +1129,7 @@ (define/public (select-backward-sexp) (select-text (λ (x) (get-backward-sexp x)) #f)) (define/public (select-up-sexp) (select-text (λ (x) (find-up-sexp x)) #f)) (define/public (select-down-sexp) (select-text (λ (x) (find-down-sexp x)) #t)) - + (define/public (introduce-let-ans pos) (dynamic-wind (λ () (begin-edit-sequence)) @@ -1169,9 +1145,9 @@ (insert before-text pos pos) (let ([blank-line-pos (+ end-l (string-length after-text) (string-length before-text))]) (set-position blank-line-pos blank-line-pos)) - (tabify-selection + (tabify-selection pos - (+ end-l + (+ end-l (string-length before-text) (string-length after-text) (string-length after-text2)))] @@ -1179,7 +1155,7 @@ (bell)]))) (λ () (end-edit-sequence)))) - + (define/public (move-sexp-out begin-inner) (begin-edit-sequence #t #f) (let ([end-inner (get-forward-sexp begin-inner)] @@ -1195,7 +1171,7 @@ [else (bell)]))] [else (bell)])) (end-edit-sequence)) - + (define/public (kill-enclosing-parens begin-inner) (begin-edit-sequence #t #f) (define begin-outer (find-up-sexp begin-inner)) @@ -1210,7 +1186,7 @@ [else (bell)])] [else (bell)]) (end-edit-sequence)) - + ;; change the parens following the cursor from () to [] or vice versa (define/public (toggle-round-square-parens start-pos) (begin-edit-sequence #t #f) @@ -1227,17 +1203,17 @@ [(_ _) (bell)])] [else (bell)])) (end-edit-sequence)) - - ;; replace-char-at-posn: natural-number string -> + + ;; replace-char-at-posn: natural-number string -> ;; replace the char at the given posn with the given string. ;; - ;; this abstraction exists because the duplicated code in toggle-round-square-parens was + ;; this abstraction exists because the duplicated code in toggle-round-square-parens was ;; just a little too much for comfort (define (replace-char-at-posn posn str) ;; insertions are performed before deletions in order to preserve the location of the cursor (insert str (+ posn 1) (+ posn 1)) (delete posn (+ posn 1))) - + (inherit get-fixed-style) (define/public (mark-matching-parenthesis pos) (let ([open-parens (map car (racket-paren:get-paren-pairs))] @@ -1257,7 +1233,7 @@ [else (change-style matching-parenthesis-style pos (+ pos 1)) (change-style matching-parenthesis-style (- end 1) end)]))))))) - + ;; get-snips/rev: start end -> (listof snip) ;; Returns a list of the snips in reverse order between ;; start and end. @@ -1274,7 +1250,7 @@ [else (loop (cons (send a-snip copy) snips/rev) (send a-snip next))]))) - + (define/public (transpose-sexp pos) (let ([start-1 (get-backward-sexp pos)]) (if (not start-1) @@ -1301,20 +1277,20 @@ (define tab-size 8) (define/public (get-tab-size) tab-size) (define/public (set-tab-size s) (set! tab-size s)) - + (define/override (get-start-of-line pos) (define para (position-paragraph pos)) (define para-start (paragraph-start-position para)) (define para-end (paragraph-end-position para)) - (define first-non-whitespace + (define first-non-whitespace (let loop ([i para-start]) (cond [(= i para-end) #f] [(char-whitespace? (get-character i)) (loop (+ i 1))] [else i]))) - (define new-pos - (cond + (define new-pos + (cond [(not first-non-whitespace) para-start] [(= pos para-start) first-non-whitespace] [(<= pos first-non-whitespace) para-start] @@ -1327,25 +1303,30 @@ (interface () )) -(define module-lexer/waived (waive-option module-lexer)) +(define module-lexer/waived (waive-option module-lexer*)) (define text-mode-mixin (mixin (color:text-mode<%> mode:surrogate-text<%>) (-text-mode<%>) - + (define saved-wordbreak-map #f) - + + (init [include-paren-keymap? #t]) + (define keymap-to-add (if include-paren-keymap? keymap non-paren-keymap)) + (define/override (on-disable-surrogate text) - (keymap:remove-chained-keymap text keymap) + (keymap:remove-chained-keymap text keymap-to-add) (send text set-wordbreak-map saved-wordbreak-map) (super on-disable-surrogate text)) - + (define/override (on-enable-surrogate text) (send text begin-edit-sequence) (super on-enable-surrogate text) - (send (send text get-private-racket-container-keymap) chain-to-keymap keymap #f) - + (send (send text get-private-racket-container-keymap) chain-to-keymap + keymap-to-add + #f) + (set! saved-wordbreak-map (send text get-wordbreak-map)) - + (send text set-load-overwrites-styles #f) (send text set-wordbreak-map wordbreak-map) (let ([bw (box 0)] @@ -1357,14 +1338,14 @@ (send text set-tabs null (send text get-tab-size) #f))) (send text set-styles-fixed #t) (send text end-edit-sequence)) - + (define tabify-pref (preferences:get 'framework:tabify)) (define tabify-pref-callback (lambda (k v) (set! tabify-pref v))) (preferences:add-callback 'framework:tabify tabify-pref-callback #t) - + (define/override (put-file text sup directory default-name) ;; don't call the surrogate's super, since it sets the default extension (cond @@ -1378,32 +1359,36 @@ (super-new (get-token (wrap-get-token module-lexer/waived (λ () tabify-pref))) (token-sym->style short-sym->style-name) - (matches '((|(| |)|) - (|[| |]|) - (|{| |}|)))))) + (matches default-paren-matches)))) + +(define default-paren-matches + '((|(| |)|) + (|[| |]|) + (|{| |}|))) (define (wrap-get-token get-token- get-tabify-pref) + (define (set-type-sym type sym) (if (hash? type) (hash-set type 'type sym) sym)) + (define (type-val type key) (and (hash? type) (hash-ref type key #f))) (define wrapped-get-token (cond [(procedure-arity-includes? get-token- 3) (λ (in offset mode) (define-values (lexeme type paren start end backup-delta new-mode) - (get-token- in offset mode)) + (parameterize ([current-lexeme->semantic-type-guess (make-lexeme->semantic-type-guess get-tabify-pref)]) + (get-token- in offset mode))) (cond - [(and (eq? type 'symbol) - (string? lexeme) - (get-head-sexp-type-from-prefs lexeme (get-tabify-pref))) - (values lexeme 'keyword paren start end backup-delta new-mode)] + [(memq (type-val type 'semantic-type-guess) '(keyword builtin)) + (values lexeme (set-type-sym type 'keyword) paren start end backup-delta new-mode)] [else (values lexeme type paren start end backup-delta new-mode)]))] [else (λ (in) - (define-values (lexeme type paren start end) (get-token- in)) + (define-values (lexeme type paren start end) + (parameterize ([current-lexeme->semantic-type-guess (make-lexeme->semantic-type-guess get-tabify-pref)]) + (get-token- in))) (cond - [(and (eq? type 'symbol) - (string? lexeme) - (get-head-sexp-type-from-prefs lexeme (get-tabify-pref))) - (values lexeme 'keyword paren start end)] + [(memq (type-val type 'semantic-type-guess) '(keyword builtin)) + (values lexeme (set-type-sym type 'keyword) paren start end)] [else (values lexeme type paren start end)]))])) (procedure-rename wrapped-get-token @@ -1413,23 +1398,12 @@ ;; get-head-sexp-type-from-prefs : string (list ht regexp regexp regexp) ;; -> (or/c #f 'lambda 'define 'begin 'for/fold) (define (get-head-sexp-type-from-prefs text pref) - (define ht (car pref)) - (define beg-reg (list-ref pref 1)) - (define def-reg (list-ref pref 2)) - (define lam-reg (list-ref pref 3)) - (define for/fold-reg (list-ref pref 4)) - (hash-ref - ht - (with-handlers ((exn:fail:read? (λ (x) #f))) - (read (open-input-string text))) - (λ () - (cond - [(and beg-reg (regexp-match? beg-reg text)) 'begin] - [(and def-reg (regexp-match? def-reg text)) 'define] - [(and lam-reg (regexp-match? lam-reg text)) 'lambda] - [(and for/fold-reg (regexp-match? for/fold-reg text)) 'for/fold] - [else #f])))) + ((racket-tabify-table->head-sexp-type pref) text)) +(define (make-lexeme->semantic-type-guess get-tabify-pref) + (let ([lexeme->head-sexp-type/promise (delay (racket-tabify-table->head-sexp-type (get-tabify-pref)))]) + (lambda (lexeme) + (and ((force lexeme->head-sexp-type/promise) lexeme) 'keyword)))) ;; in-position? : text (list symbol) -> boolean ;; determines if the cursor is currently sitting in a particular @@ -1468,7 +1442,7 @@ (and (member the-class sym-list) #t)) ;; determines if the cursor is currently sitting in a string -;; literal or a comment. +;; literal or a comment. (define (in-string/comment? text) (in-position? text '(comment string))) @@ -1496,21 +1470,232 @@ (define text-mode% (text-mode-mixin color:text-mode%)) -(define (setup-keymap keymap #:alt-as-meta-keymap [alt-as-meta-keymap #f]) +;; Inserts the open parens character and, if the resulting token +;; type satisfies checkp, then go ahead and insert the close parens +;; and set the cursor between them. +;; When space-between?, adds a space between the braces and places +;; the cursor after the space. +;; checkp: (or/c #f symbol (symbol -> boolean)) +;; When checkp is #f, always inserts both open and close braces +;; When checkp is a symbol, only inserts the closing brace if +;; the tokenizer identifies open-brace as that type of token +;; having inserted it +;; When checkp is a predicate, only inserts the closing brace if +;; the token type of the inserted open-brace satisfies if +(define (insert-brace-pair text open-brace close-brace [checkp #f] [space-between? #f]) + (define selection-start (send text get-start-position)) + (define selection-end (send text get-end-position)) + (define open-len (if (string? open-brace) (string-length open-brace) 1)) + (send text begin-edit-sequence #t #f) + (send text insert open-brace selection-start) + (define tok-type (if (send text is-stopped?) + #f + (send text classify-position selection-start))) + (when (or (not checkp) + (and (symbol? checkp) (equal? checkp tok-type)) + (and (procedure? checkp) (checkp tok-type))) + (define hash-before? ; tweak to detect and correctly close block comments #| ... |# + ; Notice: This is racket-specific and despite the name of the file we should instead rely + ; on the lexer alone so as to be language-agnostic. + ; Currently though the lexer does not provide enough information about the comment type. + (and (< 0 selection-start) + (string=? "#" (send text get-text (- selection-start 1) selection-start)))) + (send text set-position (+ selection-end open-len)) + (when space-between? (send text insert " ")) + (send text insert close-brace) + (when (and (char? open-brace) (char=? #\| open-brace) hash-before?) + (send text insert #\#)) + (send text set-position (+ selection-start open-len (if space-between? 1 0)))) + (send text end-edit-sequence)) + +;; only insert a pair if automatic-parens preference is on, depending +;; on other analyses of the state of the text (e.g. auto-parens shouldn't +;; affect typing literal characters inside a string constant, etc.) +(define (maybe-insert-brace-pair text open-brace close-brace) + (define open-parens + (for/list ([x (racket-paren:get-paren-pairs)]) (string-ref (car x) 0))) + (cond + [(not (preferences:get 'framework:automatic-parens)) + (define startpos (send text get-start-position)) + (if (and (send text get-overwrite-mode) + (= startpos (send text get-end-position))) + (send text insert open-brace startpos (add1 startpos)) + (send text insert open-brace))] + ; from here automatic-parens is enabled + [(send text is-stopped?) + ;; when the colorer is stopped we just blindly insert both + (insert-brace-pair text open-brace close-brace)] + [else + (define c (immediately-following-cursor text)) + (define cur-token + (send text classify-position (send text get-start-position))) + (cond + ; insert paren pair if it results valid parenthesis token... + [(member open-brace open-parens) + (insert-brace-pair text open-brace close-brace 'parenthesis)] + + ; ASSUME: from here on, open-brace is either " or | + [else + ;(printf "tok ~a~n" cur-token) + (match cur-token + [(or 'error #f) (insert-brace-pair text open-brace close-brace 'error)] + ['constant (insert-brace-pair text open-brace close-brace + (λ (t) (not (equal? t 'constant))))] + [(or 'symbol 'comment) + (cond + [(and c (char=? #\| open-brace) (string=? c "|")) ;; smart skip + (send text set-position (+ 1 (send text get-end-position))) + (define d (immediately-following-cursor text)) + (when (and d (string=? d "#")) ; a block comment? + (send text set-position (+ 1 (send text get-end-position))))] + [(in-position? text '(comment)) (send text insert open-brace)] + [else (insert-brace-pair text open-brace close-brace)])] + ['string + (cond + [(not (char=? #\" open-brace)) + (insert-brace-pair text open-brace close-brace + (λ (t) (not (or (equal? 'comment t) (equal? 'string t)))))] + [else + (define start-position (send text get-start-position)) + (define end-position (send text get-end-position)) + (cond + ; smart skip a " if it is the immediately following character (c) + [(and c (string=? c "\"")) + (send text set-position (+ 1 end-position))] + + ; there is no current selection - split the string in two + [(= start-position end-position) + (insert-brace-pair text #\" #\" #f #t)] + + ; there is a selection - split the selected text off as a + ; separate string from the surrounding in an intelligent way + ; and retain selection of the split-out string + [else (define selection-length (- end-position start-position)) + (insert-brace-pair text "\" \"" "\" \"") + (define cur-position (send text get-start-position)) + (send text set-position + (- cur-position 1) + (+ cur-position selection-length 1))])])] + [_ (insert-brace-pair text open-brace close-brace + (λ (t) (not (equal? 'comment t))))])])])) + + + +(define (|maybe-insert-[]-pair-maybe-fixup-[]| text) + (cond + [(or (not (preferences:get 'framework:fixup-open-parens)) + (send text is-stopped?)) + (maybe-insert-brace-pair text #\[ #\])] + [else + (insert-paren text)])) + + +(define (add-pairs-keybinding-functions keymap) + (define (add-function name f) (send keymap add-function name f)) + (define (add-edit-function name f) + (add-function name (λ (text event) (f text)))) + (add-function "balance-parens" (λ (edit event) (send edit balance-parens event))) + (add-function "balance-parens-forward" (λ (edit event) (send edit balance-parens event 'forward))) + + (add-edit-function "insert-()-pair" (λ (text) (insert-brace-pair text #\( #\)))) + (add-edit-function "insert-[]-pair" (λ (text) (insert-brace-pair text #\[ #\]))) + (add-edit-function "insert-{}-pair" (λ (text) (insert-brace-pair text #\{ #\}))) + (add-edit-function "insert-\"\"-pair" (λ (text) (insert-brace-pair text #\" #\"))) + (add-edit-function "insert-||-pair" (λ (text) (insert-brace-pair text #\| #\|))) + + (add-edit-function "maybe-insert-()-pair" (λ (text) (maybe-insert-brace-pair text #\( #\)))) + (add-edit-function "maybe-insert-[]-pair" (λ (text) (maybe-insert-brace-pair text #\[ #\]))) + (add-edit-function "maybe-insert-{}-pair" (λ (text) (maybe-insert-brace-pair text #\{ #\}))) + (add-edit-function "maybe-insert-\"\"-pair" (λ (text) (maybe-insert-brace-pair text #\" #\"))) + (add-edit-function "maybe-insert-||-pair" (λ (text) (maybe-insert-brace-pair text #\| #\|))) + + (add-edit-function "maybe-insert-[]-pair-maybe-fixup-[]" |maybe-insert-[]-pair-maybe-fixup-[]|) + + (define (add-non-clever-fn name char closer) + (send keymap add-function + name + (non-clever-fn char closer))) + (add-function "non-clever-close-paren"non-clever-close-paren) + (add-non-clever-fn "non-clever-close-square-bracket" #\] #f) + (add-non-clever-fn "non-clever-close-]" #\] #f) + (add-non-clever-fn "non-clever-close-curley-bracket" #\} #f) + (add-non-clever-fn "non-clever-close-}" #\} #f) + (add-non-clever-fn "non-clever-close-round-paren" #\) #f) + (add-non-clever-fn "non-clever-close-)" #\) #f) + (add-non-clever-fn "non-clever-open-square-bracket" #\[ #\])) + +(define (non-clever-close-paren e evt) + (define char (send evt get-key-code)) + (when (char? char) + (send e begin-edit-sequence) + (define start (send e get-start-position)) + (define stop (send e get-end-position)) + (send e insert char start stop) + (send e end-edit-sequence))) + +(define (non-clever-fn char closer) + (λ (text evt) + (send text begin-edit-sequence) + (define start (send text get-start-position)) + (define stop (send text get-end-position)) + (cond + [(and closer (preferences:get 'framework:automatic-parens)) + (send text insert closer stop stop) + (send text insert char start start) + (send text set-position (+ start 1))] + [else + (send text insert char start stop)]) + (send text end-edit-sequence))) + +(define (map-pairs-keybinding-functions keymap opener closer + #:alt-as-meta-keymap [alt-as-meta-keymap #f]) + + (define (map-meta key func proc) + (map-it! func proc) + (keymap:send-map-function-meta keymap key func #:alt-as-meta-keymap alt-as-meta-keymap)) + (define (map-key key func proc) + (map-it! func proc) + (send keymap map-function key func)) + (define (map-it! func proc) + (unless (send keymap is-function-added? func) + (send keymap add-function func proc)) + (when alt-as-meta-keymap + (unless (send alt-as-meta-keymap is-function-added? func) + (send alt-as-meta-keymap add-function func proc)))) + + (cond + [(equal? opener #\[) + (map-key "[" "maybe-insert-[]-pair-maybe-fixup-[]" (λ (txt evt) (|maybe-insert-[]-pair-maybe-fixup-[]| txt))) + (map-key "~g:c:[" "non-clever-open-square-bracket" (non-clever-fn #\[ #\]))] + [else + (map-key (string opener) (format "maybe-insert-~a~a-pair" opener closer) + (λ (text event) + (maybe-insert-brace-pair text opener closer)))]) + (map-meta (string opener) (format "insert-~a~a-pair" opener closer) + (λ (text evt) + (insert-brace-pair text opener closer))) + (unless (equal? opener closer) + (map-key (string closer) "balance-parens" (λ (edit event) (send edit balance-parens event))) + (map-meta (string closer) "balance-parens-forward" (λ (edit event) (send edit balance-parens event 'forward))) + (map-key (string-append "~g:c:" (string closer)) "non-clever-close-paren" non-clever-close-paren))) + + +(define (setup-keymap keymap + #:alt-as-meta-keymap [alt-as-meta-keymap #f] + #:paren-keymap [paren-keymap #f] + #:paren-alt-as-meta-keymap [paren-alt-as-meta-keymap #f]) (define (add-function name f) (send keymap add-function name f) (when alt-as-meta-keymap (send alt-as-meta-keymap add-function name f))) - (define (add-edit-function name f) - (send keymap add-function name (λ (edit event) (f edit))) - (when alt-as-meta-keymap - (send alt-as-meta-keymap add-function name (λ (edit event) (f edit))))) + (define (add-edit-function name f) (add-function name (λ (edit event) (f edit)))) (define (add-pos-function name f) - (define callback (λ (edit event) - (f edit (send edit get-start-position)))) - (send keymap add-function name callback) - (when alt-as-meta-keymap - (send alt-as-meta-keymap add-function name callback))) + (add-function name (λ (edit event) (f edit (send edit get-start-position))))) + + (add-pairs-keybinding-functions keymap) + (when alt-as-meta-keymap (add-pairs-keybinding-functions paren-alt-as-meta-keymap)) + (when paren-keymap (add-pairs-keybinding-functions paren-keymap)) + (add-pos-function "remove-sexp" (λ (e p) (send e remove-sexp p))) (add-pos-function "forward-sexp" (λ (e p) (send e forward-sexp p))) (add-pos-function "backward-sexp" (λ (e p) (send e backward-sexp p))) @@ -1530,30 +1715,32 @@ (lambda (e p) (send e kill-enclosing-parens p))) (add-pos-function "toggle-round-square-parens" (lambda (e p) (send e toggle-round-square-parens p))) - - (add-edit-function "select-forward-sexp" + + (add-edit-function "select-forward-sexp" (λ (x) (send x select-forward-sexp))) - (add-edit-function "select-backward-sexp" + (add-edit-function "select-backward-sexp" (λ (x) (send x select-backward-sexp))) - (add-edit-function "select-down-sexp" + (add-edit-function "select-down-sexp" (λ (x) (send x select-down-sexp))) - (add-edit-function "select-up-sexp" + (add-edit-function "select-up-sexp" (λ (x) (send x select-up-sexp))) - (add-edit-function "tabify-at-caret" + (add-edit-function "tabify-at-caret" (λ (x) (send x tabify-selection))) - (add-edit-function "do-return" + (add-edit-function "tabify-at-caret/reverse-choices" + (λ (x) (send x tabify-selection/reverse-choices))) + (add-edit-function "do-return" (λ (x) (send x insert-return))) - (add-edit-function "comment-out" + (add-edit-function "comment-out" (λ (x) (send x comment-out-selection))) - (add-edit-function "box-comment-out" + (add-edit-function "box-comment-out" (λ (x) (send x box-comment-out-selection))) - (add-edit-function "uncomment" + (add-edit-function "uncomment" (λ (x) (send x uncomment-selection))) - + (add-function "paren-double-select" (λ (text event) (keymap:region-click - text event + text event (λ (click-pos eol?) (define (word-based) (define start-box (box click-pos)) @@ -1576,12 +1763,12 @@ (ormap (λ (pr) (equal? (cdr pr) (string (send text get-character click-pos)))) (racket-paren:get-paren-pairs))) (define start (send text get-backward-sexp (+ click-pos 1))) - (if start + (if start (values start (+ click-pos 1)) (word-based))] [else (let ([end (send text get-forward-sexp click-pos)]) - (if end + (if end (let ([beginning (send text get-backward-sexp end)]) (if beginning (values beginning end) @@ -1589,198 +1776,6 @@ (word-based)))])) (send text set-position start end))))) - (let ([add/map-non-clever - (λ (name keystroke char [closer #f]) - (add-edit-function - name - (λ (e) - (send e begin-edit-sequence) - (define start (send e get-start-position)) - (define stop (send e get-end-position)) - (send e insert char start stop) - (when (and closer (preferences:get 'framework:automatic-parens)) - (send e insert closer (+ start 1) (+ start 1))) - (send e end-edit-sequence))) - (send keymap map-function keystroke name))]) - (add/map-non-clever "non-clever-open-square-bracket" "~g:c:[" #\[ #\]) - (add/map-non-clever "non-clever-close-square-bracket" "~g:c:]" #\]) - (add/map-non-clever "non-clever-close-curley-bracket" "~g:c:}" #\}) - (add/map-non-clever "non-clever-close-round-paren" "~g:c:)" #\))) - - (add-function "balance-parens" - (λ (edit event) - (send edit balance-parens event))) - (add-function "balance-parens-forward" - (λ (edit event) - (send edit balance-parens event 'forward))) - - (send keymap map-function "TAB" "tabify-at-caret") - - (send keymap map-function "return" "do-return") - (send keymap map-function "s:return" "do-return") - (send keymap map-function "s:c:return" "do-return") - (send keymap map-function "a:return" "do-return") - (send keymap map-function "s:a:return" "do-return") - (send keymap map-function "c:a:return" "do-return") - (send keymap map-function "c:s:a:return" "do-return") - (send keymap map-function "c:return" "do-return") - (send keymap map-function "d:return" "do-return") - - (send keymap map-function ")" "balance-parens") - (send keymap map-function "]" "balance-parens") - (send keymap map-function "}" "balance-parens") - - (send keymap map-function "leftbuttondouble" "paren-double-select") - - - ;(define (insert-brace-pair text open-brace close-brace [space-between? #f]) - ; (insert/check/balance text open-brace close-brace #f space-between?)) - #| - (define selection-start (send text get-start-position)) - (define hash-before? ; tweak to detect and correctly close block comments #| ... |# - (and (< 0 selection-start) - (string=? "#" (send text get-text (- selection-start 1) selection-start)))) - (send text begin-edit-sequence) - (send text set-position (send text get-end-position)) - (when space-between? (send text insert " ")) - (send text insert close-brace) - (when (and (char? open-brace) (char=? #\| open-brace) hash-before?) - (send text insert #\#)) - (send text set-position selection-start) - (send text insert open-brace) - (when space-between? - (send text set-position (+ (send text get-start-position) 1))) - (send text end-edit-sequence))|# - - ;; Inserts the open parens character and, if the resulting token - ;; type satisfies checkp, then go ahead and insert the close parens - ;; and set the cursor between them. - ;; When space-between?, adds a space between the braces and places - ;; the cursor after the space. - ;; checkp: (or/c #f symbol (symbol -> boolean)) - ;; When checkp is #f, always inserts both open and close braces - ;; When checkp is a symbol, only inserts the closing brace if - ;; the tokenizer identifies open-brace as that type of token - ;; having inserted it - ;; When checkp is a predicate, only inserts the closing brace if - ;; the token type of the inserted open-brace satisfies it - (define (insert-brace-pair text open-brace close-brace [checkp #f] [space-between? #f]) - (define selection-start (send text get-start-position)) - (define selection-end (send text get-end-position)) - (define open-len (if (string? open-brace) (string-length open-brace) 1)) - (send text begin-edit-sequence #t #f) - (send text insert open-brace selection-start) - (define tok-type (send text classify-position selection-start)) - (when (or (not checkp) - (and (symbol? checkp) (eq? checkp tok-type)) - (and (procedure? checkp) (checkp tok-type))) - (define hash-before? ; tweak to detect and correctly close block comments #| ... |# - ; Notice: This is racket-specific and despite the name of the file we should instead rely - ; on the lexer alone so as to be language-agnostic. - ; Currently though the lexer does not provide enough information about the comment type. - (and (< 0 selection-start) - (string=? "#" (send text get-text (- selection-start 1) selection-start)))) - (send text set-position (+ selection-end open-len)) - (when space-between? (send text insert " ")) - (send text insert close-brace) - (when (and (char? open-brace) (char=? #\| open-brace) hash-before?) - (send text insert #\#)) - (send text set-position (+ selection-start open-len (if space-between? 1 0)))) - (send text end-edit-sequence)) - - - ;; only insert a pair if automatic-parens preference is on, depending - ;; on other analyses of the state of the text (e.g. auto-parens shouldn't - ;; affect typing literal characters inside a string constant, etc.) - (define (maybe-insert-brace-pair text open-brace close-brace) - (define open-parens - (for/list ([x (racket-paren:get-paren-pairs)]) (string-ref (car x) 0))) - (cond - [(not (preferences:get 'framework:automatic-parens)) - (define startpos (send text get-start-position)) - (if (and (send text get-overwrite-mode) - (= startpos (send text get-end-position))) - (send text insert open-brace startpos (add1 startpos)) - (send text insert open-brace))] - - [else ; automatic-parens is enabled - (define c (immediately-following-cursor text)) - (define cur-token - (send text classify-position (send text get-start-position))) - (cond - ; insert paren pair if it results valid parenthesis token... - [(member open-brace open-parens) - (insert-brace-pair text open-brace close-brace 'parenthesis)] - - ; ASSUME: from here on, open-brace is either " or | - [else - ;(printf "tok ~a~n" cur-token) - (match cur-token - [(or 'error #f) (insert-brace-pair text open-brace close-brace 'error)] - ['constant (insert-brace-pair text open-brace close-brace - (λ (t) (not (equal? t 'constant))))] - [(or 'symbol 'comment) - (cond - [(and c (char=? #\| open-brace) (string=? c "|")) ;; smart skip - (send text set-position (+ 1 (send text get-end-position))) - (define d (immediately-following-cursor text)) - (when (and d (string=? d "#")) ; a block comment? - (send text set-position (+ 1 (send text get-end-position))))] - [(in-position? text '(comment)) (send text insert open-brace)] - [else (insert-brace-pair text open-brace close-brace)])] - ['string - (cond - [(not (char=? #\" open-brace)) - (insert-brace-pair text open-brace close-brace - (λ (t) (not (or (equal? 'comment t) (equal? 'string t)))))] - [else - (define start-position (send text get-start-position)) - (define end-position (send text get-end-position)) - (cond - ; smart skip a " if it is the immediately following character (c) - [(and c (string=? c "\"")) - (send text set-position (+ 1 end-position))] - - ; there is no current selection - split the string in two - [(= start-position end-position) - (insert-brace-pair text #\" #\" #f #t)] - - ; there is a selection - split the selected text off as a - ; separate string from the surrounding in an intelligent way - ; and retain selection of the split-out string - [else (define selection-length (- end-position start-position)) - (insert-brace-pair text "\" \"" "\" \"") - (define cur-position (send text get-start-position)) - (send text set-position - (- cur-position 1) - (+ cur-position selection-length 1))])])] - [_ (insert-brace-pair text open-brace close-brace - (λ (t) (not (equal? 'comment t))))])])])) - - - - - (add-edit-function "insert-()-pair" (λ (text) (insert-brace-pair text #\( #\)))) - (add-edit-function "insert-[]-pair" (λ (text) (insert-brace-pair text #\[ #\]))) - (add-edit-function "insert-{}-pair" (λ (text) (insert-brace-pair text #\{ #\}))) - (add-edit-function "insert-\"\"-pair" (λ (text) (insert-brace-pair text #\" #\"))) - (add-edit-function "insert-||-pair" (λ (text) (insert-brace-pair text #\| #\|))) - - (add-edit-function "maybe-insert-()-pair" (λ (text) (maybe-insert-brace-pair text #\( #\)))) - (add-edit-function "maybe-insert-[]-pair" (λ (text) (maybe-insert-brace-pair text #\[ #\]))) - (add-edit-function "maybe-insert-{}-pair" (λ (text) (maybe-insert-brace-pair text #\{ #\}))) - (add-edit-function "maybe-insert-\"\"-pair" (λ (text) (maybe-insert-brace-pair text #\" #\"))) - (add-edit-function "maybe-insert-||-pair" (λ (text) (maybe-insert-brace-pair text #\| #\|))) - - (add-edit-function "maybe-insert-[]-pair-maybe-fixup-[]" - (λ (text) - (cond - [(or (not (preferences:get 'framework:fixup-open-parens)) - (send text is-stopped?)) - (maybe-insert-brace-pair text #\[ #\])] - [else - (insert-paren text)]))) - ;; Deletes empty brace pairs (including " and |) depending on context, in a manner intended ;; to be usually the inverse of auto-parens. ;; Dependent on Racket's parens being single characters. @@ -1837,39 +1832,56 @@ (send edit set-position selection-start) (send edit insert "(λ (")) (send edit end-edit-sequence)) - + (add-edit-function "insert-lambda-template" insert-lambda-template) - - (define (map-meta key func) (keymap:send-map-function-meta keymap key func #:alt-as-meta-keymap alt-as-meta-keymap)) - (define (map key func) (send keymap map-function key func)) - + + (define (map-meta key func) + (keymap:send-map-function-meta keymap key func #:alt-as-meta-keymap alt-as-meta-keymap)) + (define (map key func) + (send keymap map-function key func)) + + (map "TAB" "tabify-at-caret") + (map "s:TAB" "tabify-at-caret/reverse-choices") + + (map "return" "do-return") + (map "s:return" "do-return") + (map "s:c:return" "do-return") + (map "a:return" "do-return") + (map "s:a:return" "do-return") + (map "c:a:return" "do-return") + (map "c:s:a:return" "do-return") + (map "c:return" "do-return") + (map "d:return" "do-return") + + (map "leftbuttondouble" "paren-double-select") + (map-meta "up" "up-sexp") (map-meta "c:u" "up-sexp") (map "a:up" "up-sexp") (map-meta "s:up" "select-up-sexp") (map "a:s:up" "select-up-sexp") (map-meta "s:c:u" "select-up-sexp") - + (map-meta "down" "down-sexp") (map "a:down" "down-sexp") (map-meta "s:down" "select-down-sexp") (map "a:s:down" "select-down-sexp") (map-meta "s:c:down" "select-down-sexp") - + (map-meta "right" "forward-sexp") (map "a:right" "forward-sexp") (map "m:right" "forward-sexp") (map-meta "s:right" "select-forward-sexp") (map "a:s:right" "select-forward-sexp") (map "m:s:right" "select-forward-sexp") - + (map-meta "left" "backward-sexp") (map "a:left" "backward-sexp") (map "m:left" "backward-sexp") (map-meta "s:left" "select-backward-sexp") (map "a:s:left" "select-backward-sexp") (map "m:s:left" "select-backward-sexp") - + (map-meta "return" "do-return") (map-meta "s:return" "do-return") (map-meta "s:c:return" "do-return") @@ -1878,61 +1890,69 @@ (map-meta "c:a:return" "do-return") (map-meta "c:s:a:return" "do-return") (map-meta "c:return" "do-return") - + (map-meta "c:semicolon" "comment-out") (map-meta "c:=" "uncomment") (map-meta "c:k" "remove-sexp") - + (map-meta "c:f" "forward-sexp") (map-meta "s:c:f" "select-forward-sexp") - + (map-meta "c:b" "backward-sexp") (map-meta "s:c:b" "select-backward-sexp") - + (map-meta "c:p" "flash-backward-sexp") (map-meta "s:c:n" "flash-forward-sexp") - + (map-meta "c:space" "select-forward-sexp") (map-meta "c:t" "transpose-sexp") - + ;(map-meta "c:m" "mark-matching-parenthesis") ; this keybinding doesn't interact with the paren colorer - (map-meta ")" "balance-parens-forward") - (map-meta "]" "balance-parens-forward") - (map-meta "}" "balance-parens-forward") - - (map-meta "(" "insert-()-pair") - (map-meta "[" "insert-[]-pair") - (map-meta "{" "insert-{}-pair") - (map-meta "\"" "insert-\"\"-pair") - (map-meta "|" "insert-||-pair") - - (map "(" "maybe-insert-()-pair") - (map "[" "maybe-insert-[]-pair-maybe-fixup-[]") - (map "{" "maybe-insert-{}-pair") - (map "\"" "maybe-insert-\"\"-pair") - (map "|" "maybe-insert-||-pair") + (define (map-paren-keys keymap alt-as-meta-keymap) + (map-pairs-keybinding-functions keymap #\( #\) #:alt-as-meta-keymap alt-as-meta-keymap) + (map-pairs-keybinding-functions keymap #\[ #\] #:alt-as-meta-keymap alt-as-meta-keymap) + (map-pairs-keybinding-functions keymap #\{ #\} #:alt-as-meta-keymap alt-as-meta-keymap) + (map-pairs-keybinding-functions keymap #\" #\" #:alt-as-meta-keymap alt-as-meta-keymap) + (map-pairs-keybinding-functions keymap #\| #\| #:alt-as-meta-keymap alt-as-meta-keymap)) + (cond + [paren-keymap + (map-paren-keys paren-keymap paren-alt-as-meta-keymap)] + [else + (map-paren-keys keymap alt-as-meta-keymap)]) (map "~c:backspace" "maybe-delete-empty-brace-pair") (map-meta "s:l" "insert-lambda-template") (map "c:c;c:b" "remove-parens-forward") - (map "c:c;c:l" "introduce-let-ans") (map "c:c;c:o" "move-sexp-out") (map "c:c;c:e" "kill-enclosing-parens") - (map "c:c;c:[" "toggle-round-square-parens")) + (map "c:c;c:[" "toggle-round-square-parens") + (map "c:c;c:l" "introduce-let-ans")) (define keymap (make-object keymap:aug-keymap%)) +(define non-paren-keymap (new keymap:aug-keymap%)) +(define paren-keymap (new keymap:aug-keymap%)) (define alt-as-meta-keymap (make-object keymap:aug-keymap%)) -(setup-keymap keymap #:alt-as-meta-keymap alt-as-meta-keymap) +(define paren-alt-as-meta-keymap (make-object keymap:aug-keymap%)) +(setup-keymap non-paren-keymap + #:alt-as-meta-keymap alt-as-meta-keymap + #:paren-keymap paren-keymap + #:paren-alt-as-meta-keymap paren-alt-as-meta-keymap) +(send keymap chain-to-keymap paren-keymap #f) +(send keymap chain-to-keymap non-paren-keymap #f) (define (get-keymap) keymap) +(define (get-paren-keymap) paren-keymap) +(define (get-non-paren-keymap) non-paren-keymap) (define (adjust-alt-as-meta on?) - (send keymap remove-chained-keymap alt-as-meta-keymap) + (send non-paren-keymap remove-chained-keymap alt-as-meta-keymap) + (send paren-keymap remove-chained-keymap paren-alt-as-meta-keymap) (when on? - (send keymap chain-to-keymap alt-as-meta-keymap #f))) + (send non-paren-keymap chain-to-keymap alt-as-meta-keymap #f) + (send paren-keymap chain-to-keymap paren-alt-as-meta-keymap #f))) (preferences:add-callback 'framework:alt-as-meta (λ (p v) (adjust-alt-as-meta v))) (adjust-alt-as-meta (preferences:get 'framework:alt-as-meta)) @@ -1943,7 +1963,7 @@ (define (insert-paren text) (let* ([pos (send text get-start-position)] [real-char #\[] - [change-to (λ (i c) + [change-to (λ (i c) ;(printf "change-to, case ~a\n" i) (set! real-char c))] [start-pos (send text get-start-position)] @@ -1974,7 +1994,7 @@ (cond [backward-match ;; there is an expression before this, at this layer - (define before-whitespace-pos2 + (define before-whitespace-pos2 (send text skip-whitespace backward-match 'backward #t)) (define backward-match2 (send text backward-match before-whitespace-pos2 0)) (cond @@ -1990,7 +2010,7 @@ (define b-w-p-char (send text get-character (- before-whitespace-pos 1))) (cond [(equal? b-w-p-char #\() - (define second-before-whitespace-pos (send text skip-whitespace + (define second-before-whitespace-pos (send text skip-whitespace (- before-whitespace-pos 1) 'backward #t)) @@ -2010,7 +2030,7 @@ (void)] [else ;; go back one more sexp in the same row, looking for `let loop' pattern - (define second-before-whitespace-pos2 (send text skip-whitespace + (define second-before-whitespace-pos2 (send text skip-whitespace second-backwards-match 'backward #t)) @@ -2042,9 +2062,9 @@ [else ;; otherwise, round. (change-to 4 #\()])])] - [else + [else (change-to 5 #\()])] - [else + [else (change-to 6 #\()]))]))) (send text delete pos (+ pos 1) #f) (send text end-edit-sequence) @@ -2065,7 +2085,7 @@ ;; find-keyword-and-distance : -> (union #f (cons string number)) (define (find-keyword-and-distance before-whitespace-pos text) ;; searches backwards for the keyword in the sequence at this level. - ;; if found, it counts how many sexps back it was + ;; if found, it counts how many sexps back it was (let loop ([pos before-whitespace-pos] [n 0]) (let ([backward-match (send text backward-match pos 0)]) @@ -2084,7 +2104,7 @@ (and keyword (list keyword (- n 1))))])))) -;; beginning-of-sequence? : text number -> boolean +;; beginning-of-sequence? : text number -> boolean ;; determines if this position is at the beginning of a sequence ;; that begins with a parenthesis. (define (beginning-of-sequence? text start) @@ -2092,7 +2112,7 @@ (cond [(zero? before-space) #t] [else - (equal? (send text get-character (- before-space 1)) + (equal? (send text get-character (- before-space 1)) #\()]))) (define (text-between-equal? str text start end) @@ -2122,25 +2142,25 @@ (define (add-preferences-panel) (preferences:add-panel - (list (string-constant editor-prefs-panel-label) + (list (string-constant editor-prefs-panel-label) (string-constant indenting-prefs-panel-label)) make-indenting-prefs-panel) (preferences:add-panel - (list (string-constant editor-prefs-panel-label) + (list (string-constant editor-prefs-panel-label) (string-constant square-bracket-prefs-panel-label)) make-square-bracket-prefs-panel)) (define (make-square-bracket-prefs-panel p) (define main-panel (make-object vertical-panel% p)) (define boxes-panel (new-horizontal-panel% [parent main-panel])) - + (define (mk-list-box sym keyword-type pref->string get-new-one) (letrec ([vp (new-vertical-panel% [parent boxes-panel])] - [_ (new message% + [_ (new message% [label (format (string-constant x-like-keywords) keyword-type)] [parent vp])] [lb - (new list-box% + (new list-box% [label #f] [parent vp] [choices (map pref->string (preferences:get sym))] @@ -2152,22 +2172,22 @@ (new button% [label (string-constant add-keyword)] [parent bp] - [callback + [callback (λ (x y) (let ([new-one (get-new-one)]) (when new-one - (preferences:set sym (append (preferences:get sym) + (preferences:set sym (append (preferences:get sym) (list new-one))))))])] [remove-button (new button% [label (string-constant remove-keyword)] [parent bp] - [callback + [callback (λ (x y) (let ([n (send lb get-selections)]) (when (pair? n) - (preferences:set - sym + (preferences:set + sym (let loop ([i 0] [prefs (preferences:get sym)]) (cond @@ -2179,7 +2199,7 @@ [(= 0 (send lb get-number)) (send remove-button enable #f)] [else - (send lb set-selection + (send lb set-selection (if (= (car n) (send lb get-number)) (- (send lb get-number) 1) (car n)))]))))])]) @@ -2189,7 +2209,7 @@ (λ (p v) (send lb clear) (for-each (λ (x) (send lb append (pref->string x))) v))))) - + (define (get-new-simple-keyword label) (λ () (let ([new-one @@ -2201,34 +2221,34 @@ (and new-one (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f))) (read (open-input-string new-one)))]) - + (and (symbol? parsed) (symbol->string parsed))))))) - + (define (get-new-cond-keyword) (define f (new dialog% [label (format (string-constant enter-new-keyword) "Cond")])) (define tb (keymap:call/text-keymap-initializer (λ () - (new text-field% + (new text-field% [parent f] [label #f])))) (define number-panel (new-horizontal-panel% [parent f] [stretchable-height #f])) - (define number-label (new message% + (define number-label (new message% [parent number-panel] [label (string-constant skip-subexpressions)])) (define number (keymap:call/text-keymap-initializer (λ () - (new text-field% + (new text-field% [parent number-panel] [init-value "1"] [min-width 50] [label #f])))) - + (define answers #f) - (define bp (new-horizontal-panel% - [parent f] - [stretchable-height #f] + (define bp (new-horizontal-panel% + [parent f] + [stretchable-height #f] [alignment '(right center)])) (define (confirm-callback b e) (let ([n (string->number (send number get-value))] @@ -2238,44 +2258,44 @@ (symbol? sym)) (set! answers (list (symbol->string sym) n))) (send f show #f))) - + (define (cancel-callback b e) (send f show #f)) - + (define-values (ok-button cancel-button) - (gui-utils:ok/cancel-buttons bp confirm-callback cancel-callback + (gui-utils:ok/cancel-buttons bp confirm-callback cancel-callback (string-constant ok) (string-constant cancel))) (send tb focus) (send f show #t) answers) - + (mk-list-box 'framework:square-bracket:letrec "Letrec" values (get-new-simple-keyword "Letrec")) - (mk-list-box 'framework:square-bracket:local - "Local" + (mk-list-box 'framework:square-bracket:local + "Local" values (get-new-simple-keyword "Local")) - (mk-list-box 'framework:square-bracket:for/fold - "For/fold" + (mk-list-box 'framework:square-bracket:for/fold + "For/fold" values (get-new-simple-keyword "For/fold")) - (mk-list-box 'framework:square-bracket:cond/offset - "Cond" + (mk-list-box 'framework:square-bracket:cond/offset + "Cond" (λ (l) (format "~a (~a)" (car l) (cadr l))) get-new-cond-keyword) - - (define check-box (new check-box% + + (define check-box (new check-box% [parent main-panel] [label (string-constant fixup-open-brackets)] [value (preferences:get 'framework:fixup-open-parens)] - [callback + [callback (λ (x y) - (preferences:set 'framework:fixup-open-parens + (preferences:set 'framework:fixup-open-parens (send check-box get-value)))])) (preferences:add-callback 'framework:fixup-open-parens (λ (p v) (send check-box set-value v))) - + main-panel) (define (make-indenting-prefs-panel p) @@ -2285,8 +2305,8 @@ (define (pick-out wanted in out) (cond [(null? in) (sort out string* ((is-a?/c text%) - string?) + string? + #:recur-inside? (-> (is-a?/c editor-snip%) any/c)) ((or/c 'forward 'backward) (or/c 'start number?) (or/c 'eof number?) @@ -24,12 +25,14 @@ [end 'eof] [get-start #t] [case-sensitive? #t] - [pop-out? #f]) + [pop-out? #f] + #:recur-inside? recur-inside?) (let/ec k (let loop ([a-text a-text] [start start] [end end]) - (define found (send a-text find-string-embedded str direction start end get-start case-sensitive?)) + (define found (send a-text find-string-embedded str direction start end get-start case-sensitive? + #:recur-inside? recur-inside?)) (define (done) (cond [(not found) @@ -72,45 +75,45 @@ (send abc//abc/abcX/abcQ//abcZ insert "abcZ") (let () - (define-values (ta pos) (find-string-embedded abcX "b" 'forward 0)) + (define-values (ta pos) (find-string-embedded abcX "b" 'forward 0 #:recur-inside? (λ (x) #t))) (check-equal? ta abcX) (check-equal? pos 1)) (let () - (define-values (ta pos) (find-string-embedded abcX "c" 'forward 0)) + (define-values (ta pos) (find-string-embedded abcX "c" 'forward 0 #:recur-inside? (λ (x) #t))) (check-equal? ta abcX) (check-equal? pos 2)) (let () - (define-values (ta pos) (find-string-embedded abcX "d" 'forward 2)) + (define-values (ta pos) (find-string-embedded abcX "d" 'forward 2 #:recur-inside? (λ (x) #t))) (check-equal? pos #f)) (let () - (define-values (ta pos) (find-string-embedded abc/abcX/abcQ "b" 'forward 0)) + (define-values (ta pos) (find-string-embedded abc/abcX/abcQ "b" 'forward 0 #:recur-inside? (λ (x) #t))) (check-equal? ta ta) (check-equal? pos 1)) (let () - (define-values (ta pos) (find-string-embedded abc/abcX/abcQ "b" 'forward 2)) + (define-values (ta pos) (find-string-embedded abc/abcX/abcQ "b" 'forward 2 #:recur-inside? (λ (x) #t))) (check-equal? ta abcX) (check-equal? pos 1)) (let () - (define-values (ta pos) (find-string-embedded abc//abc/abcX/abcQ//abcZ "X" 'forward 0)) + (define-values (ta pos) (find-string-embedded abc//abc/abcX/abcQ//abcZ "X" 'forward 0 #:recur-inside? (λ (x) #t))) (check-equal? ta abcX) (check-equal? pos 3)) (let () - (define-values (ta pos) (find-string-embedded abcX "Q" 'forward 0 'eof #t #t #t)) + (define-values (ta pos) (find-string-embedded abcX "Q" 'forward 0 'eof #t #t #t #:recur-inside? (λ (x) #t))) (check-equal? ta abc/abcX/abcQ) (check-equal? pos 7)) (let () - (define-values (ta pos) (find-string-embedded abcX "Z" 'forward 0 'eof #t #t #t)) + (define-values (ta pos) (find-string-embedded abcX "Z" 'forward 0 'eof #t #t #t #:recur-inside? (λ (x) #t))) (check-equal? ta abc//abc/abcX/abcQ//abcZ) (check-equal? pos 7)) (let () - (define-values (ta pos) (find-string-embedded abcX "c" 'forward 4 'eof #t #t #t)) + (define-values (ta pos) (find-string-embedded abcX "c" 'forward 4 'eof #t #t #t #:recur-inside? (λ (x) #t))) (check-equal? ta abc/abcX/abcQ) (check-equal? pos 6))) diff --git a/gui-lib/framework/private/sig.rkt b/gui-lib/framework/private/sig.rkt index 04556c427..59632ed85 100644 --- a/gui-lib/framework/private/sig.rkt +++ b/gui-lib/framework/private/sig.rkt @@ -1,6 +1,6 @@ #lang racket/base - (require racket/unit "text-sig.rkt") + (require racket/unit "text-sig.rkt" "editor-sig.rkt") (provide (prefix-out framework: (except-out (all-defined-out) framework^)) framework^) @@ -8,10 +8,13 @@ (define-signature number-snip-class^ (snip-class%)) (define-signature number-snip^ extends number-snip-class^ - (make-repeating-decimal-snip + (number->string/snip + make-pretty-print-size + make-repeating-decimal-snip make-fraction-snip is-number-snip? - get-number)) + get-number + remove-decimal-looking-number-snips-on-insertion-mixin)) (define-signature number-snip/int^ extends number-snip^ ()) @@ -19,7 +22,13 @@ (snip%)) (define-signature comment-box^ extends comment-box-class^ (snipclass)) - + + (define-signature srcloc-snip-class^ + (snip%)) + (define-signature srcloc-snip^ extends srcloc-snip-class^ + (snipclass + select-srcloc)) + (define-signature menu-class^ (can-restore<%> can-restore-mixin @@ -102,9 +111,10 @@ add-can-close-dialog-callback add-check - + add-boolean-option-with-ask-me show-dialog - hide-dialog)) + hide-dialog + show-tab-panel)) (define-signature autosave-class^ (autosavable<%>)) @@ -144,39 +154,7 @@ std-get-file get-file put-file)) - - (define-signature editor-class^ - (basic<%> - standard-style-list<%> - keymap<%> - autowrap<%> - info<%> - file<%> - backup-autosave<%> - autoload<%> - basic-mixin - standard-style-list-mixin - keymap-mixin - autowrap-mixin - info-mixin - file-mixin - backup-autosave-mixin - autoload-mixin - font-size-message%)) - (define-signature editor^ extends editor-class^ - (get-standard-style-list - set-standard-style-list-pref-callbacks - set-standard-style-list-delta - set-default-font-color - get-default-color-style-name - add-after-user-keymap - get-current-preferred-font-size - set-current-preferred-font-size - font-size-pref->current-font-size - set-change-font-size-when-monitors-change? - get-change-font-size-when-monitors-change? - doing-autosave?)) - + (define-signature pasteboard-class^ (basic% standard-style-list% @@ -186,6 +164,13 @@ info%)) (define-signature pasteboard^ extends pasteboard-class^ ()) + +(define-signature editor-class^ + ((open editor-misc-class^) + (open editor-autoload^))) + +(define-signature editor^ extends editor-class^ + ((open editor-misc-functions^))) (define-signature text-class^ ((open text-basic-class^) @@ -200,13 +185,15 @@ (open text-search^) (open text-first-line^) (open text-inline-overview^) + (open text-indent-guides^) + (open text-max-width-paragraph^) (open text-mixed-in-classes^))) (define-signature text^ extends text-class^ ((open text-basic-functions^) (open text-port-functions^) (open text-autocomplete-functions^))) - + (define-signature canvas-class^ (basic<%> color<%> @@ -304,6 +291,7 @@ open-file install-recent-items add-to-recent + update-currently-open-files set-recent-position set-recent-items-frame-superclass size-recently-opened-files)) @@ -377,6 +365,7 @@ (register-color-preference add-to-preferences-panel build-color-selection-panel + normalize-color-selection-button-widths add-background-preferences-panel marshall-style-delta unmarshall-style-delta @@ -395,7 +384,16 @@ register-color-scheme-entry-change-callback add-color-scheme-entry register-info-based-color-schemes - get-color-scheme-names)) + get-color-scheme-names + get-inverted-base-color-scheme + + white-on-black-color-scheme?)) + (define-signature color-prefs/int^ extends color-prefs^ + (change-colors-to-match-color-scheme + lookup-color-scheme + built-in-wob-color-scheme + built-in-color-scheme + update-dark-light-preferences-panel-ordering)) (define-signature racket-class^ (text<%> @@ -414,7 +412,11 @@ (get-wordbreak-map init-wordbreak-map get-keymap + get-paren-keymap + get-non-paren-keymap setup-keymap + add-pairs-keybinding-functions + map-pairs-keybinding-functions add-preferences-panel add-coloring-preferences-panel @@ -423,7 +425,9 @@ short-sym->pref-name short-sym->style-name - text-balanced?)) + text-balanced? + + default-paren-matches)) (define-signature main-class^ ()) (define-signature main^ extends main-class^ ()) @@ -469,6 +473,7 @@ (open (prefix color: color^)) (open (prefix color-prefs: color-prefs^)) (open (prefix comment-box: comment-box^)) + (open (prefix srcloc-snip: srcloc-snip^)) (open (prefix finder: finder^)) (open (prefix group: group^)) (open (prefix canvas: canvas^)) diff --git a/gui-lib/framework/private/srcloc-snip.rkt b/gui-lib/framework/private/srcloc-snip.rkt new file mode 100644 index 000000000..3f21c6162 --- /dev/null +++ b/gui-lib/framework/private/srcloc-snip.rkt @@ -0,0 +1,114 @@ +#lang racket/base + +(require racket/unit + racket/class + racket/gui/base + racket/snip + "sig.rkt" + (prefix-in base: racket/base)) + +(provide srcloc-snip@) + +(define-unit srcloc-snip@ + (import [prefix frame: framework:frame^] + [prefix group: framework:group^] + [prefix text: framework:text^] + [prefix editor: framework:editor^] + [prefix handler: framework:handler^]) + (export (rename framework:srcloc-snip^ [-snip% snip%])) + + (define (select-srcloc srcloc) + (define pos (srcloc-position srcloc)) + (define span (srcloc-span srcloc)) + (handler:edit-file (srcloc-source srcloc) + #:start-pos (and pos (- pos 1)) + #:end-pos (cond + [(and pos span) (+ pos span -1)] + [else (and pos (- pos 1))]))) + + ; honest attempt + (define (source->datum source) + (if (path? source) + (path->bytes source) + source)) + + (define (datum->source source) + (if (bytes? source) + (bytes->path source) + source)) + + (define srcloc-snip-class% + (class snip-class% + (inherit set-version set-classname) + (super-new) + (set-version 1) + (set-classname (format "~s" '((lib "srcloc-snip.rkt" "framework") + (lib "wxme-srcloc-snip.rkt" "framework")))) + ; serialize as (srcloc ) + (define/override (read f) + (with-handlers ([exn? (lambda (exn) #f)]) + (let* ((bytes (send f get-unterminated-bytes)) + (port (open-input-bytes bytes 'srcloc)) + (datum (base:read port)) + (srcloc (apply + (lambda (_ source line column position span) + (srcloc (datum->source source) line column position span)) + datum)) + (snip + (new -snip% [srcloc srcloc])) + (editor (send snip get-editor))) + (send editor read-from-file f #t) + (send snip activate-link) + snip))))) + + (define snipclass (new srcloc-snip-class%)) + (send (get-the-snip-class-list) add snipclass) + + ;; class for snips embedded in markup + (define markup-text% + (text:wide-snip-mixin + (text:basic-mixin + (editor:standard-style-list-mixin + (editor:basic-mixin + text%))))) + + (define -snip% + (class editor-snip% + (init-field srcloc) + (inherit set-snipclass + use-style-background + get-editor) + (super-new [editor (new markup-text%)] + [with-border? #f]) + (set-snipclass snipclass) + + ; you must call this after having put something in the editor + (define/public (activate-link) + (let ((editor (get-editor))) + (send editor set-clickback + 0 (send editor get-end-position) + (lambda (t s e) + (select-srcloc srcloc)) + #f #f) + (send editor lock #t))) + + (use-style-background #t) + + + (define/override (copy) + (let ((snip (new -snip% [srcloc srcloc]))) + (send (get-editor) copy-self-to (send snip get-editor)) + (send snip activate-link) + snip)) + + (define/override (write f) + (let ((port (open-output-string)) + (sexpr `(srcloc ,(source->datum (srcloc-source srcloc)) + ,(srcloc-line srcloc) + ,(srcloc-column srcloc) + ,(srcloc-position srcloc) + ,(srcloc-span srcloc)))) + (base:write sexpr port) + (let ((bytes (get-output-bytes port))) + (send f put (bytes-length bytes) bytes)) + (send (get-editor) write-to-file f)))))) diff --git a/gui-lib/framework/private/text-autocomplete.rkt b/gui-lib/framework/private/text-autocomplete.rkt index 43c328361..c22e90ebb 100644 --- a/gui-lib/framework/private/text-autocomplete.rkt +++ b/gui-lib/framework/private/text-autocomplete.rkt @@ -573,12 +573,12 @@ designates the character that triggers autocompletion (+ menu-padding-y y dy))))] [else (let ([c (car pc)]) - (let-values ([(w h d a) (send dc get-text-extent c)]) + (let-values ([(w h d a) (send dc get-text-extent c #f 'grapheme)]) (when (= item-number highlighted-menu-item) (send dc set-pen "black" 1 'transparent) (send dc set-brush (send editor get-autocomplete-selected-color) 'solid) (send dc draw-rectangle (+ mx dx 1) (+ dy y menu-padding-y 1) (- tw 2) (- h 1))) - (send dc draw-text c (+ mx dx menu-padding-x) (+ menu-padding-y y dy)) + (send dc draw-text c (+ mx dx menu-padding-x) (+ menu-padding-y y dy) 'grapheme) (loop (add1 item-number) (+ y h) (cdr pc))))]))]) (send dc set-pen old-pen) (send dc set-brush old-brush) diff --git a/gui-lib/framework/private/text-basic.rkt b/gui-lib/framework/private/text-basic.rkt index 4391bfae9..d0d5b250b 100644 --- a/gui-lib/framework/private/text-basic.rkt +++ b/gui-lib/framework/private/text-basic.rkt @@ -4,6 +4,7 @@ data/queue mred/mred-sig string-constants + "../preferences.rkt" "interfaces.rkt" "sig.rkt" "text-sig.rkt") @@ -15,6 +16,7 @@ [prefix icon: framework:icon^] [prefix finder: framework:finder^] [prefix color-model: framework:color-model^] + [prefix color-prefs: framework:color-prefs^] [prefix editor: framework:editor^]) (export text-basic^) (init-depend framework:editor^) @@ -25,11 +27,17 @@ (define-struct range ([start #:mutable] [end #:mutable] caret-space? - style color + style + color #;(or/c (is-a?/c color%) color-prefs:color-scheme-color-name?) adjust-on-insert/delete? key [rectangles #:mutable]) #:inspector #f) - (define-struct rectangle (left top right bottom style color) #:inspector #f) + (define-struct rectangle (left + top right bottom + style + color #;(or/c (is-a?/c color%) color-prefs:color-scheme-color-name?) + ) + #:inspector #f) (define (build-rectangle left top right bottom style color [info (λ () "")]) (unless (or (symbol? right) (symbol? left)) @@ -249,6 +257,10 @@ (loop (min (unbox b1) (unbox b2) l) (max (unbox b1) (unbox b2) r) (+ line 1))]))] + [(equal? style 'single-rectangle) + (list (build-rectangle (min start-x end-x) top-start-y + (max start-x end-x) bottom-end-y + style color))] [else (list (build-rectangle start-x top-start-y 'right-edge bottom-start-y @@ -325,23 +337,28 @@ "expected priority argument to be either 'high or 'low, got: ~e" priority)) (unless (or (is-a? in-color color%) + (color-prefs:color-scheme-color-name? in-color) (and (string? in-color) (send the-color-database find-color in-color))) (error 'highlight-range - "expected a color or a string in the-color-database for the third argument, got ~e" + (string-append + "wrong third argument;\n" + " expected: (or/c string? (is-a?/c color%) color-prefs:color-scheme-color-name?)\n" + " where the string is mapped in `the-color-database`\n" + " third argument: ~e") in-color)) - (unless (memq style '(rectangle hollow-ellipse ellipse dot)) + (unless (memq style '(rectangle single-rectangle hollow-ellipse ellipse dot)) (error 'highlight-range - "expected one of 'rectangle, 'ellipse 'hollow-ellipse, or 'dot as the style, got ~e" + "expected one of 'rectangle, 'single-rectangle, 'ellipse 'hollow-ellipse, or 'dot as the style, got ~e" style)) (when (eq? style 'dot) (unless (= start end) (error 'highlight-range "when the style is 'dot, the start and end regions must be the same"))) - (define color (if (is-a? in-color color%) - in-color - (send the-color-database find-color in-color))) + (define color (if (string? in-color) + (send the-color-database find-color in-color) + in-color)) (define l (make-range start end caret-space? style color adjust-on-insert/delete? key #f)) (if (eq? priority 'high) (enqueue! ranges-deq l) @@ -353,9 +370,12 @@ (unhighlight-range start end color caret-space? style)))) (define/public (unhighlight-range start end in-color [caret-space? #f] [style 'rectangle]) - (define color (if (is-a? in-color color%) - in-color - (send the-color-database find-color in-color))) + (define color (cond + [(is-a? in-color color%) + in-color] + [(string? in-color) + (send the-color-database find-color in-color)] + [else in-color])) (unhighlight-ranges (λ (r-start r-end r-color r-caret-space? r-style r-adjust-on-insert/delete? r-key) (and (equal? start r-start) @@ -453,28 +473,32 @@ (<= top top-margin bottom-margin bottom))) (define width (if (right . <= . left) 0 (- right left))) (define height (if (bottom . <= . top) 0 (- bottom top))) - (define color (let ([rc (rectangle-color rectangle)]) + (define color (let* ([rc (rectangle-color rectangle)] + [rc-color-obj + (if (is-a? rc color%) + rc + (color-prefs:lookup-in-color-scheme rc))]) (cond - [(not (= 1 (send rc alpha))) rc] - [(and last-color (eq? last-color rc)) - rc] - [rc + [(not (= 1 (send rc-color-obj alpha))) rc-color-obj] + [(and last-color (eq? last-color rc-color-obj)) + rc-color-obj] + [rc-color-obj (set! last-color #f) - (send dc try-color rc highlight-tmp-color) + (send dc try-color rc-color-obj highlight-tmp-color) (if (<= (color-model:rgb-color-distance - (send rc red) - (send rc green) - (send rc blue) + (send rc-color-obj red) + (send rc-color-obj green) + (send rc-color-obj blue) (send highlight-tmp-color red) (send highlight-tmp-color green) (send highlight-tmp-color blue)) 18) - (begin (set! last-color rc) - rc) + (begin (set! last-color rc-color-obj) + rc-color-obj) #f)] [else (set! last-color #f) - rc]))) + rc-color-obj]))) (when color (case (rectangle-style rectangle) [(dot) @@ -491,7 +515,7 @@ (+ dy top (- hollow-ellipse-embiggen)) (+ width (+ hollow-ellipse-embiggen hollow-ellipse-embiggen)) (+ height (+ hollow-ellipse-embiggen hollow-ellipse-embiggen)))] - [(rectangle) + [(rectangle single-rectangle) (send dc set-pen color 1 'transparent) (send dc set-brush color 'solid) (send dc draw-rectangle (+ left dx) (+ top dy) width height)] @@ -504,6 +528,8 @@ (send dc set-brush old-brush))) (super-new))) + + (define port-name-counter 0) (define other-basics-mixin (mixin (editor:basic<%> (class->interface text%)) () @@ -514,7 +540,11 @@ get-style-list change-style position-line line-start-position get-filename get-end-position) - + + (define/override (blink-caret) + (unless (preferences:get 'framework:caret-blink-disable?) + (super blink-caret))) + (define/public (get-fixed-style) (send (get-style-list) find-named-style "Standard")) @@ -532,7 +562,10 @@ (cond [(or (unbox b) (not n)) (unless port-name-identifier - (set! port-name-identifier (string->uninterned-symbol port-name-unsaved-name)) + (define our-number #f) + (set! our-number port-name-counter) + (set! port-name-counter (+ port-name-counter 1)) + (set! port-name-identifier (string->symbol (format "~a-~a" our-number port-name-unsaved-name))) (register-port-name! port-name-identifier this)) port-name-identifier] [else n]))) diff --git a/gui-lib/framework/private/text-column-guide.rkt b/gui-lib/framework/private/text-column-guide.rkt index 0ca1d958e..caa4c0d74 100644 --- a/gui-lib/framework/private/text-column-guide.rkt +++ b/gui-lib/framework/private/text-column-guide.rkt @@ -1,6 +1,8 @@ #lang racket/base (require racket/unit racket/class + racket/match + mrlib/panel-wob mred/mred-sig "text-sig.rkt" "../preferences.rkt") @@ -22,9 +24,14 @@ ;; these two functions are defined as private fields ;; because they are weakly held callbacks (define (bw-cb p v) + (define wob? + (match v + ['platform (white-on-black-panel-scheme?)] + [#t #t] + [#f #f])) (set! pen (send the-pen-list find-or-create-pen - (if v + (if wob? (make-object color% 225 225 51) (make-object color% 204 204 51)) (* column-guide-mixin-pen-size 2) @@ -49,8 +56,8 @@ (super-new) - (preferences:add-callback 'framework:white-on-black? bw-cb #t) - (bw-cb 'ignored-arg (preferences:get 'framework:white-on-black?)) + (preferences:add-callback 'framework:white-on-black-mode? bw-cb #t) + (bw-cb 'ignored-arg (preferences:get 'framework:white-on-black-mode?)) (preferences:add-callback 'framework:column-guide-width cw-cb #t) (cw-cb 'ignored-arg (preferences:get 'framework:column-guide-width)) diff --git a/gui-lib/framework/private/text-first-line.rkt b/gui-lib/framework/private/text-first-line.rkt index 0a9ed0ebf..73adf463c 100644 --- a/gui-lib/framework/private/text-first-line.rkt +++ b/gui-lib/framework/private/text-first-line.rkt @@ -4,6 +4,7 @@ mred/mred-sig "text-sig.rkt" "interfaces.rkt" + "wob-color-scheme.rkt" "../preferences.rkt") (provide text-first-line@) @@ -163,7 +164,7 @@ (define old-font (send dc get-font)) (define old-text-foreground (send dc get-text-foreground)) (define old-text-mode (send dc get-text-mode)) - (define w-o-b? (preferences:get 'framework:white-on-black?)) + (define w-o-b? (white-on-black-color-scheme?)) (send dc set-font (get-font)) (send dc set-smoothing 'aligned) (send dc set-text-mode 'transparent) diff --git a/gui-lib/framework/private/text-indent-guides.rkt b/gui-lib/framework/private/text-indent-guides.rkt new file mode 100644 index 000000000..a65fce3fe --- /dev/null +++ b/gui-lib/framework/private/text-indent-guides.rkt @@ -0,0 +1,529 @@ +#lang racket/base +(require data/skip-list + racket/pretty + racket/class + racket/list + racket/match + racket/dict + racket/unit + mred/mred-sig + "guide-struct.rkt" + "text-sig.rkt" + "sig.rkt") + +(provide text-indent-guides@) + +(define-unit text-indent-guides@ + (import mred^) + (export text-indent-guides^) + + ;; todo: + ;; - reverse the list sort order in the `guides` field of the + ;; `guide` struct? (can maybe get more sharing in the tails) + ;; - should we take cues for the colors from the syntax coloring? + + ;; the implementation splits the work of the guides into two pieces: + ;; - building of the `guides` (see the `guide` struct in guide-struct.rkt + ;; and the adjustable-skip-list in `guides`) that tracks where guides + ;; are on each line + ;; - drawing the `guides` in response to an invalidated region + ;; of the editor (see on-paint and following methods) + + (define indent-guides<%> + (interface () + show-indent-guides! + show-indent-guides?)) + + (define indent-guides-mixin + (mixin ((class->interface text%)) (indent-guides<%>) + (inherit paragraph-start-position + position-paragraph + last-paragraph + position-location + find-snip + find-position + begin-edit-sequence + end-edit-sequence + in-edit-sequence? + invalidate-bitmap-cache) + + (define on-delete-contract-start #f) + (define on-delete-contract-end #f) + (define initial-pending-lines-cache-key #f) + (define initial-pending-lines-cache #f) + (define/private (reset-initial-pending-lines-cache) + (set! initial-pending-lines-cache-key #f) + (set! initial-pending-lines-cache #f)) + + (define find-indent-cache (make-string 0)) + + ;; boolean? + ;; #t => call recalculate-x-for-guides at the + ;; end of the enclosing edit-sequence + (define recalculate-x-for-guides-after-edit-sequence #f) + + ;; para -o> guide + (define guides #f) + (define/public-final (get-guides) guides) + (define/public-final (show-indent-guides! on?) + (cond + [on? + (unless guides + (set! guides (make-adjustable-skip-list)) + (recalculate-lines-guides 0 (last-paragraph)))] + [else + (when guides + (set! guides #f) + (invalidate-bitmap-cache))])) + (define/public (show-indent-guides?) (and guides #t)) + + (super-new) + (show-indent-guides! #t) + + ; + ; + ; + ; + ; + ; ;;; ;;; + ; ;;; + ; ;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;;;;; + ; ;;;;;;; ;;; ;;; ;;; ;;;;;;; ;;;;; ;;; ;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;;;;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; + ; ;;;;;;; ;;;;;;; ;;; ;;;;;;; ;;;;;; ;; ;;; + ; ;; ;;; ;; ;;; ;;; ;; ;;; ;;;; ;;;;; + ; ;;; + ; ;;;;;;; + ; ;;;;; + ; + ; + + + ;; recalculate-lines-guides rebuilds the content of `guides` + ;; when the text's content changes; it is the top-level entry + ;; point into the code that builds `guides` but it also + ;; invalidates drawing regions that have to change + (define/private (recalculate-lines-guides para-start para-end) + (when guides + (define bx (box 0)) + (define-values (para-stopped invalidate-right) + (let loop ([para para-start] + [widest-width 0] + + [previous-guide + (if (= para-start 0) + #f + (skip-list-ref guides (- para-start 1) #f))] + ;; pending-blanks-start : + ;; (or/c #f -- no pending blanks + ;; natural?) -- which para the blanks go back to + [pending-blanks-start #f]) + (cond + [(<= para (last-paragraph)) + (define-values (width changed/blank?) + (recalculate-line-guide bx previous-guide para)) + (cond + [(or (para . <= . para-end) + changed/blank?) + (define-values (new-previous-guide new-pending-blanks) + (match changed/blank? + [(? boolean?) + (when pending-blanks-start + (update-the-blanks para previous-guide pending-blanks-start)) + (values (skip-list-ref guides para) #f)] + ['blank + (cond + [pending-blanks-start + (values previous-guide pending-blanks-start)] + [else + (values previous-guide para)])])) + (loop (+ para 1) + (max width widest-width) + new-previous-guide + new-pending-blanks)] + [else + ;; when we're outside of the edited region + ;; and the guide is the same as before, we're + ;; not going to find any more differences + (when pending-blanks-start + (update-the-blanks para previous-guide pending-blanks-start)) + (values para widest-width)])] + [else + (when pending-blanks-start + (update-the-blanks #f previous-guide pending-blanks-start)) + (values (last-paragraph) widest-width)]))) + (position-location (paragraph-start-position para-start) #f bx #t #f #t) + (define invalidate-top (unbox bx)) + (position-location (paragraph-start-position para-stopped) #f bx #f #f #t) + (define invalidate-bottom (unbox bx)) + (invalidate-bitmap-cache 0 invalidate-top invalidate-right + (- invalidate-bottom invalidate-top)) + + ;; probably don't need to do this but just in case + ;; there is a giant snip somewhere along the way + (set! find-indent-cache (make-string 0)))) + + ;; update-the-blanks : (or/c #f para) (or/c #f guide) para -> void + ;; all of the lines from `pending-blanks-start` forward + ;; to `(- guide-para 1)` are blank (or, if `guide-para` is #f, then all the way + ;; to the end). Create guides for them based on the guides at + ;; subsequent-guide-para and previous-guide + (define/private (update-the-blanks subsequent-guide-para + previous-guide + pending-blanks-start) + (define loop-termination-para + (or subsequent-guide-para + (+ (last-paragraph) 1))) + (define subsequent-guide + (if subsequent-guide-para + (skip-list-ref guides subsequent-guide-para) + #f)) + (define (common-prefix orig-l1 orig-l2) + (let loop ([l1 orig-l1][l2 orig-l2]) + (cond + [(or (empty? l1) (empty? l2)) '()] + [else + (cond + [(= (car l1) (car l2)) + (cons (car l1) (loop (cdr l1) (cdr l2)))] + [else '()])]))) + (define proto-guide + (cond + [(or (not subsequent-guide) + (not previous-guide)) + (guide #f #f '())] + [else + (define subsequent-candidates + (if (= (guide-indent subsequent-guide) 0) + (guide-guides subsequent-guide) + (append (guide-guides subsequent-guide) (list (guide-indent subsequent-guide))))) + (define prefix-candidates + (if (= 0 (guide-indent previous-guide)) + (guide-guides previous-guide) + (append (guide-guides previous-guide) (list (guide-indent previous-guide))))) + (guide #f + #f + (common-prefix prefix-candidates + subsequent-candidates))])) + + (for ([para (in-range pending-blanks-start loop-termination-para)]) + (skip-list-set! guides para (struct-copy guide proto-guide)))) + + ;; -> (values integer? (or/c 'blank boolean?)) + ;; the second result indicates if the guide changed (blanks count + ;; as always changing just to make life simpler) + ;; the first, integer result is is the larger of the previous + ;; or new width (or just the width if nothing changed) + ;; if the second result is a boolean, then + ;; the guides skip-list has a valid guide + ;; set at the position `para`. + ;; if the second result is 'blank, then the + ;; guides skip-list was not updated and + ;; needs to be updated later on (when + ;; we find the end of the blanks) + (define/private (recalculate-line-guide bx previous-guide para) + (define-values (para-start indent) (find-indent para)) + (cond + [indent + (calculate-guide-x para-start indent bx) + (define a-guide + (guide indent + (unbox bx) + (if previous-guide + (forward-guides indent + (guide-indent previous-guide) + (guide-guides previous-guide)) + '()))) + (define before (skip-list-ref guides para #f)) + (cond + [(equal? before a-guide) + (values (guide-x before) #f)] + [else + (skip-list-set! guides para a-guide) + (cond + [before + (values (max (unbox bx) (or (guide-x before) 0)) #t)] + [else + (values (unbox bx) #t)])])] + [else + ;; if we have a blank line then we punt the decision + ;; about what to do back to the caller of this function + (cond + [previous-guide + (values (guide-x previous-guide) 'blank)] + [else + (values 0 'blank)])])) + + ;; natural natural (listof sorted-natural) -> (listof softed natural) + ;; this calculates the guides for a new line that + ;; has the indent `this-line-indent` and where the + ;; previous lines's indent and guides are given + (define/public (forward-guides this-line-indent + previous-line-indent + previous-line-guides) + (define spots-to-consider + (cond + [(= previous-line-indent 0) '()] + [(member previous-line-indent previous-line-guides) previous-line-guides] + [else (append previous-line-guides (list previous-line-indent))])) + (let loop ([spots-to-consider spots-to-consider]) + (cond + [(null? spots-to-consider) '()] + [else + (define spot (car spots-to-consider)) + (if (<= this-line-indent spot) + '() + (cons spot (loop (cdr spots-to-consider))))]))) + + ;; given a paragraph, this function calculates the indent; this is + ;; mostly a matter of counting spaces, but is slightly complicated to + ;; avoid allocation and use fast paths in the text% object + (define/private (find-indent para) + (define para-start (paragraph-start-position para)) + (let loop ([snip (find-snip para-start 'after-or-none)] + [indent 0]) + (cond + [(is-a? snip string-snip%) + (define count (send snip get-count)) + (unless (<= count (string-length find-indent-cache)) + (set! find-indent-cache (make-string (* 2 count)))) + (send snip get-text! find-indent-cache 0 count 0) + (cond + [(and (= count 1) (equal? (string-ref find-indent-cache 0) #\newline)) + ;; here we found a string snip with a newline so this means the + ;; line has terminated and all of the characters in it where spaces + (values para-start #f)] + [else + (let char-loop ([i 0]) + (cond + [(< i count) + (if (equal? #\space (string-ref find-indent-cache i)) + (char-loop (+ i 1)) + (values para-start (+ indent i)))] + [else + (loop (send snip next) (+ indent count))]))])] + [(not snip) (values para-start #f)] + [else (values para-start indent)]))) + + ;; when the sizing information has changed, this function + ;; recomputes the editor coordinates that are stored in `guides` + (define/private (recalculate-x-for-guides) + (define bx (box 0)) + (for ([(para guide) (in-dict guides)]) + (define para-start (paragraph-start-position para)) + (when (guide-indent guide) + (calculate-guide-x para-start (guide-indent guide) bx) + (set-guide-x! guide (unbox bx))))) + (define/private (trigger-recalculate-x-for-guides) + (cond + [(in-edit-sequence?) + (set! recalculate-x-for-guides-after-edit-sequence #t)] + [else + (recalculate-x-for-guides)])) + + (define/private (calculate-guide-x para-start indent bx) + (position-location (+ para-start indent) bx #f #t #t)) + + ;; the methods below override callback to manage the guides state + (define/augment (after-insert start len) + (when guides + (reset-initial-pending-lines-cache) + (define para1 (position-paragraph start)) + (define para2 (position-paragraph (+ start len))) + (skip-list-expand! guides para1 para2) + (recalculate-lines-guides (scan-blank-backwards para1) para2)) + (inner (void) after-insert start len)) + (define/augment (on-delete start len) + (when guides + (begin-edit-sequence) + (set! on-delete-contract-start (position-paragraph start)) + (set! on-delete-contract-end (position-paragraph (+ start len)))) + (inner (void) on-delete start len)) + (define/augment (after-delete start len) + (when guides + (reset-initial-pending-lines-cache) + (skip-list-contract! guides on-delete-contract-start on-delete-contract-end) + (recalculate-lines-guides (scan-blank-backwards on-delete-contract-start) on-delete-contract-start) + (end-edit-sequence)) + (inner (void) after-delete start len)) + (define/augment (on-change) + (when guides + (reset-initial-pending-lines-cache) + (trigger-recalculate-x-for-guides)) + (inner (void) on-change)) + (define/augment (on-reflow) + (when guides + (reset-initial-pending-lines-cache) + (trigger-recalculate-x-for-guides)) + (inner (void) on-reflow)) + (define/augment (after-edit-sequence) + (when recalculate-x-for-guides-after-edit-sequence + (set! recalculate-x-for-guides-after-edit-sequence #f) + (recalculate-x-for-guides)) + (inner (void) after-edit-sequence)) + + (define/private (scan-blank-backwards para) + ;; scan backwards to include any blank paragraphs above `para` + (let loop ([para para]) + (define para-above-blank? + (and (not (zero? para)) + (not (guide-indent (skip-list-ref guides (- para 1)))))) + (cond + [para-above-blank? + (loop (- para 1))] + [else para]))) + + + ; + ; + ; + ; + ; + ; ;;; ;;; + ; ;;; + ; ;; ;;; ;;; ;; ;;;;; ;;; ;;; ;;; ;;; ;;; ;; ;; ;;; + ; ;;;;;;; ;;;;; ;;;;;;; ;; ;;; ;;; ;;; ;;;;;;; ;;;;;;; + ; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; + ; ;;; ;;; ;;; ;;;; ;;; ; ; ;;; ;;; ;;; ;;; ;;; ;;; + ; ;;; ;;; ;;; ;; ;;; ;;;; ;;;;; ;;; ;;; ;;; ;;; ;;; + ; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;; ;;; + ; ;;;;;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; + ; ;; ;;; ;;; ;;;;;; ;; ;;; ;;; ;;; ;;; ;; ;;; + ; ;;; + ; ;;;;;;; + ; ;;;;; + ; + ; + + + (define/override (on-paint before? dc left top right bottom dx dy draw-caret) + (when guides + (unless before? + (define pen-before (send dc get-pen)) + (send dc set-pen (send the-pen-list find-or-create-pen "gray" 1 'solid)) + (define lt-position (find-position left top)) + (define top-para (position-paragraph lt-position)) + (define lb-position (find-position left bottom)) + (define bot-para (position-paragraph lb-position)) + (draw-the-lines + (λ (x-in-editor-coordinates x y-start y-end) + (draw-a-line dc dx dy x-in-editor-coordinates x y-start y-end)) + top-para bot-para) + (send dc set-pen pen-before))) + (super on-paint before? dc left top right bottom dx dy draw-caret)) + + (define/public (draw-the-lines draw-a-line top-para bot-para) + ;; this iterates through the paragraphs, figuring out when + ;; lines start and end and drawing them when they end + ;; it is complicated by the fact that it draws only the + ;; area between `top` and `bottom` + + ;; these are the accumulator variables for the loop: + ;; pending-lines : hash[column-number -o> (cons editor-x para)] + ;; - hash tracks the lines that we are going to draw but + ;; haven't gotten to the end of yet. When the line ends, we + ;; draw it and remove it from the hash. When one starts, + ;; add it to the hash + ;; - domain is the column number of the line + ;; - range is the `x` (editor) coordinate we draw, plus + ;; the paragraph where the line started + ;; pending-xs : (listof column-number) + ;; - the content of this list is the same as the domain of + ;; pending-lines but it is sorted from smallest to largest + (define pending-lines (make-hash)) + (define pending-xs (guide-guides (skip-list-ref guides top-para))) + + ;; initialize `pending-lines` hash, which is a bit complex in + ;; the case that we're not starting from the top of the file. + ;; so, in the fear that it might take a noticeable amount of time + ;; we cache the result (in a cache of size 1) + (cond + [(equal? initial-pending-lines-cache-key (cons top-para pending-xs)) + (set! pending-lines (hash-copy initial-pending-lines-cache))] + [else + (set! initial-pending-lines-cache-key (cons top-para pending-xs)) + (let loop ([pending-xs (reverse pending-xs)] + [para top-para]) + (unless (null? pending-xs) + (when (< para 0) + (error 'text-indent-guides.rkt::internal-error + "did not find the starting editor-coordinate x and para for lines at ~s" + pending-xs)) + (define g (skip-list-ref guides para)) + (cond + [(and (guide-indent g) (= (guide-indent g) (car pending-xs))) + (hash-set! pending-lines (guide-indent g) (cons (guide-x g) top-para)) + (loop (cdr pending-xs) (- para 1))] + [else + (loop pending-xs (- para 1))]))) + (set! initial-pending-lines-cache (hash-copy pending-lines))]) + + (for ([para (in-range top-para (+ bot-para 1))]) + (define guide (skip-list-ref guides para #f)) + (define new-pending-xs + (let loop ([pending-xs pending-xs] + [guide-xs (guide-guides guide)]) + (cond + [(null? guide-xs) + ;; the remaining pending-xs have ended, draw the actual lines + (draw-ended-pending-xs draw-a-line pending-xs pending-lines (- para 1)) + '()] + [(null? pending-xs) + ;; the remaining guide-xs are new lines starting + (unless (or (null? guide-xs) + (null? (cdr guide-xs))) + (error 'text-indent-guides.rkt::internal-error + (string-append + "expected only one line to start at a time" + "\n para: ~s\n guide-xs: ~s\n guides:\n ~a") + para + guide-xs + (regexp-replace* + #rx"\n" + (pretty-format (skip-list->list guides) + #:mode 'write) + "\n "))) + (when (pair? guide-xs) + (define x (guide-x (skip-list-ref guides (- para 1)))) + (hash-set! pending-lines (car guide-xs) (cons x para))) + guide-xs] + [else + (unless (= (car pending-xs) (car guide-xs)) + (error 'text-indent-guides.rkt::internal-error + "pending-xs started with ~a but guide-xs started with ~a" + (car pending-xs) + (car guide-xs))) + (cons (car pending-xs) (loop (cdr pending-xs) (cdr guide-xs)))]))) + (set! pending-xs new-pending-xs)) + ;; here all of the remainding pending lines have finished (possibly because + ;; we're redrawing only a portion the screen), so draw them. + (draw-ended-pending-xs draw-a-line pending-xs pending-lines bot-para)) + + (define/private (draw-ended-pending-xs draw-a-line finished-xs pending-lines para) + (for ([finished-x (in-list finished-xs)]) + (match-define (cons x-in-editor-coordinates y-start) (hash-ref pending-lines finished-x)) + ;; this line no longer has the guide, end at the previous para + (define line-to-start-drawing-at y-start) + (draw-a-line x-in-editor-coordinates finished-x line-to-start-drawing-at para) + (hash-remove! pending-lines finished-x))) + + (define/private (draw-a-line dc dx dy x-in-editor-coordinates x y-start y-end) + (define by (box 0)) + (let loop ([y y-start]) + (when (<= y y-end) + (define sp (paragraph-start-position y)) + (position-location sp #f by #t #f #t) + (define sy (unbox by)) + (define ep (paragraph-start-position y)) + (position-location ep #f by #f #f #t) + (define ey (unbox by)) + (send dc draw-line + ;; subtract 1 to not overlap the insertion point + (+ dx -1 x-in-editor-coordinates) + (+ dy sy) + (+ dx -1 x-in-editor-coordinates) + (+ dy ey (if (= y (last-paragraph)) -1 0))) + (loop (+ y 1)))))))) diff --git a/gui-lib/framework/private/text-inline-overview.rkt b/gui-lib/framework/private/text-inline-overview.rkt index 7a8674ca6..9ddb491bf 100644 --- a/gui-lib/framework/private/text-inline-overview.rkt +++ b/gui-lib/framework/private/text-inline-overview.rkt @@ -23,8 +23,10 @@ (define-unit text-inline-overview@ (import mred^ - [prefix color-prefs: framework:color-prefs^]) + [prefix color-prefs: framework:color-prefs^] + [prefix text: text-max-width-paragraph^]) (export text-inline-overview^) + (init-depend text-max-width-paragraph^) (define transparent-color (make-object color% 255 255 255 0)) (define extra-blue-parts-margin 10) @@ -35,8 +37,13 @@ set-inline-overview-enabled? is-inline-overview-work-pending? )) - (define inline-overview-mixin - (mixin ((class->interface text%)) (inline-overview<%>) + + (define (inline-overview-mixin super%) + (inline-overview-mpw-mixin + (text:max-width-paragraph-mixin super%))) + + (define inline-overview-mpw-mixin + (mixin ((class->interface text%) text:max-width-paragraph<%>) (inline-overview<%>) (define is-do-a-little-work-enqueued? #f) (define invalid-start #f) (define invalid-end #f) @@ -59,7 +66,7 @@ [enabled? (reset-entire-overview)] [else - (invalidate-entire-overview-region #f) + (when (get-admin) (invalidate-entire-overview-region #f)) (set! bmp-width 0) (set! scratch-string #f) (set! primary-bmp #f) @@ -68,7 +75,8 @@ (define/private (reset-entire-overview) (define h (last-paragraph)) - (update-bmp-width 0 h) + (define previous-bmp-width bmp-width) + (update-bmp-width) (define to-create-h (+ h 20)) (unless (and primary-bmp (= (send primary-bmp get-width) bmp-width) @@ -76,9 +84,14 @@ (set! primary-bmp (unsafe:make-bitmap bmp-width to-create-h)) (set! secondary-bmp (unsafe:make-bitmap bmp-width to-create-h)) (set! known-blank 0)) + (when (and (> previous-bmp-width bmp-width) (get-admin)) + (invalidate-entire-overview-region + #t + #:extra-left-width + (- previous-bmp-width bmp-width))) (union-invalid 0 h) (maybe-queue-do-a-little-work?)) - + (define/public (get-primary-bmp) primary-bmp) (define/public (get-secondary-bmp) secondary-bmp) @@ -92,6 +105,15 @@ (inner (void) after-load-file success?) (set! loading-file? #f) (reset-entire-overview)) + + (define/augment (after-max-width-paragraph-change) + (when enabled? + ;; this guard on `enabled?` ensures that we don't ask for + ;; the width of the widest line (which can be slow) when + ;; the bitmap overview is not shown + (when (bitmap-too-big?) + (reset-entire-overview))) + (inner (void) after-max-width-paragraph-change)) (define/augment (after-insert start len) (inner (void) after-insert start len) @@ -183,6 +205,17 @@ (union-invalid ps pe) (maybe-queue-do-a-little-work?))) + (define style-has-changed-callback-pending? #f) + (define/override (style-has-changed s) + (unless style-has-changed-callback-pending? + (set! style-has-changed-callback-pending? #t) + (queue-callback + (λ () + (set! style-has-changed-callback-pending? #f) + (reset-entire-overview)) + #f)) + (super style-has-changed s)) + (define last-time-on-paint-called #f) (define/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) @@ -211,11 +244,23 @@ (- top-paragraph bitmap-first-visible-paragraph)) (+ extra-blue-parts-margin (send primary-bmp get-width)) visible-height) + (define top-region-to-skip + (if (<= bitmap-y-coordinate top (+ bitmap-y-coordinate view-height)) + (- top bitmap-y-coordinate) + 0)) + (define bottom-region-to-skip + (if (<= bitmap-y-coordinate bottom (+ bitmap-y-coordinate view-height)) + (- (+ bitmap-y-coordinate view-height) bottom) + 0)) (send dc draw-bitmap-section primary-bmp (+ dx bitmap-x-coordinate) - (+ dy bitmap-y-coordinate) - 0 bitmap-first-visible-paragraph - (send primary-bmp get-width) view-height) + (+ dy bitmap-y-coordinate top-region-to-skip) + 0 + (+ bitmap-first-visible-paragraph top-region-to-skip) + (send primary-bmp get-width) + (- view-height + top-region-to-skip + bottom-region-to-skip)) (send dc set-brush old-brush) (send dc set-pen old-pen)))) @@ -225,9 +270,10 @@ ;; we a scroll happens, we need to redraw ;; the the entire overview region, as scrolling ;; invalidates only the newly exposed region - (invalidate-entire-overview-region #f))) + (when (get-admin) + (invalidate-entire-overview-region #f)))) - (define/private (invalidate-entire-overview-region just-union?) + (define/private (invalidate-entire-overview-region just-union? #:extra-left-width [extra-left-width 0]) (define-values (view-height bitmap-first-visible-paragraph top-paragraph @@ -235,8 +281,8 @@ bitmap-x-coordinate bitmap-y-coordinate) (get-bitmap-placement-info)) - (define x (- bitmap-x-coordinate extra-blue-parts-margin)) - (define w (+ bmp-width extra-blue-parts-margin)) + (define x (- bitmap-x-coordinate extra-blue-parts-margin extra-left-width)) + (define w (+ bmp-width extra-left-width extra-blue-parts-margin)) (cond [just-union? (union-region-to-invalidate x @@ -388,7 +434,8 @@ set-position scroll-editor-to begin-edit-sequence - end-edit-sequence) + end-edit-sequence + get-max-width-paragraph) (define/private (xy-to-paragraph x y) (position-paragraph (find-position x y))) @@ -413,14 +460,19 @@ (define/private (clear-invalid) (set! invalid-start #f) (set! invalid-end #f)) - - (define/private (update-bmp-width ps pe) - ;; initialize this to `1` so that we always have a non-empty bitmap - (define text-width 1) - (for ([i (in-range ps (+ 1 pe))]) - (define w (- (paragraph-end-position i) (paragraph-start-position i))) - (set! text-width (max text-width w))) - (when (> text-width bmp-width) + + (define/private (bitmap-too-big?) + (define mwp (get-max-width-paragraph)) + (define text-width (- (paragraph-end-position mwp) + (paragraph-start-position mwp))) + (< (+ text-width 50) bmp-width)) + + (define/private (update-bmp-width) + (define mwp (get-max-width-paragraph)) + ;; use `max` to ensure that we always have a non-empty bitmap + (define text-width (max 1 (- (paragraph-end-position mwp) + (paragraph-start-position mwp)))) + (unless (<= text-width bmp-width (+ text-width 40)) (set! bmp-width (min maximum-bitmap-width (+ 20 text-width)))) (when (or (not scratch-string) (< (string-length scratch-string) bmp-width)) @@ -458,7 +510,12 @@ [width-could-have-changed-since-last-do-a-little-work? (set! width-could-have-changed-since-last-do-a-little-work? #f) (define previous-bmp-width bmp-width) - (update-bmp-width invalid-start invalid-end) + (update-bmp-width) + (when (and (get-admin) (> previous-bmp-width bmp-width)) + ;; if the bitmap gets narrower, + ;; the invalidate-entire-overview-region + ;; below won't invalidate a big enough region + (invalidate-entire-overview-region #t #:extra-left-width (- previous-bmp-width bmp-width))) (not (= previous-bmp-width bmp-width))] [else #f])) (when bmp-width-changed? diff --git a/gui-lib/framework/private/text-line-numbers.rkt b/gui-lib/framework/private/text-line-numbers.rkt index eb1d8192e..1d84b47ae 100644 --- a/gui-lib/framework/private/text-line-numbers.rkt +++ b/gui-lib/framework/private/text-line-numbers.rkt @@ -67,8 +67,8 @@ (send padding-dc set-font (get-style-font)) (define-values (padding-left padding-top padding-right padding-bottom) (get-padding)) (define new-padding (text-width padding-dc (number-space+1))) - (set-padding new-padding 0 0 0) (unless (= padding-left new-padding) + (set-padding new-padding 0 0 0) (invalidate-bitmap-cache))] [else (set-padding 0 0 0 0)])) @@ -95,7 +95,7 @@ (define notify-registered-in-list #f) (define style-change-notify - (lambda (style) (unless style (setup-padding)))) + (lambda (style) (setup-padding))) (define/private (get-style) (let* ([style-list (editor:get-standard-style-list)] diff --git a/gui-lib/framework/private/text-max-width-paragraph.rkt b/gui-lib/framework/private/text-max-width-paragraph.rkt new file mode 100644 index 000000000..2fc17a36c --- /dev/null +++ b/gui-lib/framework/private/text-max-width-paragraph.rkt @@ -0,0 +1,118 @@ +#lang racket/base + +(require racket/class + "sig.rkt" + mred/mred-sig + racket/unit + "text-sig.rkt") + +(provide text-max-width-paragraph@) + +(define-unit text-max-width-paragraph@ + (import mred^ + text-basic^ + [prefix editor: framework:editor^] + [prefix frame: framework:frame^]) + (export text-max-width-paragraph^) + + (define max-width-paragraph<%> + (interface () + get-max-width-paragraph + after-max-width-paragraph-change)) + + (define max-width-paragraph-mixin + (mixin ((class->interface text%)) (max-width-paragraph<%>) + (inherit last-paragraph + paragraph-end-position + paragraph-start-position + position-paragraph) + + (define max-width-paragraph #f) + (define max-width #f) + (define mpw-changed-in-on-delete? #f) + + (define/public-final (get-max-width-paragraph) + (unless max-width-paragraph + (calc-max-width-paragraph)) + max-width-paragraph) + + (define/private (set-max-widths _max-width-paragraph _max-width) + (set! max-width-paragraph _max-width-paragraph) + (set! max-width _max-width)) + + (define/augment (after-insert start len) + (inner (void) after-insert start len) + (define insert-start-para (position-paragraph start)) + (define insert-end-para (position-paragraph (+ start len))) + (cond + [max-width-paragraph + (cond + [(< insert-start-para insert-end-para) + ;; multi-paragraph insertion, just give up on the cache + (set-max-widths #f #f) + (after-max-width-paragraph-change)] + [(= insert-start-para max-width-paragraph) + ;; we made the max paragraph wider + (set-max-widths insert-start-para (get-paragraph-width max-width-paragraph)) + (after-max-width-paragraph-change)] + [else + ;; made some other paragraph wider + (define paragraph-new-width (get-paragraph-width insert-start-para)) + ;; if it got wider than the previous max one or the same but earlier + ;; in the file, it is the new widest + (when (or (and (= max-width paragraph-new-width) + (< insert-start-para max-width-paragraph)) + (< max-width paragraph-new-width)) + (set-max-widths insert-start-para + paragraph-new-width) + (after-max-width-paragraph-change))])] + [else + (after-max-width-paragraph-change)])) + + (define/augment (on-delete start len) + (inner (void) on-delete start len) + (define delete-start-para (position-paragraph start)) + (define delete-end-para (position-paragraph (+ start len))) + (cond + [max-width-paragraph + (cond + [(< delete-start-para delete-end-para) + ;; multi-paragraph deletion, just give up on the cache + (set-max-widths #f #f) + (set! mpw-changed-in-on-delete? #t)] + [(= delete-start-para max-width-paragraph) + ;; we made the max paragraph narrower + (set-max-widths #f #f) + (set! mpw-changed-in-on-delete? #t)] + [else + ;; made some other paragraph narrower + (void)])] + [else + (set! mpw-changed-in-on-delete? #t)])) + + (define/augment (after-delete start len) + (inner (void) after-delete start len) + (when mpw-changed-in-on-delete? + (set! mpw-changed-in-on-delete? #f) + (after-max-width-paragraph-change))) + + (define/private (get-paragraph-width para) + (- (paragraph-end-position para) + (paragraph-start-position para))) + + (define/private (calc-max-width-paragraph) + (set!-values + (max-width max-width-paragraph) + (for/fold ([width 0] + [para-with-max-width 0]) + ([this-para (in-inclusive-range 0 (last-paragraph))]) + (define this-width (get-paragraph-width this-para)) + (cond + [(<= this-width width) + (values width para-with-max-width)] + [else + (values this-width this-para)])))) + + (define/pubment (after-max-width-paragraph-change) + (inner (void) after-max-width-paragraph-change)) + (super-new)))) diff --git a/gui-lib/framework/private/text-port.rkt b/gui-lib/framework/private/text-port.rkt index 2d4cfd9ca..e4ffbd8f5 100644 --- a/gui-lib/framework/private/text-port.rkt +++ b/gui-lib/framework/private/text-port.rkt @@ -1,9 +1,13 @@ #lang racket/base (require "sig.rkt" "text-sig.rkt" + (prefix-in base: racket/base) + simple-tree-text-markup/data + (only-in simple-tree-text-markup/construct markup-transform-image-data) racket/unit racket/class racket/match + racket/draw mred/mred-sig mrlib/interactive-value-port (prefix-in image-core: mrlib/image-core)) @@ -14,7 +18,10 @@ text-basic^ (except text-mixed-in-classes^ keymap%) [prefix icon: framework:icon^] - [prefix editor: framework:editor^]) + [prefix editor: framework:editor^] + [prefix srcloc-snip: framework:srcloc-snip^] + [prefix number-snip: framework:number-snip^] + [prefix text: text-misc^]) (export text-port^) (define wide-snip<%> @@ -63,6 +70,15 @@ get-box-input-editor-snip% get-box-input-text%)) + ;; class for snips embedded in markup + (define markup-text% + (text:foreground-color-mixin + (wide-snip-mixin + (basic-mixin + (editor:standard-style-list-mixin + (editor:basic-mixin + text%)))))) + (define-struct peeker (bytes skip-count pe resp-chan nack polling?) #:inspector (make-inspector)) (define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack)) @@ -197,7 +213,9 @@ get-styles-fixed set-styles-fixed auto-wrap - get-autowrap-bitmap-width) + get-autowrap-bitmap-width + grapheme-position + position-grapheme) ;; private field (define eventspace (current-eventspace)) @@ -272,9 +290,18 @@ (channel-put box-read-chan (cons eof (position->line-col-pos unread-start-point)))) (define/public-final (clear-input-port) (channel-put clear-input-chan (void))) (define/public-final (clear-box-input-port) (channel-put box-clear-input-chan (void))) - (define/public-final (clear-output-ports) - (channel-put clear-output-chan (void)) + (define/public-final (clear-output-ports) + (set! clear-counter (+ clear-counter 1)) + (channel-put clear-output-chan clear-counter) (init-output-ports)) + + ;; clear-counter : natural? + ;; this is incremented each time `clear-output-ports` is called; each queue'd + ;; insertion checks to make sure that it has the same value of clear-counter + ;; as the current value, and just drops its insertions if it doesn't. This + ;; makes killing the interactions window in DrRacket more responsive when + ;; there is a lot of output pending + (define clear-counter 0) ;; delete/io: number number -> void (define/public-final (delete/io start end) @@ -300,9 +327,9 @@ (set! unread-start-point (+ unread-start-point len)) (let ([before-allowed? allow-edits?]) (set! allow-edits? #t) - (insert str start start #f) + (insert str start start #f #t) (when style - (change-style (add-standard style) start (+ start len))) + (change-style (add-standard style) (grapheme-position (position-grapheme start)) (+ start len))) (set! allow-edits? before-allowed?))) (define/public-final (get-in-port) @@ -334,7 +361,7 @@ (define/public (get-box-input-editor-snip%) use-style-background-editor-snip%) (define/public (get-box-input-text%) input-box%) - + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; editor integration @@ -490,29 +517,31 @@ (define flush-chan/diy (make-channel)) (define flush-chan/queue (make-channel)) - ;; clear-output-chan : (channel void) + ;; clear-output-chan : (channel natural?) (define clear-output-chan (make-channel)) ;; write-chan : (channel (cons (union snip bytes) style)) ;; send output to the editor (define write-chan (make-channel)) - ;; readers-chan : (channel (list (channel (union byte snip)) - ;; (channel ...))) - (define readers-chan (make-channel)) - - ;; queue-insertion : (listof (cons (union string snip) style)) evt -> void + ;; queue-insertion : (listof (cons (union string snip) style)) evt natural? -> void ;; txt is in the reverse order of the things to be inserted. ;; the evt is waited on when the text has actually been inserted ;; thread: any thread, except the eventspace main thread - (define/private (queue-insertion txts signal #:async? [async? #f]) + ;; the `queue-time-clear-counter` argument is the clear-counter from the + ;; time that this IO was produced; if it isn't the same as the counter + ;; at the time we're going to insert, we just skip the insertion. + (define/private (queue-insertion txts signal queue-time-clear-counter #:async? [async? #f]) (parameterize ([current-eventspace eventspace]) (queue-callback (λ () - (do-insertion txts #f) + (when (= queue-time-clear-counter clear-counter) + (do-insertion txts #f)) (if async? (thread (λ () (sync signal))) (sync signal))) #f))) - + + (inherit line-start-position position-line) + ;; do-insertion : (listof (cons (union string snip) style-delta)) boolean -> void ;; thread: eventspace main thread (define/private (do-insertion txts showing-input?) @@ -527,50 +556,169 @@ [(null? txts) (void)] [else (define fst (car txts)) - (define-values (str/snp style) + + (define (markup->snip markup style framed?) + (let* ([text (new markup-text%)] + [snip (new editor-snip% [editor text] [with-border? framed?])]) + (send snip use-style-background #t) + (send text set-styles-sticky #f) + (define start (send text get-end-position)) + (insert-markup markup text style #f) + (send snip set-style style) + (send text lock #t) + snip)) + + (define (insert-markup markup text style inline?) (cond - [(snip-special? (car fst)) - (define the-snip - (snip-special->snip (car fst))) - (if (exn:fail? the-snip) - (values (apply - string-append - "error while rendering snip " - (format "~s" (snip-special-name (car fst))) - ":\n" - (exn-message the-snip) - " context:\n" - (for/list ([x (in-list (continuation-mark-set->context - (exn-continuation-marks - the-snip)))]) - (format " ~s\n" x))) - (add-standard error-style-name)) - (values the-snip (cdr fst)))] - [else (values (car fst) (cdr fst))])) - - (define inserted-count - (if (is-a? str/snp snip%) - (send str/snp get-count) - (string-length str/snp))) - (define old-insertion-point insertion-point) - (set! insertion-point (+ insertion-point inserted-count)) - (set! unread-start-point (+ unread-start-point inserted-count)) - - (insert (if (is-a? str/snp snip%) - (let ([s (send str/snp copy)]) - (if (is-a? s snip%) - s - (new snip%))) - str/snp) - old-insertion-point - old-insertion-point - #t) - - ;; the idea here is that if you made a string snip, you - ;; could have made a string and gotten the style, so you - ;; must intend to have your own style. - (unless (is-a? str/snp string-snip%) - (change-style style old-insertion-point insertion-point)) + ((string? markup) + (send text insert markup)) + ((empty-markup? markup) (void)) + ((horizontal-markup? markup) + (for-each (lambda (markup) + (insert-markup markup text style #t)) + (horizontal-markup-markups markup))) + ((vertical-markup? markup) + (if inline? + (send text insert (markup->snip markup style #f)) + (for-each/between (lambda (markup) + (insert-markup markup text style #f)) + (lambda () (send text insert #\newline)) + (vertical-markup-markups markup)))) + ((srcloc-markup? markup) + (insert-srcloc-markup markup text style)) + ((framed-markup? markup) + (send text insert (markup->snip (framed-markup-markup markup) style #t))) + ((image-markup? markup) + (send text insert (image-markup->snip markup style))) + ((number-markup? markup) + (define snip (number-snip:number->string/snip (number-markup-number markup) + #:exact-prefix (number-markup-exact-prefix markup) + #:inexact-prefix (number-markup-inexact-prefix markup) + #:fraction-view (number-markup-fraction-view markup))) + (send snip set-style style) + (send text insert snip)))) + + (define (image-markup->snip markup style) + (let ((data (image-markup-data markup))) + (cond + ((is-a? data snip%) + (send data set-style style) + data) + ((snip-special? data) + (define snip (snip-special->snip data)) + (send snip set-style style) + (if (exn:fail? snip) + (markup->snip (image-markup-alt-markup markup) style #f) + snip)) + (else + (markup->snip (image-markup-alt-markup markup) style #f))))) + + (define (insert-srcloc-markup srcloc-markup text style) + (let ((start (send text get-end-position))) + (insert-markup (srcloc-markup-markup srcloc-markup) text style #t) + (let ([end (send text get-end-position)]) + (send text set-clickback + start end + (lambda (t s e) + (srcloc-snip:select-srcloc (srcloc-markup-srcloc srcloc-markup)))) + (send text change-style + (make-object style-delta% 'change-underline #t) + start end #f)))) + + ; like for-each, but with a thunk that gets called between elements + (define (for-each/between proc between list) + (let loop ((list list)) + (cond + ((null? list) (void)) + ((null? (cdr list)) + (proc (car list))) + (else + (proc (car list)) + (between) + (loop (cdr list)))))) + + (define (insert-str/snp! str/snp style) + (define inserted-count + (if (is-a? str/snp snip%) + (send str/snp get-count) + (string-length str/snp))) + (define old-insertion-point insertion-point) + (set! insertion-point (+ insertion-point inserted-count)) + (set! unread-start-point (+ unread-start-point inserted-count)) + + (if (string? str/snp) + (insert str/snp old-insertion-point old-insertion-point #t #t) + (insert str/snp old-insertion-point old-insertion-point #t)) + ;; the idea here is that if you made a string snip, you + ;; could have made a string and gotten the style, so you + ;; must intend to have your own style. + (unless (is-a? str/snp string-snip%) + (change-style style (grapheme-position (position-grapheme old-insertion-point)) insertion-point))) + + (define (insert-markup-top-level markup style) + (cond + [(string? markup) (insert-str/snp! markup style)] + [(empty-markup? markup) (void)] + [(horizontal-markup? markup) + (for-each (lambda (markup) + (insert-markup-top-level markup style)) + (horizontal-markup-markups markup))] + [(vertical-markup? markup) + (define pos (get-end-position)) + (if (= pos (line-start-position (position-line pos))) ; at bol? + (for-each/between (lambda (markup) + (insert-markup-top-level markup style)) + (lambda () (insert-str/snp! "\n" style)) + (vertical-markup-markups markup)) + (insert-str/snp! (markup->snip markup style #f) style))] + [(srcloc-markup? markup) + (let* ([snip (new srcloc-snip:snip% [srcloc (srcloc-markup-srcloc markup)])] + [editor (send snip get-editor)]) + (insert-markup (srcloc-markup-markup markup) editor style #t) + (let ((end (send editor get-end-position))) + (send editor change-style style 0 end #f) + (send editor change-style + (make-object style-delta% 'change-underline #t) + 0 end #f)) + (send snip activate-link) + (insert-str/snp! snip style))] + [(framed-markup? markup) + (insert-str/snp! (markup->snip (framed-markup-markup markup) style #t) style)] + [(image-markup? markup) + (insert-str/snp! (image-markup->snip markup style) style)] + [(number-markup? markup) + (insert-str/snp! (number-snip:number->string/snip (number-markup-number markup) + #:exact-prefix (number-markup-exact-prefix markup) + #:inexact-prefix (number-markup-inexact-prefix markup) + #:fraction-view (number-markup-fraction-view markup)) + style)])) + + (define thing (car fst)) + (define style (cdr fst)) + + (cond + [(snip-special? thing) + (define the-snip + (snip-special->snip thing)) + (if (exn:fail? the-snip) + (insert-str/snp! (apply + string-append + "error while rendering snip " + (format "~s" (snip-special-name thing)) + ":\n" + (exn-message the-snip) + " context:\n" + (for/list ([x (in-list (continuation-mark-set->context + (exn-continuation-marks + the-snip)))]) + (format " ~s\n" x))) + (add-standard error-style-name)) + (insert-str/snp! the-snip style))] + [(string? thing) (insert-str/snp! thing style)] + [(markup? thing) (insert-markup-top-level thing style)] + [(is-a? thing snip%) (insert-str/snp! (send thing copy) style)] + [else (void)]) + (loop (cdr txts))])) (set-styles-fixed sf?) (set! allow-edits? #f) @@ -583,6 +731,7 @@ (end-edit-sequence) (unless (null? txts) (after-io-insertion))) + (define/public (after-io-insertion) (void)) @@ -591,7 +740,8 @@ (define (output-buffer-thread) (let loop (;; text-to-insert : (queue (cons (union snip bytes) style)) [text-to-insert (empty-at-queue)] - [last-flush (current-inexact-milliseconds)]) + [last-flush (current-inexact-milliseconds)] + [clear-counter 0]) (sync (if (at-queue-empty? text-to-insert) never-evt @@ -602,8 +752,8 @@ (split-queue converter text-to-insert)) ;; we always queue the work here since the ;; always event means no one waits for the callback - (queue-insertion viable-bytes always-evt) - (loop remaining-queue (current-inexact-milliseconds))))) + (queue-insertion viable-bytes always-evt clear-counter) + (loop remaining-queue (current-inexact-milliseconds) clear-counter)))) (handle-evt flush-chan/diy (λ (return-evt/to-insert-chan) @@ -619,7 +769,7 @@ (set! remaining-queue next-remaining-queue) (list viable-bytes)]))) (channel-put return-evt/to-insert-chan viable-bytess) - (loop remaining-queue (current-inexact-milliseconds)))) + (loop remaining-queue (current-inexact-milliseconds) clear-counter))) (handle-evt flush-chan/queue (λ (return-evt/to-insert-chan) @@ -629,17 +779,17 @@ (split-queue converter q)) (cond [flush-keep-trying? - (queue-insertion viable-bytes always-evt) + (queue-insertion viable-bytes always-evt clear-counter) (loop next-remaining-queue)] [else (set! remaining-queue next-remaining-queue) - (queue-insertion viable-bytes return-evt/to-insert-chan #:async? #t) + (queue-insertion viable-bytes return-evt/to-insert-chan clear-counter #:async? #t) #f])) - (loop remaining-queue (current-inexact-milliseconds)))) + (loop remaining-queue (current-inexact-milliseconds) clear-counter))) (handle-evt clear-output-chan - (λ (_) - (loop (empty-at-queue) (current-inexact-milliseconds)))) + (λ (new-counter) + (loop (empty-at-queue) (current-inexact-milliseconds) new-counter))) (handle-evt write-chan (λ (pr-pr) @@ -653,7 +803,8 @@ (loop new-text-to-insert (if (at-queue-empty? text-to-insert) (current-inexact-milliseconds) - last-flush))] + last-flush) + clear-counter)] [else (define-values (viable-bytes remaining-queue flush-keep-trying?) (split-queue converter new-text-to-insert)) @@ -662,9 +813,9 @@ (channel-put return-chan viable-bytes)] [else (define chan (make-channel)) - (queue-insertion viable-bytes (channel-put-evt chan (void))) + (queue-insertion viable-bytes (channel-put-evt chan (void)) clear-counter) (channel-get chan)]) - (loop remaining-queue (current-inexact-milliseconds))]))))))) + (loop remaining-queue (current-inexact-milliseconds) clear-counter)]))))))) (thread output-buffer-thread)) (field [in-port-args #f] @@ -720,23 +871,29 @@ (define (out-close-proc) (void)) - + (define (make-write-special-proc style) (λ (special can-buffer? enable-breaks?) - (define str/snp (cond - [(string? special) special] - [(snip-special? special) special] - [(is-a? special snip%) special] - [else (format "~s" special)])) - (define to-send (cons str/snp style)) - (cond - [(eq? (current-thread) (eventspace-handler-thread eventspace)) - (define return-chan (make-channel)) - (thread (λ () (channel-put write-chan (cons return-chan to-send)))) - (do-insertion (channel-get return-chan) #f)] - [else - (channel-put write-chan (cons #f to-send))]) - #t)) + (define do-put + (cond + [(eq? (current-thread) (eventspace-handler-thread eventspace)) + (define return-chan (make-channel)) + (lambda (str/snp) + (thread (λ () (channel-put write-chan (cons return-chan (cons str/snp style))))) + (do-insertion (channel-get return-chan) #f))] + [else + (lambda (str/snp) + (channel-put write-chan (cons #f (cons str/snp style))))])) + + (define (put-special special) + (cond + [(string? special) (do-put special)] + [(snip-special? special) (do-put special)] + [(is-a? special snip%) (do-put special)] + [(markup? special) (do-put (markup-transform-image-data encode-image-data special))] + [else (do-put (format "~s" special))])) + + (put-special special))) (let ([out-style (add-standard (get-out-style-delta))] [err-style (add-standard (get-err-style-delta))] @@ -925,6 +1082,47 @@ (write-special (make-snip-special (send value copy)) port)])]) (void)) + (define (encode-image-data value) + (when (image-core:image? value) + (image-core:compute-image-cache value)) + ; Note that image-core:image? is not an appropriate predicate here + ; to control serialization, as it just checks subtyping for + ; various classes and interfaces, which anyone could implement. + (cond + [(is-a? value snip%) + (define str (format "~s" value)) + (cond + ;; special case these snips as they don't work properly + ;; without this and we aren't ready to break them yet + ;; and image-core:image? should be safe-- there is no user + ;; code in those images to fail + [(or (regexp-match? #rx"plot-snip%" str) + (regexp-match? #rx"pict3d%" str)) + (send value copy)] + [else + (define special (make-snip-special (send value copy))) + (and (snip-special-name special) + special)])] + [(is-a? value bitmap%) + (define w (send value get-width)) + (define h (send value get-height)) + (define copy (make-object bitmap% w h + (= (send value get-depth) 1) + (send value has-alpha-channel?) + (send value get-backing-scale))) + (define pixels (make-bytes (* w h 4))) + (send value get-argb-pixels 0 0 w h pixels) + (send copy set-argb-pixels 0 0 w h pixels) + (make-object image-snip% copy)] + [(record-dc-datum? value) + (with-handlers ((exn:fail? (lambda (e) #f))) + (let ((proc (recorded-datum->procedure (record-dc-datum-datum value))) + (bitmap (make-object bitmap% (record-dc-datum-width value) (record-dc-datum-height value)))) + (let ((dc (new bitmap-dc% [bitmap bitmap] ))) + (proc dc) + (make-object image-snip% bitmap))))] + [else #f])) + (define input-box<%> (interface ((class->interface text%)) )) @@ -1083,11 +1281,16 @@ (λ (v) (let* ([nth (at-peek-n data (- kr 1))] [nth-pos (cdr nth)]) + (define ch (car nth)) (set! position - (if (eof-object? (car nth)) + (if (eof-object? ch) nth-pos - (list (car nth-pos) - (+ 1 (cadr nth-pos)) + (list (if (eqv? ch (char->integer #\newline)) + (add1 (car nth-pos)) + (car nth-pos)) + (if (eqv? ch (char->integer #\newline)) + 0 + (+ 1 (cadr nth-pos))) (+ 1 (caddr nth-pos)))))) (set! data (at-dequeue-n data kr)) (semaphore-post peeker-sema) diff --git a/gui-lib/framework/private/text-search.rkt b/gui-lib/framework/private/text-search.rkt index e3ca9e1df..3c316344e 100644 --- a/gui-lib/framework/private/text-search.rkt +++ b/gui-lib/framework/private/text-search.rkt @@ -3,6 +3,8 @@ (require racket/unit racket/class racket/list + racket/match + racket/dict mred/mred-sig "coroutine.rkt" "sig.rkt" @@ -16,6 +18,7 @@ [prefix frame: framework:frame^] [prefix editor: framework:editor^] [prefix keymap: framework:keymap^] + [prefix color-prefs: framework:color-prefs^] text-basic^) (export text-search^) @@ -39,6 +42,51 @@ (f (send normal-search-color blue))))) (define white-on-black-yellow-bubble-color (make-object color% 50 50 5)) + (define-local-member-name + when-searching-str-redo-search + position-possibly-in-embedded-editor-changed) + + (define searching-embedded<%> + (interface () + )) + + (define searching-embedded-mixin + (mixin ((class->interface text%)) (searching-embedded<%>) + (inherit get-admin) + ;; also need to call position-possibly-in-embedded-editor-changed + ;; when the text gets the focus from its + ;; enclosing editor-snip + (define/augment (after-insert start len) + (need-searching-update 'insert) + (inner (void) after-insert start len)) + (define/augment (after-delete start len) + (need-searching-update 'delete) + (inner (void) after-delete start len)) + (define/augment (after-set-position) + (need-searching-update 'set-position) + (inner (void) after-set-position)) + + (define/private (need-searching-update what) + (let loop ([txt this]) + (define txt-admin (send txt get-admin)) + (cond + [(is-a? txt-admin editor-snip-editor-admin<%>) + (define snip (send txt-admin get-snip)) + (define snip-admin (send snip get-admin)) + (when snip-admin + (define ed (send snip-admin get-editor)) + (loop ed))] + [else + (when (is-a? txt searching<%>) + (match what + ['insert + (send txt when-searching-str-redo-search)] + ['delete + (send txt when-searching-str-redo-search)] + ['set-position + (send txt position-possibly-in-embedded-editor-changed)]))]))) + (super-new))) + (define searching-mixin (mixin (editor:basic<%> editor:keymap<%> basic<%>) (searching<%>) (inherit get-start-position get-end-position @@ -64,7 +112,11 @@ ;; (and thus we have light/dark bubbles) (define replace-mode? #f) - ;; to-replace-highlight : (or/c #f (cons/c number number)) + ;; to-replace-highlight : + #;(or/c #f + (cons/c (list*of (is-a?/c text%) + natural?) + natural?)) ;; the location where the next replacement will happen, or #f ;; if there isn't one (in case the insertion point is past ;; the last search hit, or replace-mode? is #f) @@ -75,9 +127,9 @@ ;; search-bubble-table : hash-table[(cons number number) -o> #t] (define search-bubble-table (make-hash)) - ;; get-replace-search-hit : -> (or/c number #f) + ;; get-replace-search-hit : -> (or/c (list*of (is-a?/c text%) natural?) #f) ;; returns the nearest search hit after `replace-start' - (define/public (get-replace-search-hit) + (define/public (get-replace-search-hit) (and searching-str to-replace-highlight (car to-replace-highlight))) @@ -119,14 +171,16 @@ (define/override (get-keymaps) (editor:add-after-user-keymap (keymap:get-search) (super get-keymaps))) - - (define/augment (after-insert start len) + + (define/public (when-searching-str-redo-search) (when searching-str - (redo-search #t)) + (redo-search #t))) + + (define/augment (after-insert start len) + (when-searching-str-redo-search) (inner (void) after-insert start len)) (define/augment (after-delete start len) - (when searching-str - (redo-search #t)) + (when-searching-str-redo-search) (inner (void) after-delete start len)) (define/override (on-focus on?) @@ -141,10 +195,13 @@ (update-yellow)]))) (super on-focus on?)) - (define/augment (after-set-position) + (define/public (position-possibly-in-embedded-editor-changed) (update-yellow) (maybe-queue-update-replace-bubble) - (maybe-queue-search-position-update) + (maybe-queue-search-position-update)) + + (define/augment (after-set-position) + (position-possibly-in-embedded-editor-changed) (inner (void) after-set-position)) (define/private (maybe-queue-update-replace-bubble) @@ -158,8 +215,7 @@ ;; the replace bubble to its proper color ;; before it finishes so we can just let ;; do this job - - + (define (replace-highlight->normal-hit) (when to-replace-highlight (let ([old-to-replace-highlight to-replace-highlight]) @@ -172,7 +228,7 @@ (when to-replace-highlight (unhighlight-replace))] [else - (define next (do-search (get-start-position))) + (define next (do-search (get-focus-editor-start-position))) (begin-edit-sequence #t #f) (cond [next @@ -210,19 +266,21 @@ (queue-callback (λ () (when searching-str - (define start-pos (get-focus-editor-start-position)) - (define (how-many-to-add k) - (if (search-result-compare <= (car k) start-pos) 1 0)) - (define count - (+ (if to-replace-highlight - (how-many-to-add to-replace-highlight) - 0) - (for/sum ([(k v) (in-hash search-bubble-table)]) - (how-many-to-add k)))) - (update-before-caret-search-hit-count count)) + (update-before-caret-search-hit-count + (calculate-before-caret-search-hit-count))) (set! search-position-callback-running? #f)) #f))) + (define/private (calculate-before-caret-search-hit-count) + (define start-pos (get-focus-editor-start-position)) + (define (how-many-to-add k) + (if (search-result-compare <= (car k) start-pos) 1 0)) + (+ (if to-replace-highlight + (how-many-to-add to-replace-highlight) + 0) + (for/sum ([(k v) (in-hash search-bubble-table)]) + (how-many-to-add k)))) + (define/private (get-focus-editor-start-position) (let loop ([txt this]) (define focus (send txt get-focus-snip)) @@ -264,7 +322,7 @@ (when (find-string searching-str 'forward start end #t case-sensitive?) (set! clear-yellow (highlight-range start end - (if (preferences:get 'framework:white-on-black?) + (if (color-prefs:white-on-black-color-scheme?) white-on-black-yellow-bubble-color "khaki") #f 'low 'ellipse)))) @@ -346,15 +404,14 @@ (define new-search-bubbles '()) (define new-replace-bubble #f) (define first-hit (do-search 0)) - - (define-values (this-search-hit-count this-before-caret-search-hit-count) + + ;; TODO (maybe-queue-search-position-update) + (define this-search-hit-count (cond [first-hit (define sp (get-focus-editor-start-position)) (let loop ([bubble-start first-hit] - [search-hit-count 0] - [before-caret-search-hit-count - (if (search-result-compare < first-hit sp) 1 0)]) + [search-hit-count 0]) (maybe-pause) (define bubble-end (search-result+ bubble-start (string-length searching-str))) (define bubble (cons bubble-start (string-length searching-str))) @@ -370,33 +427,16 @@ (set! new-search-bubbles (cons this-bubble new-search-bubbles)) (define next (do-search bubble-end)) - - (when (> (let loop ([x bubble-start]) - (cond - [(number? x) 1] - [else (+ 1 (loop (cdr x)))])) - 3) - ;; the check above is probably an invariant, - ;; but I have lost track of what it means. - (error 'framework/private/text.rkt "something is wrong")) - (define next-before-caret-search-hit-count - (if (and next (search-result-compare < next sp)) - (+ 1 before-caret-search-hit-count) - before-caret-search-hit-count)) (cond [next ;; start a new one if there is another hit - (loop next - (+ search-hit-count 1) - next-before-caret-search-hit-count)] + (loop next (+ search-hit-count 1))] [else - (values (+ search-hit-count 1) - before-caret-search-hit-count)]))] - [else (values 0 0)])) + (+ search-hit-count 1)]))] + [else 0])) (set! search-hit-count this-search-hit-count) - (set! before-caret-search-hit-count this-before-caret-search-hit-count) (maybe-pause) @@ -413,7 +453,8 @@ (highlight-hit search-bubble)]) (maybe-pause)) - (update-yellow) + (update-yellow) + (set! before-caret-search-hit-count (calculate-before-caret-search-hit-count)) (end-edit-sequence)] [else (begin-edit-sequence #t #f) @@ -467,15 +508,21 @@ (lt (get-the-position (car l)) (get-the-position (car r)))])]))) - (define all-txt-with-regions-to-clear (make-hasheq)) + (define all-txt-with-regions-to-clear (make-mutable-object=-hash)) (define/private (clear-all-regions) (when to-replace-highlight (unhighlight-replace)) - (for ([(txt _) (in-hash all-txt-with-regions-to-clear)]) + (for ([(txt _) (in-dict all-txt-with-regions-to-clear)]) (send txt unhighlight-ranges/key 'plt:framework:search-bubbles)) - (set! all-txt-with-regions-to-clear (make-hasheq)) + (set! all-txt-with-regions-to-clear (make-mutable-object=-hash)) (set! search-bubble-table (make-hash))) - + + ;; do-search : context+search-position -> context+search-position + ;; does a search starting at `start` and returning the next + ;; ocurrence of the search string, possibly moving out into + ;; later editors + ;; the context+search-position is list the result of `find-string-embedded`, + ;; except it cannot be #f. (define/private (do-search start) (define context (list this)) (define position @@ -489,14 +536,16 @@ [context context]) (define found-at-this-level (send (car context) find-string-embedded - searching-str 'forward position 'eof #t case-sensitive?)) + searching-str 'forward position 'eof #t case-sensitive? + #:recur-inside? (λ (x) (is-a? (send x get-editor) searching-embedded<%>)))) (cond [found-at-this-level - (let loop ([context context]) + (let loop ([context context] + [acc found-at-this-level]) (cond - [(null? (cdr context)) found-at-this-level] - [else (cons (car context) - (loop (cdr context)))]))] + [(null? (cdr context)) acc] + [else (loop (cdr context) + (cons (car context) acc))]))] [(null? (cdr context)) #f] [else (define admin (send (car context) get-admin)) @@ -530,7 +579,7 @@ (hash-set! search-bubble-table bubble #t) (define-values (txt start end) (get-highlighting-text-and-range bubble)) (when txt - (hash-set! all-txt-with-regions-to-clear txt #t) + (dict-set! all-txt-with-regions-to-clear txt #t) (send txt highlight-range start end (if replace-mode? light-search-color normal-search-color) @@ -586,3 +635,5 @@ (highlight-range anchor-pos anchor-pos "red")) (super-new)))) + +(define-custom-hash-types object=-hash #:key? object? object=? object=-hash-code) diff --git a/gui-lib/framework/private/text-sig.rkt b/gui-lib/framework/private/text-sig.rkt index 5bcf510c0..adb1696ca 100644 --- a/gui-lib/framework/private/text-sig.rkt +++ b/gui-lib/framework/private/text-sig.rkt @@ -1,4 +1,6 @@ -#lang racket +#lang racket/base +(require racket/unit) + (provide text-basic^ text-basic-class^ text-basic-functions^ @@ -10,6 +12,7 @@ text-column-guide^ text-ascii-art^ text-misc^ + text-max-width-paragraph^ text-delegate^ text-port^ text-port-class^ @@ -17,7 +20,8 @@ text-search^ text-first-line^ text-inline-overview^ - text-mixed-in-classes^) + text-mixed-in-classes^ + text-indent-guides^) (define-signature text-basic-class^ (basic<%> @@ -38,6 +42,10 @@ (line-numbers<%> line-numbers-mixin)) +(define-signature text-indent-guides^ + (indent-guides<%> + indent-guides-mixin)) + (define-signature text-autocomplete-class^ (autocomplete<%> autocomplete-mixin)) @@ -84,11 +92,14 @@ (define-signature text-search^ (searching<%> - searching-mixin)) + searching-mixin + searching-embedded<%> + searching-embedded-mixin)) (define-signature text-inline-overview^ (inline-overview<%> - inline-overview-mixin)) + inline-overview-mixin + inline-overview-mpw-mixin)) (define-signature text-first-line^ (first-line<%> @@ -118,6 +129,10 @@ overwrite-disable<%> overwrite-disable-mixin)) +(define-signature text-max-width-paragraph^ + (max-width-paragraph-mixin + max-width-paragraph<%>)) + (define-signature text-mixed-in-classes^ (basic% line-spacing% diff --git a/gui-lib/framework/private/text.rkt b/gui-lib/framework/private/text.rkt index e539f4f14..3e24001c8 100644 --- a/gui-lib/framework/private/text.rkt +++ b/gui-lib/framework/private/text.rkt @@ -10,12 +10,15 @@ "text-delegate.rkt" "text-first-line.rkt" "text-line-numbers.rkt" + "text-indent-guides.rkt" "text-misc.rkt" "text-normalize-paste.rkt" "text-port.rkt" "text-search.rkt" "text-inline-overview.rkt" + "text-max-width-paragraph.rkt" "text-sig.rkt" + "srcloc-snip.rkt" "sig.rkt") (provide text@) @@ -30,7 +33,8 @@ [frame : framework:frame^] [racket : framework:racket^] [number-snip : framework:number-snip^] - [finder : framework:finder^]) + [finder : framework:finder^] + [srcloc-snip : framework:srcloc-snip^]) (export text-ascii-art^ text-autocomplete^ @@ -41,10 +45,12 @@ text-first-line^ text-inline-overview^ text-line-numbers^ + text-indent-guides^ text-misc^ text-normalize-paste^ text-port^ - text-search^) + text-search^ + text-max-width-paragraph^) (link text-ascii-art@ text-autocomplete@ @@ -52,8 +58,10 @@ text-column-guide@ text-delegate@ text-first-line@ + text-max-width-paragraph@ text-inline-overview@ text-line-numbers@ + text-indent-guides@ text-misc@ text-normalize-paste@ text-port@ @@ -71,6 +79,7 @@ framework:racket^ framework:number-snip^ (prefix finder: framework:finder^) + framework:srcloc-snip^ ) (export framework:text^) ((text-ascii-art^ @@ -82,7 +91,9 @@ text-first-line^ text-inline-overview^ text-line-numbers^ + text-indent-guides^ text-misc^ + text-max-width-paragraph^ text-normalize-paste^ text-port^ text-search^) @@ -96,4 +107,5 @@ (prefix frame: framework:frame^) framework:racket^ framework:number-snip^ - (prefix finder: framework:finder^))) + (prefix finder: framework:finder^) + framework:srcloc-snip^)) diff --git a/gui-lib/framework/private/wob-color-scheme.rkt b/gui-lib/framework/private/wob-color-scheme.rkt new file mode 100644 index 000000000..d76a4050d --- /dev/null +++ b/gui-lib/framework/private/wob-color-scheme.rkt @@ -0,0 +1,12 @@ +#lang racket/base +(require racket/match + "../preferences.rkt" + mrlib/panel-wob) + +(provide white-on-black-color-scheme?) +(define (white-on-black-color-scheme?) + (match (preferences:get 'framework:white-on-black-mode?) + ['platform (white-on-black-panel-scheme?)] + [#t #t] + [#f #f])) + diff --git a/gui-lib/framework/splash.rkt b/gui-lib/framework/splash.rkt index 4ce4af2c7..c643848b1 100644 --- a/gui-lib/framework/splash.rkt +++ b/gui-lib/framework/splash.rkt @@ -191,12 +191,13 @@ (unless allow-funny? (set! funny? #f)) (set! splash-title _splash-title) (set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default))) - + (on-splash-eventspace/ret (let/ec k (define (no-splash) (set! splash-bitmap #f) (k (void))) + (set! splash-range-ready? #t) (send (get-gauge) set-range splash-max-width) (send splash-tlw set-label splash-title) @@ -280,12 +281,20 @@ (= (date-day date) 25) (= (date-month date) 12)))) +;; Don't set the guard value until its extent is intialized. +;; Otherwise, a guarge of range 1 gets set to 1, which is full, and +;; then the gauge is changed afterward so that 1 is a tiny fraction, +;; but that makes animation (if any) bounce (on macOS Tahoe, for +;; example) +(define splash-range-ready? #f) + (define (splash-load-handler old-load f expected) (set! splash-current-width (+ splash-current-width 1)) (when (<= splash-current-width splash-max-width) (let ([splash-save-width splash-current-width]) (on-splash-eventspace - (send (get-gauge) set-value splash-save-width) + (when splash-range-ready? + (send (get-gauge) set-value splash-save-width)) (when (or (not (member (get-gauge) (send gauge-panel get-children))) ;; when the gauge is not visible, we'll redraw the canvas regardless (refresh-splash-on-gauge-change? splash-save-width splash-max-width)) diff --git a/gui-lib/framework/srcloc-snip.rkt b/gui-lib/framework/srcloc-snip.rkt new file mode 100644 index 000000000..ad8ed10e2 --- /dev/null +++ b/gui-lib/framework/srcloc-snip.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(require framework) + +(provide (rename-out [srcloc-snip:snipclass snip-class])) diff --git a/gui-lib/framework/test.rkt b/gui-lib/framework/test.rkt index 5af179556..3be3f67ef 100644 --- a/gui-lib/framework/test.rkt +++ b/gui-lib/framework/test.rkt @@ -370,7 +370,8 @@ (find-object radio-box% in-cb) (λ (rb) (cond - [(string? state) + [(or (string? state) + (regexp? state)) (let ([total (send rb get-number)]) (let loop ([n total]) (cond @@ -897,7 +898,9 @@ (test:top-level-focus-window-has? (λ (c) (and (is-a? c button%) - (string=? (send c get-label) str) + (if (string? str) + (string=? (send c get-label) str) + (regexp-match str (send c get-label))) (send c is-enabled?) (send c is-shown?))))) @@ -912,7 +915,8 @@ (provide/doc (proc-doc/names test:button-push - (-> (or/c (and/c string? + (-> (or/c (and/c (or/c string? + regexp?) label-of-enabled/shown-button-in-top-level-window?) (and/c (is-a?/c button%) enabled-shown-button? @@ -940,14 +944,14 @@ (proc-doc/names test:set-radio-box-item! - (-> (or/c string? regexp?) void?) + (-> (or/c (or/c string? regexp?) regexp?) void?) (entry) @{Finds a @racket[radio-box%] that has a label matching @racket[entry] and sets the radio-box to @racket[entry].}) (proc-doc/names test:set-check-box! - (-> (or/c string? (is-a?/c check-box%)) boolean? void?) + (-> (or/c string? regexp? (is-a?/c check-box%)) boolean? void?) (check-box state) @{Clears the @racket[check-box%] item if @racket[state] is @racket[#f], and sets it otherwise. @@ -958,7 +962,7 @@ (proc-doc/names test:set-choice! - (-> (or/c string? (is-a?/c choice%)) (or/c string? (and/c number? exact? integer? positive?)) + (-> (or/c string? regexp? (is-a?/c choice%)) (or/c string? regexp? (and/c number? exact? integer? positive?)) void?) (choice str) @{Selects @racket[choice]'s item @racket[str]. If @racket[choice] is a string, @@ -967,8 +971,8 @@ (proc-doc/names test:set-list-box! - (-> (or/c string? (is-a?/c list-box%)) - (or/c string? exact-nonnegative-integer?) + (-> (or/c string? regexp? (is-a?/c list-box%)) + (or/c string? regexp? exact-nonnegative-integer?) void?) (choice str/index) @{Selects @racket[list-box]'s item @racket[str]. If @racket[list-box] is a string, @@ -1131,10 +1135,10 @@ (proc-doc/names label-of-enabled/shown-button-in-top-level-window? - (-> string? boolean?) + (-> (or/c string? regexp?) boolean?) (label) @{Returns @racket[#t] when @racket[label] is - the label of an enabled and shown + the label (or is a regular expression matching the label) of an enabled and shown @racket[button%] instance that is in the top-level window that currently has the focus, using @racket[test:top-level-focus-window-has?].}) diff --git a/gui-lib/framework/wxme-srcloc-snip.rkt b/gui-lib/framework/wxme-srcloc-snip.rkt new file mode 100644 index 000000000..4edefcad9 --- /dev/null +++ b/gui-lib/framework/wxme-srcloc-snip.rkt @@ -0,0 +1,58 @@ +#lang racket/base +(require racket/class + racket/format + wxme + wxme/private/readable-editor) + +(provide reader) + +(define (datum->source source) + (if (bytes? source) + (bytes->path source) + source)) + +(define (datum->source-expression source) + (if (path? source) + `(bytes->path ,(path->bytes source)) + `',source)) + +(define (srcloc->expression srcloc) + `(srcloc + ,(datum->source-expression (srcloc-source srcloc)) + ,(srcloc-line srcloc) + ,(srcloc-column srcloc) + ,(srcloc-position srcloc) + ,(srcloc-span srcloc))) + +(define editor-reader (new editor-reader%)) + +(define srcloc-snip-reader% + (class* object% (snip-reader<%>) + (define/public (read-header version stream) (void)) + (define/public (read-snip text-only? version stream) + (let* ((bytes (send stream read-raw-bytes "srcloc")) + (port (open-input-bytes bytes 'srcloc)) + (datum (read port)) + (srcloc (apply + (lambda (_ source line column position span) + (srcloc (datum->source source) line column position span)) + datum)) + (editor (send editor-reader read-snip text-only? version stream))) ; don't need this + (cond + [text-only? + (string->bytes/utf-8 (~s (srcloc->expression srcloc)))] + [else + (new srcloc-readable [srcloc srcloc])]))) + (super-new))) + +(define srcloc-readable + (class* object% (readable<%>) + (init-field srcloc) + (define/public (read-special source line column position) + (datum->syntax #f + (srcloc->expression srcloc) + (vector source line column position 1) + #f)) + (super-new))) + +(define reader (new srcloc-snip-reader%)) diff --git a/gui-lib/info.rkt b/gui-lib/info.rkt index 0d0c7848f..46930811c 100644 --- a/gui-lib/info.rkt +++ b/gui-lib/info.rkt @@ -5,25 +5,29 @@ (define deps '("srfi-lite-lib" "data-lib" ["icons" #:version "1.3"] - ["base" #:version "7.0.0.19"] - "syntax-color-lib" - ["draw-lib" #:version "1.13"] - ["snip-lib" #:version "1.2"] + ["base" #:version "9.0.0.6"] + ["syntax-color-lib" #:version "1.7"] + ["draw-lib" #:version "1.18"] + ["snip-lib" #:version "1.6"] "wxme-lib" "pict-lib" "scheme-lib" ["scribble-lib" #:version "1.36"] - ["string-constants-lib" #:version "1.34"] + ["string-constants-lib" #:version "1.56"] "option-contract-lib" "2d-lib" "compatibility-lib" "tex-table" + "simple-tree-text-markup-lib" ("gui-i386-macosx" #:platform "i386-macosx") ("gui-x86_64-macosx" #:platform "x86_64-macosx" #:version "1.3") ("gui-ppc-macosx" #:platform "ppc-macosx") + ("gui-aarch64-macosx" #:platform "aarch64-macosx") ("gui-win32-i386" #:platform "win32\\i386") ("gui-win32-x86_64" #:platform "win32\\x86_64") - ("gui-x86_64-linux-natipkg" #:platform "x86_64-linux-natipkg"))) + ("gui-win32-arm64" #:platform "win32\\arm64") + ("gui-x86_64-linux-natipkg" #:platform "x86_64-linux-natipkg") + ("gui-aarch64-linux-natipkg" #:platform "aarch64-linux-natipkg"))) (define build-deps '("at-exp-lib" "rackunit-lib")) @@ -31,4 +35,7 @@ (define pkg-authors '(mflatt robby)) -(define version "1.49") +(define version "1.80") + +(define license + '(Apache-2.0 OR MIT)) diff --git a/gui-lib/mred/installer.rkt b/gui-lib/mred/installer.rkt index f8f05b1b5..9ef06c531 100644 --- a/gui-lib/mred/installer.rkt +++ b/gui-lib/mred/installer.rkt @@ -1,10 +1,9 @@ #lang racket/base (require launcher compiler/embed - racket/file - racket/path setup/dirs - setup/cross-system) + setup/cross-system + (submod racket/gui/installer private-install-helpers)) (provide installer) @@ -12,64 +11,60 @@ (define mred-exe-systems '(unix)) (define (installer path coll user? no-main?) - (unless no-main? - (do-installer path coll user? #f) - (when (and (not user?) - (find-config-tethered-console-bin-dir)) - (do-installer path coll #f #t))) - (when (find-addon-tethered-console-bin-dir) - (do-installer path coll #t #t))) + (dispatch-to-installer-maker path coll user? no-main? do-installer)) (define (do-installer path coll user? tethered?) (define variants (available-mred-variants)) (when (memq (cross-system-type) mred-exe-systems) (for ([v variants] #:when (memq v '(3m cgc cs))) (parameterize ([current-launcher-variant v]) - (create-embedding-executable - (prep-dir (mred-program-launcher-path "MrEd" - #:user? user? - #:tethered? tethered?)) - #:cmdline (append - (if tethered? (if user? (addon-flags) (config-flags)) null) - '("-I" "scheme/gui/init")) - #:variant v - #:launcher? #t - #:gracket? #t - #:aux `((relative? . ,(not user?))))))) + (define exe-name (mred-program-launcher-path "MrEd" + #:user? user? + #:tethered? tethered?)) + (unless (exists-in-another-layer? exe-name user? tethered? #:gui? #t) + (create-embedding-executable + (prep-dir exe-name) + #:cmdline (append + ;; doing the same thing as a `make-gracket-launcher` #:tether-mode: + (if tethered? (if user? (addon-flags) (config-flags)) null) + '("-I" "scheme/gui/init")) + #:variant v + #:launcher? #t + #:gracket? #t + #:aux `((relative? . ,(not user?)))))))) ;; add a mred-text executable that uses the -z flag (preferring a script) (define tether-mode (and tethered? (if user? 'addon 'config))) (for ([vs '((script-3m 3m) (script-cgc cgc) (script-cs cs))]) (let ([v (findf (lambda (v) (memq v variants)) vs)]) (when v (parameterize ([current-launcher-variant v]) - (make-gracket-launcher - #:tether-mode tether-mode - '("-I" "scheme/gui/init" "-z") - (prep-dir (mred-program-launcher-path "mred-text" - #:user? user? - #:tethered? tethered? - #:console? #t)) - `([relative? . ,(not (or user? tethered?))] - [subsystem . console] - [single-instance? . #f])))))) + (define exe-name (mred-program-launcher-path "mred-text" + #:user? user? + #:tethered? tethered? + #:console? #t)) + (unless (exists-in-another-layer? exe-name user? tethered? #:gui? #f) + (make-gracket-launcher + #:tether-mode tether-mode + '("-I" "scheme/gui/init" "-z") + (prep-dir exe-name) + `([relative? . ,(not (or user? tethered?))] + [subsystem . console] + [single-instance? . #f]))))))) ;; add bin/mred script under OS X (when (eq? 'macosx (cross-system-type)) (for ([v variants] #:when (memq v '(script-3m script-cgc script-cs))) (parameterize ([current-launcher-variant v]) - (make-gracket-launcher - #:tether-mode tether-mode - null - (prep-dir (mred-program-launcher-path "MrEd" - #:user? user? - #:tethered? tethered?)) - `([exe-name . "GRacket"] - [relative? . ,(not (or user? tethered?))] - [exe-is-gracket . #t])))))) - -(define (prep-dir p) - (define dir (path-only p)) - (make-directory* dir) - p) + (define exe-name (mred-program-launcher-path "MrEd" + #:user? user? + #:tethered? tethered?)) + (unless (exists-in-another-layer? exe-name user? tethered? #:gui? #f) + (make-gracket-launcher + #:tether-mode tether-mode + null + (prep-dir exe-name) + `([exe-name . "GRacket"] + [relative? . ,(not (or user? tethered?))] + [exe-is-gracket . #t]))))))) (define (addon-flags) (append @@ -77,4 +72,5 @@ (list "-A" (path->string (find-system-path 'addon-dir))))) (define (config-flags) - (list "-C" (path->string (find-config-dir)))) + (list "-X" (path->string (find-collects-dir)) + "-G" (path->string (find-config-dir)))) diff --git a/gui-lib/mred/mred-sig.rkt b/gui-lib/mred/mred-sig.rkt index c336dd9de..3dbf2f4ef 100644 --- a/gui-lib/mred/mred-sig.rkt +++ b/gui-lib/mred/mred-sig.rkt @@ -12,6 +12,7 @@ application-file-handler application-preferences-handler application-quit-handler application-start-empty-handler +application-dark-mode-handler area-container-window<%> area-container<%> area<%> diff --git a/gui-lib/mred/private/app.rkt b/gui-lib/mred/private/app.rkt index e70d76a5a..438a53883 100644 --- a/gui-lib/mred/private/app.rkt +++ b/gui-lib/mred/private/app.rkt @@ -11,6 +11,7 @@ application-quit-handler application-file-handler application-start-empty-handler + application-dark-mode-handler current-eventspace-has-standard-menus? current-eventspace-has-menu-root? eventspace-handler-thread) @@ -104,6 +105,18 @@ (lambda (v) (unless v (wx:cancel-quit)) v) void)])) + (define application-dark-mode-handler + (case-lambda + [() (or (and (wx:main-eventspace? (wx:current-eventspace)) + (app-handler-orig (wx:application-dark-mode-handler))) + void)] + [(proc) + (set-handler! 'application-dark-mode-handler proc + wx:application-dark-mode-handler + 0 + values + void)])) + (define saved-files null) (define default-application-file-handler diff --git a/gui-lib/mred/private/editor.rkt b/gui-lib/mred/private/editor.rkt index 9beb26143..1564667cc 100644 --- a/gui-lib/mred/private/editor.rkt +++ b/gui-lib/mred/private/editor.rkt @@ -4,6 +4,7 @@ racket/list racket/file racket/path + racket/port racket/contract (for-syntax racket/base) (prefix-in wx: "kernel.rkt") @@ -52,7 +53,11 @@ auto-wrap get-max-view-size save-file set-file-creator-and-type - get-file-creator-and-type)) + get-file-creator-and-type + enable-sha1 + is-sha1-enabled? + get-file-sha1 + update-sha1?)) (define-local-member-name -format-filter @@ -129,6 +134,20 @@ [creator-and-type (values (car creator-and-type) (cdr creator-and-type))] [else (values #f #f)])) + ;; (or/c #f -- don't compute sha1s + ;; #t -- compute sha1s (but we haven't loaded/saved a file yet so none yet) + ;; bytes?) -- the most recently loaded or saved file's sha1 + (define compute-sha1-of-loaded-file #f) + (define/public (enable-sha1) + (unless compute-sha1-of-loaded-file + (set! compute-sha1-of-loaded-file #t))) + (define/public (is-sha1-enabled?) (and compute-sha1-of-loaded-file #t)) + (define/public (get-file-sha1) + (cond + [(boolean? compute-sha1-of-loaded-file) #f] + [else compute-sha1-of-loaded-file])) + (define/public (update-sha1? path) #t) + (private* [max-view-size (lambda () @@ -205,6 +224,13 @@ void (lambda () (set! port (open-input-file file)) + (when (and compute-sha1-of-loaded-file (update-sha1? file)) + (define bp (open-output-bytes)) + (copy-port port bp) + (close-input-port port) + (define the-bytes (get-output-bytes bp)) + (set! port (open-input-bytes the-bytes)) + (set! compute-sha1-of-loaded-file (sha1-bytes the-bytes))) (wx:begin-busy-cursor) (super-begin-edit-sequence) (dynamic-wind @@ -275,21 +301,37 @@ f-format)] [text? (memq actual-format '(text text-force-cr))] [text-mode? (and text? use-text-mode?)]) + (define (open-the-file-port-and-set-creator-and-type) + (define file-port + (open-output-file file + #:mode (if text-mode? 'text 'binary) + #:exists 'truncate/replace)) + (set-creator-and-type-on-file file text?) + file-port) (let ([port #f] - [finished? #f]) + [finished? #f] + [update-the-sha1? (and compute-sha1-of-loaded-file (update-sha1? file))]) (dynamic-wind void (lambda () - (set! port (open-output-file file - #:mode (if text-mode? 'text 'binary) - #:exists 'truncate/replace)) - (set-creator-and-type-on-file file text?) + (set! port + (if update-the-sha1? + (open-output-bytes) + (open-the-file-port-and-set-creator-and-type))) (wx:begin-busy-cursor) (dynamic-wind void (lambda () (super-save-port port format #t) (close-output-port port) ; close as soon as possible + (when update-the-sha1? + (define the-bytes (get-output-bytes port)) + (define file-port (open-the-file-port-and-set-creator-and-type)) + (dynamic-wind + void + (λ () (write-bytes the-bytes file-port)) + (λ () (close-output-port file-port))) + (set! compute-sha1-of-loaded-file (sha1-bytes the-bytes))) (unless (or (eq? format 'copy) (and (not (unbox temp-filename?-box)) (equal? file old-filename))) @@ -575,13 +617,17 @@ (lambda (key func) (send k map-function key func)) (append (case (system-type) - [(windows) '(":c:c" ":c:x" ":c:v" ":c:k" ":c:z" ":c:a")] + [(windows unix) '(":c:c" ":c:x" ":c:v" ":c:k" ":c:z" ":c:a")] [(macos macosx) '(":d:c" ":d:x" ":d:v" ":d:k" ":d:z" ":d:a")] + ;; Old bindings for Unix imitate Emacs, along with start-of-line and end-of-line below: + #; [(unix) '(":m:w" ":c:w" ":c:y" ":c:k" ":c:s:_" ":m:a")]) '(":middlebutton")) '("copy-clipboard" "cut-clipboard" "paste-clipboard" "delete-to-end-of-line" "undo" "select-all" "mouse-paste")) (send k map-function ":rightbuttonseq" "mouse-popup-menu") + ;; Old bindings for Unix: + #; (when (eq? (system-type) 'unix) (send k map-function ":c:a" "beginning-of-line") (send k map-function ":c:e" "end-of-line"))) @@ -709,7 +755,7 @@ [color (mk-menu "Color")] [background (mk-menu "Background")]) - ; Font menu + ;; Font menu (for-each (lambda (l f) (mk l family (lambda (e) @@ -721,7 +767,7 @@ (when f (send e change-style (font->delta f)))))) - ; Size menu + ;; Size menu (let ([bigger (make-object menu% "Bigger" size)] [smaller (make-object menu% "Smaller" size)] [add-change-size @@ -765,39 +811,50 @@ (let ([mk-cg (lambda (cmd arg) (lambda (e) (send e change-style (make-object wx:style-delta% cmd arg))))]) - ; Style + ;; Style (for-each (lambda (name s) (mk name style (mk-cg 'change-style s))) '("Normal" "Italic" "Slant") '(normal italic slant)) - ; Weight + ;; Weight (for-each (lambda (name s) (mk name weight (mk-cg 'change-weight s))) '("Normal" "Bold" "Light") '(normal bold light)) - ; Underline + ;; Underline (mk "No Underline" underline (mk-cg 'change-underline #f)) (mk "Underline" underline (mk-cg 'change-underline #t)) (mk "Toggle" underline (lambda (e) (send e change-style (make-object wx:style-delta% 'change-toggle-underline)))) - ; Alignment + ;; Alignment (for-each (lambda (name s) (mk name alignment (mk-cg 'change-alignment s))) '("Top" "Center" "Bottom") '(top center bottom)) (let ([colors '("Black" "White" "Red" "Orange" "Yellow" "Green" "Blue" "Purple" "Cyan" "Magenta" "Gray")]) + (define (add-transparency parent-m get-mult get-add) + (define m (make-object menu% "Opacity" parent-m)) + (for ([i (in-inclusive-range 0 100 10)]) + (mk (format "~a%" i) m (lambda (e) + (define d (make-object wx:style-delta%)) + (send (get-mult d) set-a 0.0) + (send (get-add d) set-a (/ i 100.0)) + (send e change-style d))))) - ; Colors + ;; Colors (for-each (lambda (c) (mk c color (lambda (e) (let ([d (make-object wx:style-delta%)]) (send d set-delta-foreground c) (send e change-style d))))) colors) + (add-transparency color + (lambda (d) (send d get-foreground-mult)) + (lambda (d) (send d get-foreground-add))) - ; Background + ;; Background (mk "Transparent" background (lambda (e) (let ([d (make-object wx:style-delta%)]) (send d set-transparent-text-backing-on #t) (send e change-style d)))) @@ -805,4 +862,7 @@ (mk c background (lambda (e) (let ([d (make-object wx:style-delta%)]) (send d set-delta-background c) (send e change-style d))))) - colors)))))) + colors) + (add-transparency background + (lambda (d) (send d get-background-mult)) + (lambda (d) (send d get-background-add)))))))) diff --git a/gui-lib/mred/private/kernel.rkt b/gui-lib/mred/private/kernel.rkt index 86253c40d..d973dccaa 100644 --- a/gui-lib/mred/private/kernel.rkt +++ b/gui-lib/mred/private/kernel.rkt @@ -40,4 +40,5 @@ application-quit-handler application-about-handler application-pref-handler - application-start-empty-handler) + application-start-empty-handler + application-dark-mode-handler) diff --git a/gui-lib/mred/private/messagebox.rkt b/gui-lib/mred/private/messagebox.rkt index 1611879de..e992be9c2 100644 --- a/gui-lib/mred/private/messagebox.rkt +++ b/gui-lib/mred/private/messagebox.rkt @@ -27,7 +27,7 @@ button1 button2 button3 parent style close-result check? two-results? check-message - dialog-mixin) + return-the-dialog? dialog-mixin) (check-label-string who title) (check-string/false who message) (when check? @@ -50,7 +50,7 @@ button1 button2 button3 parent style close-result check? two-results? check-message - dialog-mixin))] + return-the-dialog? dialog-mixin))] [es (if parent (send parent get-eventspace) (wx:current-eventspace))]) @@ -65,178 +65,223 @@ (channel-put ch (call-with-values go list))))) (apply values (channel-get ch))))))) -(define create-message-box/custom - (lambda (who title message - button1 button2 button3 - parent style close-result - check? two-results? check-message - dialog-mixin) - (let* ([strings (regexp-split #rx"\n" message)] - [single? (and (< (length strings) 10) - (andmap (lambda (s) (< (string-length s) 60)) strings))] - [f (make-object (dialog-mixin - (class dialog% - (public* - [get-message - (lambda () message)]) - (augment* - [can-close? (lambda () - (if (memq 'disallow-close style) - (begin - (wx:bell) - #f) - #t))]) - (override* - [on-subwindow-event - (lambda (w e) - (if (send e button-down?) - (if (is-a? w button%) - #f - (if (or (is-a? w message%) - (and - (is-a? w editor-canvas%) - (let-values ([(w h) (send w get-client-size)]) - (< (send e get-x) w)))) - (begin - (send w popup-menu - (let ([m (make-object popup-menu%)]) - (make-object menu-item% - "Copy Message" - m - (lambda (i e) - (send (wx:get-the-clipboard) - set-clipboard-string - message - (send e get-time-stamp)))) - m) - (send e get-x) - (send e get-y)) - #t) - #f)) - #f))]) - (super-make-object title parent box-width))))] - [result close-result] - [icon-id (cond - [(memq 'no-icon style) #f] - [(memq 'stop style) 'stop] - [(memq 'caution style) 'caution] - [else 'app])]) - (let-values ([(msg-pnl btn-pnl cb-pnl extra-width btn-h-align msg-h-align msg-v-align) - (case (system-type) - [(macosx) (let ([p (make-object horizontal-pane% f)]) - (send f min-width 300) - (send p set-alignment 'center 'top) - (when icon-id - (let ([m (make-object message% icon-id p)]) - (send m horiz-margin 16) - (send m vert-margin 16))) - (let* ([rhs-pnl (make-object vertical-pane% p)] - [msg-pnl (make-object vertical-pane% rhs-pnl)] - [btn-pnl (make-object vertical-pane% rhs-pnl)]) - (send msg-pnl vert-margin 16) - (when single? - (send msg-pnl horiz-margin 8)) - (send btn-pnl vert-margin 8) - (send msg-pnl min-height 40) - (send msg-pnl min-width 300) - (send btn-pnl stretchable-height #f) - (values msg-pnl btn-pnl btn-pnl 96 'right 'left 'top)))] - [else (let ([p (new horizontal-pane% [parent f] [alignment '(center top)])]) - (let ([icon-msg (and icon-id (make-object message% icon-id p))] - [msg-pnl (new vertical-pane% [parent p])]) - (values (if (= 1 (length strings)) - (new horizontal-pane% - [parent msg-pnl] - [alignment '(center top)] - [min-height (if icon-msg - (send icon-msg min-height) - 1)]) - msg-pnl) - f msg-pnl 0 'center 'center 'center)))])]) - (if single? - (begin - (send msg-pnl set-alignment (if (= (length strings) 1) msg-h-align 'left) msg-v-align) - (for-each (lambda (s) (make-object message% (protect& s) msg-pnl)) strings) - (send f stretchable-width #f) - (send f stretchable-height #f)) - ;; Try without scrollbar, then add one if necessary: - (let loop ([scroll? #f]) - (let* ([e (make-object text%)] - [c (make-object editor-canvas% msg-pnl e (if scroll? - '(no-hscroll) - '(no-hscroll no-vscroll transparent no-border)))]) - (send c min-width 400) - (send c set-line-count 5) - (send c allow-tab-exit #t) - (send f reflow-container) - (send e auto-wrap #t) - (send e insert message) - (send e set-position 0) - (send e hide-caret #t) - (send e set-cursor (make-object wx:cursor% 'arrow) #t) - (when (white-on-black-panel-scheme?) - (when scroll? - (send c set-canvas-background (send the-color-database find-color "black"))) - (define sd (new style-delta%)) - (send sd set-delta-foreground "white") - (send e change-style sd 0 (send e last-position))) - (send e lock #t) - (when (not scroll?) - ;; Check whether it actually fits - (let ([vh (box 0)] - [eh (box 0)]) - (send e get-view-size #f vh) - (send e get-extent #f eh) - (unless ((unbox eh) . <= . (unbox vh)) - (send c show #f) - (send msg-pnl delete-child c) - (loop #t))))))) - (let ([check (and check? - (let ([p (new vertical-pane% [parent cb-pnl] - [stretchable-height #f] - [alignment '(left center)])]) - (when (and single? - (eq? 'macosx (system-type))) - ;; Match text-panel margin: - (send p horiz-margin 8)) - (new check-box% - [label check-message] - [parent p] - [callback void] - [value (memq 'checked style)])))]) - (let* ([p (make-object horizontal-pane% btn-pnl)] - [mk-button (lambda (title v default?) - (let ([b (make-object button% title p (lambda (b e) (set! result v) (send f show #f)) - (if default? '(border) null))]) - (when default? (send b focus))))]) - (send p set-alignment btn-h-align 'center) - (send p stretchable-height #f) - (send p stretchable-width #t) ; to get panel's centering - (let ([mk-1 (lambda () - (when button1 - (mk-button button1 1 (memq 'default=1 style))))] - [mk-2 (lambda () - (when button2 - (mk-button button2 2 (memq 'default=2 style))))] - [mk-3 (lambda () - (when button3 - (mk-button button3 3 (memq 'default=3 style))))]) - (cond - [(or (memq 'number-order style) - (memq (system-type) '(windows))) - (mk-1) - (mk-2) - (mk-3)] - [else - (mk-3) - (make-object horizontal-pane% p) - (mk-2) - (mk-1)]))) - (send f center) - (send f show #t) - (if two-results? - (values result (and check? (send check get-value))) - result)))))) +(define (create-message-box/custom who title message + button1 button2 button3 + parent style close-result + check? two-results? check-message + return-the-dialog? dialog-mixin) + (define result close-result) + (define message-box/custom-dialog% + (class dialog% + (inherit show) + (define/public (show-and-return-results) + (show #t) + (if two-results? + (values result (and check? (send check-box get-value))) + result)) + (define/public (set-message new-message) + (set! message new-message) + (send dlg begin-container-sequence) + (fill-message-box-message check? msg-pnl check-parent-panel msg-h-align msg-v-align dlg message icon-msg) + (send dlg end-container-sequence)) + (define/public (get-message) message) + (augment* + [can-close? (lambda () + (if (memq 'disallow-close style) + (begin + (wx:bell) + #f) + #t))]) + (override* + [on-subwindow-event + (lambda (w e) + (if (send e button-down?) + (if (is-a? w button%) + #f + (if (or (is-a? w message%) + (and + (is-a? w editor-canvas%) + (let-values ([(w h) (send w get-client-size)]) + (< (send e get-x) w)))) + (begin + (send w popup-menu + (let ([m (make-object popup-menu%)]) + (make-object menu-item% + "Copy Message" + m + (lambda (i e) + (send (wx:get-the-clipboard) + set-clipboard-string + message + (send e get-time-stamp)))) + m) + (send e get-x) + (send e get-y)) + #t) + #f)) + #f))]) + (super-make-object title parent box-width))) + (define message-box+check-box/custom-dialog% + (if check? + (class message-box/custom-dialog% + (define/public (set-check-label msg) + (unless (label-string? msg) + (raise-argument-error 'set-check-label "label-string?" msg)) + (send check-box set-label msg)) + (super-new)) + message-box/custom-dialog%)) + (define dlg (make-object (dialog-mixin message-box+check-box/custom-dialog%))) + (define icon-id + (cond + [(memq 'no-icon style) #f] + [(memq 'stop style) 'stop] + [(memq 'caution style) 'caution] + [else 'app])) + (define-values (msg-pnl icon-msg btn-pnl cb-pnl extra-width btn-h-align msg-h-align msg-v-align) + (case (system-type) + [(macosx) + (define p (make-object horizontal-pane% dlg)) + (send dlg min-width 300) + (send p set-alignment 'center 'top) + (when icon-id + (let ([m (make-object message% icon-id p)]) + (send m horiz-margin 16) + (send m vert-margin 16))) + (let* ([rhs-pnl (make-object vertical-pane% p)] + [msg-pnl (make-object vertical-pane% rhs-pnl)] + [btn-pnl (make-object vertical-pane% rhs-pnl)]) + (send msg-pnl vert-margin 16) + (send btn-pnl vert-margin 8) + (send msg-pnl min-height 40) + (send msg-pnl min-width 300) + (send btn-pnl stretchable-height #f) + (values msg-pnl #f btn-pnl btn-pnl 96 'right 'left 'top))] + [else + (define p (new horizontal-pane% [parent dlg] [alignment '(center top)])) + (define icon-msg (and icon-id (make-object message% icon-id p))) + (define msg-pnl-parent (new vertical-panel% [parent p])) + (define msg-pnl (new vertical-panel% [parent msg-pnl-parent] [stretchable-height #t])) + (values msg-pnl icon-msg dlg msg-pnl-parent 0 'center 'center 'center)])) + (define check-parent-panel + (and check? + (new vertical-pane% [parent cb-pnl] + [stretchable-height #f] + [alignment '(left center)]))) + (fill-message-box-message check? msg-pnl check-parent-panel msg-h-align msg-v-align dlg message icon-msg) + (define check-box + (and check? + (new check-box% + [label check-message] + [parent check-parent-panel] + [callback void] + [stretchable-width #t] + [value (memq 'checked style)]))) + (define p (make-object horizontal-pane% btn-pnl)) + (define (mk-button title v default?) + (let ([b (make-object button% title p (lambda (b e) (set! result v) (send dlg show #f)) + (if default? '(border) null))]) + (when default? (send b focus)))) + (send p set-alignment btn-h-align 'center) + (send p stretchable-height #f) + (send p stretchable-width #t) ; to get panel's centering + (define (mk-1) + (when button1 + (mk-button button1 1 (memq 'default=1 style)))) + (define (mk-2) + (when button2 + (mk-button button2 2 (memq 'default=2 style)))) + (define (mk-3) + (when button3 + (mk-button button3 3 (memq 'default=3 style)))) + (cond + [(or (memq 'number-order style) + (memq (system-type) '(windows))) + (mk-1) + (mk-2) + (mk-3)] + [else + (mk-3) + (make-object horizontal-pane% p) + (mk-2) + (mk-1)]) + (send dlg center) + (cond + [return-the-dialog? + dlg] + [else + (send dlg show-and-return-results)])) + +(define (fill-message-box-message check? _msg-pnl check-parent-panel msg-h-align msg-v-align dlg message icon-msg) + (define strings (regexp-split #rx"\n" message)) + (define single? + (and (< (length strings) 10) + (andmap (lambda (s) (< (string-length s) 60)) strings))) + + (send _msg-pnl change-children (λ (l) '())) + (define msg-pnl + (cond + [(and icon-msg (= 1 (length strings))) + (new horizontal-panel% + [parent _msg-pnl] + [alignment '(center top)] + [min-height (send icon-msg min-height)])] + [else _msg-pnl])) + + ;; Match text-panel margin based on `single?` and `check?`. + (when check? + (when (equal? 'macosx (system-type)) + (send check-parent-panel horiz-margin (if single? 8 0)))) + (send msg-pnl horiz-margin (if single? 8 0)) + (cond + [single? + (send msg-pnl set-alignment (if (= (length strings) 1) msg-h-align 'left) msg-v-align) + (for-each (lambda (s) (make-object message% (protect& s) msg-pnl)) strings) + (send dlg stretchable-width #f) + (send dlg stretchable-height #f) + (send dlg reflow-container)] + [else + (send dlg stretchable-width #t) + (send dlg stretchable-height #t) + ;; Try without scrollbar + (define c (new editor-canvas% + [parent msg-pnl] + [style '(no-hscroll no-vscroll transparent no-border)])) + (define e (fill-canvas-with-content c dlg message #f)) + ;; Check whether it actually fits + (define vh (box 0)) + (define eh (box 0)) + (send e get-view-size #f vh) + (send e get-extent #f eh) + (unless ((unbox eh) . <= . (unbox vh)) + ;; Didn't fit; try again with a scrollbar + (send c show #f) + (send msg-pnl delete-child c) + (define new-c (new editor-canvas% + [parent msg-pnl] + [style '(no-hscroll)])) + (when (white-on-black-panel-scheme?) + (send new-c set-canvas-background (send the-color-database find-color "black"))) + (define e (fill-canvas-with-content new-c dlg message #t)) + (void))])) + +(define (fill-canvas-with-content c dlg message scroll?) + (define e (make-object text%)) + (send c set-editor e) + (send c min-width 400) + (send c set-line-count 5) + (send c allow-tab-exit #t) + (send dlg reflow-container) + (send e auto-wrap #t) + (send e insert message) + (send e set-position 0) + (send e hide-caret #t) + (send e set-cursor (make-object wx:cursor% 'arrow) #t) + (when (white-on-black-panel-scheme?) + (define sd (new style-delta%)) + (send sd set-delta-foreground "white") + (send e change-style sd 0 (send e last-position))) + (send e lock #t) + e) (define message-box/custom (lambda (title message @@ -246,11 +291,12 @@ [parent #f] [style '(no-default)] [close-result #f] + #:return-the-dialog? [return-the-dialog? #f] #:dialog-mixin [dialog-mixin values]) (do-message-box/custom 'message-box/custom title message button1 button2 button3 parent style close-result - #f #f #f dialog-mixin))) + #f #f #f return-the-dialog? dialog-mixin))) (define do-message-box (lambda (who title message parent style check? check-message dialog-mixin) @@ -294,7 +340,7 @@ (list default 'disallow-close))) close-val check? #t check-message - dialog-mixin)]) + #f dialog-mixin)]) (let ([result (case result [(1) one-v] [(2) two-v])]) @@ -315,12 +361,13 @@ [parent #f] [style '(no-default)] [close-result #f] + #:return-the-dialog? [return-the-dialog? #f] #:dialog-mixin [dialog-mixin values]) (do-message-box/custom 'message+check-box/custom title message button1 button2 button3 parent style close-result #t #t checkbox-message - dialog-mixin))) + return-the-dialog? dialog-mixin))) (define message+check-box (lambda (title message check-message [parent #f] [style '(ok)] #:dialog-mixin [dialog-mixin values]) diff --git a/gui-lib/mred/private/misc.rkt b/gui-lib/mred/private/misc.rkt index dcd644ec1..c574489da 100644 --- a/gui-lib/mred/private/misc.rkt +++ b/gui-lib/mred/private/misc.rkt @@ -76,13 +76,11 @@ ;; no setting => search for some known commands [cmd (or cmd (ormap find-executable-path - '("aplay" "play" "esdplay" "sndfile-play" + '("paplay" "aplay" "play" "esdplay" "sndfile-play" "audioplay")) (error 'play-sound "not supported on this machine ~a" "(no default, and no known command found)"))] - [>null (open-output-file "/dev/null" 'append)] - [string (expand-path f))) @@ -96,8 +94,12 @@ (regexp-replace* #rx"([$\"\\])" file "\\\\\\1") "\""))))) + (define >null (open-output-file "/dev/null" 'append)) + (define null null) + (close-input-port don't show error output diff --git a/gui-lib/mred/private/moredialogs.rkt b/gui-lib/mred/private/moredialogs.rkt index 26a0d849a..4943516e0 100644 --- a/gui-lib/mred/private/moredialogs.rkt +++ b/gui-lib/mred/private/moredialogs.rkt @@ -7,6 +7,7 @@ "check.rkt" "wx.rkt" "helper.rkt" + "panel-wob.rkt" "mrtop.rkt" "mrcanvas.rkt" "mritem.rkt" @@ -355,7 +356,13 @@ (send ok-button enable ok?) (send alpha set-field-background (send wx:the-color-database find-color - (if ok? "white" "pink"))))) + (if ok? + (if (white-on-black-panel-scheme?) + "black" + "white") + (if (white-on-black-panel-scheme?) + "firebrick" + "pink")))))) (define bp (make-object horizontal-pane% f)) (define (get-current-color) (make-object wx:color% diff --git a/gui-lib/mred/private/mred.rkt b/gui-lib/mred/private/mred.rkt index 9f0be1048..994041cfa 100644 --- a/gui-lib/mred/private/mred.rkt +++ b/gui-lib/mred/private/mred.rkt @@ -80,89 +80,89 @@ (define-syntax propagate (lambda (stx) (syntax-case stx () - [(_ n ...) - (let ([ns (syntax->list (syntax (n ...)))]) - (with-syntax ([(k:n ...) + [(_ wx:n ...) + (let ([ns (syntax->list (syntax (wx:n ...)))]) + (with-syntax ([(n ...) (map (lambda (n) (datum->syntax-object n (string->symbol - (format - "wx:~a" - (syntax-e n))) + (regexp-replace #rx"^wx:" + (format "~a" (syntax-e n)) + "")) #f)) ns)]) (syntax (begin ;; We can't just re-export, because kernel.rkt's ;; exports are protected. - (define n k:n) ... + (define n wx:n) ... (provide n ...)))))]))) - (propagate add-editor-keymap-functions - add-text-keymap-functions - add-pasteboard-keymap-functions - begin-busy-cursor - bell - editor-data% - editor-data-class% - editor-data-class-list<%> - check-for-break - clipboard<%> - clipboard-client% - control-event% - column-control-event% - current-eventspace - cursor% - get-display-depth - end-busy-cursor - event% - event-dispatch-handler - eventspace? - flush-display - get-current-mouse-state - get-highlight-background-color - get-highlight-text-color - get-label-foreground-color - get-label-background-color - get-the-editor-data-class-list - is-busy? - is-color-display? - key-event% - keymap% - editor-admin% - editor-set-x-selection-mode - editor-snip-editor-admin<%> - editor-stream-in% - editor-stream-in-base% - editor-stream-in-bytes-base% - editor-stream-out% - editor-stream-out-base% - editor-stream-out-bytes-base% - editor-wordbreak-map% - mouse-event% - read-editor-global-footer - read-editor-global-header - read-editor-version - scroll-event% - special-control-key - special-option-key - any-control+alt-is-altgr - map-command-as-meta-key - label->plain-label - write-editor-global-footer - write-editor-global-header - write-editor-version - queue-callback - yield - eventspace-shutdown? - eventspace-event-evt - get-panel-background - graphical-system-type + (propagate wx:add-editor-keymap-functions + wx:add-text-keymap-functions + wx:add-pasteboard-keymap-functions + wx:begin-busy-cursor + wx:bell + wx:editor-data% + wx:editor-data-class% + wx:editor-data-class-list<%> + wx:check-for-break + wx:clipboard<%> + wx:clipboard-client% + wx:control-event% + wx:column-control-event% + wx:current-eventspace + wx:cursor% + wx:get-display-depth + wx:end-busy-cursor + wx:event% + wx:event-dispatch-handler + wx:eventspace? + wx:flush-display + wx:get-current-mouse-state + wx:get-highlight-background-color + wx:get-highlight-text-color + wx:get-label-foreground-color + wx:get-label-background-color + wx:get-the-editor-data-class-list + wx:is-busy? + wx:is-color-display? + wx:key-event% + wx:keymap% + wx:editor-admin% + wx:editor-set-x-selection-mode + wx:editor-snip-editor-admin<%> + wx:editor-stream-in% + wx:editor-stream-in-base% + wx:editor-stream-in-bytes-base% + wx:editor-stream-out% + wx:editor-stream-out-base% + wx:editor-stream-out-bytes-base% + wx:editor-wordbreak-map% + wx:mouse-event% + wx:read-editor-global-footer + wx:read-editor-global-header + wx:read-editor-version + wx:scroll-event% + wx:special-control-key + wx:special-option-key + wx:any-control+alt-is-altgr + wx:map-command-as-meta-key + wx:label->plain-label + wx:write-editor-global-footer + wx:write-editor-global-header + wx:write-editor-version + wx:queue-callback + wx:yield + wx:eventspace-shutdown? + wx:eventspace-event-evt + wx:get-panel-background + wx:graphical-system-type - the-editor-wordbreak-map - make-screen-bitmap - make-gl-bitmap) + wx:the-editor-wordbreak-map + wx:make-screen-bitmap + wx:make-gl-bitmap) (define the-clipboard (wx:get-the-clipboard)) (define the-x-selection-clipboard (wx:get-the-x-selection)) @@ -288,6 +288,7 @@ application-quit-handler application-file-handler application-start-empty-handler + application-dark-mode-handler current-eventspace-has-standard-menus? current-eventspace-has-menu-root? eventspace-handler-thread diff --git a/gui-lib/mred/private/mritem.rkt b/gui-lib/mred/private/mritem.rkt index 421f4658c..bfcb1b851 100644 --- a/gui-lib/mred/private/mritem.rkt +++ b/gui-lib/mred/private/mritem.rkt @@ -2,6 +2,8 @@ (require racket/class racket/list + (only-in racket/draw the-color-database) + (only-in racket/draw/private/color color%) (prefix-in wx: "kernel.rkt") "lock.rkt" "const.rkt" @@ -101,6 +103,11 @@ (define zero-bitmap #f) +(define (maybe-find-color c) + (if (string? c) + (send the-color-database find-color c) + c)) + (define message% (class* basic-control% () (init label parent [style null] @@ -108,6 +115,7 @@ ;; init argument *after* all of its parent arguments, which ;; normally can't happen. [font no-val] + [color no-val] [enabled #t] [vert-margin no-val] [horiz-margin no-val] @@ -132,6 +140,15 @@ (super set-label l) (when do-auto-resize? (do-auto-resize))))]) + (public* + [get-color (entry-point + (lambda () + (send (mred->wx this) get-color)))] + [set-color (entry-point + (lambda (c) + (unless (or (not c) (string? c) (is-a? c color%)) + (raise-argument-error (who->name '(method message% set-color)) "(or/c #f string? (is-a?/c color%))" c)) + (send (mred->wx this) set-color (maybe-find-color c))))]) (private* [strip-amp (lambda (s) (if (string? s) (regexp-replace* #rx"&(.)" s "\\1") @@ -183,7 +200,7 @@ zero-bitmap] [else label]) label) - -1 -1 style (no-val->#f font))]) + -1 -1 style (no-val->#f font) (maybe-find-color (no-val->#f color)))]) ;; Record dx & dy: (let ([w (box 0)] [h (box 0)]) (send m get-size w h) @@ -434,7 +451,7 @@ (check-container-parent cwho parent) (check-callback cwho callback) (check-slider-integer cwho init-value) - (check-style cwho '(vertical horizontal) '(plain vertical-label horizontal-label deleted) style) + (check-style cwho '(vertical horizontal upward) '(plain vertical-label horizontal-label deleted) style) (check-font cwho font) (unless (<= minv maxv) (raise-arguments-error (who->name cwho) diff --git a/gui-lib/mred/private/mrpanel.rkt b/gui-lib/mred/private/mrpanel.rkt index c7a552b88..509f479cf 100644 --- a/gui-lib/mred/private/mrpanel.rkt +++ b/gui-lib/mred/private/mrpanel.rkt @@ -9,7 +9,10 @@ "wx.rkt" "wxpanel.rkt" "mrwindow.rkt" - "mrcontainer.rkt") + "mrcontainer.rkt" + "wxtabcanvas.rkt" + "gdi.rkt" + (only-in "wx/platform.rkt" tab-panel-available?)) (provide pane% vertical-pane% @@ -21,7 +24,12 @@ tab-panel% group-box-panel%) -(define-local-member-name get-initial-label) +(define-local-member-name + get-initial-label + as-plain-panel? + finish-wx + get-inner-getter + get-outer-getter) (define pane% (class (make-subarea% (make-container% area%)) @@ -169,7 +177,11 @@ [stretchable-height no-val]) (init-rest) (define wx #f) - (public* [get-initial-label (lambda () #f)]) + (public* [get-initial-label (lambda () #f)] + [as-plain-panel? (lambda () #f)] + [finish-wx (lambda (proc) (proc this))] + [get-inner-getter (lambda () (lambda () wx))] + [get-outer-getter (lambda () (lambda () wx))]) (let* ([who (cond ; yuck! - we do this to make h-p and v-p subclasses of p [(is-a? this tab-panel%) 'tab-panel] [(is-a? this group-box-panel%) 'group-box-panel] @@ -188,11 +200,13 @@ (memq 'hide-hscroll style)))]) (check-container-parent cwho parent) (check-style cwho #f (append '(border deleted) - (if can-canvas? - '(hscroll vscroll - auto-hscroll auto-vscroll - hide-hscroll hide-vscroll) - null)) + (cond + [can-canvas? + '(hscroll vscroll + auto-hscroll auto-vscroll + hide-hscroll hide-vscroll)] + [(eq? who 'tab-panel) '(can-reorder can-close flat-portable new-button)] + [else null])) style) (define (add-scrolls style) @@ -208,26 +222,31 @@ (as-entry (lambda () (super-instantiate - ((lambda () (set! wx (make-object (case who - [(vertical-panel) - (if (as-canvas?) - wx-vertical-canvas-panel% - wx-vertical-panel%)] - [(tab-panel) wx-vertical-tab-panel%] - [(group-box-panel) wx-vertical-group-panel%] - [(horizontal-panel) - (if (as-canvas?) - wx-horizontal-canvas-panel% - wx-horizontal-panel%)] - [else (if (as-canvas?) - wx-canvas-panel% - wx-panel%)]) - this this (mred->wx-container parent) - (cons 'transparent (add-scrolls style)) - (get-initial-label))) + ((lambda () (set! wx (finish-wx + (lambda (mred) + (make-object (case who + [(vertical-panel) + (if (as-canvas?) + wx-vertical-canvas-panel% + wx-vertical-panel%)] + [(tab-panel) + (if (as-plain-panel?) + wx-vertical-panel% + wx-vertical-tab-panel%)] + [(group-box-panel) wx-vertical-group-panel%] + [(horizontal-panel) + (if (as-canvas?) + wx-horizontal-canvas-panel% + wx-horizontal-panel%)] + [else (if (as-canvas?) + wx-canvas-panel% + wx-panel%)]) + mred this (mred->wx-container parent) + (cons 'transparent (add-scrolls style)) + (get-initial-label))))) wx) - (lambda () wx) - (lambda () wx) + (get-inner-getter) + (get-outer-getter) (lambda () (check-container-ready cwho parent)) #f parent #f) [enabled enabled] @@ -302,10 +321,14 @@ [get-orientation (λ () (send (mred->wx this) get-orientation))]))) (define list-append append) +(define always-use-tab-canvas? (or (and (getenv "PLT_FLAT_PORTABLE_TAB_PANEL") #t) + (not (tab-panel-available?)))) (define tab-panel% (class vertical-panel% - (init choices parent [callback (lambda (b e) (void))] [style null] [font no-val] + (init choices parent [callback (lambda (b e) (void))]) + (init-field [style null]) + (init [font no-val] ;; inherited inits [enabled #t] [vert-margin no-val] @@ -321,20 +344,82 @@ (define save-choices choices) (override* [get-initial-label (lambda () save-choices)]) + (define use-tab-canvas? (and (memq 'no-border style) + (or always-use-tab-canvas? + (memq 'flat-portable style) + (and (or (memq 'can-reorder style) + (memq 'can-close style)) + (eq? 'windows (system-type)))))) + + (define tab-canvas #f) + (define outside #f) + (define inside #f) + (define init-font font) + + (define/override (as-plain-panel?) use-tab-canvas?) + (define/override (finish-wx proc) + (define wx (proc (if use-tab-canvas? #f this))) + (set! outside wx) + (cond + [use-tab-canvas? + (set! tab-canvas (make-object wx-tab-canvas% + save-choices + style + (if (eq? init-font no-val) + normal-control-font + init-font) + (lambda (index) (on-close-request index)) + (lambda () (on-new-request)) + (lambda (new-positions) (on-reorder new-positions)) + this this + wx + -1 -1 + 0 0 + '(no-focus transparent) + #f)) + (set! inside (make-object wx-vertical-panel% + this this + wx + '() + #f)) + (send inside skip-subwindow-events? #t) + (send inside skip-enter-leave-events #t) + (send (send inside area-parent) add-child inside) + (send wx set-container inside) + (send tab-canvas set-sibling-client inside)] + [else + (set! inside wx)]) + wx) + (define/override (get-inner-getter) (lambda () inside)) + (define/override (get-outer-getter) (lambda () outside)) + + ;; Between the time that tabs have been rearranged by dragging and a notification + ;; is been delivered via `on-reorder`, pretend that things are still in the old + ;; order by setting this list to a non-#f value: + (define external-mapping #f) + (define/private (external->internal i) + (if external-mapping + (for/first ([ext-i (in-list external-mapping)] + [actual-i (in-naturals)] + #:when (= ext-i i)) + actual-i) + i)) + (define/private (internal->external i) + (if external-mapping + (list-ref external-mapping i) + i)) + (let ([cwho '(constructor tab-panel)]) (unless (and (list? choices) (andmap label-string? choices)) (raise-argument-error (who->name cwho) "label-string?" choices)) (check-callback cwho callback) (check-container-parent cwho parent) - (check-style cwho #f '(deleted no-border) style) + (check-style cwho #f '(deleted no-border can-reorder can-close flat-portable new-button) style) (check-font cwho font)) (super-new [parent parent] - [style - (if (memq 'no-border style) - (if (eq? (car style) 'no-border) - (cdr style) - (list (car style))) - (cons 'border style))] + [style (if (memq 'no-border style) + (remq 'no-border style) + (cons 'border style))] [enabled enabled] [vert-margin vert-margin] [horiz-margin horiz-margin] @@ -345,8 +430,12 @@ [min-height min-height] [stretchable-width stretchable-width] [stretchable-height stretchable-height]) - (send (mred->wx this) set-callback (lambda (wx e) (callback (wx->mred wx) e))) + + (define/private (get-tab-widget) + (or tab-canvas (mred->wx this))) + (send (get-tab-widget) set-callback (lambda (wx e) (callback (wx->mred wx) e))) + (public* [get-number (lambda () (length save-choices))] [append (entry-point @@ -354,21 +443,24 @@ (check-label-string '(method tab-panel% append) n) (let ([n (string->immutable-string n)]) (set! save-choices (list-append save-choices (list n))) - (send (mred->wx this) append n))))] + (when external-mapping + (set! external-mapping (append external-mapping (length external-mapping)))) + (send (get-tab-widget) append n))))] [get-selection (lambda () (and (pair? save-choices) - (send (mred->wx this) get-selection)))] + (internal->external (send (get-tab-widget) get-selection))))] [set-selection (entry-point (lambda (i) (check-item 'set-selection i) - (send (mred->wx this) set-selection i)))] + (send (get-tab-widget) set-selection (external->internal i))))] [delete (entry-point (lambda (i) (check-item 'delete i) - (set! save-choices (let loop ([p 0][l save-choices]) - (if (= p i) - (cdr l) - (cons (car l) (loop (add1 p) (cdr l)))))) - (send (mred->wx this) delete i)))] + (let ([i (external->internal i)]) + (set! save-choices (let loop ([p 0] [l save-choices]) + (if (= p i) + (cdr l) + (cons (car l) (loop (add1 p) (cdr l)))))) + (send (get-tab-widget) delete i))))] [set-item-label (entry-point (lambda (i s) (check-item 'set-item-label i) @@ -378,18 +470,35 @@ (if (zero? i) (cons s (cdr save-choices)) (cons (car save-choices) (loop (cdr save-choices) (sub1 i)))))) - (send (mred->wx this) set-label i s))))] + (send (get-tab-widget) set-label i s))))] [set (entry-point (lambda (l) (unless (and (list? l) (andmap label-string? l)) (raise-argument-error (who->name '(method tab-panel% set)) "(listof label-string?)" l)) (set! save-choices (map string->immutable-string l)) - (send (mred->wx this) set l)))] + (set! external-mapping #f) + (send (get-tab-widget) set l)))] [get-item-label (entry-point (lambda (i) (check-item 'get-item-label i) - (list-ref save-choices i)))]) + (let ([i (external->internal i)]) + (list-ref save-choices i))))] + + [do-on-choice-reorder (lambda (new-positions) + ;; in atomic mode when we get here + (set! save-choices (for/list ([i (in-list new-positions)]) + (list-ref save-choices i))) + (set! external-mapping (for/list ([old-internal (in-list new-positions)]) + (internal->external old-internal))) + (wx:queue-callback (lambda () + (set! external-mapping #f) + (on-reorder new-positions)) + wx:middle-queue-key))] + [on-close-request (lambda (which) (void))] + [on-new-request (lambda () (void))]) + (pubment* + [on-reorder (lambda (new-positions) (inner (void) on-reorder new-positions))]) (private* [check-item diff --git a/gui-lib/mred/private/mrtop.rkt b/gui-lib/mred/private/mrtop.rkt index 140827380..bcfd0f284 100644 --- a/gui-lib/mred/private/mrtop.rkt +++ b/gui-lib/mred/private/mrtop.rkt @@ -23,8 +23,7 @@ get-top-level-focus-window get-top-level-edit-target-window send-message-to-window - (protect-out check-top-level-parent/false - check-frame-parent/false)) + (protect-out check-top-level-parent/false)) (define top-level-window<%> (interface (area-container-window<%>) @@ -165,7 +164,7 @@ do-create-status-line do-set-status-text) (let ([cwho '(constructor frame)]) (check-label-string cwho label) - (check-frame-parent/false cwho parent) + (check-top-level-parent/false cwho parent) (check-init-dimension cwho width) (check-init-dimension cwho height) (check-init-position cwho x) @@ -336,10 +335,6 @@ (unless (or (not p) (is-a? p frame%) (is-a? p dialog%)) (raise-argument-error (who->name who) "(or/c (is-a?/c frame%) (is-a?/c dialog%) #f)" p))) -(define (check-frame-parent/false who p) - (unless (or (not p) (is-a? p frame%)) - (raise-argument-error (who->name who) "(or/c (is-a?/c frame%) #f)" p))) - (define root-menu-frame (and (current-eventspace-has-menu-root?) ;; The very first frame shown is somehow sticky under Cocoa, diff --git a/gui-lib/mred/private/mrwindow.rkt b/gui-lib/mred/private/mrwindow.rkt index 87dfccdb1..9afefe1c9 100644 --- a/gui-lib/mred/private/mrwindow.rkt +++ b/gui-lib/mred/private/mrwindow.rkt @@ -239,6 +239,7 @@ [is-shown? (entry-point (lambda () (send wx is-shown?)))] [on-superwindow-show (lambda (visible?) (void))] [on-superwindow-enable (lambda (active?) (void))] + [on-superwindow-activate (λ (active?) (void))] [refresh (entry-point (lambda () (send wx refresh)))] diff --git a/gui-lib/mred/private/panel-wob.rkt b/gui-lib/mred/private/panel-wob.rkt index dd854445b..a272fd536 100644 --- a/gui-lib/mred/private/panel-wob.rkt +++ b/gui-lib/mred/private/panel-wob.rkt @@ -1,19 +1,3 @@ #lang racket (require racket/class "wx/platform.rkt") (provide white-on-black-panel-scheme?) - -(define (luminance c) - ;; from https://en.wikipedia.org/wiki/Relative_luminance - (define r (/ (send c red) 255)) - (define g (/ (send c green) 255)) - (define b (/ (send c blue) 255)) - (+ (* .2126 r) - (* .7152 g) - (* .0722 b))) - -(define (white-on-black-panel-scheme?) - ;; if the background and foreground are the same - ;; color, probably something has gone wrong; - ;; in that case we want to return #f. - (< (luminance (get-label-background-color)) - (luminance (get-label-foreground-color)))) diff --git a/gui-lib/mred/private/snipfile.rkt b/gui-lib/mred/private/snipfile.rkt index e0bd52e75..50823a4bd 100644 --- a/gui-lib/mred/private/snipfile.rkt +++ b/gui-lib/mred/private/snipfile.rkt @@ -354,7 +354,7 @@ (define (show s) (define (insert) (send text begin-edit-sequence) - (send text insert s pos) + (send text insert s pos 'same #t #t) (send text end-edit-sequence)) (if (and eventspace (and (not (eq? (current-thread) @@ -364,12 +364,12 @@ (insert)) (set! pos (+ (string-length s) pos))) (define (flush-text) - (let ([cnt (peek-bytes-avail!* raw-buffer 0 #f in)]) + (let ([cnt (peek-bytes-avail!** raw-buffer 0 #f in)]) (when (positive? cnt) (let-values ([(got used status) (bytes-convert cvt raw-buffer 0 cnt utf8-buffer)]) (cond [(positive? got) - (read-bytes-avail!* raw-buffer in 0 used) + (read-bytes! raw-buffer in 0 used) (show (bytes->string/utf-8 utf8-buffer #\? 0 got)) (flush-text)] [(eq? status 'error) @@ -412,4 +412,11 @@ (add1 pos)))) void (add1 pos))) - port))) + port)) + + (define (peek-bytes-avail!** bstr skip progress-evt in) + (let loop ([got 0]) + (define cnt (peek-bytes-avail!* bstr (+ skip got) progress-evt in got)) + (if (zero? cnt) + got + (loop (+ got cnt)))))) diff --git a/gui-lib/mred/private/wx.rkt b/gui-lib/mred/private/wx.rkt index 41a32d7a9..ab279783b 100644 --- a/gui-lib/mred/private/wx.rkt +++ b/gui-lib/mred/private/wx.rkt @@ -6,6 +6,7 @@ (provide (protect-out wx<%> wx/proxy<%> + wx/client-adjacent<%> make-glue% wx->mred wx->proxy @@ -18,10 +19,11 @@ ;; The `make-glue%' mixin adds fields and methods to map ;; wx (internal) objects to mred (external) objects. ;; Sometimes, multiple wx instances have one mred instance; - ;; hance proxies. + ;; hence proxies. (define wx<%> (interface () get-mred)) (define wx/proxy<%> (interface (wx<%>) get-proxy)) + (define wx/client-adjacent<%> (interface () get-sibling-client)) (define (make-glue% %) (class* % (wx/proxy<%>) diff --git a/gui-lib/mred/private/wx/cocoa/button.rkt b/gui-lib/mred/private/wx/cocoa/button.rkt index 4fe00e3e0..392c4d553 100644 --- a/gui-lib/mred/private/wx/cocoa/button.rkt +++ b/gui-lib/mred/private/wx/cocoa/button.rkt @@ -9,7 +9,8 @@ "const.rkt" "window.rkt" "../common/event.rkt" - "image.rkt") + "image.rkt" + "liquid-glass.rkt") (provide (protect-out button% @@ -110,6 +111,30 @@ (NSRect-origin f) (make-NSSize (+ (NSSize-width (NSRect-size f)) 2) (+ (NSSize-height (NSRect-size f)) 4)))))) + + (define-values (h-margin v-margin) + (if liquid-glass? + (if (eq? event-type 'check-box) + (values 1 1) + (values 5 5)) + (values 0 0))) + + (define/override (get-frame) + (define r (super get-frame)) + (cond + [(and (= h-margin 0) (= v-margin 0)) + r] + [else + (define p (NSRect-origin r)) + (define s (NSRect-size r)) + (make-NSRect (make-NSPoint (+ (NSPoint-x p) h-margin) + (+ (NSPoint-y p) v-margin)) + (make-NSSize (+ (NSSize-width s) (* 2 h-margin)) + (+ (NSSize-height s) (* 2 h-margin))))])) + + (define/override (set-frame x y w h) + (super set-frame (+ x v-margin) (+ y h-margin) + (max 0 (- w (* 2 h-margin))) (max 0 (- h (* 2 v-margin))))) (define-values (cocoa image-cocoa) (if (and button-type diff --git a/gui-lib/mred/private/wx/cocoa/canvas.rkt b/gui-lib/mred/private/wx/cocoa/canvas.rkt index cd4b6b21a..d3b7e0b49 100644 --- a/gui-lib/mred/private/wx/cocoa/canvas.rkt +++ b/gui-lib/mred/private/wx/cocoa/canvas.rkt @@ -3,7 +3,7 @@ ffi/unsafe ffi/unsafe/collect-callback racket/class - racket/draw + (only-in racket/draw color% gl-config%) racket/draw/private/gl-context (except-in racket/draw/private/color color% make-color) @@ -12,6 +12,7 @@ "utils.rkt" "const.rkt" "types.rkt" + "liquid-glass.rkt" "window.rkt" "frame.rkt" "dc.rkt" @@ -123,7 +124,7 @@ (tellv ctx saveGraphicsState) (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] [r (tell #:type _NSRect self bounds)]) - (CGContextSetRGBFillColor cg 0 0 0 1.0) + (CGContextSetRGBFillColor cg frame-black frame-black frame-black 1.0) (let* ([l (NSPoint-x (NSRect-origin r))] [t (NSPoint-y (NSRect-origin r))] [b (+ t (NSSize-height (NSRect-size r)))] @@ -145,16 +146,16 @@ (tell (tell NSTextFieldCell alloc) initTextCell: #:type _NSString "")) (tellv bezel-cell setBezeled: #:type _BOOL #t) -(define-objc-class FocusView NSView +(define-objc-class FocusView NSView [on?] (-a _void (setFocusState: [_BOOL is-on?]) (set! on? is-on?)) (-a #:async-apply (box (void)) _void (drawRect: [_NSRect r]) (let ([f (tell #:type _NSRect self frame)]) - (tellv bezel-cell + (tellv bezel-cell drawWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 2 2) - (let ([s (NSRect-size r)]) + (let ([s (NSRect-size f)]) (make-NSSize (- (NSSize-width s) 4) (- (NSSize-height s) 4)))) inView: self)) @@ -394,6 +395,11 @@ ;; called atomically (not expecting exceptions) (tellv content-cocoa setNeedsDisplay: #:type _BOOL #t))) + (define/public (worthwhile-to-paint?) + ;; since the OS may hide and show the window, just keep + ;; it up-to-date even when not shown + #t) + (define/override (get-cocoa-content) content-cocoa) (define is-gl? (and (not is-combo?) (memq 'gl style))) @@ -412,7 +418,8 @@ (tell (tell (cond [is-combo? NSView] [has-control-border? FocusView] - [(memq 'border style) (if (memq 'vscroll style) + [(memq 'border style) (if (and (memq 'vscroll style) + (not liquid-glass?)) CornerlessFrameView FrameView)] [else NSView]) @@ -466,6 +473,10 @@ (send dc start-backing-retained) + (when (and (version-14.0-or-later?) + (is-panel?)) + (tellv content-cocoa setClipsToBounds: #:type _BOOL #true)) + (queue-paint) (define/public (is-panel?) #f) @@ -502,7 +513,7 @@ (define/override (set-size x y w h) (do-set-size x y w h)) - (define tr 0) + (define tr #f) (define/override (show on?) ;; FIXME: what if we're in the middle of an on-paint? diff --git a/gui-lib/mred/private/wx/cocoa/cg.rkt b/gui-lib/mred/private/wx/cocoa/cg.rkt index b57f0ac0f..69c9bd086 100644 --- a/gui-lib/mred/private/wx/cocoa/cg.rkt +++ b/gui-lib/mred/private/wx/cocoa/cg.rkt @@ -24,6 +24,7 @@ (define-appserv CGContextRestoreGState (_fun _CGContextRef -> _void)) (define-appserv CGContextConcatCTM (_fun _CGContextRef _CGAffineTransform -> _void)) (define-appserv CGContextSetRGBFillColor (_fun _CGContextRef _CGFloat _CGFloat _CGFloat _CGFloat -> _void)) +(define-appserv CGContextSetRGBStrokeColor (_fun _CGContextRef _CGFloat _CGFloat _CGFloat _CGFloat -> _void)) (define-appserv CGContextFillRect (_fun _CGContextRef _NSRect -> _void)) (define-appserv CGContextClearRect (_fun _CGContextRef _NSRect -> _void)) (define-appserv CGContextAddRect (_fun _CGContextRef _NSRect -> _void)) diff --git a/gui-lib/mred/private/wx/cocoa/check-box.rkt b/gui-lib/mred/private/wx/cocoa/check-box.rkt index cd2ed74a1..35eeda8a7 100644 --- a/gui-lib/mred/private/wx/cocoa/check-box.rkt +++ b/gui-lib/mred/private/wx/cocoa/check-box.rkt @@ -13,12 +13,12 @@ ;; ---------------------------------------- (defclass check-box% core-button% - (inherit get-cocoa) + (inherit get-cocoa-control) (super-new [button-type NSSwitchButton] [event-type 'check-box]) (define/public (set-value v) - (tellv (get-cocoa) setState: #:type _NSInteger (if v 1 0))) + (tellv (get-cocoa-control) setState: #:type _NSInteger (if v 1 0))) (define/public (get-value) - (positive? (tell #:type _NSInteger (get-cocoa) state)))) + (positive? (tell #:type _NSInteger (get-cocoa-control) state)))) diff --git a/gui-lib/mred/private/wx/cocoa/choice.rkt b/gui-lib/mred/private/wx/cocoa/choice.rkt index c15b724fc..3d204666b 100644 --- a/gui-lib/mred/private/wx/cocoa/choice.rkt +++ b/gui-lib/mred/private/wx/cocoa/choice.rkt @@ -30,18 +30,21 @@ (inherit get-cocoa init-font register-as-child) (super-new [parent parent] - [cocoa - (let ([cocoa + [cocoa + (let ([cocoa (as-objc-allocation - (tell (tell RacketPopUpButton alloc) + (tell (tell RacketPopUpButton alloc) initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y) (make-NSSize w h)) pullsDown: #:type _BOOL #f))]) + (define menu (tell cocoa menu)) (for ([lbl (in-list choices)] [i (in-naturals)]) - (tellv cocoa - insertItemWithTitle: #:type _NSString lbl - atIndex: #:type _NSInteger i)) + (tell menu + insertItemWithTitle: #:type _NSString lbl + action: #:type _SEL #f + keyEquivalent: #:type _NSString "" + atIndex: #:type _NSInteger i)) (init-font cocoa font) (tellv cocoa sizeToFit) (tellv cocoa setTarget: cocoa) @@ -65,9 +68,13 @@ (define/public (clear) (tellv (get-cocoa) removeAllItems)) (define/public (append lbl) - (tellv (get-cocoa) - insertItemWithTitle: #:type _NSString lbl - atIndex: #:type _NSInteger (number))) + (define menu (tell (get-cocoa) menu)) + (tell menu + insertItemWithTitle: #:type _NSString lbl + action: #:type _SEL #f + keyEquivalent: #:type _NSString "" + atIndex: #:type _NSInteger (number)) + (void)) (define/public (delete i) (tellv (get-cocoa) removeItemAtIndex: #:type _NSInteger i)) diff --git a/gui-lib/mred/private/wx/cocoa/color.rkt b/gui-lib/mred/private/wx/cocoa/color.rkt new file mode 100644 index 000000000..e6a1034b3 --- /dev/null +++ b/gui-lib/mred/private/wx/cocoa/color.rkt @@ -0,0 +1,24 @@ +#lang racket/base + +(require ffi/unsafe/objc + racket/draw/private/color + "types.rkt" + "utils.rkt") + +(provide + get-default-label-color + color->NSColor) + +(import-class NSColor) + +(define (get-default-label-color) + (if (version-10.10-or-later?) + (tell NSColor labelColor) + (tell NSColor controlTextColor))) + +(define (color->NSColor c) + (tell NSColor + colorWithDeviceRed: #:type _CGFloat (/ (color-red c) 255.0) + green: #:type _CGFloat (/ (color-green c) 255.0) + blue: #:type _CGFloat (/ (color-blue c) 255.0) + alpha: #:type _CGFloat (color-alpha c))) diff --git a/gui-lib/mred/private/wx/cocoa/colordialog.rkt b/gui-lib/mred/private/wx/cocoa/colordialog.rkt index 99d7df5a4..2f2d99359 100644 --- a/gui-lib/mred/private/wx/cocoa/colordialog.rkt +++ b/gui-lib/mred/private/wx/cocoa/colordialog.rkt @@ -7,13 +7,13 @@ "utils.rkt" "types.rkt" "queue.rkt" - "frame.rkt") + "frame.rkt" + "color.rkt") -(provide +(provide (protect-out get-color-from-user)) -(import-class NSColorPanel - NSColor) +(import-class NSColorPanel) (define-cocoa NSDeviceRGBColorSpace _id) @@ -42,8 +42,4 @@ (let ([p (tell NSColorPanel sharedColorPanel)] [color mode]) (atomically - (tellv p setColor: (tell NSColor - colorWithDeviceRed: #:type _CGFloat (/ (color-red color) 255.0) - green: #:type _CGFloat (/ (color-green color) 255.0) - blue: #:type _CGFloat (/ (color-blue color) 255.0) - alpha: #:type _CGFloat 1.0))))])) + (tellv p setColor: (color->NSColor color))))])) diff --git a/gui-lib/mred/private/wx/cocoa/const.rkt b/gui-lib/mred/private/wx/cocoa/const.rkt index c9c5bd740..61809de12 100644 --- a/gui-lib/mred/private/wx/cocoa/const.rkt +++ b/gui-lib/mred/private/wx/cocoa/const.rkt @@ -39,6 +39,7 @@ (define NSOtherMouseDown 25) (define NSOtherMouseUp 26) (define NSOtherMouseDragged 27) +(define NSEventTypeKeyDown 10) (define NSEventTypeGesture 29) (define NSEventTypeMagnify 30) (define NSEventTypeSwipe 31) diff --git a/gui-lib/mred/private/wx/cocoa/dialog.rkt b/gui-lib/mred/private/wx/cocoa/dialog.rkt index bfb8517ec..55bf9d20a 100644 --- a/gui-lib/mred/private/wx/cocoa/dialog.rkt +++ b/gui-lib/mred/private/wx/cocoa/dialog.rkt @@ -14,4 +14,4 @@ (super-new [is-dialog? #t]) ;; #t result avoids children sheets - (define/override (get-sheet) #t))) + (define/override (get-sheet) this))) diff --git a/gui-lib/mred/private/wx/cocoa/filedialog.rkt b/gui-lib/mred/private/wx/cocoa/filedialog.rkt index 3e7e22ded..8b6e92698 100644 --- a/gui-lib/mred/private/wx/cocoa/filedialog.rkt +++ b/gui-lib/mred/private/wx/cocoa/filedialog.rkt @@ -12,7 +12,16 @@ (provide (protect-out file-selector)) (import-class NSOpenPanel NSSavePanel NSURL NSArray - NSMenu NSMenuItem) + NSMenu NSMenuItem + NSTimer NSRunLoop) + +(define-appkit NSModalPanelRunLoopMode _id) + +;; used for fixup-panel-showing; +(define-objc-class RacketFileDialogDelegate NSObject + [ns] + [-a _void (windowDidMove: sender) + (tellv ns setAlphaValue: #:type _CGFloat 1.0)]) (define (nsurl->string url) (string->path (tell #:type _NSString url path))) @@ -27,6 +36,7 @@ (tell NSSavePanel savePanel) (tell NSOpenPanel openPanel)))] [parent (and parent + ; (not (version-12.0-or-later?)) (not (send parent get-sheet)) parent)]) @@ -102,6 +112,12 @@ [orig-mb (tell app mainMenu)]) (when orig-mb (tellv app setMainMenu: (make-standard-menu-bar))) + (define finish-timer + (cond + [(and parent + (version-12.0-or-later?)) + (fixup-panel-showing ns)] + [else void])) (when parent (tellv ns beginSheetModalForWindow: (send parent get-cocoa-window) completionHandler: #:type _pointer (and completion @@ -119,7 +135,8 @@ ;; (and this works despite the docs's claim that ;; `runModalForWindow:` centers its argument). (begin - (if (version-10.15-or-later?) + (if (and (version-10.15-or-later?) + (not (version-12.0-or-later?))) (tell ns runModal) (tell app runModalForWindow: ns)) (set-box! completion #f) @@ -130,7 +147,8 @@ (when parent (tell app endSheet: ns)) (when orig-mb (tellv app setMainMenu: orig-mb)) (when front (tellv (send front get-cocoa-window) - makeKeyAndOrderFront: #f)))))]) + makeKeyAndOrderFront: #f)) + (finish-timer))))]) (begin0 (if (zero? result) #f @@ -178,3 +196,31 @@ keyEquivalent: #:type _NSString "")) (tellv mb addItem: edit-item) mb) + +;; Hack: On Monterey, a file dialog with a parent is first centered +;; and made visible, and then the sheet animation happens. Defeat that +;; initial visibility by setting the window's alpha to 0. Set alpha to +;; 1 when the window is moved, presumably to its sheet position. For the +;; very unlikely case that the sheet position is centered on the screen, +;; so no move happens, start a backup timer to show the window. +;; A second problem is that a save dialog doesn't get the keyboard focus +;; in the file-name text field. It would be nice if the timer could do +;; something about that, but I didn't find anything that worked. +(define (fixup-panel-showing ns) + (define timer-keep (box null)) + (tellv ns setAlphaValue: #:type _CGFloat 0.0) + (tellv ns center) + (define delegate (tell RacketFileDialogDelegate alloc)) + (set-ivar! delegate ns ns) + (tellv ns setDelegate: delegate) + (define timer (tell NSTimer timerWithTimeInterval: #:type _double 2.0 + repeats: #:type _BOOL #f + block: #:type _pointer (objc-block (_fun #:keep timer-keep #:atomic? #t _pointer -> _void) + (lambda (timer) + (tellv ns setAlphaValue: #:type _CGFloat 1.0) + (void)) + #:keep timer-keep))) + (tellv (tell NSRunLoop currentRunLoop) addTimer: timer forMode: NSModalPanelRunLoopMode) + (lambda () + (tellv timer invalidate) + (set! timer-keep null))) diff --git a/gui-lib/mred/private/wx/cocoa/frame.rkt b/gui-lib/mred/private/wx/cocoa/frame.rkt index 1fc3a4557..77e344e9d 100644 --- a/gui-lib/mred/private/wx/cocoa/frame.rkt +++ b/gui-lib/mred/private/wx/cocoa/frame.rkt @@ -6,6 +6,7 @@ "utils.rkt" "const.rkt" "types.rkt" + "liquid-glass.rkt" "window.rkt" "queue.rkt" "menu-bar.rkt" @@ -28,7 +29,7 @@ (import-class NSWindow NSGraphicsContext NSMenu NSPanel NSApplication NSAutoreleasePool NSScreen - NSToolbar NSArray) + NSToolbar NSArray NSView) (define NSWindowCloseButton 0) (define NSWindowToolbarButton 3) @@ -48,6 +49,18 @@ ;; problems. (define all-windows (make-hash)) +(set-queue-events-to-refresh-all-canvases! + (let ([queue-events-to-refresh-all-canvases + (λ () + (atomically + (for ([b (in-hash-values all-windows)]) + (define frame (weak-box-value b)) + (when frame + (queue-event + (send frame get-eventspace) + (λ () (send frame request-refresh-all-canvas-children)))))))]) + queue-events-to-refresh-all-canvases)) + ;; called in atomic mode (define (send-screen-change-notifications flags) (reset-menu-bar!) @@ -129,11 +142,14 @@ ;; but we're trying to fix up a case where Cocoa seems ;; to be confused: (tellv parent resignMainWindow))))))) - (set! front wx) - (send wx install-wait-cursor) - (send wx install-mb) - (queue-window-event wx (lambda () - (send wx on-activate #t))))))) + ;; Redirect to sheet, if any, which is needed when the parent + ;; window is clicked while the sheet is visible: + (let ([wx (or (send wx get-sheet) wx)]) + (set! front wx) + (send wx install-wait-cursor) + (send wx install-mb) + (queue-window-event wx (lambda () + (send wx on-activate #t)))))))) ;; If the fake root became main (because no other windows exist), ;; we need to hide it again to avoid it getting stuck in the window list. (when (and root-fake-frame (ptr-equal? self (send root-fake-frame get-cocoa))) @@ -304,12 +320,37 @@ (tellv cocoa setAcceptsMouseMovedEvents: #:type _BOOL #t) + (define inner-content-view + (cond + [(and is-dialog? liquid-glass?) + (import-class NSLayoutConstraint) + (define cv (tell (tell NSView alloc) init)) + (define win (tell cocoa contentView)) + (define margin 10) + (tellv win addSubview: cv) + (tellv cv setTranslatesAutoresizingMaskIntoConstraints: #:type _BOOL #false) + (tellv NSLayoutConstraint + activateConstraints: + (tell NSArray + arrayWithObjects: #:type (_list i _id) + (list + (tell (tell cv topAnchor) constraintEqualToAnchor: (tell win topAnchor) constant: #:type _CGFloat margin) + (tell (tell cv leadingAnchor) constraintEqualToAnchor: (tell win leadingAnchor) constant: #:type _CGFloat margin) + (tell (tell cv trailingAnchor) constraintEqualToAnchor: (tell win trailingAnchor) constant: #:type _CGFloat (- margin)) + (tell (tell cv bottomAnchor) constraintEqualToAnchor: (tell win bottomAnchor) constant: #:type _CGFloat (- margin))) + count: #:type _NSUInteger 4)) + cv] + [else #f])) + ;; Setting the window in one-shot mode helps prevent the ;; frame from being resurrected by a click on the dock icon. (tellv cocoa setOneShot: #:type _BOOL #t) + (define/override (get-frame) + (tell #:type _NSRect cocoa frame)) + (define/override (get-cocoa-content) - (tell cocoa contentView)) + (or inner-content-view (tell cocoa contentView))) (define/override (get-cocoa-window) cocoa) (define/override (get-wx-window) this) @@ -398,7 +439,10 @@ (tell (tell NSApplication sharedApplication) endSheet: cocoa)))) (when (is-shown?) ; otherwise, `deminiaturize' can show the window - (tellv cocoa deminiaturize: #f) + (unless (version-13.0-or-later?) + ;; In Ventura, `deminiaturize` appears to queue a callback + ;; that will re-show the frame: + (tellv cocoa deminiaturize: #f)) (define fs? (fullscreened?)) (set! unshown-fullscreen? fs?) (tellv cocoa setReleasedWhenClosed: #:type _BOOL #f) @@ -845,6 +889,14 @@ (when f (send f fixup-locations-children)))))) +(set-post-key-callback-hook! + (lambda (evt) + (key-event-received #f) + (and root-fake-frame + (lambda (evt) + (unless (key-event-received) + (tellv (send root-fake-frame get-cocoa) keyDown: evt)))))) + ;; ---------------------------------------- ;; As of Mac OS 10.14, NSWindow-specific flushing control is no longer ;; supported. It seems to have been removed as a way of simplifying the @@ -860,7 +912,8 @@ (define (request-global-flush-suspend frame) (when (eq? frame front) (atomically - (tellv NSAnimationContext beginGrouping) + (unless global-suspend-at + (tellv NSAnimationContext beginGrouping)) (set! global-suspend-at (send frame get-cocoa))))) (define (force-global-flush-resume) diff --git a/gui-lib/mred/private/wx/cocoa/gauge.rkt b/gui-lib/mred/private/wx/cocoa/gauge.rkt index 7265bce32..62184871e 100644 --- a/gui-lib/mred/private/wx/cocoa/gauge.rkt +++ b/gui-lib/mred/private/wx/cocoa/gauge.rkt @@ -39,16 +39,20 @@ (tellv cocoa setMaxValue: #:type _double* rng) (tellv cocoa setDoubleValue: #:type _double* 0.0) (tellv cocoa sizeToFit) + ;; disable threaded animation to avoid a race initializing + ;; a gauge, which can make the gauge appear to run backward: + (tell cocoa setUsesThreadedAnimation: #:type _BOOL #f) (when (memq 'vertical style) (let ([r (tell #:type _NSRect cocoa frame)]) - (printf "height ~s\n" (NSSize-height (NSRect-size r))) (tellv cocoa setFrame: #:type _NSRect (make-NSRect (NSRect-origin r) (make-NSSize (NSSize-height (NSRect-size r)) (NSSize-width (NSRect-size r))))) - (tellv cocoa rotateByAngle: #:type _CGFloat -90))) + (tellv cocoa rotateByAngle: #:type _CGFloat (if (version-13.0-or-later?) + 90 + -90)))) cocoa)] [callback void] [no-show? (memq 'deleted style)]) @@ -57,6 +61,7 @@ (define/override (enable on?) (void)) (define/override (is-window-enabled?) #t) + (define/override (is-enabled-to-root?) #t) (define/public (get-range) (inexact->exact (floor (tell #:type _double cocoa maxValue)))) diff --git a/gui-lib/mred/private/wx/cocoa/group-panel.rkt b/gui-lib/mred/private/wx/cocoa/group-panel.rkt index 763d1615f..75cebdcd9 100644 --- a/gui-lib/mred/private/wx/cocoa/group-panel.rkt +++ b/gui-lib/mred/private/wx/cocoa/group-panel.rkt @@ -39,5 +39,7 @@ (define/override (get-cocoa-cursor-content) (get-cocoa)) + (define/override (is-group?) #t) + (define/public (set-label l) (tellv (get-cocoa) setTitle: #:type _NSString l))) diff --git a/gui-lib/mred/private/wx/cocoa/item.rkt b/gui-lib/mred/private/wx/cocoa/item.rkt index d95dc8bd3..59ea74ade 100644 --- a/gui-lib/mred/private/wx/cocoa/item.rkt +++ b/gui-lib/mred/private/wx/cocoa/item.rkt @@ -30,11 +30,12 @@ (tellv cocoa setFont: sys-font))) (define (strip-mnemonic s) - (regexp-replace #rx"[&](.)" s "\\1")) + (regexp-replace* #rx"[&](.)" s "\\1")) (defclass item% window% (inherit get-cocoa - is-window-enabled?) + is-window-enabled? + is-enabled-to-root?) (init-field callback) @@ -54,5 +55,8 @@ (def/public-unimplemented get-label) (super-new) + (unless (is-enabled-to-root?) + (tellv (get-cocoa-control) setEnabled: #:type _BOOL #false)) + (define/public (init-font cocoa font) (install-control-font cocoa font))) diff --git a/gui-lib/mred/private/wx/cocoa/key-translate.rkt b/gui-lib/mred/private/wx/cocoa/key-translate.rkt index 46ce7f4a8..66daf5795 100644 --- a/gui-lib/mred/private/wx/cocoa/key-translate.rkt +++ b/gui-lib/mred/private/wx/cocoa/key-translate.rkt @@ -426,7 +426,7 @@ ;; The strings used to store output from UCKeyTranslate is only allocated once: (define max-string-length 255) -(define output-chars (malloc _UniChar max-string-length)) +(define output-chars (malloc _UniChar (add1 max-string-length))) ; leave room for a terminator ;; Dead key state ; A pointer to an unsigned 32-bit value, initialized to zero. @@ -490,10 +490,11 @@ max-string-length actual-string-length output-chars) - ; get the number of characters returned, and convert to string + ;; get the number of characters returned, and convert to string; + ;; the characters are UTF-16 (define n (max 0 (min max-string-length (unbox actual-string-length)))) - (list->string (for/list ([i (in-range n)]) - (integer->char (ptr-ref output-chars _UniChar i))))) + (ptr-set! output-chars _UniChar n 0) ; ensure nul terminator + (cast output-chars _pointer _string/utf-16)) ;;; ;;; Conversions back and forth between characters and key codes. diff --git a/gui-lib/mred/private/wx/cocoa/liquid-glass.rkt b/gui-lib/mred/private/wx/cocoa/liquid-glass.rkt new file mode 100644 index 000000000..5dea37dbb --- /dev/null +++ b/gui-lib/mred/private/wx/cocoa/liquid-glass.rkt @@ -0,0 +1,27 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/objc + "utils.rkt" + "types.rkt" + "const.rkt") + +(provide liquid-glass?) + +(define liquid-glass? + (and (version-26.0-or-later?) + (let () + (import-class NSWindow) + (objc-class-has-instance-method? NSWindow (selector _cornerRadius)) + ;; This seems like a terrible way to detect whether we're using + ;; the GUI rendering introduced in Tahoe (it depends on how Racket + ;; is linked, not the OS it runs on), but this is the best + ;; recommendation I can find for now: + (define cocoa + (tell (tell NSWindow alloc) + initWithContentRect: #:type _NSRect (make-NSRect (make-NSPoint 0 0) + (make-NSSize 256 256)) + styleMask: #:type _int NSTitledWindowMask + backing: #:type _int NSBackingStoreBuffered + defer: #:type _BOOL NO)) + ((tell #:type _double cocoa _cornerRadius) . > . 12.0)))) + diff --git a/gui-lib/mred/private/wx/cocoa/list-box.rkt b/gui-lib/mred/private/wx/cocoa/list-box.rkt index 5ad9d7aff..dcaa637db 100644 --- a/gui-lib/mred/private/wx/cocoa/list-box.rkt +++ b/gui-lib/mred/private/wx/cocoa/list-box.rkt @@ -18,27 +18,30 @@ ;; ---------------------------------------- -(import-class NSScrollView NSTableView NSTableColumn NSCell NSIndexSet) +(import-class NSScrollView NSTableView NSTableColumn NSCell NSIndexSet NSFont) (import-protocol NSTableViewDataSource) (define NSLineBreakByTruncatingTail 4) (define during-selection-set? (make-parameter #f)) +;; 11.0 and up: +(define NSTableViewStyleAutomatic 0) +(define NSTableViewStyleFullWidth 1) +(define NSTableViewStyleInset 2) +(define NSTableViewStyleSourceList 3) +(define NSTableViewStylePlain 4) + +(define default-cell-font + (and (version-11.0-or-later?) + (atomically + (let ([f (tell NSFont controlContentFontOfSize: #:type _CGFloat 0.0)]) + (tellv f retain) + f)))) + (define-objc-class RacketTableView NSTableView #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) [wxb] - [-a _id (preparedCellAtColumn: [_NSInteger column] row: [_NSInteger row]) - (let ([wx (->wx wxb)]) - (tell - (let ([c (tell (tell NSCell alloc) initTextCell: #:type _NSString - (if wx (send wx get-cell column row) "???"))] - [font (and wx (send wx get-cell-font))]) - (tellv c setLineBreakMode: #:type _NSUInteger NSLineBreakByTruncatingTail) - (when font - (tellv c setFont: font)) - c) - autorelease))] [-a _void (doubleClicked: [_id sender]) (queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box-dclick)))] [-a _void (tableViewSelectionDidChange: [_id aNotification]) @@ -56,13 +59,16 @@ [-a _NSInteger (numberOfRowsInTableView: [_id view]) (let ([wx (->wx wxb)]) (send wx number))] - [-a _NSString (tableView: [_id aTableView] - objectValueForTableColumn: [_id aTableColumn] - row: [_NSInteger rowIndex]) - (let ([wx (->wx wxb)]) - (if wx - (send wx get-cell aTableColumn rowIndex) - "???"))]) + [-a _id (tableView: [_id aTableView] + objectValueForTableColumn: [_id aTableColumn] + row: [_NSInteger rowIndex]) + (define wx (->wx wxb)) + (define text (if wx (send wx get-cell aTableColumn rowIndex) "???")) + (define cell (tell (tell NSCell alloc) initTextCell: #:type _NSString text)) + (define font (and wx (send wx get-cell-font))) + (tellv cell setLineBreakMode: #:type _NSUInteger NSLineBreakByTruncatingTail) + (when font (tellv cell setFont: font)) + (tell cell autorelease)]) (define (remove-nth data i) (cond @@ -106,6 +112,9 @@ (tellv (tell col headerCell) setStringValue: #:type _NSString title) col))) (init-font content-cocoa font) + (when (version-11.0-or-later?) + (tellv content-cocoa setStyle: #:type _NSInteger NSTableViewStyleFullWidth) + (tellv content-cocoa setIntercellSpacing: #:type _NSSize (make-NSSize 1.0 1.0))) (values content-cocoa cols))) (set-ivar! content-cocoa wxb (->wxb this)) @@ -168,7 +177,8 @@ (def/public-unimplemented get-label-font) - (define cell-font (and font (font->NSFont font))) + (define cell-font (or (and font (font->NSFont font)) + default-cell-font)) (when cell-font (tellv content-cocoa setRowHeight: #:type _CGFloat (+ (tell #:type _CGFloat cell-font defaultLineHeightForFont) 2))) diff --git a/gui-lib/mred/private/wx/cocoa/menu-bar.rkt b/gui-lib/mred/private/wx/cocoa/menu-bar.rkt index cc5c8885a..128785fb4 100644 --- a/gui-lib/mred/private/wx/cocoa/menu-bar.rkt +++ b/gui-lib/mred/private/wx/cocoa/menu-bar.rkt @@ -203,7 +203,7 @@ (list (cons (car i) (cons str (cddr i))))) (drop menus (add1 pos)))) (when (eq? current-mb this) - (tellv (tell cocoa-mb itemAtIndex: #:type _NSInteger 1) + (tellv (tell (tell cocoa-mb itemAtIndex: #:type _NSInteger 1) submenu) setTitle: #:type _NSString (clean-menu-label str)))) (define/public (do-on-menu-click) diff --git a/gui-lib/mred/private/wx/cocoa/message.rkt b/gui-lib/mred/private/wx/cocoa/message.rkt index b8e17b03e..d124a921a 100644 --- a/gui-lib/mred/private/wx/cocoa/message.rkt +++ b/gui-lib/mred/private/wx/cocoa/message.rkt @@ -9,14 +9,16 @@ "item.rkt" "utils.rkt" "types.rkt" - "image.rkt") + "image.rkt" + "color.rkt" + "liquid-glass.rkt") -(provide +(provide (protect-out message%)) ;; ---------------------------------------- -(import-class NSTextField NSImageView NSWorkspace NSRunningApplication) +(import-class NSTextField NSImageView NSWorkspace NSRunningApplication NSColor) (define _OSType _uint32) @@ -38,7 +40,7 @@ (tell (tell NSWorkspace sharedWorkspace) iconForFileType: (NSFileTypeForHFSTypeCode id))))]) - (tellv icon retain) + (tellv icon retain) (tellv icon setSize: #:type _NSSize (make-NSSize 64 64)) (unless (eq? label 'app) ;; Add badge: @@ -48,7 +50,7 @@ (make-NSSize 32 32)) fromRect: #:type _NSRect (make-NSRect (make-NSPoint 0 0) (make-NSSize 64 64)) - operation: #:type _int 2 ; NSCompositeSourceOver + operation: #:type _int 2 ; NSCompositeSourceOver fraction: #:type _CGFloat 1.0) (tellv icon unlockFocus))) icon)) @@ -74,8 +76,11 @@ (init parent label x y style font) + (init-field color) (inherit get-cocoa init-font) - + + (define text-label? (string? label)) + (super-new [parent parent] [cocoa (let* ([label (cond [(string? label) label] @@ -90,6 +95,8 @@ (cond [(string? label) (init-font cocoa font) + (when color + (tellv cocoa setTextColor: (color->NSColor color))) (tellv cocoa setSelectable: #:type _BOOL #f) (tellv cocoa setEditable: #:type _BOOL #f) (tellv cocoa setBordered: #:type _BOOL #f) @@ -100,7 +107,7 @@ (tellv cocoa setImage: (if (label . is-a? . bitmap%) (bitmap->image label) label)) - (tellv cocoa setFrame: #:type _NSRect + (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) (if (label . is-a? . bitmap%) (make-NSSize (send label get-width) @@ -111,6 +118,7 @@ [no-show? (memq 'deleted style)]) (define/override (set-label label) + (set! text-label? (string? label)) (cond [(string? label) (tellv (get-cocoa) setStringValue: #:type _NSString (strip-mnemonic label))] @@ -123,5 +131,32 @@ (tellv (get-cocoa) sizeToFit) #t) - (def/public-unimplemented get-font)) + (define b-margin + (if liquid-glass? + 4 + 0)) + (define/override (get-frame) + (define r (super get-frame)) + (cond + [(= b-margin 0) + r] + [else + (define p (NSRect-origin r)) + (define s (NSRect-size r)) + (make-NSRect p + (make-NSSize (NSSize-width s) + (+ (NSSize-height s) b-margin)))])) + + (define/override (set-frame x y w h) + (super set-frame x y w (max 0 (- h b-margin)))) + + (define/public (get-color) color) + (define/public (set-color c) + (when text-label? + (set! color c) + (tellv (get-cocoa) setTextColor: (if c + (color->NSColor c) + (get-default-label-color))))) + + (def/public-unimplemented get-font)) diff --git a/gui-lib/mred/private/wx/cocoa/panel.rkt b/gui-lib/mred/private/wx/cocoa/panel.rkt index bdb3043c7..85e588d66 100644 --- a/gui-lib/mred/private/wx/cocoa/panel.rkt +++ b/gui-lib/mred/private/wx/cocoa/panel.rkt @@ -6,13 +6,17 @@ "types.rkt" "utils.rkt" "cg.rkt" - "window.rkt") + "window.rkt" + "procs.rkt" + "liquid-glass.rkt") (provide (protect-out panel% panel-mixin - FrameView)) + FrameView + frame-black + frame-white)) (import-class NSView NSGraphicsContext) @@ -20,15 +24,25 @@ #:mixins (KeyMouseTextResponder CursorDisplayer) [wxb]) +(define frame-black (if liquid-glass? 0.7 0)) +(define frame-white (if liquid-glass? 0.5 0.8)) + (define-objc-class FrameView NSView [] (-a #:async-apply (box (void)) _void (drawRect: [_NSRect r]) - (let ([ctx (tell NSGraphicsContext currentContext)]) + (let ([wob? (white-on-black-panel-scheme?)] + [ctx (tell NSGraphicsContext currentContext)]) (tellv ctx saveGraphicsState) (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] [r (tell #:type _NSRect self bounds)]) - (CGContextSetRGBFillColor cg 0 0 0 1.0) + (cond + [wob? + (CGContextSetRGBFillColor cg 0 0 0 1.0) + (CGContextSetRGBStrokeColor cg frame-white frame-white frame-white 1.0)] + [else + (CGContextSetRGBFillColor cg 1.0 1.0 1.0 1.0) + (CGContextSetRGBStrokeColor cg frame-black frame-black frame-black 1.0)]) (CGContextAddRect cg r) (CGContextStrokePath cg)) (tellv ctx restoreGraphicsState)))) diff --git a/gui-lib/mred/private/wx/cocoa/platform.rkt b/gui-lib/mred/private/wx/cocoa/platform.rkt index bd3a1502d..84df903a4 100644 --- a/gui-lib/mred/private/wx/cocoa/platform.rkt +++ b/gui-lib/mred/private/wx/cocoa/platform.rkt @@ -95,4 +95,6 @@ check-for-break key-symbol-to-menu-key needs-grow-box-spacer? - graphical-system-type)) + graphical-system-type + white-on-black-panel-scheme? + tab-panel-available?)) diff --git a/gui-lib/mred/private/wx/cocoa/procs.rkt b/gui-lib/mred/private/wx/cocoa/procs.rkt index cecc05370..786b064d7 100644 --- a/gui-lib/mred/private/wx/cocoa/procs.rkt +++ b/gui-lib/mred/private/wx/cocoa/procs.rkt @@ -20,6 +20,7 @@ "sound.rkt" "keycode.rkt" "font.rkt" + "queue.rkt" "../../lock.rkt" "../common/handlers.rkt" (except-in "../common/default-procs.rkt" @@ -71,7 +72,8 @@ key-symbol-to-menu-key needs-grow-box-spacer? get-current-mouse-state - graphical-system-type) + graphical-system-type + white-on-black-panel-scheme?) (import-class NSScreen NSCursor NSMenu NSEvent) @@ -176,23 +178,43 @@ ;; Text & highlight color (import-class NSColor) - -(define-cocoa NSDeviceRGBColorSpace _id) +(import-class NSColorSpace) +(import-class NSAppearance) (define (get-color get) - (let ([hi (as-objc-allocation-with-retain - (tell (get) colorUsingColorSpaceName: NSDeviceRGBColorSpace))] - [as-color (lambda (v) - (inexact->exact (floor (* 255.0 v))))]) - (begin0 - (make-object color% - (as-color - (tell #:type _CGFloat hi redComponent)) - (as-color - (tell #:type _CGFloat hi greenComponent)) - (as-color - (tell #:type _CGFloat hi blueComponent))) - (release hi)))) + (define hi + (as-objc-allocation-with-retain + (cond + [(version-11.0-or-later?) + (define ans #f) + (define keep (box null)) + (tell (tell app effectiveAppearance) + performAsCurrentDrawingAppearance: + #:type _pointer + (objc-block + (_fun #:atomic? #t #:keep keep _pointer -> _void) + (λ (blk) + (set! ans (tell (get) colorUsingColorSpace: (tell NSColorSpace deviceRGBColorSpace)))) + #:keep keep)) + (void/reference-sink keep) + ans] + [(version-10.7-or-later?) + (tell (get) colorUsingColorSpace: (tell NSColorSpace deviceRGBColorSpace))] + [else + ;; In 10.6 and earlier, `colorUsingColorSpace:` with (tell NSColorSpace deviceRGBColorSpace)` + ;; doesn't produce a color with RGB components + (tell (get) colorUsingColorSpaceName: #:type _NSString "NSDeviceRGBColorSpace")]))) + (define (as-color v) + (inexact->exact (floor (* 255.0 v)))) + (begin0 + (make-object color% + (as-color + (tell #:type _CGFloat hi redComponent)) + (as-color + (tell #:type _CGFloat hi greenComponent)) + (as-color + (tell #:type _CGFloat hi blueComponent))) + (release hi))) (define (get-highlight-background-color) (get-color (lambda () (tell NSColor selectedTextBackgroundColor)))) @@ -211,6 +233,34 @@ ;; Seems like accurate than other option for Mojave: (tell NSColor controlBackgroundColor))))) +(define-appkit NSAppearanceNameAqua _id #:fail (λ () #f)) +(define-appkit NSAppearanceNameDarkAqua _id #:fail (λ () #f)) +(import-class NSArray) + +(define (white-on-black-panel-scheme?) + (cond + [(version-10.14-or-later?) + (equal? + NSAppearanceNameDarkAqua + (atomically + (tell (tell app effectiveAppearance) + bestMatchFromAppearancesWithNames: + (tell NSArray + arrayWithObjects: + #:type + (_list i _id) + (list NSAppearanceNameAqua + NSAppearanceNameDarkAqua) + count: + #:type _NSUInteger + 2))))] + [else + ;; if the background and foreground are the same + ;; color, probably something has gone wrong; + ;; in that case we want to return #f. + (< (luminance (get-label-background-color)) + (luminance (get-label-foreground-color)))])) + (define (get-highlight-text-color) #f) diff --git a/gui-lib/mred/private/wx/cocoa/queue.rkt b/gui-lib/mred/private/wx/cocoa/queue.rkt index 07fd0af6f..94f5ea393 100644 --- a/gui-lib/mred/private/wx/cocoa/queue.rkt +++ b/gui-lib/mred/private/wx/cocoa/queue.rkt @@ -24,39 +24,75 @@ set-front-hook! set-menu-bar-hooks! set-mouse-or-key-hook! + set-post-key-callback-hook! set-fixup-window-locations! post-dummy-event try-to-sync-refresh try-to-flush sync-cocoa-events - set-screen-changed-callback!) + set-screen-changed-callback! + set-queue-events-to-refresh-all-canvases!) ;; from common/queue: current-eventspace queue-event yield) -(import-class NSApplication NSAutoreleasePool NSColor NSProcessInfo NSArray NSMenu NSThread) +(import-class NSApplication NSAutoreleasePool NSColor NSProcessInfo NSArray NSMenu NSThread + NSUserDefaults NSDictionary) (unless (tell #:type _BOOL NSThread isMainThread) (error 'racket/gui "cannot instantiate in a non-main place on Mac OS")) -;; Extreme hackery to hide original arguments from -;; NSApplication, because NSApplication wants to turn -;; the arguments into `application:openFile:' calls. -;; To hide the arguments, we replace the implementation -;; of `arguments' in the NSProcessInfo object. -(define (hack-argument-replacement self method) - (tell NSArray - arrayWithObjects: #:type (_vector i _NSString) (vector (path->string (find-system-path 'exec-file))) - count: #:type _NSUInteger 1)) -(let ([m (class_getInstanceMethod NSProcessInfo (selector arguments))]) - (void (method_setImplementation m hack-argument-replacement))) +;; Hide original arguments from NSApplication, because NSApplication +;; otherwise turns the arguments into `application:openFile:' calls. +(void + (tell (tell NSUserDefaults standardUserDefaults) + registerDefaults: + (tell NSDictionary + dictionaryWithObjects: + (tell NSArray + arrayWithObjects: #:type (_vector i _NSString) (vector "NO") + count: #:type _NSUInteger 1) + forKeys: + (tell NSArray + arrayWithObjects: #:type (_vector i _NSString) (vector "NSTreatUnknownArgumentsAsOpen") + count: #:type _NSUInteger 1)))) (define app (tell NSApplication sharedApplication)) +;; ------------------------------------------------------------ +;; Create an event to post when Racket has been sleeping but is +;; ready to wake up + +(import-class NSEvent) +(define wake-evt + (tell NSEvent + otherEventWithType: #:type _NSUInteger NSApplicationDefined + location: #:type _NSPoint (make-NSPoint 0.0 0.0) + modifierFlags: #:type _NSUInteger 0 + timestamp: #:type _double 0.0 + windowNumber: #:type _NSUInteger 0 + context: #:type _pointer #f + subtype: #:type _short 0 + data1: #:type _NSInteger 0 + data2: #:type _NSInteger 0)) +(retain wake-evt) +(define (post-dummy-event) + (tell #:type _void app postEvent: wake-evt atStart: #:type _BOOL YES)) + +;; This callback will be invoked by the CoreFoundation run loop +;; when data is available on `ready_sock', which is used to indicate +;; that Racket would like to wake up (and posting a Cocoa event +;; causes the event-getting function to unblock). +(define (socket_callback) + (read2 ready_sock read-buf 1) + (post-dummy-event)) + +;; ------------------------------------------------------------ + (define got-file? #f) (define-objc-class RacketApplicationDelegate NSObject ;; note: NSApplicationDelegate doesn't exist at run time @@ -90,8 +126,20 @@ [-a _void (applicationDidFinishLaunching: [_id notification]) ;; Create an empty windows menu for right clicking in the dock (tell app setWindowsMenu: (tell (tell NSMenu alloc) init)) + (when (version-10.9-or-later?) + (tell app addObserver: + self + forKeyPath: #:type _NSString "effectiveAppearance" + options: #f + context: #f)) (unless got-file? (queue-start-empty-event))] + [-a _void (observeValueForKeyPath: [_NSString keyPath] ofObject: ofObject change: change context: context) + ;; we add an observer only for "effectiveAppearance", + ;; so no check is needed to know why we got here + (queue-dark-mode-event) + (queue-events-to-refresh-all-canvases) + (void)] [-a _BOOL (applicationShouldHandleReopen: [_id app] hasVisibleWindows: [_BOOL has-visible?]) ;; If we have any visible windows, return #t to do the default thing. ;; Otherwise return #f, because we don't want any invisible windows resurrected. @@ -110,6 +158,10 @@ [-a _void (retrySelfToFront: o) (tellv app activateIgnoringOtherApps: #:type _BOOL #t)]) +(define queue-events-to-refresh-all-canvases void) +(define (set-queue-events-to-refresh-all-canvases! f) + (set! queue-events-to-refresh-all-canvases f)) + (define fixup-window-locations void) (define (set-fixup-window-locations! f) (set! fixup-window-locations f)) @@ -206,34 +258,6 @@ reason: #:type _NSString "Racket default") retain)) -;; ------------------------------------------------------------ -;; Create an event to post when Racket has been sleeping but is -;; ready to wake up - -(import-class NSEvent) -(define wake-evt - (tell NSEvent - otherEventWithType: #:type _NSUInteger NSApplicationDefined - location: #:type _NSPoint (make-NSPoint 0.0 0.0) - modifierFlags: #:type _NSUInteger 0 - timestamp: #:type _double 0.0 - windowNumber: #:type _NSUInteger 0 - context: #:type _pointer #f - subtype: #:type _short 0 - data1: #:type _NSInteger 0 - data2: #:type _NSInteger 0)) -(retain wake-evt) -(define (post-dummy-event) - (tell #:type _void app postEvent: wake-evt atStart: #:type _BOOL YES)) - -;; This callback will be invoked by the CoreFoundation run loop -;; when data is available on `ready_sock', which is used to indicate -;; that Racket would like to wake up (and posting a Cocoa event -;; causes the event-getting function to unblock). -(define (socket_callback) - (read2 ready_sock read-buf 1) - (post-dummy-event)) - ;; ------------------------------------------------------------ ;; Create a pipe's pair of file descriptors, used to communicate ;; from the Racket-sleep thread to the CoreFoundation run loop. @@ -330,7 +354,11 @@ (define (exiting-run-loop x y z) (when sleeping? (if already-exited? - (unsafe-signal-received) + (begin + ;; should get out of the event loop: + (post-dummy-event) + ;; for good measure, alow let the scheduler know: + (unsafe-signal-received)) (set! already-exited? #t)))) (let ([o (CFRunLoopObserverCreate #f kCFRunLoopExit #t 0 exiting-run-loop #f)]) (CFRunLoopAddObserver (CFRunLoopGetMain) o kCFRunLoopCommonModes)) @@ -399,6 +427,9 @@ (define front-hook (lambda () (values #f #f))) (define (set-front-hook! proc) (set! front-hook proc)) +(define get-post-key-callback (lambda () #f)) +(define (set-post-key-callback-hook! proc) (set! get-post-key-callback proc)) + (define in-menu-bar-range? (lambda (p flipped?) #f)) (define (set-menu-bar-hooks! r?) (set! in-menu-bar-range? r?)) @@ -498,8 +529,14 @@ (lambda () ;; in atomic mode (with-autorelease - (tellv app sendEvent: evt) - (release evt)))) + (define post-key + (and (not w) + (= NSEventTypeKeyDown (tell #:type _NSUInteger evt type)) + (not (tell app keyWindow)) + (get-post-key-callback evt))) + (tellv app sendEvent: evt) + (when post-key (post-key evt)) + (release evt)))) (when mouse-or-key? (set! avoid-mouse-key-until #f))))) (tellv app sendEvent: evt))) diff --git a/gui-lib/mred/private/wx/cocoa/radio-box.rkt b/gui-lib/mred/private/wx/cocoa/radio-box.rkt index 4a6547da4..7b6fc47f1 100644 --- a/gui-lib/mred/private/wx/cocoa/radio-box.rkt +++ b/gui-lib/mred/private/wx/cocoa/radio-box.rkt @@ -8,6 +8,7 @@ "types.rkt" "const.rkt" "utils.rkt" + "liquid-glass.rkt" "window.rkt" "../common/event.rkt" "image.rkt") @@ -85,7 +86,9 @@ RacketImageButtonCell) numberOfRows: #:type _NSInteger (if horiz? 1 (length labels)) numberOfColumns: #:type _NSInteger (if horiz? (length labels) 1)))]) - (tellv cocoa setIntercellSpacing: #:type _NSSize (make-NSSize 2 2)) + (tellv cocoa setIntercellSpacing: #:type _NSSize (if liquid-glass? + (make-NSSize 5 5) + (make-NSSize 2 2))) (for ([label (in-list labels)] [i (in-naturals)]) (let ([button (tell cocoa diff --git a/gui-lib/mred/private/wx/cocoa/slider.rkt b/gui-lib/mred/private/wx/cocoa/slider.rkt index 9080dfafa..bf2c4f788 100644 --- a/gui-lib/mred/private/wx/cocoa/slider.rkt +++ b/gui-lib/mred/private/wx/cocoa/slider.rkt @@ -44,7 +44,9 @@ (inherit get-cocoa register-as-child init-font) - (define vert? (memq 'vertical style)) + (define vert? (or (memq 'vertical style) + (memq 'upward style))) + (define up? (memq 'upward style)) (define slider-lo lo) (define slider-hi hi) @@ -63,6 +65,8 @@ (make-NSPoint 0 0) (make-NSSize (if vert? 24 32) (if vert? 64 24)))) + (when (and vert? (version-10.12-or-later?)) + (tellv cocoa setVertical: #:type _BOOL #t)) (tellv cocoa setContinuous: #:type _BOOL #t) ;; (tellv cocoa sizeToFit) cocoa)) @@ -153,7 +157,9 @@ (define/private (flip v) (if vert? - (+ slider-lo (- slider-hi v)) + (if up? + v + (+ slider-lo (- slider-hi v))) v)) (define/public (set-value v) diff --git a/gui-lib/mred/private/wx/cocoa/tab-panel.rkt b/gui-lib/mred/private/wx/cocoa/tab-panel.rkt index 4ac48e42a..301d6e971 100644 --- a/gui-lib/mred/private/wx/cocoa/tab-panel.rkt +++ b/gui-lib/mred/private/wx/cocoa/tab-panel.rkt @@ -15,7 +15,8 @@ (for-syntax racket/base)) (provide - (protect-out tab-panel%)) + (protect-out tab-panel% + tab-panel-available?)) (define-runtime-path psm-tab-bar-dir '(so "PSMTabBarControl.framework")) @@ -29,23 +30,29 @@ (directory-exists? mm-tab-bar-dir))) ;; Load MMTabBarView or PSMTabBarControl: -(if use-mm? - (void (ffi-lib (build-path mm-tab-bar-dir "MMTabBarView"))) - (void (ffi-lib (build-path psm-tab-bar-dir "PSMTabBarControl")))) +(define tab-ok? + (if use-mm? + (and (ffi-lib (build-path mm-tab-bar-dir "MMTabBarView") #:fail (lambda () #f)) + 'mm) + (and (ffi-lib (build-path psm-tab-bar-dir "PSMTabBarControl") #:fail (lambda () #f)) + 'psm))) +(define (tab-panel-available?) tab-ok?) + (define NSNoTabsNoBorder 6) (define NSDefaultControlTint 0) (define NSClearControlTint 7) -(import-class NSView NSTabView NSTabViewItem) +(import-class NSView NSTabView NSTabViewItem NSSegmentedControl) (define TabBarControl - (if use-mm? - (let () - (import-class MMTabBarView) - MMTabBarView) - (let () - (import-class PSMTabBarControl) - PSMTabBarControl))) + (cond + [(not tab-ok?) #f] + [use-mm? + (import-class MMTabBarView) + MMTabBarView] + [else + (import-class PSMTabBarControl) + PSMTabBarControl])) (import-protocol NSTabViewDelegate) (define NSOrderedAscending -1) @@ -65,7 +72,15 @@ (-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa]) (let ([wx (->wx wxb)]) (when (and wx (send wx callbacks-enabled?)) - (queue-window*-event wxb (lambda (wx) (send wx do-callback))))))) + (queue-window*-event wxb (lambda (wx) (send wx do-callback)))))) + (-a _void (onCloseTabViewItem: item) + (let ([wx (->wx wxb)]) + (when wx + (queue-window*-event wxb (lambda (wx) (send wx do-tab-close item)))))) + (-a _void (onDropTabViewItem: item) + (let ([wx (->wx wxb)]) + (when wx + (send wx check-reorder))))) ;; The MMTabBarView widget doesn't support disabling, so we have to ;; implement it. Also, we need to override a method to disable (for now) @@ -79,7 +94,19 @@ #f (super-tell hitTest: #:type _NSPoint pt)))) (-a _BOOL (shouldStartDraggingAttachedTabBarButton: b withMouseDownEvent: evt) - #f)) + (let ([wx (->wx wxb)]) + (cond + [(and wx (send wx drag-enabled?)) + (super-tell #:type _BOOL shouldStartDraggingAttachedTabBarButton: b withMouseDownEvent: evt)] + [else #f])))) + +(define-objc-class RacketTabViewDelegate NSObject + [] + (-a _BOOL (tabView: tv shouldCloseTabViewItem: item) + (tellv tv onCloseTabViewItem: item) + #f) + (-a _void (tabView: tv didMoveTabViewItem: item toIndex: pos) + (tellv tv onDropTabViewItem: item))) ;; A no-op mixin instead of `EnableMixin` for PSMTabBarControl: (define-objc-mixin (EmptyMixin Superclass) @@ -99,7 +126,9 @@ labels) (inherit get-cocoa register-as-child is-window-enabled? - block-mouse-events) + is-enabled-to-root? + block-mouse-events + refresh) (define tabv-cocoa (as-objc-allocation (tell (tell RacketTabView alloc) init))) @@ -108,17 +137,23 @@ (tell (tell NSView alloc) init)) tabv-cocoa)) + (define has-close? (and (memq 'can-close style) #t)) + (define control-cocoa (and (not (memq 'border style)) (let ([i (as-objc-allocation (tell (tell RacketPSMTabBarControl alloc) initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) (make-NSSize 200 22))))]) + (set-ivar! tabv-cocoa wxb (->wxb this)) (tellv cocoa addSubview: i) (tellv cocoa addSubview: tabv-cocoa) (tellv tabv-cocoa setDelegate: i) (tellv tabv-cocoa setTabViewType: #:type _int NSNoTabsNoBorder) (tellv i setTabView: tabv-cocoa) + (when use-mm? + (let ([delegate (as-objc-allocation (tell (tell RacketTabViewDelegate alloc) init))]) + (tellv i setDelegate: delegate))) (tellv i setStyleNamed: #:type _NSString (if use-mm? (if (version-10.14-or-later?) @@ -126,16 +161,28 @@ "Yosemite") "Aqua")) ;; (tellv i setSizeCellsToFit: #:type _BOOL #t) + (if (and has-close? + use-mm?) + (tellv i setOnlyShowCloseOnHover: #:type _BOOL #t) + (tellv i setDisableTabClose: #:type _BOOL #t)) (when use-mm? (tellv i setResizeTabsToFitTotalWidth: #:type _BOOL #t)) - (tellv i setDisableTabClose: #:type _BOOL #t) i))) + (define content-cocoa + (as-objc-allocation + (tell (tell NSView alloc) + initWithFrame: #:type _NSRect (tell #:type _NSRect tabv-cocoa contentRect)))) + (define item-cocoas (for/list ([lbl (in-list labels)]) (let ([item (as-objc-allocation (tell (tell NSTabViewItem alloc) initWithIdentifier: #f))]) (tellv item setLabel: #:type _NSString (label->plain-label lbl)) + (tellv item setView: content-cocoa) + (when (and has-close? + use-mm?) + (tellv item setHasCloseButton: #:type _BOOL #t)) (tellv tabv-cocoa addTabViewItem: item) item))) (if control-cocoa @@ -145,12 +192,6 @@ (tellv tabv-cocoa setFrame: #:type _NSRect (make-NSRect (make-init-point x y) sz)) (tellv tabv-cocoa setDelegate: tabv-cocoa))) - (define content-cocoa - (as-objc-allocation - (tell (tell NSView alloc) - initWithFrame: #:type _NSRect (tell #:type _NSRect tabv-cocoa contentRect)))) - (tellv tabv-cocoa addSubview: content-cocoa) - (define/override (get-cocoa-content) content-cocoa) (define/override (get-cocoa-cursor-content) tabv-cocoa) (define/override (set-size x y w h) @@ -201,6 +242,10 @@ (let ([item (as-objc-allocation (tell (tell NSTabViewItem alloc) initWithIdentifier: #f))]) (tellv item setLabel: #:type _NSString (label->plain-label lbl)) + (tellv item setView: content-cocoa) + (when (and has-close? + use-mm?) + (tellv item setHasCloseButton: #:type _BOOL #t)) (tellv tabv-cocoa addTabViewItem: item) (set! item-cocoas (append item-cocoas (list item))) ;; Sometimes the sub-view for the tab buttons gets put in front @@ -236,7 +281,7 @@ (super-new [parent parent] [cocoa cocoa] [no-show? (memq 'deleted style)]) - + (when control-cocoa (set-ivar! control-cocoa wxb (->wxb this))) @@ -248,7 +293,17 @@ (if on? NSDefaultControlTint NSClearControlTint)) (when control-cocoa (unless use-mm? - (tellv control-cocoa setEnabled: #:type _BOOL on?))))) + (tellv control-cocoa seteEnabled: #:type _BOOL on?))) + (when (version-26.0-or-later?) + (when (eq? cocoa tabv-cocoa) + (let ([subviews (tell cocoa subviews)]) + (for ([i (in-range 0 (tell #:type _NSUInteger subviews count))]) + (define c (tell subviews objectAtIndex: #:type _NSUInteger i)) + (when (tell #:type _BOOL c isKindOfClass: (tell NSSegmentedControl class)) + (tellv c setEnabled: #:type _BOOL on?)))))))) + + (unless (is-enabled-to-root?) + (enable-window #f)) (define/override (can-accept-focus?) (and (not control-cocoa) @@ -265,5 +320,33 @@ (direct-set-selection n))) (define/override (maybe-register-as-child parent on?) - (register-as-child parent on?))) + (register-as-child parent on?)) + + (define is-drag-enabled? (and (memq 'can-reorder style))) + (define/public (drag-enabled?) is-drag-enabled?) + (define/public (check-reorder) + (define rev-mapping + (for/hash ([item-cocoa (in-list item-cocoas)] + [i (in-naturals)]) + (values (tell #:type _NSInteger tabv-cocoa indexOfTabViewItem: item-cocoa) + (cons i item-cocoa)))) + (unless (for/and ([(k v) (in-hash rev-mapping)]) + (= k (car v))) + (set! item-cocoas (for/list ([i (in-range (length item-cocoas))]) + (cdr (hash-ref rev-mapping i)))) + (define moved-mapping + (for/list ([i (in-range (length item-cocoas))]) (car (hash-ref rev-mapping i)))) + (refresh) ; seems to be needed sometimes to fix display + (on-choice-reorder moved-mapping))) + (define/public (on-choice-reorder new-positions) + (void)) + (define/public (do-tab-close close-item-cocoa) + (define i (for/or ([item-cocoa (in-list item-cocoas)] + [i (in-naturals)]) + (and (equal? item-cocoa close-item-cocoa) + i))) + (when i + (on-choice-close i))) + (define/public (on-choice-close pos) + (void))) diff --git a/gui-lib/mred/private/wx/cocoa/utils.rkt b/gui-lib/mred/private/wx/cocoa/utils.rkt index 67a110dba..b5541e9c0 100644 --- a/gui-lib/mred/private/wx/cocoa/utils.rkt +++ b/gui-lib/mred/private/wx/cocoa/utils.rkt @@ -32,7 +32,12 @@ version-10.12-or-later? version-10.13-or-later? version-10.14-or-later? - version-10.15-or-later?) + version-10.15-or-later? + version-11.0-or-later? + version-12.0-or-later? + version-13.0-or-later? + version-14.0-or-later? + version-26.0-or-later?) with-autorelease call-with-autorelease define-mz) @@ -107,3 +112,13 @@ (NSAppKitVersionNumber . >= . 1671)) (define (version-10.15-or-later?) ; Catalina (NSAppKitVersionNumber . >= . 1700)) +(define (version-11.0-or-later?) ; Big Sur + (NSAppKitVersionNumber . >= . 2000)) +(define (version-12.0-or-later?) ; Monterey + (NSAppKitVersionNumber . >= . 2100)) +(define (version-13.0-or-later?) ; Ventura + (NSAppKitVersionNumber . >= . 2200)) +(define (version-14.0-or-later?) ; Sonoma + (NSAppKitVersionNumber . >= . 2400)) +(define (version-26.0-or-later?) ; Tahoe + (NSAppKitVersionNumber . >= . 2600)) diff --git a/gui-lib/mred/private/wx/cocoa/window.rkt b/gui-lib/mred/private/wx/cocoa/window.rkt index 585a3a0a5..549f81f72 100644 --- a/gui-lib/mred/private/wx/cocoa/window.rkt +++ b/gui-lib/mred/private/wx/cocoa/window.rkt @@ -26,6 +26,8 @@ KeyMouseTextResponder CursorDisplayer + key-event-received + queue-window-event queue-window-refresh-event queue-window*-event @@ -39,6 +41,8 @@ (define-local-member-name flip-client) +(define got null) + ;; ---------------------------------------- (define special-control-key? #f) @@ -81,6 +85,7 @@ (import-protocol NSTextInput) (define current-insert-text (make-parameter #f)) +(define current-insert-text-timestamp (make-parameter 0.0)) (define current-set-mark (make-parameter #f)) (define NSDragOperationCopy 1) @@ -136,7 +141,7 @@ [-a _void (mouseEntered: [_id event]) (unless (do-mouse-event wxb event 'enter 'check 'check 'check) (super-tell #:type _void mouseEntered: event))] - [-a _void (mouseExited: [_id event]) + [-a _void (mouseExited: [_id event]) (unless (do-mouse-event wxb event 'leave 'check 'check 'check) (super-tell #:type _void mouseExited: event))] [-a _void (rightMouseDown: [_id event]) @@ -181,8 +186,8 @@ (let ([wx (->wx wxb)]) (post-dummy-event) ;; to wake up in case of character palette insert (when wx - (queue-window-event wx (lambda () - (send wx key-event-as-string str)))))))] + (let ([ts (current-insert-text-timestamp)]) + (send wx key-event-as-string str ts))))))] ;; for NSTextInput: [-a _BOOL (hasMarkedText) (get-saved-marked wxb)] @@ -199,7 +204,7 @@ (make-NSRange (car s) (cdr s)))) (make-NSRange 0 0))] [-a _void (setMarkedText: [_NSStringOrAttributed aString] selectedRange: [_NSRange selRange]) - ;; We interpreter a call to `setMarkedText:' as meaning that the + ;; We interpret a call to `setMarkedText:' as meaning that the ;; key is a dead key for composing some other character. (let ([m (current-set-mark)]) (when m (set-box! m #t))) ;; At the same time, we need to remember the text: @@ -301,6 +306,7 @@ (let ([inserted-text (box #f)] [set-mark (box #f)] [had-saved-text? (and (send wx get-saved-marked) #t)]) + (key-event-received #t) (when down? ;; Calling `interpretKeyEvents:' allows key combinations to be ;; handled, such as option-e followed by e to produce é. The @@ -310,6 +316,7 @@ ;; text and handle the event as usual, though probably we should ;; be doing something with it. (parameterize ([current-insert-text inserted-text] + [current-insert-text-timestamp (tell #:type _double event timestamp)] [current-set-mark set-mark]) (let ([array (tell (tell NSArray alloc) initWithObjects: #:type _ptr-to-id event @@ -394,7 +401,7 @@ modifier-cmd-key modifier-control-key)) (define kc (tell #:type _ushort event keyCode)) (define mods (bitwise-and (<< modifiers -8) mask)) - (when (zero? code-offset) + (when (zero? code-offset)< (define s (key-translate kc #:modifier-key-state mods #:dead-key-state dead-key-state)) (define dead? (= 0 (string-length s))) @@ -612,7 +619,7 @@ (set-ivar! cocoa wxb (->wxb this)) (unless no-show? - (show #t)) + (show #t)) (define/public (focus-is-on on?) (void)) @@ -729,9 +736,15 @@ (define/public (block-mouse-events block?) (set! block-all-mouse-events? block?)) - (define/private (get-frame) - (let ([v (tell #:type _NSRect cocoa frame)]) - v)) + (define/public (is-group?) #f) + + (define/public (get-frame) + (tellv cocoa layoutSubtreeIfNeeded) + (tell #:type _NSRect cocoa frame)) + + (define/public (set-frame x y w h) + (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h)) + (make-NSSize w h)))) (define/public (flip y h) (if parent @@ -792,6 +805,7 @@ (define/public (get-client-size w h) ;; May be called in Cocoa event-handling mode + (tellv (get-cocoa-content) layoutSubtreeIfNeeded) (let ([s (NSRect-size (tell #:type _NSRect (get-cocoa-content) bounds))]) (set-box! w (->long (ceiling (NSSize-width s)))) (set-box! h (->long (ceiling (NSSize-height s)))))) @@ -801,8 +815,7 @@ [y (if (not y) (get-y) y)]) ;; old location will need refresh: (tellv cocoa setNeedsDisplay: #:type _BOOL #t) - (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h)) - (make-NSSize w h))) + (set-frame x y w h) ;; new location needs refresh: (tellv cocoa setNeedsDisplay: #:type _BOOL #t)) (queue-on-size)) @@ -910,18 +923,22 @@ (define/public (pre-on-event w e) #f) (define/public (pre-on-char w e) #f) - (define/public (key-event-as-string s) - (dispatch-on-char (new key-event% - [key-code (string-ref s 0)] - [shift-down #f] - [control-down #f] - [meta-down #f] - [alt-down #f] - [x 0] - [y 0] - [time-stamp (current-milliseconds)] ; FIXME - [caps-down #f]) - #f)) + (define/public (key-event-as-string s timestamp) + (for ([i (in-range (string-length s))]) + (queue-window-event + this + (lambda () + (dispatch-on-char (new key-event% + [key-code (string-ref s i)] + [shift-down #f] + [control-down #f] + [meta-down #f] + [alt-down #f] + [x 0] + [y 0] + [time-stamp (->long (* timestamp 1000.0))] + [caps-down #f]) + #f))))) (define/public (post-mouse-down) (void)) @@ -1105,6 +1122,14 @@ ;; ---------------------------------------- +(define key-event-received? #f) +(define key-event-received + (case-lambda + [() key-event-received?] + [(received?) (set! key-event-received? received?)])) + +;; ---------------------------------------- + (define (queue-window-event wx thunk) (queue-event (send wx get-eventspace) thunk)) diff --git a/gui-lib/mred/private/wx/common/backing-dc.rkt b/gui-lib/mred/private/wx/common/backing-dc.rkt index dde9594c0..3d8bd7293 100644 --- a/gui-lib/mred/private/wx/common/backing-dc.rkt +++ b/gui-lib/mred/private/wx/common/backing-dc.rkt @@ -3,6 +3,7 @@ racket/draw/private/dc racket/draw/private/bitmap-dc racket/draw/private/bitmap + racket/draw/private/color racket/draw/private/local racket/draw/private/record-dc racket/draw/unsafe/cairo @@ -39,6 +40,8 @@ cancel-delay end-delay) +(define black-color (send the-color-database find-color "black")) + (define backing-dc% (class (record-dc-mixin (dc-mixin bitmap-dc-backend%)) (init transparent?) @@ -55,14 +58,28 @@ reset-cr set-recording-limit get-recorded-command - get-clear-operator) + get-clear-operator + get-clipping-region) (super-new) - (set-recording-limit (if transparent? 1024 -1)) + (set-recording-limit (if (and transparent? + ;; Windows doesn't buffer the screen for us, so + ;; always stick to a backing store + (not (eq? 'windows (system-type)))) + 1024 + -1)) (define/override (ok?) #t) + (define/override (draw-bitmap src dest-x dest-y [style 'solid] [color black-color] [mask #f]) + (when (and (src . is-a? . bitmap%) + ((* (send src get-width) (send src get-height)) + . > . (* 32 32))) + ;; disable recording + (set-recording-limit -1)) + (super draw-bitmap src dest-x dest-y style color mask)) + ;; Override this method to get the right size (define/public (get-backing-size xb yb) (set-box! xb 1) @@ -76,13 +93,14 @@ ;; called with a procedure that is applied to a bitmap; ;; returns #f if there's nothing to flush - (define/public (on-backing-flush proc) + (define/public (on-backing-flush proc [nothing-to-draw-proc void]) (cond [(not retained-cr) #f] [(positive? retained-counter) - (unless nada? - (proc (or (get-recorded-command) - (internal-get-bitmap)))) + (if nada? + (nothing-to-draw-proc) + (proc (or (get-recorded-command) + (internal-get-bitmap)))) #t] [else (reset-backing-retained proc) @@ -141,9 +159,15 @@ (define/override (erase) (super erase) - (when (= (get-clear-operator) - CAIRO_OPERATOR_CLEAR) - (set! nada? #t))) + (cond + [(and (= (get-clear-operator) + CAIRO_OPERATOR_CLEAR) + (not (get-clipping-region))) + (set! nada? #t)] + [else + ;; force drawing to a bitmap, so erase + ;; will affect the recorded parts + (set-recording-limit -1)])) (define/public (clean-slate) (super erase) @@ -208,9 +232,18 @@ (define w 0) (define h 0) (define mx (make-cairo_matrix_t 0.0 0.0 0.0 0.0 0.0 0.0)) + (define save-mx (make-cairo_matrix_t 0.0 0.0 0.0 0.0 0.0 0.0)) (super-new) + ;; disable cleraing operation so that it doesn't + ;; paint black on a destination without alpha; + ;; if there was any clearing within the recorded + ;; image, it triggered bitmap mode instead of + ;; getting here + (define/override (get-clear-operator) + CAIRO_OPERATOR_DEST) + (define/public (set-cr new-cr new-w new-h) (set! cr new-cr) (when cr (cairo_get_matrix cr mx)) @@ -226,7 +259,10 @@ (define/override (reset-clip cr) (super reset-clip cr) + (cairo_get_matrix cr save-mx) + (cairo_set_matrix cr mx) (cairo_rectangle cr 0 0 w h) + (cairo_set_matrix cr save-mx) (cairo_clip cr))))))) (define (backing-draw-bm bm cr w h [dx 0] [dy 0] [backing-scale 1.0]) diff --git a/gui-lib/mred/private/wx/common/canvas-mixin.rkt b/gui-lib/mred/private/wx/common/canvas-mixin.rkt index 6a6889355..2ccdb66be 100644 --- a/gui-lib/mred/private/wx/common/canvas-mixin.rkt +++ b/gui-lib/mred/private/wx/common/canvas-mixin.rkt @@ -119,12 +119,12 @@ (inherit request-canvas-flush-delay cancel-canvas-flush-delay queue-canvas-refresh-event - is-shown-to-root? on-paint queue-backing-flush get-dc get-canvas-background-for-backing - skip-pre-paint?) + skip-pre-paint? + worthwhile-to-paint?) ;; Avoid multiple queued paints, and also allow cancel ;; of queued paint: @@ -148,7 +148,7 @@ (when pq (set-box! pq #f))) (set! paint-queued #f) (cond - [(or (not b) (is-shown-to-root?)) + [(or (not b) (worthwhile-to-paint?)) (let ([dc (get-dc)]) (send dc suspend-flush) (send dc ensure-ready) @@ -163,7 +163,7 @@ (send dc resume-flush) (queue-backing-flush))] [b ; => not shown to root - ;; invalidate dc so that it's refresh + ;; invalidate dc so that it's refreshed ;; when it's shown again (send (get-dc) reset-backing-retained)])) (when req diff --git a/gui-lib/mred/private/wx/common/default-procs.rkt b/gui-lib/mred/private/wx/common/default-procs.rkt index d10d63d25..3f419ab7a 100644 --- a/gui-lib/mred/private/wx/common/default-procs.rkt +++ b/gui-lib/mred/private/wx/common/default-procs.rkt @@ -6,7 +6,8 @@ any-control+alt-is-altgr file-creator-and-type get-panel-background - fill-private-color) + fill-private-color + luminance) (define special-control-key? #f) (define special-control-key @@ -37,3 +38,12 @@ (define (fill-private-color dc col) (send dc set-background col) (send dc clear)) + +(define (luminance c) + ;; from https://en.wikipedia.org/wiki/Relative_luminance + (define r (/ (send c red) 255)) + (define g (/ (send c green) 255)) + (define b (/ (send c blue) 255)) + (+ (* .2126 r) + (* .7152 g) + (* .0722 b))) diff --git a/gui-lib/mred/private/wx/common/freeze.rkt b/gui-lib/mred/private/wx/common/freeze.rkt index 7ee55836a..724dc6c0f 100644 --- a/gui-lib/mred/private/wx/common/freeze.rkt +++ b/gui-lib/mred/private/wx/common/freeze.rkt @@ -43,7 +43,11 @@ #;(internal-error (format "constrained-reply not within an unfreeze point for ~s" thunk)) fail-result] [(not (eq? (current-thread) (eventspace-handler-thread es))) - (internal-error "wrong eventspace for constrained event handling\n") + ;; Some events don't get dispatched where expected on Mac OS. For example, + ;; a char-down and char-up event might be dequeued where the char-down event + ;; closed a window, and then the char-up event can be dispatched to + ;; a different window. So, don't complain in this case, either. + #;(internal-error "wrong eventspace for constrained event handling\n") fail-result] [else (try-atomic thunk default)])) diff --git a/gui-lib/mred/private/wx/common/handlers.rkt b/gui-lib/mred/private/wx/common/handlers.rkt index 7c57414d5..93804c720 100644 --- a/gui-lib/mred/private/wx/common/handlers.rkt +++ b/gui-lib/mred/private/wx/common/handlers.rkt @@ -6,6 +6,7 @@ application-quit-handler application-about-handler application-pref-handler + application-dark-mode-handler nothing-application-pref-handler nothing-application-about-handler)) @@ -63,3 +64,10 @@ (case-lambda [(proc) (set! aph proc)] [() aph])) + +(define (nothing-application-dark-mode-handler) (void)) +(define admh nothing-application-dark-mode-handler) +(define application-dark-mode-handler + (case-lambda + [(proc) (set! admh proc)] + [() admh])) diff --git a/gui-lib/mred/private/wx/common/queue.rkt b/gui-lib/mred/private/wx/common/queue.rkt index c7d897361..d39d76474 100644 --- a/gui-lib/mred/private/wx/common/queue.rkt +++ b/gui-lib/mred/private/wx/common/queue.rkt @@ -59,6 +59,7 @@ queue-about-event queue-file-event queue-start-empty-event + queue-dark-mode-event begin-busy-cursor end-busy-cursor @@ -604,6 +605,10 @@ (queue-event main-eventspace (application-start-empty-handler) 'med)) +(define (queue-dark-mode-event) + ;; called in event-pump thread + (queue-event main-eventspace (application-dark-mode-handler) 'med)) + (define (begin-busy-cursor) (let ([e (current-eventspace)]) (atomically @@ -659,3 +664,18 @@ (lambda (s skip evt v) (filter v)))) (orig)))))) + +;; Similar to `current-get-interaction-input-port`, but for contexts +;; that don't use a port directly: +(current-get-interaction-evt + (let ([orig (current-get-interaction-evt)]) + (lambda () + (let ([e (thread-cell-ref handler-thread-of)]) + (if e + (choice-evt (orig) + (wrap-evt (eventspace-event-evt e) + (lambda (v) + (lambda () + (parameterize ([current-eventspace e]) + (yield)))))) + (orig)))))) diff --git a/gui-lib/mred/private/wx/gtk/button.rkt b/gui-lib/mred/private/wx/gtk/button.rkt index bd55c3f66..9186c668b 100644 --- a/gui-lib/mred/private/wx/gtk/button.rkt +++ b/gui-lib/mred/private/wx/gtk/button.rkt @@ -36,7 +36,7 @@ (define _GtkSettings (_cpointer 'GtkSettings)) (define-gtk gtk_settings_get_default (_fun -> _GtkSettings)) (define-gobj g_object_set/boolean - (_fun _GtkSettings _string _gboolean (_pointer = #f) -> _void) + (_fun #:varargs-after 2 _GtkSettings _string _gboolean (_pointer = #f) -> _void) #:c-id g_object_set) (define (force-button-images-on gtk) ;; Globally turning on button images isn't really the right thing. diff --git a/gui-lib/mred/private/wx/gtk/canvas.rkt b/gui-lib/mred/private/wx/gtk/canvas.rkt index cfb034f8d..27f7ac9ec 100644 --- a/gui-lib/mred/private/wx/gtk/canvas.rkt +++ b/gui-lib/mred/private/wx/gtk/canvas.rkt @@ -3,7 +3,7 @@ ffi/unsafe/define ffi/unsafe/collect-callback racket/class - racket/draw + (only-in racket/draw color%) ffi/unsafe/alloc (except-in racket/draw/private/color color% make-color) @@ -25,6 +25,7 @@ "gl-context.rkt" "combo.rkt" "gcwin.rkt" + "frame.rkt" "panel.rkt") (provide @@ -36,9 +37,11 @@ (define-gobj g_object_freeze_notify (_fun _GtkWidget -> _void)) (define-gobj g_object_thaw_notify (_fun _GtkWidget -> _void)) -(define-gobj g_object_set_double (_fun _GtkWidget _string _double* (_pointer = #f) -> _void) +(define-gobj g_object_set_double (_fun #:varargs-after 2 + _GtkWidget _string _double* (_pointer = #f) -> _void) #:c-id g_object_set) -(define-gobj g_object_get_double (_fun _GtkWidget _string (r : (_ptr o _double)) (_pointer = #f) +(define-gobj g_object_get_double (_fun #:varargs-after 2 + _GtkWidget _string (r : (_ptr o _double)) (_pointer = #f) -> _void -> r) #:c-id g_object_get) @@ -76,6 +79,7 @@ (define-gtk gtk_vscrollbar_new (_fun _pointer -> _GtkWidget)) (define-gtk gtk_widget_set_double_buffered (_fun _GtkWidget _gboolean -> _void)) +(define-gtk gtk_widget_set_app_paintable (_fun _GtkWidget _gboolean -> _void)) (define _GtkAdjustment _GtkWidget) ; no, actually a GtkObject (define-gtk gtk_adjustment_new (_fun _double* _double* _double* _double* _double* _double* -> _GtkAdjustment)) @@ -123,7 +127,8 @@ (define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) (define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) -(define-gobj g_object_set_bool (_fun _GtkWidget _string _gboolean [_pointer = #f] -> _void) +(define-gobj g_object_set_bool (_fun #:varargs-after 2 + _GtkWidget _string _gboolean [_pointer = #f] -> _void) #:c-id g_object_set) (define _GtkIMContext (_cpointer 'GtkIMContext)) @@ -255,7 +260,7 @@ (lambda (gtk) (let ([wx (gtk->wx gtk)]) (when wx - (send wx unrealize))))) + (send wx unmap))))) (define (do-value-changed gtk dir) (let ([wx (gtk->wx gtk)]) @@ -285,7 +290,8 @@ reset-auto-scroll get-eventspace register-extra-gtk - call-pre-on-event set-focus on-event) + call-pre-on-event set-focus on-event + is-shown-to-root?) (define is-combo? (memq 'combo style)) (define has-border? (or (memq 'border style) @@ -444,7 +450,11 @@ (when (and (is-auto-scroll?) (not (is-panel?))) (reset-auto-scroll)) + (when dc (send dc update-canvas-size x y w h)) (on-size)) + + (define/public (reset-gl-context mapped?) + (when dc (send dc reset-gl-context mapped?))) (set! dc (new dc% [canvas this] [transparentish? transparentish?])) @@ -614,12 +624,23 @@ flush-win-box))))) (define/public (unrealize) (unrealize-win-box flush-win-box)) + (define/public (unmap) + (reset-gl-context #f) + (unrealize)) (define/override (reset-child-freezes) ;; A transparent canvas can't have a native window, so we ;; need to release any freezes befre the window implementation ;; might change. (when (or transparentish? wayland?) (unrealize))) + (define/override (notify-children-top-realize) + (reset-gl-context #t)) + + (define/override (save-size x y w h) + (super save-size x y w h) + (when (and dc for-gl?) + (send dc update-canvas-size x y w h))) + (define/public (begin-refresh-sequence) (send dc suspend-flush)) (define/public (end-refresh-sequence) @@ -641,6 +662,9 @@ (unless for-gl? (gtk_widget_queue_draw client-gtk))) + (define/public (worthwhile-to-paint?) + (is-shown-to-root?)) + (define/override (reset-child-dcs) (when (dc . is-a? . dc%) (reset-dc))) diff --git a/gui-lib/mred/private/wx/gtk/combo.rkt b/gui-lib/mred/private/wx/gtk/combo.rkt index abf7c2050..714db2131 100644 --- a/gui-lib/mred/private/wx/gtk/combo.rkt +++ b/gui-lib/mred/private/wx/gtk/combo.rkt @@ -46,7 +46,8 @@ (define-gobj g_signal_handler_block (_fun _GtkWidget _uint -> _void)) (define-gobj g_signal_handler_unblock (_fun _GtkWidget _uint -> _void)) -(define-gobj g_signal_emit (_fun _GtkWidget +(define-gobj g_signal_emit (_fun #:varargs-after 3 + _GtkWidget _uint _GQuark _pointer diff --git a/gui-lib/mred/private/wx/gtk/dc.rkt b/gui-lib/mred/private/wx/gtk/dc.rkt index 45e8ca853..239314950 100644 --- a/gui-lib/mred/private/wx/gtk/dc.rkt +++ b/gui-lib/mred/private/wx/gtk/dc.rkt @@ -22,12 +22,20 @@ (protect-out dc% do-backing-flush x11-bitmap% + cairo-bitmap% gdk_gc_new gdk_gc_unref gdk_gc_set_rgb_fg_color gdk_gc_set_line_attributes - gdk_draw_rectangle)) + gdk_draw_rectangle + + update-canvas-size + reset-gl-context)) + +(define-local-member-name + update-canvas-size + reset-gl-context) (define-gdk gdk_cairo_create (_fun _pointer -> _cairo_t) #:wrap (allocator cairo_destroy)) @@ -59,7 +67,7 @@ (define sf (if gtk3? (if gtk - (->screen (gtk_widget_get_scale_factor gtk)) + (->screen (exact->inexact (gtk_widget_get_scale_factor gtk))) (display-bitmap-resolution 0 (lambda () 1.0))) (->screen 1.0))) (define/private (scale x) @@ -143,13 +151,36 @@ (define cairo-bitmap% (class bitmap% (init w h gtk) + + (define gl #f) + (define/public (install-gl-context new-gl) (set! gl new-gl)) + (define/override (get-bitmap-gl-context) gl) + + (define/override (make-dc) + (if gl + (make-object gl-sync-bitmap-dc% this gl) + (super make-dc))) + + (define/override (surface-flush) + (when gl (send gl gl-to-cairo-sync)) + (super surface-flush)) + (super-make-object w h #f #t (if gtk3? (if gtk - (->screen (gtk_widget_get_scale_factor gtk)) + (->screen (exact->inexact (gtk_widget_get_scale_factor gtk))) (display-bitmap-resolution 0 (lambda () 1.0))) (->screen 1.0))))) +(define gl-sync-bitmap-dc% + (class -bitmap-dc% + (init bm gl-context) + (define gl gl-context) + (define/override (get-cr) + (send gl gl-to-cairo-sync) + (super get-cr)) + (super-make-object bm))) + (define win32-bitmap% (class bitmap% (init w h gdk-win) @@ -193,6 +224,13 @@ (when v (set! gl v)) v))) + (define/public (update-canvas-size x y w h) + (when gl + (send gl gl-update-size x y w h))) + + (define/public (reset-gl-context mapped?) + (when gl (send gl gl-reset-context mapped?))) + (define/override (make-backing-bitmap w h) (cond [(and (not is-transparentish?) diff --git a/gui-lib/mred/private/wx/gtk/dialog.rkt b/gui-lib/mred/private/wx/gtk/dialog.rkt index 209930d98..afe7d94f6 100644 --- a/gui-lib/mred/private/wx/gtk/dialog.rkt +++ b/gui-lib/mred/private/wx/gtk/dialog.rkt @@ -18,7 +18,6 @@ (define GDK_WINDOW_TYPE_HINT_DIALOG 1) (define-gtk gtk_window_set_position (_fun _GtkWidget _int -> _void)) -(define-gtk gtk_window_set_transient_for (_fun _GtkWidget _GtkWidget -> _void)) (define-gtk gtk_window_set_type_hint (_fun _GtkWidget _int -> _void)) (define dialog% diff --git a/gui-lib/mred/private/wx/gtk/frame.rkt b/gui-lib/mred/private/wx/gtk/frame.rkt index 8b8a846cf..b7180d259 100644 --- a/gui-lib/mred/private/wx/gtk/frame.rkt +++ b/gui-lib/mred/private/wx/gtk/frame.rkt @@ -16,18 +16,24 @@ "widget.rkt" "cursor.rkt" "pixbuf.rkt" - "resolution.rkt" - "queue.rkt" + "resolution.rkt" + "queue.rkt" "../common/queue.rkt") (provide (protect-out frame% display-origin display-size - display-count + display-count display-bitmap-resolution location->window - get-current-mouse-state)) + get-current-mouse-state + gtk_window_set_transient_for + + gtk_fixed_new + gtk_fixed_move + + tell-all-frames-request-refresh-all-canvas-children)) ;; ---------------------------------------- @@ -95,9 +101,15 @@ (define-gtk gtk_widget_get_allocated_height (_fun _GtkWidget -> _int) #:make-fail make-not-available) +(define-gtk gtk_get_major_version (_fun -> _uint) #:fail (lambda () (lambda () 2))) +(define-gtk gtk_get_minor_version (_fun -> _uint) #:fail (lambda () (lambda () 2))) +(define-gtk gtk_get_micro_version (_fun -> _uint) #:fail (lambda () (lambda () 2))) + (define-gtk gtk_layout_new (_fun (_pointer = #f) (_pointer = #f) -> _GtkWidget)) (define-gtk gtk_layout_put (_fun _GtkWidget _GtkWidget _int _int -> _void)) +(define-gtk gtk_window_set_transient_for (_fun _GtkWidget _GtkWidget -> _void)) + (define-signal-handler connect-delete "delete-event" (_fun _GtkWidget -> _gboolean) (lambda (gtk) @@ -124,6 +136,13 @@ (->normal h)))) #f)) +(define-signal-handler connect-map "map" + (_fun _GtkWidget _pointer -> _void) + (lambda (gtk event) + (let ([wx (gtk->wx gtk)]) + (when wx + (send wx notify-children-top-realize))))) + (define-cstruct _GdkEventWindowState ([type _int] [window _GtkWindow] [send_event _int8] @@ -184,6 +203,9 @@ (gtk_window_new (if floating? GTK_WINDOW_POPUP GTK_WINDOW_TOPLEVEL)))) + (when (and parent wayland?) + (gtk_window_set_transient_for gtk (send parent get-gtk))) + (when (memq 'no-caption style) (gtk_window_set_decorated gtk #f)) (when floating? @@ -211,6 +233,9 @@ GDK_KEY_RELEASE_MASK)) (connect-key panel-gtk) + (when wayland? + (connect-map gtk)) + (unless is-dialog? (gtk_window_set_icon_list gtk (cdr (force icon-pixbufs+glist)))) @@ -379,6 +404,10 @@ (when saved-child (send saved-child refresh))) + (define/override (notify-children-top-realize) + (when saved-child + (send saved-child notify-children-top-realize))) + (define/override (direct-show on?) ;; atomic mode (if on? @@ -589,7 +618,24 @@ (unless (num . < . (gdk_screen_get_n_monitors s)) (fail)) (gdk_screen_get_monitor_geometry s num r) - r)) + (cond + ;; work around the upstream issue https://gitlab.gnome.org/GNOME/gtk/-/issues/2599 + [(and wayland? + ;; for gtk3 >= 3.24.9 and < 3.24.42 + gtk3? + (or + (> (gtk_get_minor_version) 24) + (and (= (gtk_get_minor_version) 24) + (>= (gtk_get_micro_version) 9) + (< (gtk_get_micro_version) 42)))) + (define scale (gdk_screen_get_monitor_scale_factor + (gdk_screen_get_default) + num)) + (make-GdkRectangle (floor (inexact->exact (/ (GdkRectangle-x r) scale))) + (floor (inexact->exact (/ (GdkRectangle-y r) scale))) + (floor (inexact->exact (/ (GdkRectangle-width r) scale))) + (floor (inexact->exact (/ (GdkRectangle-height r) scale))))] + [else r]))) (define (display-origin x y all? num fail) (let ([r (monitor-rect num fail)]) @@ -605,11 +651,12 @@ (gdk_screen_get_n_monitors (gdk_screen_get_default))) (define (display-bitmap-resolution num fail) - (define (get) (* (or (get-interface-scale-factor num) - 1.0) - (gdk_screen_get_monitor_scale_factor - (gdk_screen_get_default) - num))) + (define (get) + (* (or (get-interface-scale-factor num) + 1.0) + (gdk_screen_get_monitor_scale_factor + (gdk_screen_get_default) + num))) (if (zero? num) (get) (if (num . < . (gdk_screen_get_n_monitors (gdk_screen_get_default))) @@ -647,7 +694,17 @@ (maybe GDK_MOD1_MASK 'alt) (maybe GDK_META_MASK 'meta)))) +(define (tell-all-frames-request-refresh-all-canvas-children) + (tell-all-frames-something + (λ (f) + (send f request-refresh-all-canvas-children)))) + (define (tell-all-frames-signal-changed n) + (tell-all-frames-something + (λ (f) + (send f display-changed)))) + +(define (tell-all-frames-something proc) (define frames (for/list ([f (in-hash-keys all-frames)]) f)) (for ([f (in-hash-keys all-frames)]) (define e (send f get-eventspace)) @@ -655,7 +712,7 @@ (parameterize ([current-eventspace e]) (queue-callback (λ () - (send f display-changed))))))) + (proc f))))))) (define-signal-handler connect-monitor-changed-signal diff --git a/gui-lib/mred/private/wx/gtk/gl-cairo.rkt b/gui-lib/mred/private/wx/gtk/gl-cairo.rkt new file mode 100644 index 000000000..ff4d1cb08 --- /dev/null +++ b/gui-lib/mred/private/wx/gtk/gl-cairo.rkt @@ -0,0 +1,232 @@ +#lang racket +(require ffi/unsafe + ffi/unsafe/define + racket/draw/unsafe/cairo + (only-in "queue.rkt" wayland?)) + +(provide create-cairo-texture-sync + update-texture-from-cairo + update-cairo-from-texture + destroy-cairo-texture-sync) + +(define libgl (and wayland? + (ffi-lib "libGL" '("1" "")))) + +;; ============================================================================ +;; Type Definitions +;; ============================================================================ + +;; OpenGL types +(define _GLenum _uint32) +(define _GLuint _uint32) +(define _GLint _int32) +(define _GLsizei _int32) + +;; Cairo types +(define _cairo_surface_t _pointer) +(define _cairo_t _pointer) +(define _cairo_format_t _int) + +;; Constants + +(define GL_TEXTURE_2D #x0DE1) +(define GL_BGRA #x80E1) +(define GL_RGBA #x1908) +(define GL_RGB #x1907) +(define GL_RED #x1903) +(define GL_UNSIGNED_BYTE #x1401) +(define GL_LINEAR #x2601) +(define GL_CLAMP_TO_EDGE #x812F) +(define GL_TEXTURE_MIN_FILTER #x2801) +(define GL_TEXTURE_MAG_FILTER #x2800) +(define GL_TEXTURE_WRAP_S #x2802) +(define GL_TEXTURE_WRAP_T #x2803) +(define GL_UNPACK_ROW_LENGTH #x0CF2) +(define GL_FRAMEBUFFER #x8D40) +(define GL_COLOR_ATTACHMENT0 #x8CE0) +(define GL_FRAMEBUFFER_COMPLETE #x8CD5) +(define GL_PACK_ROW_LENGTH #x0D02) + +;; ============================================================================ +;; OpenGL Function Bindings +;; ============================================================================ + +(define-ffi-definer define-gl libgl + #:default-make-fail make-not-available) + +(define-gl glGenTextures + (_fun _GLsizei (i : (_ptr o _GLuint)) -> _void -> i)) + +(define-gl glBindTexture + (_fun _GLenum _GLuint -> _void)) + +(define-gl glTexImage2D + (_fun _GLenum _GLint _GLint _GLsizei _GLsizei _GLint _GLenum _GLenum _pointer -> _void)) + +(define-gl glTexSubImage2D + (_fun _GLenum _GLint _GLint _GLint _GLsizei _GLsizei _GLenum _GLenum _pointer -> _void)) + +(define-gl glTexParameteri + (_fun _GLenum _GLenum _GLint -> _void)) + +(define-gl glPixelStorei + (_fun _GLenum _GLint -> _void)) + +(define-gl glGenFramebuffers + (_fun _GLsizei (i : (_ptr o _GLuint)) -> _void -> i)) + +(define-gl glBindFramebuffer + (_fun _GLenum _GLuint -> _void)) + +(define-gl glFramebufferTexture2D + (_fun _GLenum _GLenum _GLenum _GLuint _GLint -> _void)) + +(define-gl glCheckFramebufferStatus + (_fun _GLenum -> _GLenum)) + +(define-gl glDeleteTextures + (_fun _GLsizei (_ptr i _GLuint) -> _void)) + +(define-gl glDeleteFramebuffers + (_fun _GLsizei (_ptr i _GLuint) -> _void)) + +(define-gl glReadPixels + (_fun _GLint _GLint _GLsizei _GLsizei _GLenum _GLenum _pointer -> _void)) + +(define-gl glGetTexImage + (_fun _GLenum _GLint _GLenum _GLenum _pointer -> _void)) + +(define-gl glFinish + (_fun -> _void)) + +;; ============================================================================ +;; Main Bridge Structure and Functions +;; ============================================================================ + +(struct cairo-texture-sync (texture-id + framebuffer-id + width + height + gl-format + gl-internal-format + gl-type)) + +;; Needs GL context set +(define (create-cairo-texture-sync width height) + ;; Get GL format parameters + (define-values (gl-format gl-internal-format gl-type) + ;; assuming `CAIRO_FORMAT_ARGB32` + (values GL_BGRA GL_RGBA GL_UNSIGNED_BYTE)) + + ;; Create texture + (define texture-id (glGenTextures 1)) + + (glBindTexture GL_TEXTURE_2D texture-id) + (glTexImage2D GL_TEXTURE_2D 0 gl-internal-format width height 0 + gl-format gl-type #f) + (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR) + (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR) + (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE) + (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE) + + ;; Create framebuffer + (define framebuffer-id (glGenFramebuffers 1)) + + (glBindFramebuffer GL_FRAMEBUFFER framebuffer-id) + (glFramebufferTexture2D GL_FRAMEBUFFER GL_COLOR_ATTACHMENT0 + GL_TEXTURE_2D texture-id 0) + + ;; Check framebuffer completeness + (define status (glCheckFramebufferStatus GL_FRAMEBUFFER)) + (unless (= status GL_FRAMEBUFFER_COMPLETE) + (error "Framebuffer not complete")) + + (cairo-texture-sync texture-id framebuffer-id + width height + gl-format gl-internal-format gl-type)) + +;; Needs GL context set +(define (update-texture-from-cairo sync cairo-surface) + ;; Flush Cairo surface + (cairo_surface_flush cairo-surface) + + ;; Get Cairo surface data + (define data (if (system-big-endian?) + (cairo_image_surface_get_data cairo-surface) ; copies + (cairo_image_surface_get_data* cairo-surface))) + (define stride (cairo_image_surface_get_stride cairo-surface)) + (define width (cairo-texture-sync-width sync)) + (define height (cairo-texture-sync-height sync)) + + (when (system-big-endian?) + (reverse-byte-order data width height stride)) + + ;; Bind texture and update + (glBindTexture GL_TEXTURE_2D (cairo-texture-sync-texture-id sync)) + + ;; Handle stride alignment if necessary + (define bytes-per-pixel 4) ; assuming ARGB32 + + (unless (= stride (* width bytes-per-pixel)) + (glPixelStorei GL_UNPACK_ROW_LENGTH (quotient stride bytes-per-pixel))) + + ;; Update texture + (glTexSubImage2D GL_TEXTURE_2D 0 0 0 width height + (cairo-texture-sync-gl-format sync) + (cairo-texture-sync-gl-type sync) + data) + + ;; Reset stride setting + (glPixelStorei GL_UNPACK_ROW_LENGTH 0)) + +(define (update-cairo-from-texture sync cairo-surface) + ;; Get Cairo surface properties + (define width (cairo-texture-sync-width sync)) + (define height (cairo-texture-sync-height sync)) + (define cairo-data (cairo_image_surface_get_data* cairo-surface)) + (define stride (cairo_image_surface_get_stride cairo-surface)) + + ;; Bind the framebuffer with our texture + (glBindFramebuffer GL_FRAMEBUFFER (cairo-texture-sync-framebuffer-id sync)) + + ;; Handle stride alignment for reading + (define bytes-per-pixel 4) ; ARGB32 + + (unless (= stride (* width bytes-per-pixel)) + (glPixelStorei GL_PACK_ROW_LENGTH (quotient stride bytes-per-pixel))) + + ;; Read pixels from framebuffer into Cairo surface data + (glReadPixels 0 0 width height + (cairo-texture-sync-gl-format sync) + (cairo-texture-sync-gl-type sync) + cairo-data) + + ;; Reset pack alignment + (glPixelStorei GL_PACK_ROW_LENGTH 0) + + ;; Ensure all GL operations complete + (glFinish) + + (when (system-big-endian?) + (reverse-byte-order cairo-data width height stride)) + + ;; Mark Cairo surface as modified + (cairo_surface_mark_dirty cairo-surface)) + +;; Needs GL context set +(define (destroy-cairo-texture-sync sync egl-display) + (glDeleteTextures 1 (cairo-texture-sync-texture-id sync)) + (glDeleteFramebuffers 1 (cairo-texture-sync-framebuffer-id sync))) + +(define (reverse-byte-order data width height stride) + (for ([j (in-range 0 height)]) + (define start (* j stride)) + (for ([i (in-range 0 width)]) + (define b (ptr-ref data _byte (+ start (* i 4)))) + (define g (ptr-ref data _byte (+ start 1 (* i 4)))) + (define r (ptr-ref data _byte (+ start 2 (* i 4)))) + (define a (ptr-ref data _byte (+ start 3 (* i 4)))) + (ptr-set! data _byte (+ start (* i 4)) a) + (ptr-set! data _byte (+ start 1 (* i 4)) r) + (ptr-set! data _byte (+ start 2 (* i 4)) g) + (ptr-set! data _byte (+ start 3 (* i 4)) b)))) diff --git a/gui-lib/mred/private/wx/gtk/gl-context.rkt b/gui-lib/mred/private/wx/gtk/gl-context.rkt index e406ab431..ba33bb156 100644 --- a/gui-lib/mred/private/wx/gtk/gl-context.rkt +++ b/gui-lib/mred/private/wx/gtk/gl-context.rkt @@ -5,14 +5,19 @@ ffi/unsafe ffi/unsafe/define ffi/unsafe/alloc + ffi/unsafe/atomic ffi/cvector (prefix-in draw: racket/draw/private/gl-context) racket/draw/private/gl-config "../../lock.rkt" "types.rkt" "utils.rkt" + "widget.rkt" "window.rkt" - "x11.rkt") + "x11.rkt" + "queue.rkt" + "wayland.rkt" + "gl-cairo.rkt") (provide (protect-out prepare-widget-gl-context @@ -20,7 +25,10 @@ create-and-install-gl-context get-gdk-pixmap - install-gl-context)) + install-gl-context + gl-update-size + gl-to-cairo-sync + gl-reset-context)) (define (ffi-lib/complaint-on-failure name vers) (ffi-lib name vers @@ -29,6 +37,115 @@ name vers) #f))) +(define-local-member-name + gl-update-size + gl-to-cairo-sync + gl-reset-context) + +;; =================================================================================================== +;; Wayland GL + +(define egl-lib + (and wayland? (ffi-lib "libEGL" '("1" "")))) +(define wayland-egl-lib + (and wayland? (ffi-lib "libwayland-egl" '("1" "")))) + +(define-ffi-definer define-egl egl-lib + #:default-make-fail make-not-available) +(define-ffi-definer define-wayland-egl wayland-egl-lib + #:default-make-fail make-not-available) + +(define-gdk gdk_wayland_window_get_wl_surface + (_fun _GdkWindow -> _pointer) + #:fail (lambda () #f)) + +(define-wayland-egl wl_egl_window_create + (_fun _pointer _int _int -> _pointer)) +(define-wayland-egl wl_egl_window_resize + (_fun _pointer _int _int _int _int -> _void)) +(define-wayland-egl wl_egl_window_destroy + (_fun _pointer -> _void)) + +(define _EGLInt _int32) +(define _EGLBoolean _bool) ; not _stdbool +(define _EGLDisplay (_cpointer/null 'EGLDisplay)) +(define _EGLConfig (_cpointer/null 'EGLConfig)) +(define _EGLSurface (_cpointer/null 'EGLSurface)) +(define _EGLContext (_cpointer/null 'EGLContext)) + +(define-egl eglGetProcAddress + (_fun _string -> _fpointer)) +(define eglGetPlatformDisplay-type + (_fun _EGLInt _pointer (_list i _EGLInt) -> _EGLDisplay)) +(define-egl eglGetPlatformDisplay eglGetPlatformDisplay-type) +(define-egl eglInitialize + (_fun _pointer (_ptr o _int) (_ptr o _int) -> _EGLBoolean)) +(define-egl eglChooseConfig + (_fun _EGLDisplay (_list i _EGLInt) (c : (_ptr o _EGLConfig)) (_int = 1) (n : (_ptr o _EGLInt)) + -> (r : _EGLBoolean) + -> (and r (= n 1) c))) +(define eglCreatePlatformWindowSurface-type + (_fun _EGLDisplay _EGLConfig _pointer (_list i _int) -> _EGLSurface)) +(define-egl eglCreatePlatformWindowSurface + eglCreatePlatformWindowSurface-type) +(define-egl eglBindAPI + (_fun _EGLInt -> _EGLBoolean)) +(define-egl eglCreateContext + (_fun _EGLDisplay _EGLConfig _EGLContext (_list i _EGLInt) -> _EGLContext)) +(define-egl eglMakeCurrent + (_fun _EGLDisplay _EGLSurface _EGLSurface _EGLContext -> _EGLBoolean)) +(define-egl eglSwapBuffers + (_fun _EGLDisplay _EGLSurface -> _EGLBoolean)) +(define-egl eglCreatePbufferSurface + (_fun _EGLDisplay _EGLConfig (_list i _EGLInt) -> _EGLSurface)) +(define-egl eglGetError + (_fun -> _EGLInt)) +(define-egl eglDestroySurface + (_fun _EGLDisplay _EGLSurface -> _int)) +(define-egl eglDestroyContext + (_fun _EGLDisplay _EGLContext -> _EGLBoolean)) +(define-egl eglGetCurrentDisplay + (_fun -> _EGLDisplay)) +(define-egl eglGetCurrentContext + (_fun -> _EGLContext)) +(define-egl eglGetCurrentSurface + (_fun _EGLInt -> _EGLSurface)) + +(define-gdk gdk_wayland_display_get_wl_display (_fun _GdkDisplay -> _pointer) + #:make-fail make-not-available) +(define-gdk gdk_wayland_display_get_wl_compositor (_fun _GdkDisplay -> _pointer) + #:make-fail make-not-available) + +(define EGL_OPENGL_API #x30A2) +(define EGL_SURFACE_TYPE #x3033) +(define EGL_WINDOW_BIT #x0004) +(define EGL_PBUFFER_BIT #x0001) +(define EGL_RENDERABLE_TYPE #x3040) +(define EGL_RENDER_BUFFER #x3086) +(define EGL_BACK_BUFFER #x3084) +(define EGL_SINGLE_BUFFER #x3085) +(define EGL_OPENGL_BIT #x0008) +(define EGL_OPENGL_ES_BIT #x0001) +(define EGL_OPENGL_ES2_BIT #x0004) +(define EGL_DEPTH_SIZE #x3025) +(define EGL_STENCIL_SIZE #x3026) +(define EGL_RED_SIZE #x3024) +(define EGL_GREEN_SIZE #x3023) +(define EGL_BLUE_SIZE #x3022) +(define EGL_ALPHA_SIZE #x3021) +(define EGL_NONE #x3038) +(define EGL_WIDTH #x3057) +(define EGL_HEIGHT #x3056) +(define EGL_NO_SURFACE #f) +(define EGL_CONTEXT_CLIENT_VERSION #x3098) +(define EGL_CONTEXT_MAJOR_VERSION #x3098) +(define EGL_CONTEXT_MINOR_VERSION #x30FB) +(define EGL_CONTEXT_OPENGL_PROFILE_MASK #x30FD) +(define EGL_CONTEXT_OPENGL_CORE_PROFILE_BIT #x00000001) +(define EGL_PLATFORM_WAYLAND_KHR #x31D8) +(define EGL_DRAW #x3059) +(define EGL_READ #x305A) + ;; =================================================================================================== ;; X11/GLX FFI @@ -152,6 +269,9 @@ (define lazy-get-glx-version (delay + (when wayland? + (error 'get-glx-version "can't use GLX on Wayland")) + (define-values (worked? glx-major glx-minor) (glXQueryVersion (gdk_x11_display_get_xdisplay (gdk_display_get_default)))) @@ -198,8 +318,10 @@ (define/public (get-gtk-drawable) drawable) (define/public (get-glx-pixmap) pixmap) - (define (get-drawable-xid) + (define/private (get-drawable-xid) (if pixmap pixmap (gdk_x11_drawable_get_xid drawable))) + + (define/public (gl-reset-context mapped?) (void)) (define/override (draw:do-call-as-current t) (define xdisplay (gdk_x11_display_get_xdisplay display)) @@ -212,10 +334,114 @@ (define/override (draw:do-swap-buffers) (glXSwapBuffers (gdk_x11_display_get_xdisplay display) - (get-drawable-xid))) - + (get-drawable-xid)) + (void)) + + (define/public (gl-update-size x y w h) + (void)) + (super-new))) +;; =================================================================================================== +;; Wrapper for EGLContext (Wayland) + +(define-local-member-name + egl-finalize) + +(define egl-context% + (class draw:gl-context% + (init-field context + display wl-display + surface [wl-surface #f] [wl-parent-surface #f] [wl-subsurface #f] + [widget #f] [win #f] + [cairo-surface #f] [texture-sync #f] + [create #f]) + + (define/public (gl-reset-context mapped?) + (when (and create + (or (and (not mapped?) wl-parent-surface) + (and mapped? (not wl-parent-surface)))) + (egl-finalize #f) + (unless mapped? + (set! callback #f) + (set! callback-handle #f)) + (define-values (new-surface new-wl-surface new-wl-parent-surface new-wl-subsurface new-win) + (create #t)) + (set! surface new-surface) + (set! wl-surface new-wl-surface) + (set! wl-parent-surface new-wl-parent-surface) + (set! wl-subsurface new-wl-subsurface) + (set! win new-win))) + + (define/public (egl-finalize [including-context? #t]) + ;; If there's a parent surface, it will destroy the + ;; subsurface when it's destroyed + (unless wl-parent-surface + (wayland-surface-destroy wl-surface)) + (eglDestroySurface display surface) + (wl_egl_window_destroy win) + (when including-context? + (eglDestroyContext display context))) + (define/override (get-handle) context) + + (define cairo-mode? #t) + + (define/override (draw:do-call-as-current t) + (dynamic-wind + (lambda () + (eglMakeCurrent display surface surface context)) + (lambda () + (when (and texture-sync cairo-mode?) + (set! cairo-mode? #f) + (update-texture-from-cairo texture-sync cairo-surface)) + (t)) + (lambda () + (eglMakeCurrent display #f #f #f)))) + + (define/public (gl-to-cairo-sync) + (unless cairo-mode? + (call-as-atomic + (lambda () + (set! cairo-mode? #t) + (call-with-egl-current + display surface surface context + (lambda () + (update-cairo-from-texture texture-sync cairo-surface))))))) + + (define callback #f) + (define callback-handle #f) + + (define/override (draw:do-swap-buffers) + (when wl-surface + (unless callback + (eglSwapBuffers display surface) + (set! callback (lambda (data callback-h time) + (set! callback #f) + (gtk_widget_queue_draw widget))) + (set! callback-handle (wayland-register-surface-frame-callback wl-surface callback)) + (wayland-surface-commit wl-surface)))) + + (define/public (gl-update-size x y w h) + (when win + (wl_egl_window_resize win w h 0 0) + (when (and widget wl-subsurface) + (define toplevel (gtk_widget_get_toplevel widget)) + (define-values (dx dy) + (gtk_widget_translate_coordinates widget toplevel 0 0)) + (wayland-subsurface-set-position wl-subsurface dx dy)))) + + (super-new))) + +(define (call-with-egl-current display d-surface r-surface context thunk) + (define current (list (eglGetCurrentDisplay) + (eglGetCurrentSurface EGL_DRAW) + (eglGetCurrentSurface EGL_READ) + (eglGetCurrentContext))) + (eglMakeCurrent display d-surface r-surface context) + (define result (thunk)) + (apply eglMakeCurrent current) + result) + ;; =================================================================================================== ;; Getting OpenGL contexts @@ -347,92 +573,226 @@ (define-values (err value) (glXGetFBConfigAttrib xdisplay cfg attrib)) (if (= err Success) value bad-value)) -;; (or/c #f _GtkWidget) _GdkDrawable gl-config% boolean? -> gl-context% -;; where _GdkDrawable = (or/c _GtkWindow _GdkPixmap) +;; (or/c #f _GtkWidget) (or/c _GdkDrawable (is-a/c bitmap%) gl-config% boolean? -> gl-context% +;; where X11 uses _GdkDrawable = (or/c _GtkWindow _GdkPixmap) +;; and Wayland uses bitmap% that holds a Cairo ARGB32 image surface (define (make-gtk-drawable-gl-context widget drawable conf wants-double?) - (define glx-version (get-glx-version)) - - ;; If widget isn't #f, use its display and screen - (define display (gtk-maybe-widget-get-display widget)) - (define screen (gtk-maybe-widget-get-screen widget)) - - ;; Get the X objects wrapped by the GDK objects - (define xdisplay (gdk_x11_display_get_xdisplay display)) - (define xscreen (gdk_x11_screen_get_screen_number screen)) - - ;; Create an attribute list using the GL config - (define xattribs - (append - ;; Be aware: we may get double buffering even if we don't ask for it - (if wants-double? - (if (send conf get-double-buffered) (list GLX_DOUBLEBUFFER True) null) - null) - (if (send conf get-stereo) (list GLX_STEREO True) null) - ;; Finish out with standard GLX 1.3 attributes - (list - GLX_X_RENDERABLE True ; yes, we want to use OpenGL to render today - GLX_DEPTH_SIZE (send conf get-depth-size) - GLX_STENCIL_SIZE (send conf get-stencil-size) - GLX_ACCUM_RED_SIZE (send conf get-accum-size) - GLX_ACCUM_GREEN_SIZE (send conf get-accum-size) - GLX_ACCUM_BLUE_SIZE (send conf get-accum-size) - GLX_ACCUM_ALPHA_SIZE (send conf get-accum-size) - ;; GLX_SAMPLES is handled below - GLX regards it as an absolute lower bound, which makes it - ;; too easy for user programs to fail to get a context - None))) - - (define multisample-size (send conf get-multisample-size)) - - ;; Get all framebuffer configs for this display and screen that match the requested attributes, - ;; then sort them to put the best in front - ;; GLX already sorts them pretty well, so we just need a stable sort on multisamples at the moment - (define cfgs - (let* ([cfgs (cvector->list (glXChooseFBConfig xdisplay xscreen xattribs))] - ;; Keep all configs with multisample size <= requested (i.e. make multisample-size an - ;; abolute upper bound) - [cfgs (if (< glx-version #e1.4) - cfgs - (filter (λ (cfg) - (define m (glx-get-fbconfig-attrib xdisplay cfg GLX_SAMPLES 0)) - (<= m multisample-size)) - cfgs))] - ;; Sort all configs by multisample size, decreasing - [cfgs (if (< glx-version #e1.4) - cfgs - (sort cfgs > - #:key (λ (cfg) (glx-get-fbconfig-attrib xdisplay cfg GLX_SAMPLES 0)) - #:cache-keys? #t))]) - cfgs)) - (cond - [(null? cfgs) #f] - [else - ;; The framebuffer configs are sorted best-first, so choose the first - (define cfg (car cfgs)) - (define share-gl - (let ([share-ctxt (send conf get-share-context)]) - (and share-ctxt (send share-ctxt get-handle)))) - - ;; Get a GL context - (define gl - (if (and (>= glx-version #e1.4) - (not (send conf get-legacy?)) - (force lazy-GLX_ARB_create_context?) - (force lazy-GLX_ARB_create_context_profile?)) - ;; If the GLX version is high enough, legacy? is #f, and GLX has the right extensions, - ;; try to get a core-profile context - (glx-create-core-context xdisplay cfg share-gl) - ;; Otherwise use the old method - (glx-create-new-context xdisplay cfg share-gl))) - ;; The above will return a direct rendering context when it can - ;; If it doesn't, the context will be version 1.4 or lower, unless GLX is implemented with - ;; proprietary extensions (NVIDIA's drivers sometimes do this) - - (when (and widget (send conf get-sync-swap)) - (glXSwapIntervalEXT xdisplay (gdk_x11_drawable_get_xid drawable) 1)) - - ;; Now wrap the GLX context in a gl-context% - (cond + [wayland? + (define gdk-display (gtk-maybe-widget-get-display widget)) + (define wl-display (gdk_wayland_display_get_wl_display gdk-display)) + + (define eglGetPlatformDisplayEXT-addr + (eglGetProcAddress "eglGetPlatformDisplayEXT")) + (unless eglGetPlatformDisplayEXT-addr + (error 'EGL "could not get eglGetPlatformDisplayEXT")) + (define display ((cast eglGetPlatformDisplayEXT-addr _fpointer eglGetPlatformDisplay-type) + EGL_PLATFORM_WAYLAND_KHR wl-display (list EGL_NONE))) + + (unless (eglInitialize display) + (error 'EGL "initialization failed")) + + (define accum-size (send conf get-accum-size)) + (define attribs (list + EGL_SURFACE_TYPE EGL_WINDOW_BIT + EGL_RENDERABLE_TYPE EGL_OPENGL_BIT + EGL_DEPTH_SIZE (send conf get-depth-size) + EGL_STENCIL_SIZE (send conf get-stencil-size) + EGL_RED_SIZE accum-size + EGL_GREEN_SIZE accum-size + EGL_BLUE_SIZE accum-size + EGL_ALPHA_SIZE accum-size + EGL_NONE)) + (define config (or (eglChooseConfig display attribs) + (error 'EGL "configuration failed"))) + + (unless (eglBindAPI EGL_OPENGL_API) + (error 'EGL "API bind failed")) + + (define (make-context maj min) + (define context-attribs (list + EGL_CONTEXT_MAJOR_VERSION maj + EGL_CONTEXT_MINOR_VERSION min + EGL_CONTEXT_OPENGL_PROFILE_MASK EGL_CONTEXT_OPENGL_CORE_PROFILE_BIT + EGL_NONE)) + (eglCreateContext display config #f context-attribs)) + (define context (or (for/or ([ver (if (send conf get-legacy?) + '((2 1)) + core-gl-versions)]) + (make-context (car ver) (cadr ver))) + (error 'EGL "context failed"))) + + (define (make-win-surface win) + (define eglCreatePlatformWindowSurfaceEXT-addr + (or (eglGetProcAddress "eglCreatePlatformWindowSurfaceEXT") + (error 'EGL "could not get eglCreatePlatformWindowSurfaceEXP"))) + (or ((cast eglCreatePlatformWindowSurfaceEXT-addr + _fpointer eglCreatePlatformWindowSurface-type) + display config win + (list + EGL_RENDER_BUFFER (if wants-double? EGL_BACK_BUFFER EGL_SINGLE_BUFFER) + EGL_NONE)) + (error 'EGL "surface failed"))) + + (define ctxt + (cond + [widget + (define wl-compositor (gdk_wayland_display_get_wl_compositor gdk-display)) + (define wl-subcompositor (or (wayland-get-subcompositor wl-display) + (error 'EGL "subcompositor failed"))) + + (define (create recreate?) + (define-values (width height) + (let ([a (widget-allocation widget)]) + (values (GtkAllocation-width a) + (GtkAllocation-height a)))) + + (define wl-surface/sub (or (wayland-compositor-create-surface wl-compositor) + (error 'EGL "subsurface create failed"))) + + (define toplevel (gtk_widget_get_toplevel widget)) + (define wl-surface (gdk_wayland_window_get_wl_surface + (widget-window widget))) + (define wl-subsurface (and wl-surface + (or (wayland-subcompositor-get-subsurface wl-subcompositor + wl-surface/sub + wl-surface) + (error 'EGL "subsurface failed")))) + + (when wl-surface + (define-values (dx dy) + (gtk_widget_translate_coordinates widget toplevel 0 0)) + + (let ([region (wayland-compositor-create-region wl-compositor)]) + (wayland-surface-set-input-region wl-surface/sub region) + (wayland-region-destroy region)) + (wayland-subsurface-set-position wl-subsurface dx dy) + (wayland-subsurface-set-sync wl-subsurface #f) + (wayland-surface-commit wl-surface/sub) + (wayland-surface-commit wl-surface)) + + (define win (wl_egl_window_create wl-surface/sub width height)) + (define surface (make-win-surface win)) + + (cond + [recreate? + (values surface wl-surface/sub wl-surface wl-subsurface win)] + [else + (new egl-context% [context context] + [display display] [wl-display wl-display] + [surface surface] [wl-surface wl-surface/sub] [wl-parent-surface wl-surface] + [wl-subsurface wl-subsurface] + [widget widget] + [win win] + [create create])])) + (create #f)] + [else + (define width (send drawable get-width)) + (define height (send drawable get-height)) + + (define wl-compositor (gdk_wayland_display_get_wl_compositor gdk-display)) + (define wl-surface (or (wayland-compositor-create-surface wl-compositor) + (error 'EGL "surface create failed"))) + (define win (wl_egl_window_create wl-surface width height)) + (define surface (make-win-surface win)) + + (define texture-sync + (call-with-egl-current + display surface surface context + (lambda () + (create-cairo-texture-sync width height)))) + + (new egl-context% [context context] + [display display] [wl-display wl-display] + [surface surface] [wl-surface wl-surface] + [win win] + [cairo-surface (send drawable get-handle)] [texture-sync texture-sync])])) + (register-finalizer ctxt (λ (ctxt) (send ctxt egl-finalize))) + ctxt] + [else + (define glx-version (get-glx-version)) + + ;; If widget isn't #f, use its display and screen + (define display (gtk-maybe-widget-get-display widget)) + (define screen (gtk-maybe-widget-get-screen widget)) + + ;; Get the X objects wrapped by the GDK objects + (define xdisplay (gdk_x11_display_get_xdisplay display)) + (define xscreen (gdk_x11_screen_get_screen_number screen)) + + ;; Create an attribute list using the GL config + (define xattribs + (append + ;; Be aware: we may get double buffering even if we don't ask for it + (if wants-double? + (if (send conf get-double-buffered) (list GLX_DOUBLEBUFFER True) null) + null) + (if (send conf get-stereo) (list GLX_STEREO True) null) + ;; Finish out with standard GLX 1.3 attributes + (list + GLX_X_RENDERABLE True ; yes, we want to use OpenGL to render today + GLX_DEPTH_SIZE (send conf get-depth-size) + GLX_STENCIL_SIZE (send conf get-stencil-size) + GLX_ACCUM_RED_SIZE (send conf get-accum-size) + GLX_ACCUM_GREEN_SIZE (send conf get-accum-size) + GLX_ACCUM_BLUE_SIZE (send conf get-accum-size) + GLX_ACCUM_ALPHA_SIZE (send conf get-accum-size) + ;; GLX_SAMPLES is handled below - GLX regards it as an absolute lower bound, which makes it + ;; too easy for user programs to fail to get a context + None))) + + (define multisample-size (send conf get-multisample-size)) + + ;; Get all framebuffer configs for this display and screen that match the requested attributes, + ;; then sort them to put the best in front + ;; GLX already sorts them pretty well, so we just need a stable sort on multisamples at the moment + (define cfgs + (let* ([cfgs (cvector->list (glXChooseFBConfig xdisplay xscreen xattribs))] + ;; Keep all configs with multisample size <= requested (i.e. make multisample-size an + ;; abolute upper bound) + [cfgs (if (< glx-version #e1.4) + cfgs + (filter (λ (cfg) + (define m (glx-get-fbconfig-attrib xdisplay cfg GLX_SAMPLES 0)) + (<= m multisample-size)) + cfgs))] + ;; Sort all configs by multisample size, decreasing + [cfgs (if (< glx-version #e1.4) + cfgs + (sort cfgs > + #:key (λ (cfg) (glx-get-fbconfig-attrib xdisplay cfg GLX_SAMPLES 0)) + #:cache-keys? #t))]) + cfgs)) + + (cond + [(null? cfgs) #f] + [else + ;; The framebuffer configs are sorted best-first, so choose the first + (define cfg (car cfgs)) + (define share-gl + (let ([share-ctxt (send conf get-share-context)]) + (and share-ctxt (send share-ctxt get-handle)))) + + ;; Get a GL context + (define gl + (if (and (>= glx-version #e1.4) + (not (send conf get-legacy?)) + (force lazy-GLX_ARB_create_context?) + (force lazy-GLX_ARB_create_context_profile?)) + ;; If the GLX version is high enough, legacy? is #f, and GLX has the right extensions, + ;; try to get a core-profile context + (glx-create-core-context xdisplay cfg share-gl) + ;; Otherwise use the old method + (glx-create-new-context xdisplay cfg share-gl))) + ;; The above will return a direct rendering context when it can + ;; If it doesn't, the context will be version 1.4 or lower, unless GLX is implemented with + ;; proprietary extensions (NVIDIA's drivers sometimes do this) + + (when (and widget (send conf get-sync-swap)) + (glXSwapIntervalEXT xdisplay (gdk_x11_drawable_get_xid drawable) 1)) + + ;; Now wrap the GLX context in a gl-context% + (cond [gl ;; If there's no widget, this is for a pixmap, so get the stupid GLX wrapper for it or ;; indirect rendering may crash on some systems (notably mine) @@ -460,15 +820,22 @@ (unless (and gtk3? (not widget)) (g_object_unref drawable)) (g_object_unref display))) ctxt] - [else #f])])) + [else #f])])])) (define (make-gtk-widget-gl-context widget conf) - (atomically - (make-gtk-drawable-gl-context widget (widget-window widget) conf #t))) + (call-as-atomic + (lambda () + (make-gtk-drawable-gl-context widget (widget-window widget) conf #t)))) (define (make-gtk-pixmap-gl-context pixmap conf) - (atomically - (make-gtk-drawable-gl-context #f pixmap conf #f))) + (call-as-atomic + (lambda () + (make-gtk-drawable-gl-context #f pixmap conf #f)))) + +(define (make-wayland-gl-context bm conf) + (call-as-atomic + (lambda () + (make-gtk-drawable-gl-context #f bm conf #f)))) ;; =================================================================================================== @@ -486,5 +853,7 @@ install-gl-context) (define (create-and-install-gl-context bm conf) - (define ctxt (make-gtk-pixmap-gl-context (send bm get-gdk-pixmap) conf)) + (define ctxt (if wayland? + (make-wayland-gl-context bm conf) + (make-gtk-pixmap-gl-context (send bm get-gdk-pixmap) conf))) (and ctxt (send bm install-gl-context ctxt))) diff --git a/gui-lib/mred/private/wx/gtk/group-panel.rkt b/gui-lib/mred/private/wx/gtk/group-panel.rkt index f1595127e..3ccc8bff0 100644 --- a/gui-lib/mred/private/wx/gtk/group-panel.rkt +++ b/gui-lib/mred/private/wx/gtk/group-panel.rkt @@ -6,6 +6,7 @@ "window.rkt" "client-window.rkt" "panel.rkt" + "frame.rkt" "utils.rkt" "types.rkt") diff --git a/gui-lib/mred/private/wx/gtk/list-box.rkt b/gui-lib/mred/private/wx/gtk/list-box.rkt index 60677a33c..ebef42588 100644 --- a/gui-lib/mred/private/wx/gtk/list-box.rkt +++ b/gui-lib/mred/private/wx/gtk/list-box.rkt @@ -39,13 +39,16 @@ (define-gtk gtk_list_store_newv (_fun _int (_list i _long) -> _GtkListStore)) (define-gtk gtk_list_store_clear (_fun _GtkListStore -> _void)) (define-gtk gtk_list_store_append (_fun _GtkListStore _GtkTreeIter-pointer _pointer -> _void)) -(define-gtk gtk_list_store_set (_fun _GtkListStore _GtkTreeIter-pointer _int _string _int -> _void)) +(define-gtk gtk_list_store_set (_fun #:varargs-after 2 + _GtkListStore _GtkTreeIter-pointer _int _string _int -> _void)) (define-gtk gtk_tree_view_new_with_model (_fun _GtkListStore -> _GtkWidget)) (define-gtk gtk_tree_view_set_model (_fun _GtkWidget _GtkListStore -> _void)) (define-gtk gtk_tree_view_set_headers_visible (_fun _GtkWidget _gboolean -> _void)) (define-gtk gtk_cell_renderer_text_new (_fun -> _GtkCellRenderer)) -(define-gtk gtk_tree_view_column_new_with_attributes (_fun _string _GtkCellRenderer _string _int _pointer -> _GtkTreeViewColumn)) -(define-gtk gtk_tree_view_column_set_attributes (_fun _GtkTreeViewColumn _GtkCellRenderer _string _int _pointer -> _void)) +(define-gtk gtk_tree_view_column_new_with_attributes (_fun #:varargs-after 2 + _string _GtkCellRenderer _string _int _pointer -> _GtkTreeViewColumn)) +(define-gtk gtk_tree_view_column_set_attributes (_fun #:varargs-after 2 + _GtkTreeViewColumn _GtkCellRenderer _string _int _pointer -> _void)) (define-gtk gtk_tree_view_column_set_resizable (_fun _GtkTreeViewColumn _gboolean -> _void)) (define-gtk gtk_tree_view_column_set_clickable (_fun _GtkTreeViewColumn _gboolean -> _void)) (define-gtk gtk_tree_view_column_set_reorderable (_fun _GtkTreeViewColumn _gboolean -> _void)) @@ -75,7 +78,8 @@ (define-gtk gtk_tree_selection_unselect_all (_fun _GtkWidget -> _void)) (define-gtk gtk_tree_selection_select_path (_fun _GtkWidget _pointer -> _void)) (define-gtk gtk_tree_selection_unselect_path (_fun _GtkWidget _pointer -> _void)) -(define-gtk gtk_tree_path_new_from_indices (_fun _int _int -> _pointer)) +(define-gtk gtk_tree_path_new_from_indices (_fun #:varargs-after 1 + _int _int -> _pointer)) (define-gtk gtk_tree_path_free (_fun _pointer -> _void)) (define-gtk gtk_tree_path_get_indices (_fun _pointer -> _pointer)) diff --git a/gui-lib/mred/private/wx/gtk/menu.rkt b/gui-lib/mred/private/wx/gtk/menu.rkt index f51116fa7..213ef3b07 100644 --- a/gui-lib/mred/private/wx/gtk/menu.rkt +++ b/gui-lib/mred/private/wx/gtk/menu.rkt @@ -32,6 +32,12 @@ (_fun _GtkWidget _pointer _pointer _pointer -> _void) _pointer _uint _uint32 -> _void)) +(define-gtk gtk_menu_popup_at_rect (_fun _GtkWidget _GdkWindow + _GdkRectangle-pointer + _int _int + _pointer + -> _void) + #:fail (lambda () void)) (define-gtk gtk_widget_get_screen (_fun _GtkWidget -> _GdkScreen)) (define-gdk gdk_screen_get_width (_fun _GdkScreen -> _int)) @@ -123,32 +129,41 @@ (define on-popup #f) (define cancel-none-box (box #t)) - (define/public (popup x y queue-cb) + (define/public (popup x y in-gtk queue-cb) ;; Pin the menu object so that it is not garbage collected while displayed (hash-set! global-prevent-gc this #t) (set! on-popup queue-cb) (set! cancel-none-box (box #f)) - (gtk_menu_popup gtk - #f - #f - (lambda (menu _x _y _push) - (let ([r (make-GtkRequisition 0 0)]) - (gtk_widget_size_request menu r) - ;; Try to keep the menu on the screen: - (let* ([s (gtk_widget_get_screen menu)] - [sw (gdk_screen_get_width s)] - [sh (gdk_screen_get_height s)]) - (ptr-set! _x _int (min (->screen x) - (max 0 - (- sw - (GtkRequisition-width r))))) - (ptr-set! _y _int (min (->screen y) - (max 0 - (- sh - (GtkRequisition-height r)))))))) - #f - 0 - recent-event-time)) + (cond + [(and in-gtk + (widget-window in-gtk)) + => (lambda (win) + (gtk_menu_popup_at_rect gtk win + (make-GdkRectangle x y 1 1) + 1 1 + (synthesize-click-event win x y recent-event-time)))] + [else + (gtk_menu_popup gtk + #f + #f + (lambda (menu _x _y _push) + (let ([r (make-GtkRequisition 0 0)]) + (gtk_widget_size_request menu r) + ;; Try to keep the menu on the screen: + (let* ([s (gtk_widget_get_screen menu)] + [sw (gdk_screen_get_width s)] + [sh (gdk_screen_get_height s)]) + (ptr-set! _x _int (min (->screen x) + (max 0 + (- sw + (GtkRequisition-width r))))) + (ptr-set! _y _int (min (->screen y) + (max 0 + (- sh + (GtkRequisition-height r)))))))) + #f + 0 + recent-event-time)])) (define ignore-callback? #f) @@ -314,3 +329,20 @@ (cdr items)] [else (cons (car items) (loop (cdr items)))]))))) + +;; ---------------------------------------- + +(define (synthesize-click-event win x y recent-time) + (and wayland? + (make-GdkEventButton GDK_BUTTON_PRESS + win + 1 ; send_event + recent-time + (exact->inexact x) + (exact->inexact y) + #f + 0 ; state + 1 ; button + #f ; device + (exact->inexact x) + (exact->inexact y)))) diff --git a/gui-lib/mred/private/wx/gtk/message.rkt b/gui-lib/mred/private/wx/gtk/message.rkt index 4264abc17..af33f1d03 100644 --- a/gui-lib/mred/private/wx/gtk/message.rkt +++ b/gui-lib/mred/private/wx/gtk/message.rkt @@ -1,5 +1,12 @@ #lang racket/base (require racket/class + racket/draw/private/color + racket/math + (only-in racket/draw/unsafe/pango + pango_attr_list_new + pango_attr_list_insert + pango_attr_foreground_new + pango_attr_foreground_alpha_new) ffi/unsafe "../../syntax.rkt" "../../lock.rkt" @@ -9,18 +16,18 @@ "pixbuf.rkt" "window.rkt") -(provide +(provide (protect-out message% - + gtk_label_new_with_mnemonic gtk_label_set_text_with_mnemonic)) ;; ---------------------------------------- (define-gtk gtk_label_new (_fun _string -> _GtkWidget)) -(define-gtk gtk_label_set_text (_fun _GtkWidget _string -> _void)) (define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) -(define-gtk gtk_image_new_from_stock (_fun _string _int -> _GtkWidget)) +(define-gtk gtk_label_set_attributes (_fun _GtkWidget _pointer -> _void)) +(define-gtk gtk_image_new_from_icon_name (_fun _string _int -> _GtkWidget)) (define-gtk gtk_misc_set_alignment (_fun _GtkWidget _float _float -> _void)) (define-gtk gtk_image_set_from_pixbuf (_fun _GtkWidget _GdkPixbuf -> _void)) @@ -33,27 +40,52 @@ (define icon-size 6) ; = GTK_ICON_SIZE_DIALOG +(define (color-component->gtk c) + (exact-round (* (/ c 255.0) 65535))) + +(define (do-set-label-color label c) + (define attrs (pango_attr_list_new)) + (when c + (define color-attr (pango_attr_foreground_new + (color-component->gtk (color-red c)) + (color-component->gtk (color-green c)) + (color-component->gtk (color-blue c)))) + (define color-alpha-attr (pango_attr_foreground_alpha_new + (color-component->gtk (* (color-alpha c) 255)))) + (pango_attr_list_insert attrs color-attr) + (when color-alpha-attr + (pango_attr_list_insert attrs color-alpha-attr))) + (gtk_label_set_attributes label attrs)) + (defclass message% item% (init parent label x y style font) + (init-field color) (inherit set-auto-size get-gtk) + (define text-label? (string? label)) + (super-new [parent parent] - [gtk (if (or (string? label) - (not label)) - (as-gtk-allocation (gtk_label_new_with_mnemonic (or label ""))) - (if (symbol? label) - (as-gtk-allocation - (case label - [(caution) (gtk_image_new_from_stock "gtk-dialog-warning" icon-size)] - [(stop) (gtk_image_new_from_stock "gtk-dialog-error" icon-size)] - [else (gtk_image_new_from_stock "gtk-dialog-question" icon-size)])) - (let ([pixbuf (bitmap->pixbuf label (->screen 1.0))]) - (begin0 - (as-gtk-allocation - (gtk_image_new_from_pixbuf pixbuf)) - (release-pixbuf pixbuf)))))] + [gtk (cond + [(or (string? label) (not label)) + (define gtk-label + (as-gtk-allocation (gtk_label_new_with_mnemonic (or label "")))) + (when color + (do-set-label-color gtk-label color)) + gtk-label] + [(symbol? label) + (as-gtk-allocation + (case label + [(caution) (gtk_image_new_from_icon_name "dialog-warning" icon-size)] + [(stop) (gtk_image_new_from_icon_name "dialog-error" icon-size)] + [else (gtk_image_new_from_icon_name "dialog-question" icon-size)]))] + [else + (define pixbuf (bitmap->pixbuf label (->screen 1.0))) + (begin0 + (as-gtk-allocation + (gtk_image_new_from_pixbuf pixbuf)) + (release-pixbuf pixbuf))])] [font font] [no-show? (memq 'deleted style)]) @@ -63,14 +95,21 @@ (set-auto-size) (define/override (set-label s) + (set! text-label? (string? s)) (cond - [(string? s) - (gtk_label_set_text_with_mnemonic (get-gtk) (mnemonic-string s))] - [else - (let ([pixbuf (bitmap->pixbuf s (->screen 1.0))]) - (atomically - (gtk_image_set_from_pixbuf (get-gtk) pixbuf) - (release-pixbuf pixbuf)))])) + [(string? s) + (gtk_label_set_text_with_mnemonic (get-gtk) (mnemonic-string s))] + [else + (let ([pixbuf (bitmap->pixbuf s (->screen 1.0))]) + (atomically + (gtk_image_set_from_pixbuf (get-gtk) pixbuf) + (release-pixbuf pixbuf)))])) + + (define/public (get-color) color) + (define/public (set-color c) + (when text-label? + (set! color c) + (do-set-label-color (get-gtk) c))) (define/public (set-preferred-size) (gtk_widget_set_size_request (get-gtk) -1 -1) diff --git a/gui-lib/mred/private/wx/gtk/panel.rkt b/gui-lib/mred/private/wx/gtk/panel.rkt index 1dd007b4f..9185d9178 100644 --- a/gui-lib/mred/private/wx/gtk/panel.rkt +++ b/gui-lib/mred/private/wx/gtk/panel.rkt @@ -6,6 +6,7 @@ "../../syntax.rkt" "../../lock.rkt" "window.rkt" + "frame.rkt" "utils.rkt" "types.rkt" "const.rkt" @@ -16,18 +17,14 @@ panel-mixin panel-container-mixin - gtk_fixed_new - gtk_fixed_move gtk_event_box_new gtk_container_set_border_width connect-expose/draw-border)) -(define-gtk gtk_fixed_new (_fun -> _GtkWidget)) (define-gtk gtk_event_box_new (_fun -> _GtkWidget)) (define-gtk gtk_event_box_set_visible_window (_fun _GtkWidget _gboolean -> _void)) -(define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void)) (define-gtk gtk_widget_get_visible (_fun _GtkWidget -> _gboolean) #:fail (lambda () #f)) @@ -131,6 +128,10 @@ (for ([child (in-list children)]) (send child refresh))) + (define/override (notify-children-top-realize) + (for ([child (in-list children)]) + (send child notify-children-top-realize))) + (define/public (set-item-cursor x y) (void)))) (define (panel-container-mixin %) @@ -195,6 +196,7 @@ (super-new [parent parent] [gtk gtk] [extra-gtks (list client-gtk)] + [connect-size-allocate? #f] [no-show? (memq 'deleted style)]) ;; Start with a minimum size: diff --git a/gui-lib/mred/private/wx/gtk/platform.rkt b/gui-lib/mred/private/wx/gtk/platform.rkt index 1d478c213..201cb78ac 100644 --- a/gui-lib/mred/private/wx/gtk/platform.rkt +++ b/gui-lib/mred/private/wx/gtk/platform.rkt @@ -96,4 +96,6 @@ check-for-break key-symbol-to-menu-key needs-grow-box-spacer? - graphical-system-type)) + graphical-system-type + white-on-black-panel-scheme? + tab-panel-available?)) diff --git a/gui-lib/mred/private/wx/gtk/printer-dc.rkt b/gui-lib/mred/private/wx/gtk/printer-dc.rkt index c3021119f..ccb5d8b7a 100644 --- a/gui-lib/mred/private/wx/gtk/printer-dc.rkt +++ b/gui-lib/mred/private/wx/gtk/printer-dc.rkt @@ -165,7 +165,7 @@ (connect-end-print op-gtk) (gtk_print_operation_set_n_pages op-gtk (length pages)) - (gtk_print_operation_set_allow_async op-gtk #t) + (gtk_print_operation_set_allow_async op-gtk #f) (gtk_print_operation_set_default_page_setup op-gtk page-setup) (define done-sema (make-semaphore)) diff --git a/gui-lib/mred/private/wx/gtk/procs.rkt b/gui-lib/mred/private/wx/gtk/procs.rkt index 623294891..3768bb6a6 100644 --- a/gui-lib/mred/private/wx/gtk/procs.rkt +++ b/gui-lib/mred/private/wx/gtk/procs.rkt @@ -61,10 +61,12 @@ any-control+alt-is-altgr get-panel-background fill-private-color + white-on-black-panel-scheme? get-color-from-user key-symbol-to-menu-key needs-grow-box-spacer? - graphical-system-type) + graphical-system-type + tab-panel-available?) (define (find-graphical-system-path what) (case what @@ -90,11 +92,13 @@ (define _GtkSettings (_cpointer 'GtkSettings)) (define-gtk gtk_settings_get_default (_fun -> _GtkSettings)) -(define-gobj g_object_get/int (_fun _GtkSettings _string (r : (_ptr o _int)) (_pointer = #f) +(define-gobj g_object_get/int (_fun #:varargs-after 2 + _GtkSettings _string (r : (_ptr o _int)) (_pointer = #f) -> _void -> r) #:c-id g_object_get) -(define-gobj g_object_get/string (_fun _GtkSettings _string (r : (_ptr o _pointer)) (_pointer = #f) +(define-gobj g_object_get/string (_fun #:varargs-after 2 + _GtkSettings _string (r : (_ptr o _pointer)) (_pointer = #f) -> _void -> r) #:c-id g_object_get) @@ -174,9 +178,12 @@ (define/top (make-gl-bitmap [exact-positive-integer? w] [exact-positive-integer? h] [gl-config% c]) - (let ([bm (make-object x11-bitmap% w h #f)]) - (create-and-install-gl-context bm c) - bm)) + (define bm + (cond + [wayland? (make-object cairo-bitmap% w h #f)] + [else (make-object x11-bitmap% w h #f)])) + (create-and-install-gl-context bm c) + bm) (define (check-for-break) #f) @@ -186,3 +193,13 @@ (cond [gtk3? 'gtk3] [else 'gtk2])) + + +(define (white-on-black-panel-scheme?) + ;; if the background and foreground are the same + ;; color, probably something has gone wrong; + ;; in that case we want to return #f. + (< (luminance (get-label-background-color)) + (luminance (get-label-foreground-color)))) + +(define (tab-panel-available?) #t) diff --git a/gui-lib/mred/private/wx/gtk/queue.rkt b/gui-lib/mred/private/wx/gtk/queue.rkt index 111389b07..608bca4e7 100644 --- a/gui-lib/mred/private/wx/gtk/queue.rkt +++ b/gui-lib/mred/private/wx/gtk/queue.rkt @@ -169,7 +169,7 @@ poll-fd-count)]) (let ([to (ptr-ref timeout _int)]) (when (to . >= . 0) - (unsafe-poll-ctx-milliseconds-wakeup fds (+ (current-inexact-milliseconds) to)))) + (unsafe-poll-ctx-milliseconds-wakeup fds (+ (current-inexact-monotonic-milliseconds) to)))) (if (n . > . poll-fd-count) (begin (set! poll-fds (malloc _GPollFD n)) diff --git a/gui-lib/mred/private/wx/gtk/slider.rkt b/gui-lib/mred/private/wx/gtk/slider.rkt index 8ba67182f..1a0cfa7f9 100644 --- a/gui-lib/mred/private/wx/gtk/slider.rkt +++ b/gui-lib/mred/private/wx/gtk/slider.rkt @@ -23,6 +23,7 @@ (define-gtk gtk_range_get_value (_fun _GtkWidget -> _double)) (define-gtk gtk_scale_set_digits (_fun _GtkWidget _int -> _void)) (define-gtk gtk_scale_set_draw_value (_fun _GtkWidget _gboolean -> _void)) +(define-gtk gtk_range_set_inverted (_fun _GtkWidget _gboolean -> _void)) (define-signal-handler connect-changed "value-changed" (_fun _GtkWidget -> _void) @@ -42,7 +43,8 @@ (super-new [parent parent] [gtk (as-gtk-allocation - (if (memq 'vertical style) + (if (or (memq 'vertical style) + (memq 'upward style)) (gtk_vscale_new #f) (gtk_hscale_new #f)))] [callback cb] @@ -53,6 +55,8 @@ (gtk_range_set_range gtk lo hi) (gtk_range_set_increments gtk 1.0 1.0) (gtk_range_set_value gtk val) + (when (memq 'upward style) + (gtk_range_set_inverted gtk #true)) (when (memq 'plain style) (gtk_scale_set_draw_value gtk #f)) diff --git a/gui-lib/mred/private/wx/gtk/style.rkt b/gui-lib/mred/private/wx/gtk/style.rkt index dbfe7a8a1..40102fbcd 100644 --- a/gui-lib/mred/private/wx/gtk/style.rkt +++ b/gui-lib/mred/private/wx/gtk/style.rkt @@ -2,7 +2,9 @@ (require ffi/unsafe "types.rkt" "utils.rkt" - "init.rkt") + "init.rkt" + "frame.rkt" + "../common/queue.rkt") (provide (protect-out get-selected-text-color @@ -71,13 +73,16 @@ (define-gtk gtk_text_view_new (_fun -> _GtkWidget)) (define-gtk gtk_widget_destroy (_fun _GtkWidget -> _void)) -(define the-text-style - (let ([w (gtk_text_view_new)]) - (let ([style (gtk_rc_get_style w)]) - (g_object_ref style) - (begin0 - style - (gtk_widget_destroy w))))) +(define the-text-style #f) +(define (update-the-text-style!) + (when the-text-style (g_object_unref the-text-style)) + (define w (gtk_text_view_new)) + (define style (gtk_rc_get_style w)) + (g_object_ref style) + (set! the-text-style style) + (gtk_widget_destroy w) + (void)) +(update-the-text-style!) (define (extract-color-values c) (define (s v) (arithmetic-shift v -8)) @@ -96,3 +101,30 @@ (define (get-label-bg-color) (extract-color-values (GtkStyle-bg1 the-text-style))) + +(define _GtkSettings (_cpointer 'GtkSettings)) +(define-gtk gtk_settings_get_default (_fun -> _GtkSettings)) +(define-gobj g_object_get/string (_fun #:varargs-after 2 + _GtkSettings _string (r : (_ptr o _pointer)) (_pointer = #f) + -> _void + -> r) + #:c-id g_object_get) +(define-signal-handler connect-dark "notify::gtk-theme-name" + (_fun _GtkSettings -> _void) + (λ (gtk) + (define new-dark? (calculate-dark?)) + (unless (equal? new-dark? is-dark?) + (set! is-dark? new-dark?) + (update-the-text-style!) + (tell-all-frames-request-refresh-all-canvas-children) + (queue-dark-mode-event)))) +(void (connect-dark (cast (gtk_settings_get_default) _GtkSettings _GtkWidget))) + +(define (calculate-dark?) + (define s (gtk_settings_get_default)) + (define th (g_object_get/string s "gtk-theme-name")) + (define dark? (regexp-match? #rx"(^|-)dark(-|$)" (cast th _pointer _string))) + (g_free th) + dark?) +(define is-dark? (calculate-dark?)) +(define (dark?) is-dark?) diff --git a/gui-lib/mred/private/wx/gtk/tab-panel.rkt b/gui-lib/mred/private/wx/gtk/tab-panel.rkt index c8330effe..fcfa64b86 100644 --- a/gui-lib/mred/private/wx/gtk/tab-panel.rkt +++ b/gui-lib/mred/private/wx/gtk/tab-panel.rkt @@ -9,6 +9,7 @@ "types.rkt" "widget.rkt" "message.rkt" + "frame.rkt" "../../lock.rkt" "../common/event.rkt") @@ -23,15 +24,36 @@ (define-gtk gtk_notebook_get_current_page (_fun _GtkWidget -> _int)) (define-gtk gtk_notebook_set_current_page (_fun _GtkWidget _int -> _void)) (define-gtk gtk_notebook_get_tab_label (_fun _GtkWidget _GtkWidget -> _GtkWidget)) +(define-gtk gtk_notebook_set_tab_reorderable (_fun _GtkWidget _GtkWidget _gboolean -> _void)) (define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) +(define text-close-label? #t) + +;; Used for test close label: +(define-gtk gtk_label_new (_fun _string -> _GtkWidget)) +(define-gtk gtk_label_set_use_markup (_fun _GtkWidget _gboolean -> _void)) +(define-gtk gtk_label_set_use_underline (_fun _GtkWidget _gboolean -> _void)) + +;; Used for icon close label: +(define-gtk gtk_button_new (_fun -> _GtkWidget)) +(define-gtk gtk_button_set_relief (_fun _GtkWidget _int -> _void)) +(define-gtk gtk_button_set_image (_fun _GtkWidget _GtkWidget -> _void)) +(define-gtk gtk_image_new_from_stock (_fun _string _int -> _GtkWidget)) +(define GTK_STOCK_CLOSE "gtk-close") +(define GTK_ICON_SIZE_MENU 1) +(define GTK_RELIEF_NONE 2) + +(define-gtk gtk_widget_get_parent (_fun _GtkWidget -> _GtkWidget)) +(define-gtk gtk_widget_set_focus_on_click (_fun _GtkWidget _gboolean -> _void) + #:fail (lambda () (lambda (w focus?) (void)))) + (define-gtk gtk_widget_ref (_fun _GtkWidget -> _void) #:fail (lambda () g_object_ref)) (define-gtk gtk_widget_unref (_fun _GtkWidget -> _void) #:fail (lambda () g_object_unref)) -(define-struct page (bin-gtk label-gtk)) +(define-struct page (bin-gtk label-gtk close-gtk)) (define-signal-handler connect-changed "switch-page" (_fun _GtkWidget _pointer _int -> _void) @@ -40,6 +62,20 @@ (when wx (send wx page-changed i))))) +(define-signal-handler connect-reordered "page-reordered" + (_fun _GtkWidget _pointer _int -> _void) + (lambda (gtk child i) + (let ([wx (gtk->wx gtk)]) + (when wx + (send wx page-reordered child i))))) + +(define-signal-handler connect-clicked "clicked" + (_fun _GtkWidget _GtkWidget -> _void) + (lambda (button-gtk gtk) + (let ([wx (gtk->wx gtk)]) + (when wx + (send wx queue-close-clicked (gtk_widget_get_parent button-gtk)))))) + (define tab-panel% (class (client-size-mixin (panel-container-mixin (panel-mixin window%))) (init parent @@ -65,6 +101,8 @@ (define client-gtk (gtk_fixed_new)) (gtk_notebook_set_scrollable notebook-gtk #t) + (define can-reorder? (and (memq 'can-reorder style) #t)) + (define can-close? (and (memq 'can-close style) #t)) (super-new [parent parent] [gtk gtk] @@ -82,7 +120,7 @@ (define empty-bin-gtk (gtk_hbox_new #f 0)) (define current-bin-gtk #f) - (define (select-bin bin-gtk) + (define/private (select-bin bin-gtk) (set! current-bin-gtk bin-gtk) ;; re-parenting can change the underlying window, so ;; make sure no freeze in places: @@ -91,13 +129,47 @@ ;; re-parenting can change the underlying window dc: (reset-child-dcs)) + (define/private (maybe-add-close label-gtk) + (cond + [can-close? + (let ([hbox-gtk (gtk_hbox_new #f 0)] + [close-gtk (gtk_button_new)]) + + (cond + [text-close-label? + ;; abuse of multiply symbol? + (define close-label-gtk (gtk_label_new "\xD7")) + (gtk_label_set_use_markup close-label-gtk #f) + (gtk_label_set_use_underline close-label-gtk #f) + (gtk_container_add close-gtk close-label-gtk) + (gtk_widget_show close-label-gtk)] + [else + ;; looks heavy for most purposes: + (define close-icon (gtk_image_new_from_stock GTK_STOCK_CLOSE + GTK_ICON_SIZE_MENU)) + (gtk_button_set_image close-gtk close-icon)]) + + (gtk_widget_set_focus_on_click close-gtk #f) + (gtk_button_set_relief close-gtk GTK_RELIEF_NONE) + (gtk_container_add hbox-gtk label-gtk) + (gtk_container_add hbox-gtk close-gtk) + (gtk_widget_show close-gtk) + (gtk_widget_show label-gtk) + (connect-clicked close-gtk gtk) + hbox-gtk)] + [else label-gtk])) + + (define pages (for/list ([lbl labels]) - (let ([bin-gtk (gtk_hbox_new #f 0)] - [label-gtk (gtk_label_new_with_mnemonic lbl)]) - (gtk_notebook_append_page notebook-gtk bin-gtk label-gtk) + (let* ([bin-gtk (gtk_hbox_new #f 0)] + [label-gtk (gtk_label_new_with_mnemonic lbl)] + [close-gtk (maybe-add-close label-gtk)]) + (gtk_notebook_append_page notebook-gtk bin-gtk close-gtk) + (when can-reorder? + (gtk_notebook_set_tab_reorderable notebook-gtk bin-gtk #t)) (gtk_widget_show bin-gtk) - (make-page bin-gtk label-gtk)))) + (make-page bin-gtk label-gtk close-gtk)))) (define/private (install-empty-page) (gtk_notebook_append_page notebook-gtk empty-bin-gtk #f) @@ -141,6 +213,33 @@ (when callback-ok? (queue-window-event this (lambda () (do-callback)))))) (connect-changed notebook-gtk) + + (define/public (page-reordered child new-pos) + (unless (equal? child (list-ref pages new-pos)) + (define old-pages (for/hash ([page (in-list pages)] + [i (in-naturals)]) + (values (page-bin-gtk page) (cons i page)))) + (define move-page (cdr (hash-ref old-pages child))) + (define new-pages (let loop ([l pages] [i 0]) + (cond + [(= i new-pos) (cons move-page (remove move-page l))] + [(equal? (car l) move-page) + (loop (cdr l) i)] + [else + (cons (car l) (loop (cdr l) (add1 i)))]))) + (set! pages new-pages) + (on-choice-reorder (for/list ([page (in-list new-pages)]) + (car (hash-ref old-pages (page-bin-gtk page))))))) + (define/public (on-choice-reorder moved-mapping) (void)) + (when can-reorder? + (connect-reordered notebook-gtk)) + + (define/public (queue-close-clicked close-gtk) + (for ([page (in-list pages)] + [i (in-naturals)]) + (when (equal? close-gtk (page-close-gtk page)) + (queue-window-event this (lambda () (on-choice-close i)))))) + (define/public (on-choice-close pos) (void)) (define/override (get-client-gtk) client-gtk) @@ -153,11 +252,14 @@ (define/private (do-append lbl) (let ([page - (let ([bin-gtk (gtk_hbox_new #f 0)] - [label-gtk (gtk_label_new_with_mnemonic lbl)]) - (gtk_notebook_append_page notebook-gtk bin-gtk label-gtk) + (let* ([bin-gtk (gtk_hbox_new #f 0)] + [label-gtk (gtk_label_new_with_mnemonic lbl)] + [close-gtk (maybe-add-close label-gtk)]) + (gtk_notebook_append_page notebook-gtk bin-gtk close-gtk) + (when can-reorder? + (gtk_notebook_set_tab_reorderable notebook-gtk bin-gtk #t)) (gtk_widget_show bin-gtk) - (make-page bin-gtk label-gtk))]) + (make-page bin-gtk label-gtk close-gtk))]) (set! pages (append pages (list page))) (when (null? (cdr pages)) (swap-in (page-bin-gtk (car pages))) diff --git a/gui-lib/mred/private/wx/gtk/types.rkt b/gui-lib/mred/private/wx/gtk/types.rkt index a12530332..3854b9704 100644 --- a/gui-lib/mred/private/wx/gtk/types.rkt +++ b/gui-lib/mred/private/wx/gtk/types.rkt @@ -72,7 +72,7 @@ [axes _pointer] ; array of _double [state _uint] [button _uint] - [device _GdkDevice] + [device (_or-null _GdkDevice)] [x_root _double] [y_root _double])) diff --git a/gui-lib/mred/private/wx/gtk/wayland.rkt b/gui-lib/mred/private/wx/gtk/wayland.rkt new file mode 100644 index 000000000..e69bb50e5 --- /dev/null +++ b/gui-lib/mred/private/wx/gtk/wayland.rkt @@ -0,0 +1,277 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + "types.rkt" + "utils.rkt" + (only-in "queue.rkt" wayland?)) + +(provide wayland-get-subcompositor + wayland-compositor-create-surface + wayland-subcompositor-get-subsurface + wayland-subsurface-destroy + wayland-subsurface-set-position + wayland-subsurface-set-sync + wayland-surface-commit + wayland-surface-destroy + wayland-roundtrip + wayland-display-dispatch-pending + wayland-register-surface-frame-callback + wayland-compositor-create-region + wayland-surface-set-input-region + wayland-region-destroy) + +(define wayland-lib + (and wayland? (ffi-lib "libwayland-client" '("0" "")))) + +(define-ffi-definer define-wayland wayland-lib + #:default-make-fail make-not-available) + +(define-cstruct _wl_registry_listener ([handle (_fun #:atomic? #t + _pointer ; data + _pointer ; registry + _uint32 ; id + _string ; interface + _uint32 ; version + -> _void)] + [remove (_fun #:atomic? #t + _pointer ; data + _pointer ; registry + _uint32 ; id + -> _void)]) + #:malloc-mode 'atomic-interior) + +(define-cstruct _wl_frame_listener ([handle (_fun #:atomic? #t + _pointer ; data + _pointer ; callback + _uint32 ; time + -> _void)]) + #:malloc-mode 'atomic-interior) + +(define WL_MARSHAL_FLAG_DESTROY 1) + +(define WL_DISPLAY_GET_REGISTRY 1) +(define WL_REGISTRY_BIND 0) +(define WL_COMPOSITOR_CREATE_SURFACE 0) +(define WL_COMPOSITOR_CREATE_REGION 1) +(define WL_SUBCOMPOSITOR_GET_SUBSURFACE 1) +(define WL_SUBSURFACE_DESTROY 0) +(define WL_SUBSURFACE_SET_POSITION 1) +(define WL_SUBSURFACE_SET_SYNC 4) +(define WL_SUBSURFACE_SET_DESYNC 5) +(define WL_SURFACE_DESTROY 0) +(define WL_SURFACE_FRAME 3) +(define WL_SURFACE_SET_INPUT_REGION 5) +(define WL_SURFACE_COMMIT 6) +(define WL_REGION_DESTROY 0) + +(define _registry (_cpointer/null 'wl_registry)) + +(define-wayland wl_registry_interface _fpointer) ; really a struct address +(define-wayland wl_subcompositor_interface _fpointer) +(define-wayland wl_surface_interface _fpointer) +(define-wayland wl_subsurface_interface _fpointer) +(define-wayland wl_callback_interface _fpointer) +(define-wayland wl_region_interface _fpointer) + +(define-wayland wl_display_roundtrip + (_fun _pointer -> _int)) +(define-wayland wl_display_dispatch_pending + (_fun _pointer -> _int)) +(define-wayland wl_proxy_marshal_constructor/wl_display_get_registry + (_fun #:varargs-after 3 _pointer _uint32 _pointer _pointer -> _registry) + #:c-id wl_proxy_marshal_constructor) +(define-wayland wl_proxy_marshal_flags/wl_registry_bind + (_fun #:varargs-after 5 + _pointer _uint32 _pointer _uint32 + _uint32 + _uint32 _pointer _uint32 + _pointer + -> _pointer) + #:c-id wl_proxy_marshal_flags) +(define-wayland wl_proxy_marshal_flags/wl_compositor_create_X + (_fun #:varargs-after 5 + _pointer _uint32 _pointer _uint32 + _uint32 + _pointer + -> _pointer) + #:c-id wl_proxy_marshal_flags) +(define-wayland wl_proxy_marshal_flags/wl_subcompositor_get_subsurface + (_fun #:varargs-after 5 + _pointer _uint32 _pointer _uint32 + _uint32 + _pointer + _pointer _pointer + -> _pointer) + #:c-id wl_proxy_marshal_flags) +(define-wayland wl_proxy_marshal_flags/wl_subcompositor_set_position + (_fun #:varargs-after 5 + _pointer _uint32 _pointer _uint32 + _uint32 + _int32 _int32 + -> _pointer) + #:c-id wl_proxy_marshal_flags) +(define-wayland wl_proxy_marshal_flags/wl_subsurface_set_position + (_fun #:varargs-after 5 + _pointer _uint32 _pointer _uint32 + _uint32 + _int32 _int32 + -> _pointer + -> (void)) + #:c-id wl_proxy_marshal_flags) +(define-wayland wl_proxy_marshal_flags/wl_subsurface_set_sync + (_fun #:varargs-after 5 + _pointer _uint32 _pointer _uint32 + _uint32 + -> _pointer + -> (void)) + #:c-id wl_proxy_marshal_flags) +(define-wayland wl_proxy_marshal_flags/wl_surface_commit + (_fun #:varargs-after 5 + _pointer _uint32 _pointer _uint32 + _uint32 + -> _pointer + -> (void)) + #:c-id wl_proxy_marshal_flags) +(define-wayland wl_proxy_marshal_flags/wl_surface_ + (_fun #:varargs-after 5 + _pointer _uint32 _pointer _uint32 + _uint32 + _pointer + -> _pointer) + #:c-id wl_proxy_marshal_flags) +(define-wayland wl_proxy_marshal_flags/wl__destroy + (_fun #:varargs-after 5 + _pointer _uint32 _pointer _uint32 + _uint32 + -> _pointer) + #:c-id wl_proxy_marshal_flags) +(define-wayland wl_proxy_add_listener + (_fun _pointer _pointer _pointer -> _void)) +(define-wayland wl_proxy_get_version (_fun _pointer -> _uint32)) + +(define subcompositor #f) + +(define (handle-callback data registry id interface version) + (when (equal? interface "wl_subcompositor") + (set! subcompositor (wl_proxy_marshal_flags/wl_registry_bind + registry + WL_REGISTRY_BIND + wl_subcompositor_interface 1 + 0 + ;; name is immedieate member of an interface + id (ptr-ref wl_subcompositor_interface _pointer) 1 + #f)))) +(define (remove-callback data registry id) + (void)) + +(define cached-subcompositor #f) + +(define (wayland-get-subcompositor display) + (unless cached-subcompositor + (define registry (wl_proxy_marshal_constructor/wl_display_get_registry + display + WL_DISPLAY_GET_REGISTRY + wl_registry_interface + #f)) + (define l (make-wl_registry_listener handle-callback remove-callback)) + (wl_proxy_add_listener registry l #f) + (wl_display_roundtrip display) + (void/reference-sink l) + (set! cached-subcompositor subcompositor)) + cached-subcompositor) + +(define (wayland-compositor-create-surface compositor) + (wl_proxy_marshal_flags/wl_compositor_create_X + compositor + WL_COMPOSITOR_CREATE_SURFACE + wl_surface_interface (wl_proxy_get_version compositor) + 0 + #f)) + +(define (wayland-subcompositor-get-subsurface subcompositor child parent) + (wl_proxy_marshal_flags/wl_subcompositor_get_subsurface + subcompositor + WL_SUBCOMPOSITOR_GET_SUBSURFACE + wl_subsurface_interface (wl_proxy_get_version subcompositor) + 0 + #f child parent)) + +(define (wayland-subsurface-destroy subsurface) + (wl_proxy_marshal_flags/wl__destroy + subsurface + WL_SUBSURFACE_DESTROY + #f (wl_proxy_get_version subsurface) + WL_MARSHAL_FLAG_DESTROY) + (void)) + +(define (wayland-subsurface-set-position subsurface x y) + (wl_proxy_marshal_flags/wl_subsurface_set_position + subsurface + WL_SUBSURFACE_SET_POSITION + #f (wl_proxy_get_version subsurface) + 0 + x y)) + +(define (wayland-subsurface-set-sync subsurface on?) + (wl_proxy_marshal_flags/wl_subsurface_set_sync + subsurface + (if on? WL_SUBSURFACE_SET_SYNC WL_SUBSURFACE_SET_DESYNC) + #f (wl_proxy_get_version subsurface) + 0)) + +(define (wayland-surface-commit surface) + (wl_proxy_marshal_flags/wl_surface_commit + surface + WL_SURFACE_COMMIT + #f (wl_proxy_get_version surface) + 0)) + +(define (wayland-surface-destroy surface) + (wl_proxy_marshal_flags/wl__destroy + surface + WL_SURFACE_DESTROY + #f (wl_proxy_get_version surface) + WL_MARSHAL_FLAG_DESTROY) + (void)) + +(define (wayland-roundtrip display) + (wl_display_roundtrip display)) +(define (wayland-display-dispatch-pending display) + (wl_display_roundtrip display)) + + +(define (wayland-register-surface-frame-callback surface callback) + (define frame (wl_proxy_marshal_flags/wl_surface_ + surface + WL_SURFACE_FRAME + wl_callback_interface (wl_proxy_get_version surface) + 0 + #f)) + (define l (make-wl_frame_listener callback)) + (wl_proxy_add_listener frame l #f) + l) + +(define (wayland-compositor-create-region compositor) + (wl_proxy_marshal_flags/wl_compositor_create_X + compositor + WL_COMPOSITOR_CREATE_REGION + wl_region_interface (wl_proxy_get_version compositor) + 0 + #f)) + +(define (wayland-surface-set-input-region surface region) + (wl_proxy_marshal_flags/wl_surface_ + surface + WL_SURFACE_SET_INPUT_REGION + #f (wl_proxy_get_version surface) + 0 + region) + (void)) + +(define (wayland-region-destroy region) + (wl_proxy_marshal_flags/wl__destroy + region + WL_REGION_DESTROY + #f (wl_proxy_get_version region) + WL_MARSHAL_FLAG_DESTROY) + (void)) diff --git a/gui-lib/mred/private/wx/gtk/widget.rkt b/gui-lib/mred/private/wx/gtk/widget.rkt index 0b44df28d..394f106e9 100644 --- a/gui-lib/mred/private/wx/gtk/widget.rkt +++ b/gui-lib/mred/private/wx/gtk/widget.rkt @@ -16,6 +16,10 @@ gtk_widget_hide gtk_widget_destroy + gtk_widget_queue_draw + gtk_widget_get_toplevel + gtk_widget_translate_coordinates + gtk_vbox_new gtk_hbox_new gtk_box_pack_start @@ -32,6 +36,13 @@ (define-gtk gtk_box_pack_end (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void)) (define-gtk gtk_widget_get_parent (_fun _GtkWidget -> (_or-null _GtkWidget))) +(define-gtk gtk_widget_queue_draw (_fun _GtkWidget -> _void)) +(define-gtk gtk_widget_get_toplevel (_fun _GtkWidget -> _GtkWidget)) +(define-gtk gtk_widget_translate_coordinates (_fun _GtkWidget _GtkWidget _int _int + (x : (_ptr o _int)) (y : (_ptr o _int)) + -> _gboolean + -> (values x y))) + (define-signal-handler connect-destroy "destroy" (_fun _GtkWidget _pointer -> _void) (lambda (gtk cell) diff --git a/gui-lib/mred/private/wx/gtk/window.rkt b/gui-lib/mred/private/wx/gtk/window.rkt index 9c1ca01d5..6208f6090 100644 --- a/gui-lib/mred/private/wx/gtk/window.rkt +++ b/gui-lib/mred/private/wx/gtk/window.rkt @@ -236,7 +236,7 @@ (lambda (gtk a) (let ([wx (gtk->wx gtk)]) (when wx - (send wx save-size + (send wx save-size (->normal (GtkAllocation-x a)) (->normal (GtkAllocation-y a)) (->normal (GtkAllocation-width a)) @@ -867,17 +867,22 @@ (define/public (get-client-handle) (get-container-gtk)) (define/public (popup-menu m x y) - (let ([gx (box x)] - [gy (box y)]) - (client-to-screen gx gy) - (send m popup (unbox gx) (unbox gy) - (lambda (thunk) (queue-window-event this thunk))))) + (if wayland? + (send m popup x y (get-gtk) + (lambda (thunk) (queue-window-event this thunk))) + (let ([gx (box x)] + [gy (box y)]) + (client-to-screen gx gy) + (send m popup (unbox gx) (unbox gy) #f + (lambda (thunk) (queue-window-event this thunk)))))) (define/public (center a b) (void)) (define/public (refresh) (refresh-all-children)) (define/public (refresh-all-children) (void)) + (define/public (notify-children-top-realize) (void)) + (define/public (screen-to-client x y) (internal-screen-to-client x y)) (define/public (internal-screen-to-client x y) diff --git a/gui-lib/mred/private/wx/platform.rkt b/gui-lib/mred/private/wx/platform.rkt index 0cc59545b..dab935034 100644 --- a/gui-lib/mred/private/wx/platform.rkt +++ b/gui-lib/mred/private/wx/platform.rkt @@ -85,5 +85,7 @@ check-for-break key-symbol-to-menu-key needs-grow-box-spacer? - graphical-system-type) + graphical-system-type + white-on-black-panel-scheme? + tab-panel-available?) ((dynamic-require platform-lib 'platform-values))) diff --git a/gui-lib/mred/private/wx/win32/button.rkt b/gui-lib/mred/private/wx/win32/button.rkt index 04d568388..e74442741 100644 --- a/gui-lib/mred/private/wx/win32/button.rkt +++ b/gui-lib/mred/private/wx/win32/button.rkt @@ -36,6 +36,7 @@ (define/public (get-class) "PLTBUTTON") (define/public (get-flags) BS_PUSHBUTTON) + (define/public (get-event-type) 'button) (super-new [callback cb] [parent parent] @@ -170,7 +171,7 @@ (queue-window-event this (lambda () (callback this (new control-event% - [event-type 'button] + [event-type (get-event-type)] [time-stamp (current-milliseconds)]))))) (define/public (set-border on?) diff --git a/gui-lib/mred/private/wx/win32/canvas.rkt b/gui-lib/mred/private/wx/win32/canvas.rkt index 49736a71b..6267e8007 100644 --- a/gui-lib/mred/private/wx/win32/canvas.rkt +++ b/gui-lib/mred/private/wx/win32/canvas.rkt @@ -92,13 +92,16 @@ get-virtual-width get-virtual-height reset-auto-scroll refresh-for-autoscroll - try-mouse) + try-mouse + is-shown-to-root?) (define hscroll? (or (memq 'hscroll style) (memq 'auto-hscroll style))) (define vscroll? (or (memq 'vscroll style) (memq 'auto-vscroll style))) (define for-gl? (memq 'gl style)) + (define no-autoclear? (memq 'no-autoclear style)) + (define transparent? (memq 'transparent style)) (define panel-hwnd (and (memq 'combo style) @@ -202,9 +205,12 @@ (FillRect hdc r hbrush)) (unless transparent? (DeleteObject hbrush)))))]) - (when transparent? (erase)) (unless (do-canvas-backing-flush hdc) - (unless transparent? (erase)) + ;; Is it better to erase here, to reflect that the screen is not + ;; yet updated, or just leave it alone, which might reduce flicker. + ;; For now, this doesn't seem to be a source of flickering, so we + ;; leave it in place. + (erase) (queue-paint))))) (EndPaint w ps))) 0] @@ -256,7 +262,7 @@ 0 (default w msg wParam lParam))) - (set! dc (new dc% [canvas this] [transparent? (memq 'transparent style)])) + (set! dc (new dc% [canvas this] [transparent? transparent?])) (send dc start-backing-retained) (define/public (get-dc) dc) @@ -340,14 +346,15 @@ (define/public (schedule-periodic-backing-flush) (void)) (define/public (do-canvas-backing-flush hdc) + (define clear-hbrush (and transparent? background-hbrush)) (if hdc - (do-backing-flush this dc hdc) + (do-backing-flush this dc hdc #f clear-hbrush) (if (positive? paint-suspended) ;; suspended => try again later (schedule-periodic-backing-flush) ;; not suspended (let ([hdc (GetDC canvas-hwnd)]) - (do-backing-flush this dc hdc) + (do-backing-flush this dc hdc #f clear-hbrush) (ReleaseDC canvas-hwnd hdc) ;; We'd like to validate the region that ;; we just updated, so we can potentially @@ -358,6 +365,9 @@ #; (ValidateRect canvas-hwnd #f))))) + (define/public (worthwhile-to-paint?) + (is-shown-to-root?)) + (define/public (make-compatible-bitmap w h) (send dc make-backing-bitmap w h)) @@ -375,16 +385,15 @@ (set! suspended-refresh? #f) (InvalidateRect canvas-hwnd #f #f))))) - (define no-autoclear? (memq 'no-autoclear style)) - (define transparent? (memq 'transparent style)) (define bg-col (make-object color% "white")) (define bg-colorref #xFFFFFF) (define/public (get-canvas-background) (if transparent? #f bg-col)) - (define/public (get-canvas-background-for-backing) (and (not transparent?) - (not no-autoclear?) - bg-col)) + (define/public (get-canvas-background-for-backing) (if transparent? + background-hbrush-color + (and (not no-autoclear?) + bg-col))) (define/public (set-canvas-background col) (atomically (set! bg-col col) diff --git a/gui-lib/mred/private/wx/win32/check-box.rkt b/gui-lib/mred/private/wx/win32/check-box.rkt index e4548b7db..9e6e74c87 100644 --- a/gui-lib/mred/private/wx/win32/check-box.rkt +++ b/gui-lib/mred/private/wx/win32/check-box.rkt @@ -20,6 +20,8 @@ (define/override (get-flags) (bitwise-ior BS_AUTOCHECKBOX)) + (define/override (get-event-type) 'check-box) + (define/override (get-button-background) (GetSysColor COLOR_BTNFACE)) diff --git a/gui-lib/mred/private/wx/win32/dc.rkt b/gui-lib/mred/private/wx/win32/dc.rkt index 15d05b869..6acc96dc6 100644 --- a/gui-lib/mred/private/wx/win32/dc.rkt +++ b/gui-lib/mred/private/wx/win32/dc.rkt @@ -29,6 +29,9 @@ (define-gdi32 BitBlt (_wfun _pointer _int _int _int _int _pointer _int _int _DWORD -> _BOOL)) (define SRCCOPY #X00cc0020) +(define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int) + -> (when (zero? r) (failed 'FillRect)))) + (define hwnd-param (make-parameter #f)) (define need-clip-text-workaround? #t) @@ -95,7 +98,7 @@ v))) (define/override (make-backing-bitmap w h) - (if (send canvas get-canvas-background) + (if (send canvas get-canvas-background-for-backing) (make-object win32-bitmap% w h (send canvas get-hwnd)) (make-object bitmap% w h #f #t (->screen 1.0)))) @@ -122,7 +125,7 @@ (define/override (cancel-delay req) (cancel-flush-delay req)))) -(define (do-backing-flush canvas dc hdc) +(define (do-backing-flush canvas dc hdc blit-clear-hbrush nada-clear-hbrush) (send dc on-backing-flush (lambda (bm) (let ([w (box 0)] @@ -131,6 +134,8 @@ (define sw (->screen (unbox w))) (define sh (->screen (unbox h))) (define r (make-RECT 0 0 sw sh)) + (when blit-clear-hbrush + (FillRect hdc r blit-clear-hbrush)) (define clip-type (if need-clip-refresh-workaround? (GetClipBox hdc r) @@ -170,7 +175,13 @@ (backing-draw-bm bm cr (->normal sw) (->normal sh) 0 0 (->screen 1.0)) - (cairo_destroy cr))]))))) + (cairo_destroy cr))]))) + (if nada-clear-hbrush + (lambda () + (define r (make-RECT 0 0 0 0)) + (GetClipBox hdc r) + (FillRect hdc r nada-clear-hbrush)) + void))) (define (request-flush-delay canvas) (do-request-flush-delay diff --git a/gui-lib/mred/private/wx/win32/frame.rkt b/gui-lib/mred/private/wx/win32/frame.rkt index 99bf815e4..a89e51309 100644 --- a/gui-lib/mred/private/wx/win32/frame.rkt +++ b/gui-lib/mred/private/wx/win32/frame.rkt @@ -767,7 +767,8 @@ (eq? mode 'both)) (atomically (set! big-hicon hicon) - (SendMessageW hwnd WM_SETICON 1 (cast hicon _HICON _LPARAM)))))) + (SendMessageW hwnd WM_SETICON 1 (cast hicon _HICON _LPARAM)))) + (void))) (define/public (set-title s) (atomically diff --git a/gui-lib/mred/private/wx/win32/key.rkt b/gui-lib/mred/private/wx/win32/key.rkt index 3bdb41b39..9df39b024 100644 --- a/gui-lib/mred/private/wx/win32/key.rkt +++ b/gui-lib/mred/private/wx/win32/key.rkt @@ -11,13 +11,15 @@ generates-key-event? reset-key-mapping key-symbol-to-menu-key - any-control+alt-is-altgr)) + any-control+alt-is-altgr + get-event-time-stamp)) (define-user32 GetKeyState (_wfun _int -> _SHORT)) (define-user32 MapVirtualKeyW (_wfun _UINT _UINT -> _UINT)) (define-user32 VkKeyScanW (_wfun _WCHAR -> _SHORT)) (define-user32 ToUnicode (_wfun _UINT _UINT _pointer _pointer _int _UINT -> _int)) (define-user32 GetKeyboardState (_wfun _pointer -> _BOOL)) +(define-user32 GetMessageTime (_wfun -> _UDWORD)) (define control+alt-always-as-altgr? #f) (define any-control+alt-is-altgr @@ -182,7 +184,8 @@ ;; shift/AltGr state: (let ([k (MapVirtualKeyW sc 1)]) (if (zero? k) - (values (integer->char id) #f #f #f) + (let ([id (surrogate->char id)]) + (values (and id (integer->char id)) #f #f #f)) (for/fold ([id id][s #f][a #f][sa #f]) ([o (in-vector (get-other-key-codes))] [j (in-naturals)]) (if (= (bitwise-and o #xFF) k) @@ -289,7 +292,7 @@ [alt-down #f] [x 0] [y 0] - [time-stamp 0] + [time-stamp (get-event-time-stamp)] [caps-down caps-down?] [control+meta-is-altgr (and control-down? alt-down? @@ -399,3 +402,23 @@ (hash-set! mapped-keys key mapped?) mapped?] [else #f])))) + +(define (get-event-time-stamp) + (GetMessageTime)) + +(define saved-surrogate-high #f) +(define (surrogate->char id) + (cond + [(<= #xD800 id #xDBFF) + (set! saved-surrogate-high id) + #f] + [(<= #xDC00 id #xDFFF) + (cond + [saved-surrogate-high + (begin0 + (+ #x10000 + (arithmetic-shift (bitwise-and saved-surrogate-high #x3FF) 10) + (bitwise-and id #x3FF)) + (set! saved-surrogate-high #f))] + [else #f])] + [else id])) diff --git a/gui-lib/mred/private/wx/win32/list-box.rkt b/gui-lib/mred/private/wx/win32/list-box.rkt index fedd4b795..e36239c46 100644 --- a/gui-lib/mred/private/wx/win32/list-box.rkt +++ b/gui-lib/mred/private/wx/win32/list-box.rkt @@ -411,11 +411,10 @@ (if single-column? (void (SendMessageW hwnd LB_SETTOPINDEX i 0)) (let ([c (SendMessageW hwnd LVM_GETCOUNTPERPAGE 0 0)]) - (unless (= c i) - (if (> (SendMessageW hwnd LVM_GETTOPINDEX 0 0) - i) - (void (SendMessageW hwnd LVM_ENSUREVISIBLE i 0)) - (void (SendMessageW hwnd LVM_ENSUREVISIBLE (sub1 (min num (+ i c))) 0))))))) + (if (> (SendMessageW hwnd LVM_GETTOPINDEX 0 0) + i) + (void (SendMessageW hwnd LVM_ENSUREVISIBLE i 0)) + (void (SendMessageW hwnd LVM_ENSUREVISIBLE (sub1 (min num (+ i c))) 0)))))) (define/public (get-first-item) (SendMessageW hwnd (if single-column? LB_GETTOPINDEX LVM_GETTOPINDEX) 0 0)) diff --git a/gui-lib/mred/private/wx/win32/message.rkt b/gui-lib/mred/private/wx/win32/message.rkt index 0ed6e15cb..7928d6c7d 100644 --- a/gui-lib/mred/private/wx/win32/message.rkt +++ b/gui-lib/mred/private/wx/win32/message.rkt @@ -41,8 +41,10 @@ (init parent label x y style font) + (init-field color) (define bitmap? (label . is-a? . bitmap%)) + (define text-label? (string? label)) (define/public (get-class) "PLTSTATIC") @@ -93,4 +95,31 @@ (define/public (set-preferred-size) #f) (define/override (get-setimage-message) - STM_SETIMAGE))) + STM_SETIMAGE) + + (define/override (control-will-color hdc) + (cond + [(and text-label? color) + (define bg-color (GetPixel hdc 0 0)) + (define fg-color + (COLORREF-alpha-blend + (make-COLORREF + (send color red) + (send color green) + (send color blue)) + bg-color + (send color alpha))) + (SetBkColor hdc bg-color) + (SetTextColor hdc fg-color) + (cast (GetSysColorBrush COLOR_WINDOW) _HBRUSH _LRESULT)] + [else #f])) + + (define/override (set-label label) + (set! text-label? (string? label)) + (super set-label label)) + + (define/public (get-color) color) + (define/public (set-color c) + (when text-label? + (set! color c) + (InvalidateRect (get-hwnd) #f #f))))) diff --git a/gui-lib/mred/private/wx/win32/platform.rkt b/gui-lib/mred/private/wx/win32/platform.rkt index e1f1d0c7d..84ab2d838 100644 --- a/gui-lib/mred/private/wx/win32/platform.rkt +++ b/gui-lib/mred/private/wx/win32/platform.rkt @@ -24,7 +24,8 @@ "tab-panel.rkt" "window.rkt" "key.rkt" - "procs.rkt") + "procs.rkt" + (only-in "../common/default-procs.rkt" luminance)) (provide (protect-out platform-values)) (define (platform-values) @@ -97,4 +98,15 @@ check-for-break key-symbol-to-menu-key needs-grow-box-spacer? - graphical-system-type)) + graphical-system-type + white-on-black-panel-scheme? + tab-panel-available?)) + +(define (white-on-black-panel-scheme?) + ;; if the background and foreground are the same + ;; color, probably something has gone wrong; + ;; in that case we want to return #f. + (< (luminance (get-label-background-color)) + (luminance (get-label-foreground-color)))) + +(define (tab-panel-available?) #t) diff --git a/gui-lib/mred/private/wx/win32/slider.rkt b/gui-lib/mred/private/wx/win32/slider.rkt index 9e10b6aed..ef1a87562 100644 --- a/gui-lib/mred/private/wx/win32/slider.rkt +++ b/gui-lib/mred/private/wx/win32/slider.rkt @@ -43,7 +43,10 @@ auto-size) (define callback cb) - (define vertical? (memq 'vertical style)) + (define vertical? (or (memq 'vertical style) + (memq 'upward style))) + (define up? (memq 'upward style)) + (define upward-hi (and up? hi)) (define panel-hwnd (if (memq 'plain style) @@ -127,7 +130,7 @@ (SendMessageW slider-hwnd TBM_SETRANGEMIN 1 lo) (SendMessageW slider-hwnd TBM_SETRANGEMAX 1 hi) - (set-value val) + (set-value (if up? (- hi val) val)) (define/override (set-size x y w h) (super set-size x y w h) @@ -165,4 +168,7 @@ (SetWindowTextW value-hwnd (format "~s" val))) (define/public (get-value) - (SendMessageW slider-hwnd TBM_GETPOS 0 0))) + (define v (SendMessageW slider-hwnd TBM_GETPOS 0 0)) + (if up? + (- upward-hi v) + v))) diff --git a/gui-lib/mred/private/wx/win32/tab-panel.rkt b/gui-lib/mred/private/wx/win32/tab-panel.rkt index 6c3458222..ce9651850 100644 --- a/gui-lib/mred/private/wx/win32/tab-panel.rkt +++ b/gui-lib/mred/private/wx/win32/tab-panel.rkt @@ -15,6 +15,15 @@ (provide (protect-out tab-panel%)) +;; Implementing drag-and-drop reorderable tabs and close buttons with +;; the native widget probably means working at a fairly low level, +;; manually drawing things and handling button events. One possibility +;; is to do something like this: +;; http://www.suodenjoki.dk/us/productions/articles/dragdroptab.htm +;; A better possibility is to not try to use the native widget drawing at +;; all, and just implement tabs from scratch with a drawing canvas, at +;; least in 'no-border mode. + (define TCIF_TEXT #x0001) (define TCM_SETUNICODEFORMAT #x2005) (define TCM_FIRST #x1300) @@ -27,6 +36,14 @@ (define TCM_DELETEALLITEMS (+ TCM_FIRST 9)) (define TCM_GETCURFOCUS (+ TCM_FIRST 47)) (define TCM_SETCURFOCUS (+ TCM_FIRST 48)) +(define TCM_SETEXTENDEDSTYLE (+ TCM_FIRST 52)) +(define TCM_GETEXTENDEDSTYLE (+ TCM_FIRST 53)) + +(define TCS_EX_FLATSEPARATORS #x1) +(define TCS_EX_REGISTERDROP #x2) + +(define TCS_FLATBUTTONS #x0008) +(define TCS_BUTTONS #x0100) (define-cstruct _TCITEMW ([mask _UINT] @@ -180,6 +197,9 @@ (SendMessageW hwnd TCM_GETCURFOCUS 0 0) (SendMessageW hwnd TCM_SETCURFOCUS i 0))) + (define/public (on-choice-reorder mapping) (void)) + (define/public (on-choice-close which) (void)) + (define/public (set-callback cb) (set! callback cb)))) diff --git a/gui-lib/mred/private/wx/win32/utils.rkt b/gui-lib/mred/private/wx/win32/utils.rkt index 0b176eaf5..e3f70f57d 100644 --- a/gui-lib/mred/private/wx/win32/utils.rkt +++ b/gui-lib/mred/private/wx/win32/utils.rkt @@ -25,7 +25,8 @@ GetWindowLongPtrW SetWindowLongPtrW SendMessageW SendMessageW/str SendMessageW/ptr - GetSysColor GetRValue GetGValue GetBValue make-COLORREF + GetSysColor GetRValue GetGValue GetBValue make-COLORREF COLORREF-alpha-blend + GetSysColorBrush CreateBitmap CreateCompatibleBitmap DeleteObject @@ -46,7 +47,10 @@ RemoveMenu SelectObject WideCharToMultiByte - GetDeviceCaps + SetTextColor + GetBkColor SetBkColor + GetPixel + GetDeviceCaps strip-& ->screen ->screen* @@ -83,8 +87,7 @@ (GetLastError))) (define is-win64? - (equal? "win32\\x86_64" - (path->string (system-library-subpath #f)))) + (eqv? 64 (system-type 'word))) (define GetWindowLongPtrW (get-ffi-obj (if is-win64? 'GetWindowLongPtrW 'GetWindowLongW) user32-lib @@ -100,6 +103,7 @@ #:c-id SendMessageW) (define-user32 GetSysColor (_wfun _int -> _DWORD)) +(define-user32 GetSysColorBrush (_wfun _int -> _HBRUSH)) (define (GetRValue v) (bitwise-and v #xFF)) (define (GetGValue v) (bitwise-and (arithmetic-shift v -8) #xFF)) @@ -108,6 +112,20 @@ r (arithmetic-shift g 8) (arithmetic-shift b 16))) +(define (COLORREF-alpha-blend fg bg fg-alpha) + (cond + [(= fg-alpha 1.0) fg] + [else + (define bg-alpha (- 1.0 fg-alpha)) + (make-COLORREF + (clamp-color-val (+ (* (GetRValue fg) fg-alpha) + (* (GetRValue bg) bg-alpha))) + (clamp-color-val (+ (* (GetGValue fg) fg-alpha) + (* (GetGValue bg) bg-alpha))) + (clamp-color-val (+ (* (GetBValue fg) fg-alpha) + (* (GetBValue bg) bg-alpha))))])) +(define (clamp-color-val v) + (modulo (inexact->exact (truncate v)) 256)) (define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> (r : _BOOL) -> (unless r (failed 'MoveWindow)))) @@ -203,3 +221,8 @@ (if (exact? x) (floor (/ (* x 96) screen-dpi)) (/ (* x 96) screen-dpi))))) + +(define-gdi32 SetTextColor (_wfun _HDC _COLORREF -> _COLORREF)) +(define-gdi32 GetBkColor (_wfun _HDC -> _COLORREF)) +(define-gdi32 SetBkColor (_wfun _HDC _COLORREF -> _COLORREF)) +(define-gdi32 GetPixel (_wfun _HDC _int _int -> _COLORREF)) diff --git a/gui-lib/mred/private/wx/win32/window.rkt b/gui-lib/mred/private/wx/win32/window.rkt index 81ad2ff1e..264bc69e2 100644 --- a/gui-lib/mred/private/wx/win32/window.rkt +++ b/gui-lib/mred/private/wx/win32/window.rkt @@ -4,6 +4,7 @@ racket/class racket/draw racket/draw/unsafe/bstr + file/resource "../../syntax.rkt" "../common/freeze.rkt" "../common/queue.rkt" @@ -78,6 +79,9 @@ (define-user32 SetCursorPos (_wfun _int _int -> _BOOL)) +(define-kernel32 GetTickCount (_wfun -> _UDWORD)) +(define-user32 GetMessageTime (_wfun -> _UDWORD)) + (define-cstruct _NMHDR ([hwndFrom _HWND] [idFrom _pointer] @@ -135,6 +139,15 @@ -> (unless r (failed 'TrackMouseEvent)))) (define-user32 GetCursorPos (_wfun _POINT-pointer -> _BOOL)) +(define wheel-scale + (or (let ([s (get-resource "HKEY_CURRENT_USER" "Control Panel\\Desktop\\WheelScrollLines")]) + (and s + (let ([n (string->number s)]) + ;; A -1 value means "one screen per scroll" (and we don't try to do that, so far) + (and (exact-positive-integer? n) + n)))) + 3)) + (defclass window% object% (init-field parent hwnd) (init style @@ -246,11 +259,18 @@ [(= msg WM_INPUTLANGCHANGE) (reset-key-mapping) 0] + [(= msg WM_CTLCOLORSTATIC) + (define control-hwnd (cast lParam _LPARAM _HWND)) + (define maybe-wx (any-hwnd->wx control-hwnd)) + (cond + [(and maybe-wx (send maybe-wx control-will-color (cast wParam _WPARAM _HDC))) => values] + [else (default w msg wParam lParam)])] [else (default w msg wParam lParam)]))) (define/public (is-command? cmd) #f) (define/public (control-scrolled) #f) + (define/public (control-will-color hdc) #f) (define/public (do-command cmd control-hwnd) (void)) @@ -560,38 +580,39 @@ (define/public (set-wheel-steps-mode mode) (set! wheel-steps-mode mode)) (define/private (gen-wheels w msg lParam amt down up) + (define wheel-delta (round (/ WHEEL_DELTA wheel-scale))) (let loop ([amt amt]) (cond - [((abs amt) . < . WHEEL_DELTA) + [((abs amt) . < . wheel-delta) (case wheel-steps-mode [(one integer) amt] [(fraction) (unless (zero? amt) - (do-key w msg down lParam #f #f void (/ amt (exact->inexact WHEEL_DELTA)))) + (do-key w msg down lParam #f #f void (/ amt (exact->inexact wheel-delta)))) 0.0])] [(negative? amt) (case wheel-steps-mode [(one) (do-key w msg down lParam #f #f void 1.0) - (loop (+ amt WHEEL_DELTA))] + (loop (+ amt wheel-delta))] [(integer) - (define steps (quotient (- amt) WHEEL_DELTA)) + (define steps (quotient (- amt) wheel-delta)) (do-key w msg down lParam #f #f void (exact->inexact steps)) - (loop (+ amt (* steps WHEEL_DELTA)))] + (loop (+ amt (* steps wheel-delta)))] [else - (do-key w msg down lParam #f #f void (/ (- amt) (exact->inexact WHEEL_DELTA))) + (do-key w msg down lParam #f #f void (/ (- amt) (exact->inexact wheel-delta))) 0.0])] [else (case wheel-steps-mode [(one) (do-key w msg up lParam #f #f void 1.0) - (loop (- amt WHEEL_DELTA))] + (loop (- amt wheel-delta))] [(integer) - (define steps (quotient amt WHEEL_DELTA)) + (define steps (quotient amt wheel-delta)) (do-key w msg up lParam #f #f void (exact->inexact steps)) - (loop (- amt (* steps WHEEL_DELTA)))] + (loop (- amt (* steps wheel-delta)))] [else - (do-key w msg up lParam #f #f void (/ amt (exact->inexact WHEEL_DELTA))) + (do-key w msg up lParam #f #f void (/ amt (exact->inexact wheel-delta))) 0.0])]))) (define/private (do-key w msg wParam lParam is-char? is-up? default wheel-steps) @@ -704,7 +725,7 @@ [control-down (bit? flags MK_CONTROL)] [meta-down #f] [alt-down #f] - [time-stamp 0] + [time-stamp (get-event-time-stamp)] [caps-down #f]))]) (if (eq? type 'leave) (let ([t (get-top-frame)]) diff --git a/gui-lib/mred/private/wx/win32/wndclass.rkt b/gui-lib/mred/private/wx/win32/wndclass.rkt index 19201b466..458c4917a 100644 --- a/gui-lib/mred/private/wx/win32/wndclass.rkt +++ b/gui-lib/mred/private/wx/win32/wndclass.rkt @@ -2,6 +2,7 @@ (require ffi/unsafe ffi/unsafe/alloc racket/class + racket/draw "../../lock.rkt" "../common/utils.rkt" "utils.rkt" @@ -13,6 +14,7 @@ (protect-out hInstance DefWindowProcW background-hbrush + background-hbrush-color set-hwnd-wx! hwnd->wx hwnd->ctlproc @@ -28,7 +30,7 @@ ;; ---------------------------------------- ;; We use the "user data" field of an HWND to ;; store a weak pointer back to the Racket object. -;; The weak pointer must be wrapped in an immuable cell. +;; The weak pointer must be wrapped in an immutable cell. ;; In addition, if we need to save a control's old ;; ctlproc, we put it in the same immutable cell. @@ -144,7 +146,8 @@ (SetWindowLongPtrW hwnd GWLP_WNDPROC control_proc))) -(define _DialogProc (_wfun _HWND _UINT _WPARAM _LPARAM -> _INT_PTR)) +(define _DialogProc (_wfun #:atomic? #t #:keep (box null) + _HWND _UINT _WPARAM _LPARAM -> _INT_PTR)) (define (dlgproc w msg wParam lParam) (if (= msg WM_DESTROY) @@ -244,6 +247,9 @@ (define background-hbrush (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))]) (cpointer-push-tag! p 'HBRUSH) p)) +(define background-hbrush-color + (let ([c (GetSysColor COLOR_BTNFACE)]) + (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) (define-kernel32 GetModuleFileNameW (_wfun #:save-errno 'windows _pointer _pointer _DWORD -> _DWORD)) (define ERROR_INSUFFICIENT_BUFFER 122) diff --git a/gui-lib/mred/private/wxcanvas.rkt b/gui-lib/mred/private/wxcanvas.rkt index 1bdd2db08..1683f4c49 100644 --- a/gui-lib/mred/private/wxcanvas.rkt +++ b/gui-lib/mred/private/wxcanvas.rkt @@ -81,8 +81,10 @@ (init parent x y w h style gl-config) (inherit get-top-level) (public* - [clear-margins (lambda () (void))]) + [clear-margins (lambda () (void))] + [initialize-size (lambda () (void))]) (super-make-object style parent x y w h (cons 'deleted style) "canvas" gl-config) + (initialize-size) (unless (memq 'deleted style) (send (get-top-level) show-control this #t))))) @@ -203,7 +205,7 @@ [set-y-margin (lambda (m) (super set-y-margin m) (when fixed-height? (update-size)))]) - + (super-make-object style parent x y w h (or name "") (cons 'deleted style) spp init-buffer) (unless (memq 'deleted style) (send (get-top-level) show-control this #t)) diff --git a/gui-lib/mred/private/wxitem.rkt b/gui-lib/mred/private/wxitem.rkt index 7eae727af..bbd24ed9f 100644 --- a/gui-lib/mred/private/wxitem.rkt +++ b/gui-lib/mred/private/wxitem.rkt @@ -246,7 +246,6 @@ (super-make-object mred proxy style parent cb label x y w h (cons 'deleted style) font))) (define wx-message% (class (make-window-glue% (make-simple-control% wx:message%)) - (init mred proxy parent label x y style font) + (init mred proxy parent label x y style font [color #f]) (override* [gets-focus? (lambda () #f)]) - (super-make-object mred proxy style parent label x y (cons 'deleted style) font)))) - + (super-make-object mred proxy style parent label x y (cons 'deleted style) font color)))) diff --git a/gui-lib/mred/private/wxlitem.rkt b/gui-lib/mred/private/wxlitem.rkt index 78077b7ba..e17083a2f 100644 --- a/gui-lib/mred/private/wxlitem.rkt +++ b/gui-lib/mred/private/wxlitem.rkt @@ -397,17 +397,19 @@ (define c (make-object wx-internal-slider% mred proxy (get-p) func label value min-val max-val (filter-style style) font)) - - (set-c c - (memq 'horizontal style) - (memq 'vertical style)) - + + (let ([vert? (or (memq 'vertical style) + (memq 'upward style))]) + (set-c c + (not vert?) + vert?) + (let ([h? (not vert?)]) + (stretchable-in-x h?) + (stretchable-in-y (not h?)))) + (bounce c (get-value) - (set-value v)) - (let ([h? (and (memq 'horizontal style) #t)]) - (stretchable-in-x h?) - (stretchable-in-y (not h?))))) - + (set-value v)))) + ) diff --git a/gui-lib/mred/private/wxme/editor-canvas.rkt b/gui-lib/mred/private/wxme/editor-canvas.rkt index e7ff44491..13c93d922 100644 --- a/gui-lib/mred/private/wxme/editor-canvas.rkt +++ b/gui-lib/mred/private/wxme/editor-canvas.rkt @@ -350,12 +350,12 @@ (define-syntax-rule (using-admin body ...) (let ([oldadmin (send media get-admin)]) - (unless (eq? admin oldadmin) + (unless (object-or-false=? admin oldadmin) (send media set-admin admin)) (begin0 (begin body ...) (when media - (unless (eq? admin oldadmin) + (unless (object-or-false=? admin oldadmin) ;; FIXME: how do we know that this adminstrator ;; still wants the editor? (send media set-admin oldadmin)))))) @@ -1104,7 +1104,7 @@ (define/public (get-editor) media) (define/public (set-editor m [update? #t]) - (unless (eq? media m) + (unless (object-or-false=? media m) (when media (when (object/bool=? admin (send media get-admin)) (send media set-admin @@ -1220,6 +1220,7 @@ (send canvas get-dc-and-offset fx fy)])) (define/override (get-view fx fy fh fw [full? #f]) + (define A-VERY-BIG-NUMBER 1e50) (cond [(not canvas) (when fx (set-box! fx 0)) @@ -1230,8 +1231,8 @@ (and m (send m get-printing))) (when fx (set-box! fx 0)) (when fy (set-box! fy 0)) - (when fh (set-box! fh 10000)) - (when fw (set-box! fw 10000))] + (when fh (set-box! fh A-VERY-BIG-NUMBER)) + (when fw (set-box! fw A-VERY-BIG-NUMBER))] [else (send canvas get-view fx fy fh fw full?)])) @@ -1344,7 +1345,8 @@ (let-boxes ([dx 0.0] [dy 0.0]) (send canvas get-dc-and-offset dx dy) - (send canvas popup-menu m (->long (- x dx)) (->long (- y dy))))))))) + (send canvas popup-menu m (->long (- x dx)) (->long (- y dy))) + #t)))))) (define/public (adjust-std-flag) ;; 1 indicates that this is the sole, main admin. diff --git a/gui-lib/mred/private/wxme/editor-snip.rkt b/gui-lib/mred/private/wxme/editor-snip.rkt index d29442be9..855f6ce06 100644 --- a/gui-lib/mred/private/wxme/editor-snip.rkt +++ b/gui-lib/mred/private/wxme/editor-snip.rkt @@ -99,7 +99,7 @@ (def/override (set-admin [(make-or-false snip-admin%) a]) - (when (not (eq? a s-admin)) + (unless (object-or-false=? a s-admin) (super set-admin a) (when editor (if a @@ -125,7 +125,7 @@ (void)) (def/public (set-editor [editor<%> b]) - (unless (eq? editor b) + (unless (object-or-false=? editor b) (when (and editor s-admin) (send editor set-admin #f)) (set! editor b) diff --git a/gui-lib/mred/private/wxme/editor.rkt b/gui-lib/mred/private/wxme/editor.rkt index 395edbadb..f4c8e1f24 100644 --- a/gui-lib/mred/private/wxme/editor.rkt +++ b/gui-lib/mred/private/wxme/editor.rkt @@ -294,7 +294,7 @@ #t) (def/public (do-set-caret-owner [(make-or-false snip%) snip] [symbol? dist]) - (let ([same? (eq? snip s-caret-snip)]) + (let ([same? (object-or-false=? snip s-caret-snip)]) (if (and same? (or (not s-admin) (eq? dist 'immediate))) #f @@ -610,7 +610,7 @@ [new-list (read-styles-from-file s-style-list f overwritestylename? list-id)]) (and new-list (begin - (unless (eq? new-list s-style-list) + (unless (object=? new-list s-style-list) (set-style-list new-list)) (let-boxes ([num-headers 0]) (send f get-fixed num-headers) @@ -1232,7 +1232,7 @@ (define/public (do-own-x-selection on? force?) (if on? (if (and (not force?) - (not (eq? editor-x-selection-allowed this))) + (not (object-or-false=? editor-x-selection-allowed this))) #f (begin (when editor-x-selection-owner @@ -1243,7 +1243,7 @@ (set! editor-x-selection-owner this) #t)) (begin - (when (eq? this editor-x-selection-owner) + (when (object-or-false=? this editor-x-selection-owner) (set! editor-x-selection-owner #f) (when (and (not x-selection-copied?) (send the-x-selection-clipboard same-clipboard-client? @@ -1252,7 +1252,7 @@ #t))) (define/public (copy-out-x-selection) - (when (eq? this editor-x-selection-owner) + (when (object-or-false=? this editor-x-selection-owner) (copy-into-selection) (set! x-selection-copied? #t))) @@ -1472,7 +1472,7 @@ (reverse snip-list) (let loop ([snip start-snip]) (if (and snip - (not (eq? snip end-snip))) + (not (object-or-false=? snip end-snip))) (cons snip (loop (snip->next snip))) null)))]) diff --git a/gui-lib/mred/private/wxme/keymap.rkt b/gui-lib/mred/private/wxme/keymap.rkt index deafa9d5e..380d7dcd2 100644 --- a/gui-lib/mred/private/wxme/keymap.rkt +++ b/gui-lib/mred/private/wxme/keymap.rkt @@ -760,12 +760,12 @@ (define/public (cycle-check km) (ormap (lambda (c) - (or (eq? km c) + (or (object=? km c) (send c cycle-check km))) chain-to)) (def/public (chain-to-keymap [keymap% km] [any? prefix?]) - (unless (or (eq? km this) + (unless (or (object=? km this) (cycle-check km) (send km cycle-check this)) (set! chain-to (if prefix? diff --git a/gui-lib/mred/private/wxme/mline.rkt b/gui-lib/mred/private/wxme/mline.rkt index a1f72a4db..0e1e62e47 100644 --- a/gui-lib/mred/private/wxme/mline.rkt +++ b/gui-lib/mred/private/wxme/mline.rkt @@ -28,11 +28,13 @@ delete find-line find-position + find-grapheme-position find-scroll find-location find-paragraph get-line get-position + get-grapheme-position get-scroll get-location get-paragraph @@ -85,13 +87,13 @@ flags paragraph ;; relative values: - line pos scroll parno y + line pos grapheme-pos scroll parno y max-width snip last-snip scroll-snip - len numscrolls + len grapheme-len numscrolls last-h last-w ;; height/width of last snip in line h w ;; height/width of line bottombase topbase ;; bottom baseline, top baseline (relative) @@ -103,10 +105,10 @@ (define (create-mline) (make-mline #f #f NIL NIL NIL (bitwise-ior BLACK MAX-W-HERE CALC-HERE) #f - 0 0 0 0 0.0 + 0 0 0 0 0 0.0 0.0 #f #f #f - 0 1 + 0 0 1 0.0 0.0 0.0 0.0 0.0 0.0)) @@ -118,6 +120,7 @@ (define (mline-destroy! m) ;; Doesn't need to to anything, but this may be helpful for debugging + #; (begin (set-mline-prev! m 'BAD) (set-mline-parent! m 'BAD) @@ -127,6 +130,7 @@ (set-mline-paragraph! m 'BAD) (set-mline-line! m 'BAD) (set-mline-pos! m 'BAD) + (set-mline-grapheme-pos! m 'BAD) (set-mline-scroll! m 'BAD) (set-mline-parno! m 'BAD) (set-mline-y! m 'BAD) @@ -135,6 +139,7 @@ (set-mline-last-snip! m 'BAD) (set-mline-scroll-snip! m 'BAD) (set-mline-len! m 'BAD) + (set-mline-grapheme-len! m 'BAD) (set-mline-numscrolls! m 'BAD) (set-mline-last-h! m 'BAD) (set-mline-last-w! m 'BAD) @@ -197,6 +202,7 @@ ;; Adjust relative values: (set-mline-line! newchild (- (mline-line newchild) (+ (mline-line mline) 1))) (set-mline-pos! newchild (- (mline-pos newchild) (+ (mline-pos mline) (mline-len mline)))) + (set-mline-grapheme-pos! newchild (- (mline-grapheme-pos newchild) (+ (mline-grapheme-pos mline) (mline-grapheme-len mline)))) (set-mline-scroll! newchild (- (mline-scroll newchild) (+ (mline-scroll mline) (mline-numscrolls mline)))) (set-mline-y! newchild (- (mline-y newchild) (+ (mline-y mline) (mline-h mline)))) (set-mline-parno! newchild (- (mline-parno newchild) (+ (mline-parno mline) (starts-paragraph mline)))))) @@ -206,6 +212,7 @@ ;; Adjust relative values: (set-mline-line! oldchild (+ (mline-line oldchild) (+ (mline-line mline) 1))) (set-mline-pos! oldchild (+ (mline-pos oldchild) (+ (mline-pos mline) (mline-len mline)))) + (set-mline-grapheme-pos! oldchild (+ (mline-grapheme-pos oldchild) (+ (mline-grapheme-pos mline) (mline-grapheme-len mline)))) (set-mline-scroll! oldchild (+ (mline-scroll oldchild) (+ (mline-scroll mline) (mline-numscrolls mline)))) (set-mline-y! oldchild (+ (mline-y oldchild) (+ (mline-y mline) (mline-h mline)))) (set-mline-parno! oldchild (+ (mline-parno oldchild) (+ (mline-parno mline) (starts-paragraph mline)))))) @@ -375,6 +382,7 @@ ;; adjust ancestor offsets (let ([len (mline-len mline)] + [grapheme-len (mline-grapheme-len mline)] [numscrolls (mline-numscrolls mline)] [h (mline-h mline)]) (let loop ([v mline]) @@ -385,6 +393,7 @@ (let ([v parent]) (set-mline-line! v (- (mline-line v) 1)) (set-mline-pos! v (- (mline-pos v) len)) + (set-mline-grapheme-pos! v (- (mline-grapheme-pos v) grapheme-len)) (set-mline-scroll! v (- (mline-scroll v) numscrolls)) (set-mline-y! v (- (mline-y v) h)) (set-mline-parno! v (- (mline-parno v) (starts-paragraph mline))) @@ -402,6 +411,7 @@ (let ([x parent]) (set-mline-line! x (- (mline-line x) 1)) (set-mline-pos! x (- (mline-pos x) (mline-len v))) + (set-mline-grapheme-pos! x (- (mline-grapheme-pos x) (mline-grapheme-len v))) (set-mline-scroll! x (- (mline-scroll x) (mline-numscrolls v))) (set-mline-y! x (- (mline-y x) (mline-h v))) (set-mline-parno! x (- (mline-parno x) (starts-paragraph v))) @@ -437,6 +447,7 @@ (set-mline-line! v (mline-line mline)) (set-mline-pos! v (mline-pos mline)) + (set-mline-grapheme-pos! v (mline-grapheme-pos mline)) (set-mline-scroll! v (mline-scroll mline)) (set-mline-y! v (mline-y mline)) (set-mline-parno! v (mline-parno mline)) @@ -551,6 +562,9 @@ (define (find-position mline pos) (search mline pos mline-pos mline-len)) +(define (find-grapheme-position mline pos) + (search mline pos mline-grapheme-pos mline-grapheme-len)) + (define (find-scroll mline scroll) (search mline scroll mline-scroll mline-numscrolls)) @@ -577,6 +591,9 @@ (define (get-position mline) (sum mline mline-pos mline-len)) +(define (get-grapheme-position mline) + (sum mline mline-grapheme-pos mline-grapheme-len)) + (define (get-scroll mline) (sum mline mline-scroll mline-numscrolls)) @@ -601,13 +618,19 @@ ;; ---------------------------------------- -(define (adjust mline new-val val-sel val-mut! sel mut!) +(define (adjust mline new-val val-sel val-mut! new-val2 val-sel2 val-mut2! sel mut! sel2 mut2!) (define delta (- new-val (val-sel mline))) + (define delta2 (if new-val2 (- new-val2 (val-sel2 mline)) 0)) (define val-changed? (cond - [(= (val-sel mline) new-val) #f] + [(and (= (val-sel mline) new-val) + (or (not val-sel2) + (= (val-sel2 mline) new-val2))) + #f] [else (val-mut! mline new-val) + (when new-val2 + (val-mut2! mline new-val2)) #t])) (or (let loop ([node mline]) (let ([parent (mline-parent node)]) @@ -616,29 +639,38 @@ [else (if (eq? node (mline-left parent)) (cond - [(= delta 0) + [(and (= delta 0) + (= delta2 0)) (loop parent)] [else (mut! parent (+ delta (sel parent))) + (when sel2 + (mut2! parent (+ delta2 (sel2 parent)))) (loop parent) #t]) (loop parent))]))) val-changed?)) -(define (set-length mline len) +(define (set-length mline len grapheme-len) (adjust mline - len mline-len set-mline-len! - mline-pos set-mline-pos!)) + len mline-len set-mline-len! + grapheme-len mline-grapheme-len set-mline-grapheme-len! + mline-pos set-mline-pos! + mline-grapheme-pos set-mline-grapheme-pos!)) (define (set-scroll-length mline numscrolls) (adjust mline numscrolls mline-numscrolls set-mline-numscrolls! - mline-scroll set-mline-scroll!)) + #f #f #f + mline-scroll set-mline-scroll! + #f #f)) (define (set-height mline h) (adjust mline h mline-h set-mline-h! - mline-y set-mline-y!)) + #f #f #f + mline-y set-mline-y! + #f #f)) (define (set-paragraph-ends mline) (let ([next (mline-next mline)]) @@ -663,24 +695,25 @@ (set-starts-paragraph mline #f)]))) (define (calc-line-length mline) - (let ([l - (let ([nexts (snip->next (mline-last-snip mline))]) - (let loop ([asnip (mline-snip mline)][l 0]) - (if (eq? asnip nexts) - l - (let ([l (+ l (snip->count asnip))]) - (when (has-flag? (snip->flags asnip) WIDTH-DEPENDS-ON-X) - (send asnip size-cache-invalid)) - (loop (snip->next asnip) l)))))]) - - (when (not (= l (mline-len mline))) - (set-length mline l))) + (define-values (l gl) + (let ([nexts (snip->next (mline-last-snip mline))]) + (let loop ([asnip (mline-snip mline)] [l 0] [gl 0]) + (if (eq? asnip nexts) + (values l gl) + (let ([l (+ l (snip->count asnip))] + [gl (+ gl (snip->grapheme-count asnip))]) + (when (has-flag? (snip->flags asnip) WIDTH-DEPENDS-ON-X) + (send asnip size-cache-invalid)) + (loop (snip->next asnip) l gl)))))) + (when (or (not (= l (mline-len mline))) + (not (= gl (mline-grapheme-len mline)))) + (set-length mline l gl)) (set-paragraph-ends mline)) -;; A scalable variant of `calc-line-lengt`, but doesn't +;; A scalable variant of `calc-line-length`, but doesn't ;; check WIDTH-DEPENDS-ON-X flags: -(define (adjust-line-length mline delta) - (set-length mline (+ (mline-len mline) delta)) +(define (adjust-line-length mline delta grapheme-delta) + (set-length mline (+ (mline-len mline) delta) (+ (mline-grapheme-len mline) grapheme-delta)) (set-paragraph-ends mline)) (define (set-starts-paragraph mline starts?) diff --git a/gui-lib/mred/private/wxme/standard-snip-admin.rkt b/gui-lib/mred/private/wxme/standard-snip-admin.rkt index d6b410b30..cf31d4e8f 100644 --- a/gui-lib/mred/private/wxme/standard-snip-admin.rkt +++ b/gui-lib/mred/private/wxme/standard-snip-admin.rkt @@ -65,28 +65,28 @@ [nonnegative-real? w] [nonnegative-real? h] [any? [refresh? #t]] [(symbol-in start end none) [bias 'none]]) - (and (eq? (send s get-admin) this) + (and (object-or-false=? (send s get-admin) this) (send editor scroll-to s localx localy w h refresh? bias))) (def/override (set-caret-owner [snip% s] [(symbol-in imeditorte display global) dist]) - (when (eq? (send s get-admin) this) + (when (object-or-false=? (send s get-admin) this) (send editor set-caret-owner s dist))) (def/override (resized [snip% s] [any? redraw?]) - (when (eq? (send s get-admin) this) + (when (object-or-false=? (send s get-admin) this) (send editor resized s redraw?))) (def/override (recounted [snip% s] [any? redraw?]) - (when (eq? (send s get-admin) this) + (when (object-or-false=? (send s get-admin) this) (send editor recounted s redraw?))) (def/override (needs-update [snip% s] [real? localx] [real? localy] [nonnegative-real? w] [nonnegative-real? h]) - (when (eq? (send s get-admin) this) + (when (object-or-false=? (send s get-admin) this) (send editor needs-update s localx localy w h))) (def/override (release-snip [snip% s]) - (and (eq? (send s get-admin) this) + (and (object-or-false=? (send s get-admin) this) (send editor release-snip s))) (def/override (update-cursor) @@ -105,7 +105,7 @@ (send admin popup-menu m (+ x sl) (+ y st))))))) (def/override (modified [snip% s] [any? modified?]) - (when (eq? (send s get-admin) this) + (when (object-or-false=? (send s get-admin) this) (send editor on-snip-modified s modified?))) (def/override (get-line-spacing) diff --git a/gui-lib/mred/private/wxme/stream.rkt b/gui-lib/mred/private/wxme/stream.rkt index 911fd4f94..518e90a4c 100644 --- a/gui-lib/mred/private/wxme/stream.rkt +++ b/gui-lib/mred/private/wxme/stream.rkt @@ -4,6 +4,7 @@ "private.rkt" racket/snip/private/private racket/snip/private/snip + racket/format "editor-data.rkt" "version.rkt" (only-in "cycle.rkt" @@ -49,7 +50,7 @@ (define/public (do-reading-version sclass) (or (ormap (lambda (scl) - (and (eq? (snip-class-link-c scl) sclass) + (and (object-or-false=? (snip-class-link-c scl) sclass) (snip-class-link-reading-version scl))) sl) ;; Class didn't show up in the header? @@ -59,26 +60,26 @@ (define/public (do-map-position sclass-or-dclass) (if (sclass-or-dclass . is-a? . snip-class%) (or (ormap (lambda (scl) - (and (eq? (snip-class-link-c scl) sclass-or-dclass) + (and (object=? (snip-class-link-c scl) sclass-or-dclass) (snip-class-link-map-position scl))) sl) -1) (or (ormap (lambda (dcl) - (and (eq? (editor-data-class-link-c dcl) sclass-or-dclass) + (and (object=? (editor-data-class-link-c dcl) sclass-or-dclass) (editor-data-class-link-map-position dcl))) dl) -1))) (define/public (do-get-header-flag sclass) (or (ormap (lambda (scl) - (and (eq? (snip-class-link-c scl) sclass) + (and (object=? (snip-class-link-c scl) sclass) (snip-class-link-header-flag scl))) sl) 0)) (define/public (do-set-header-flag sclass) (ormap (lambda (scl) - (and (eq? (snip-class-link-c scl) sclass) + (and (object=? (snip-class-link-c scl) sclass) (begin (set-snip-class-link-header-flag! scl #t) #t))) @@ -369,46 +370,69 @@ [(<= (char->integer #\0) c (char->integer #\9)) (loop (+ (* (or n 0) 10) (- c (char->integer #\0))))] [else (fail)]))])) - (let loop ([accum null] - [left-to-get orig-len] - [first-char-to-consider first-char-post-id]) - (when (or is-bad? (negative? left-to-get)) (fail)) - (cond - [(= first-char-to-consider (char->integer #\))) - ;; got all of the byte strings - (unless (zero? left-to-get) (fail)) - (inc-item-count) - (define the-bytes (apply bytes-append (reverse accum))) - (when id (hash-set! previously-read-bytes id the-bytes)) - the-bytes] - [(= first-char-to-consider (char->integer #\#)) - ;; another byte string still to get - (unless (equal? (send f read-byte) (char->integer #\")) - (fail)) - (define v (get-single-line-bytes (min left-to-get 16) #t)) - (when is-bad? (fail)) - (unless ((bytes-length v) . <= . left-to-get) (fail)) - (loop (cons v accum) - (- left-to-get (bytes-length v)) - (do-skip-whitespace))] - [else (fail)]))] - [(member first-byte (map char->integer (string->list "0123456789"))) + (cond + [(= first-char-post-id (char->integer #\#)) + ;; this is for an older format where the bytes were chopped up + ;; into multiple lines with bytes-encoded bytes on each line + (let loop ([accum null] + [left-to-get orig-len] + [first-char-to-consider first-char-post-id]) + (when (or is-bad? (negative? left-to-get)) (fail)) + (cond + [(= first-char-to-consider (char->integer #\))) + ;; got all of the byte strings + (unless (zero? left-to-get) (fail)) + (inc-item-count) + (define the-bytes (apply bytes-append (reverse accum))) + (when id (hash-set! previously-read-bytes id the-bytes)) + the-bytes] + [(= first-char-to-consider (char->integer #\#)) + ;; another byte string still to get + (unless (equal? (send f read-byte) (char->integer #\")) + (fail)) + (define v (get-single-line-bytes (min left-to-get 16) #t)) + (when is-bad? (fail)) + (unless ((bytes-length v) . <= . left-to-get) (fail)) + (loop (cons v accum) + (- left-to-get (bytes-length v)) + (do-skip-whitespace))] + [else (fail)]))] + [(<= (char->integer #\0) first-char-post-id (char->integer #\9)) + (define size (fetch-number first-char-post-id fail)) + (define the-bytes (make-bytes size)) + (define amt-read (send f read-bytes the-bytes 0 size)) + (unless (= size amt-read) + (fail)) + (unless (equal? (send f read-byte) (char->integer #\newline)) + (fail)) + (unless (equal? (send f read-byte) (char->integer #\))) + (fail)) + (inc-item-count) + (when id (hash-set! previously-read-bytes id the-bytes)) + the-bytes] + [else (fail)])] + [(<= (char->integer #\0) first-byte (char->integer #\9)) ;; read an id and use it to find a previously read byte string - (define id - (let loop ([n (- first-byte (char->integer #\0))]) - (define b (send f read-byte)) - (cond - [(not b) n] - [(char-whitespace? (integer->char b)) - n] - [(<= (char->integer #\0) b (char->integer #\9)) - (loop (+ (* n 10) (- b (char->integer #\0))))] - [else (fail)]))) + (define id (fetch-number first-byte fail)) (inc-item-count) (hash-ref previously-read-bytes id (λ () (fail)))] [else (fail)]))) + ;; reads a natural number from `f` where `first-byte` is + ;; expected to be the first digit; also consumes one character + ;; after the number, which must be whitespace + (define/private (fetch-number first-byte fail) + (let loop ([n (- first-byte (char->integer #\0))]) + (define b (send f read-byte)) + (cond + [(not b) n] + [(char-whitespace? (integer->char b)) + n] + [(<= (char->integer #\0) b (char->integer #\9)) + (loop (+ (* n 10) (- b (char->integer #\0))))] + [else (fail)]))) + (define/private (get-single-line-bytes orig-len extra-whitespace-ok?) (define (fail) (set! is-bad? #t) @@ -656,7 +680,8 @@ (send f tell) (let ([pos (send f tell)]) (when (not (equal? (hash-ref pos-map items pos) pos)) - (error "again")) + (error 'tell + "internal error: underlying editor-stream-in-base% changed in an unexpected way")) (hash-set! pos-map items pos) items))) @@ -742,8 +767,9 @@ (do-put-bytes s)) (define/private (do-put-bytes orig-s) + (define orig-s-len (bytes-length orig-s)) (define (single-string) - (if ((bytes-length orig-s) . < . 72) + (if (orig-s-len . < . 72) (let ([s (open-output-bytes)]) (write orig-s s) (let* ([v (get-output-bytes s)] @@ -767,28 +793,50 @@ (hash-set! previously-written-bytes orig-s id) (send f write-bytes #"\n(") (send f write-bytes (string->bytes/utf-8 (number->string id))) - (let loop ([offset 0][remain (bytes-length orig-s)]) - (unless (zero? remain) - (let lloop ([amt (min 50 remain)][retry? #t]) - (let ([s (open-output-bytes)]) - (write (subbytes orig-s offset (+ offset amt)) s) - (let* ([v (get-output-bytes s #t)] - [len (bytes-length v)]) - (if (len . <= . 71) - (if (and (len . < . 71) - retry? - (amt . < . remain)) - (lloop (add1 amt) #t) - (begin - (send f write-bytes #"\n ") - (send f write-bytes v) - (loop (+ offset amt) (- remain amt)))) - (lloop (quotient amt 2) #f))))))) - (send f write-bytes #"\n)") + + (when #t + (send f write-bytes #" ") + (send f write-bytes (string->bytes/utf-8 (number->string (bytes-length orig-s)))) + (send f write-bytes #"\n") + (send f write-bytes orig-s) + (send f write-bytes #"\n)")) + + (when #f + ;; this code produces a less efficient writing (and one + ;; that is hard to read in efficiently) as compared to the + ;; `(when #t ..)` above. but wxme format files used this, + ;; so code in the reader reads data in this format + (define scratch-bytes (make-bytes 75 (char->integer #\space))) + (define scratch-len (bytes-length scratch-bytes)) + (define scratch-prefix #"\n #\"") + (define scratch-starting-point (bytes-length scratch-prefix)) + (bytes-copy! scratch-bytes 0 scratch-prefix) + (define (flush-out-pending-bytes scratch-offset) + (bytes-set! scratch-bytes scratch-offset (char->integer #\")) + (send f write-bytes (subbytes scratch-bytes 0 (+ scratch-offset 1)))) + + (let loop ([orig-s-offset 0] + [scratch-offset scratch-starting-point]) + (cond + [(< orig-s-offset orig-s-len) + (define the-bytes (vector-ref encoded-bytes (bytes-ref orig-s orig-s-offset))) + (define len (bytes-length the-bytes)) + (cond + [(< (+ scratch-offset len) (- scratch-len 1)) + (bytes-copy! scratch-bytes scratch-offset the-bytes) + (loop (+ orig-s-offset 1) (+ scratch-offset len))] + [else + (flush-out-pending-bytes scratch-offset) + (loop orig-s-offset scratch-starting-point)])] + [else + (unless (= scratch-offset scratch-starting-point) + (flush-out-pending-bytes scratch-offset))])) + (send f write-bytes #"\n)")) + (set! col 1)])) (check-ok) - (do-put-number (bytes-length orig-s)) + (do-put-number orig-s-len) (single-string) (set! items (add1 items)) this) @@ -842,4 +890,39 @@ (show #" http://racket-lang.org/\n|#\n") (set! col 0))) +(define encoded-bytes + (for/vector ([i (in-range 256)]) + (define c (integer->char i)) + (cond + + ;; whitespace chars + [(equal? c #\backspace) #"\\b"] + [(equal? c #\tab) #"\\t"] + [(equal? c #\newline) #"\\n"] + [(equal? c #\space) #" "] + [(equal? c #\vtab) #"\\v"] + [(equal? c #\page) #"\\f"] + [(equal? c #\return) #"\\r"] + + ;; bell + [(= i 7) #"\\a"] + + ;; escape + [(= i 27) #"\\e"] + + ;; chars where the `char-graphic?` case will produce the wrong answer + [(equal? c #\\) #"\\\\"] + [(equal? c #\") #"\\\""] + + ;; a bunch of special cases that'll take less space + [(and (< i 128) ;; is ascii + (char-graphic? c)) + (string->bytes/utf-8 + (format "~a" c))] + + ;; the default case, use hex printing + [else + (string->bytes/utf-8 + (~a "\\x" (~r i #:base (list 'up 16) #:min-width 2 #:pad-string "0")))]))) + (set-editor-stream-out%! editor-stream-out%) diff --git a/gui-lib/mred/private/wxme/text.rkt b/gui-lib/mred/private/wxme/text.rkt index db7072ab1..c9d7c9039 100644 --- a/gui-lib/mred/private/wxme/text.rkt +++ b/gui-lib/mred/private/wxme/text.rkt @@ -23,7 +23,9 @@ editor-snip%) "wordbreak.rkt" "stream.rkt" - "wx.rkt") + "wx.rkt" + racket/draw/private/region + racket/snip/private/grapheme) (provide text% add-text-keymap-functions @@ -85,9 +87,8 @@ 'solid)])) (define outline-pen (send the-pen-list find-or-create-pen "BLACK" 0 'transparent)) -(define outline-inactive-pen (send the-pen-list find-or-create-pen (get-highlight-background-color) 1 'solid)) -(define outline-brush (send the-brush-list find-or-create-brush (get-highlight-background-color) 'solid)) -(define outline-nonowner-brush outline-brush) +(define (outline-inactive-pen) (send the-pen-list find-or-create-pen (get-highlight-background-color) 1 'solid)) +(define (outline-brush) (send the-brush-list find-or-create-brush (get-highlight-background-color) 'solid)) (define clear-brush (send the-brush-list find-or-create-brush "WHITE" 'solid)) (define (showcaret>= a b) @@ -288,7 +289,7 @@ (let loop ([line first-line] [snip snips] [snip-num 0]) - (unless (eq? snips (mline-snip first-line)) + (unless (object-or-false=? snips (mline-snip first-line)) (error who "bad start snip")) (let sloop ([snip snip][snip-num snip-num]) (when (zero? (snip->count snip)) @@ -296,13 +297,13 @@ (error who "snip count is 0 at ~s" snip-num))) (unless (eq? line (snip->line snip)) (error who "snip's line is wrong: ~s ~s" snip (snip->line snip))) - (if (eq? snip (mline-last-snip line)) + (if (object-or-false=? snip (mline-last-snip line)) (if (mline-next line) (begin (unless (has-flag? (snip->flags snip) NEWLINE) (error who "strange line ending")) (loop (mline-next line) (snip->next snip) (add1 snip-num))) - (unless (eq? last-snip snip) + (unless (object-or-false=? last-snip snip) (error who "bad last snip"))) (begin (when (or (has-flag? (snip->flags snip) NEWLINE) @@ -515,7 +516,7 @@ (when (send event button-down?) (set-caret-owner snip)) (when (and prev-mouse-snip - (not (eq? snip prev-mouse-snip))) + (not (object-or-false=? snip prev-mouse-snip))) (let-boxes ([x 0.0] [y 0.0]) (get-snip-position-and-location prev-mouse-snip #f x y) (send prev-mouse-snip on-goodbye-event dc (- x scrollx) (- y scrolly) x y event))) @@ -913,10 +914,10 @@ editor-x-selection-mode? (or (and (not (eq? 'local seltype)) (not (= start end )) - (not (eq? editor-x-selection-owner this)) + (not (object-or-false=? editor-x-selection-owner this)) (eq? (own-x-selection #t #f seltype) 'x)) (and (or (= start end) - (not (eq? editor-x-selection-allowed this)) + (not (object-or-false=? editor-x-selection-allowed this)) (eq? 'local seltype)) (eq? editor-x-selection-owner this) (own-x-selection #f #f #f))))]) @@ -1104,7 +1105,9 @@ start)] [(eq? 'line kind) (line-start-position (position-line start posateol?))] - [else (max 0 (sub1 start))]))]) + [else + (grapheme-position + (max 0 (sub1 (position-grapheme start))))]))]) (let-values ([(start end) (if extend? (if leftshrink? @@ -1132,7 +1135,9 @@ end)] [(eq? 'line kind) (line-end-position (position-line end posateol?))] - [else (add1 end)]))]) + [else + (grapheme-position + (add1 (position-grapheme end)))]))]) (let-values ([(start end) (if extend? (if rightshrink? @@ -1229,7 +1234,7 @@ (let* ([newtop (find-scroll-line (+ vy scroll-height))] [y (scroll-line-location (+ newtop 1))] [newtop (if (y . > . (+ vy scroll-height)) - (sub1 newtop) + (max 0 (sub1 newtop)) newtop)] [y (scroll-line-location newtop)]) ;; y is the new top location @@ -1312,7 +1317,7 @@ ;; ---------------------------------------- - (define/private (do-insert isnip str snipsl start end scroll-ok?) + (define/private (do-insert isnip str snipsl start end scroll-ok? force-keep-caret?) (assert (consistent-snip-lines 'do-insert)) (unless (or write-locked? s-user-locked? @@ -1321,8 +1326,9 @@ [str (and str (positive? (string-length str)) str)]) ;; turn off pending style, if it doesn't apply (when caret-style - (when (or (not (equal? end start)) (not (= startpos start))) - (set! caret-style #f))) + (unless force-keep-caret? + (when (or (not (or (eq? end 'same) (equal? end start))) (not (= startpos start))) + (set! caret-style #f)))) (let ([deleted? (and (not (eq? end 'same)) (start . < . end) (begin @@ -1507,14 +1513,14 @@ [line (mline-insert gline line-root-box #t)]) (set-snip-line! isnip line) (set! num-valid-lines (add1 num-valid-lines)) - (if (eq? gsnip (mline-snip gline)) + (if (object-or-false=? gsnip (mline-snip gline)) (set-mline-snip! line isnip) (set-mline-snip! line (mline-snip gline))) (set-mline-last-snip! line isnip) (set-mline-snip! gline gsnip) (let loop ([c-snip (mline-snip line)]) - (unless (eq? c-snip isnip) + (unless (object-or-false=? c-snip isnip) (set-snip-line! c-snip line) (loop (snip->next c-snip)))) @@ -1523,7 +1529,7 @@ #t) (let ([gline (snip->line gsnip)]) (set-snip-line! isnip gline) - (when (eq? (mline-snip gline) gsnip) + (when (object=? (mline-snip gline) gsnip) (set-mline-snip! gline isnip)) #f))))]) @@ -1590,11 +1596,11 @@ (values #f 0))]) (let-values ([(snip s-pos) (if (or (not gsnip) - (and caret-style (not (eq? caret-style (snip->style gsnip)))) + (and caret-style (not (object-or-false=? caret-style (snip->style gsnip)))) (not (has-flag? (snip->flags gsnip) IS-TEXT)) ((+ (snip->count gsnip) addlen) . > . MAX-COUNT-FOR-SNIP) (and (not sticky-styles?) - (not (eq? (snip->style gsnip) (get-default-style))))) + (not (object-or-false=? (snip->style gsnip) (get-default-style))))) (let ([style (or caret-style (if sticky-styles? @@ -1617,7 +1623,7 @@ (if (and gsnip (has-flag? (snip->flags gsnip) HARD-NEWLINE) - (eq? (snip->next gsnip) snip)) + (object-or-false=? (snip->next gsnip) snip)) ;; preceding snip was a newline, so the new slip belongs on the next line: (let* ([oldline (snip->line gsnip)] [inserted-new-line? @@ -1663,14 +1669,19 @@ (let loop ([pos (- start s)] [snip snip] [size (+ addlen s)]) (cond [(size . > . MAX-COUNT-FOR-SNIP) - (define half (quotient size 2)) - - (define intm-snip - (split-one half snip #f)) - - (define-values (next-snip next-pos) - (loop pos intm-snip half)) - (loop next-pos next-snip (- size half))] + (define half (send snip grapheme-position + (send snip position-grapheme (quotient size 2)))) + (cond + [(< 0 half size) + (define intm-snip + (split-one half snip #f)) + + (define-values (next-snip next-pos) + (loop pos intm-snip half)) + (loop next-pos next-snip (- size half))] + [else + ;; split wouldn't make anything smaller, susprisingly, so give up + (values snip s)])] [else (define new-snip (split-one* size snip)) (values (snip->next new-snip) (+ pos size))])) @@ -1739,7 +1750,7 @@ HARD-NEWLINE) INVISIBLE) CAN-APPEND)) - (if (not (eq? snip (mline-last-snip (snip->line snip)))) + (if (not (object=? snip (mline-last-snip (snip->line snip)))) (let* ([old-line (snip->line snip)] [line (mline-insert old-line line-root-box #t)]) (set-snip-line! snip line) @@ -1748,24 +1759,26 @@ (set-mline-snip! line (mline-snip old-line)) ;; retarget snips moved to new line: - (define delta - (let loop ([c-snip (mline-snip old-line)] [delta 0]) + (define-values (delta grapheme-delta) + (let loop ([c-snip (mline-snip old-line)] [delta 0] [grapheme-delta 0]) (cond - [(eq? c-snip snip) - (+ delta (snip->count snip))] + [(object-or-false=? c-snip snip) + (values (+ delta (snip->count snip)) + (+ grapheme-delta (snip->grapheme-count snip)))] [else (set-snip-line! c-snip line) (loop (snip->next c-snip) - (+ delta (snip->count c-snip)))]))) + (+ delta (snip->count c-snip)) + (+ grapheme-delta (snip->grapheme-count c-snip)))]))) (set-mline-snip! old-line (snip->next snip)) - (mline-adjust-line-length old-line (- delta)) + (mline-adjust-line-length old-line (- delta) (- grapheme-delta)) (mline-mark-recalculate old-line) (when (max-width . > . 0) (mline-mark-check-flow old-line)) - (mline-adjust-line-length line delta) + (mline-adjust-line-length line delta grapheme-delta) (mline-mark-recalculate line) (when (max-width . > . 0) (mline-mark-check-flow line))) @@ -1789,7 +1802,7 @@ ts))]) (set-snip-style! tabsnip (snip->style snip)) (let* ([rsnip (snip-set-admin tabsnip snip-admin)] - [tabsnip (if (not (eq? rsnip tabsnip)) + [tabsnip (if (not (object-or-false=? rsnip tabsnip)) ;; uh-oh (let ([tabsnip (new tab-snip%)]) (set-snip-style! tabsnip (snip->style snip)) @@ -1808,9 +1821,9 @@ (splice-snip tabsnip (snip->prev snip) (snip->next snip)) (set-snip-line! tabsnip (snip->line snip)) - (when (eq? (mline-snip (snip->line snip)) snip) + (when (object=? (mline-snip (snip->line snip)) snip) (set-mline-snip! (snip->line tabsnip) tabsnip)) - (when (eq? (mline-last-snip (snip->line snip)) snip) + (when (object=? (mline-last-snip (snip->line snip)) snip) (set-mline-last-snip! (snip->line tabsnip) tabsnip)) tabsnip))))) @@ -1844,30 +1857,45 @@ (case-args args [([string? str]) - (do-insert #f str #f startpos endpos #t)] + (do-insert #f str #f startpos endpos #t #f)] [([string? str] [exact-nonnegative-integer? start] [(make-alts exact-nonnegative-integer? (symbol-in same)) [end 'same]] - [any? [scroll-ok? #t]]) - (do-insert #f str #f start end scroll-ok?)] + [any? [scroll-ok? #t]] + [any? [join-graphemes? #f]]) + (if join-graphemes? + (do-insert-graphemes str start end scroll-ok?) + (do-insert #f str #f start end scroll-ok? #f))] [([exact-nonnegative-integer? len] - [string? str]) + [string? str] + [any? [join-graphemes? #f]]) (check-len str len) - (do-insert #f (substring str 0 len) #f startpos endpos #t)] + (let ([str (if (= len (string-length str)) + str + (substring str 0 len))]) + (if join-graphemes? + (do-insert-graphemes str startpos endpos #t) + (do-insert #f str #f startpos endpos #t #f)))] [([exact-nonnegative-integer? len] [string? str] [exact-nonnegative-integer? start] [(make-alts exact-nonnegative-integer? (symbol-in same)) [end 'same]] - [any? [scroll-ok? #t]]) + [any? [scroll-ok? #t]] + [any? [join-graphemes? #f]]) (check-len str len) - (do-insert #f (substring str 0 len) #f start end scroll-ok?)] + (let ([str (if (= len (string-length str)) + str + (substring str 0 len))]) + (if join-graphemes? + (do-insert-graphemes str startpos endpos #t) + (do-insert #f str #f start end scroll-ok? #f)))] [([snip% snip]) - (do-insert snip #f #f startpos endpos #t)] + (do-insert snip #f #f startpos endpos #t #f)] [([snip% snip] [exact-nonnegative-integer? [start startpos]] [(make-alts exact-nonnegative-integer? (symbol-in same)) [end 'same]] [any? [scroll-ok? #t]]) - (do-insert snip #f #f start end scroll-ok?)] + (do-insert snip #f #f start end scroll-ok? #f)] [([char? ch]) (do-insert-char ch startpos endpos)] [([char? ch] @@ -1877,17 +1905,58 @@ (method-name 'text% 'insert))) (define/public (do-insert-snips snips pos) - (do-insert #f #f snips pos pos #t)) + (do-insert #f #f snips pos pos #t #f)) (define/private (do-insert-char ch start end) (let ([streak? typing-streak?] [ifs? insert-force-streak?]) (end-streaks '(delayed)) (set! insert-force-streak? streak?) - (do-insert #f (string ch) #f start end #t) + + (cond + [(char-iso-control? ch) + ;; shortcut for character that never joins, especially #\newline + (do-insert #f (string ch) #f start end #t #f)] + [else + (do-insert-graphemes (string ch) start end #t)]) + (set! insert-force-streak? ifs?) (set! typing-streak? #t))) + (define/private (do-insert-graphemes str start-in end-in scroll-ok?) + ;; maybe join characters to form a grapheme; we limit + ;; the search for a grapheme to one surrounding snip on + ;; the grounds that this makes sense when graphemes are + ;; already joined + (define start (max 0 (min start-in len))) + (define end (if (eq? end-in 'same) start (max start (min end-in len)))) + (define keep-caret? (and (= start startpos) + (or (eq? end 'same) (eqv? end start)))) + (let loop ([s str] [start start] [end end]) + (define pre-s (do-find-snip start 'before)) + (define pre-pos (get-snip-position pre-s)) + (define pre-count (snip->count pre-s)) + (define txt (send pre-s get-text 0 (- start pre-pos) #f)) + (cond + [(grapheme-spans? txt 0 (- start pre-pos) + s 0 (string-length s)) + (loop (string-append (string (string-ref txt (- start pre-pos 1))) s) + (sub1 start) + end)] + [else + (define post-s (do-find-snip end 'after)) + (define post-pos (get-snip-position post-s)) + (define post-count (snip->count post-s)) + (define txt (send post-s get-text 0 post-count #f)) + (cond + [(grapheme-spans? s 0 (string-length s) + txt (- end post-pos) post-count) + (loop (string-append s (string (string-ref txt (- end post-pos)))) + start + (add1 end))] + [else + (do-insert #f s #f start end #t keep-caret?)])]))) + (define/private (do-delete start end with-undo? [scroll-ok? #t]) (assert (consistent-snip-lines 'do-delete)) (unless (or write-locked? s-user-locked?) @@ -1895,7 +1964,10 @@ (if (eq? end 'back) (if (zero? start) (values 0 0 #f) - (values (sub1 start) start #t)) + (values (grapheme-position + (sub1 (position-grapheme start))) + start + #t)) (values start end (and (= start startpos) (= end endpos))))]) (end-streaks '(delayed)) @@ -1946,15 +2018,17 @@ (let loop ([snip end-snip] [deleted-line? #f] [update-cursor? #f]) - (if (eq? snip start-snip) + (if (object-or-false=? snip start-snip) (values deleted-line? update-cursor?) (let ([update-cursor? - (or (and (eq? snip s-caret-snip) + (or (and (object-or-false=? snip s-caret-snip) (let ([rl? read-locked?]) (set! read-locked? #t) (send s-caret-snip own-caret #f) + (do-own-caret #t) (set! read-locked? rl?) (set! s-caret-snip #f) + (on-focus #t) #t)) update-cursor?)]) @@ -1965,8 +2039,8 @@ [deleted-another-line? (let ([line (snip->line snip)]) (cond - [(eq? (mline-snip line) snip) - (if (eq? (mline-last-snip line) snip) + [(object-or-false=? (mline-snip line) snip) + (if (object-or-false=? (mline-last-snip line) snip) (begin (mline-delete line line-root-box) (set! num-valid-lines (sub1 num-valid-lines)) @@ -1974,7 +2048,7 @@ (begin (set-mline-snip! line (snip->next snip)) #f))] - [(eq? (mline-last-snip line) snip) + [(object-or-false=? (mline-last-snip line) snip) (if (mline-next line) (begin (set-mline-last-snip! line (mline-last-snip (mline-next line))) @@ -2018,7 +2092,7 @@ ;; fix line references from possibly moved snips: (let ([next (snip->next (mline-last-snip line))]) (let loop ([snip (mline-snip line)]) - (unless (eq? snip next) + (unless (object-or-false=? snip next) (set-snip-line! snip line) (loop (snip->next snip))))) @@ -2183,7 +2257,7 @@ (set! flow-locked? #t) (let loop ([snip start]) - (unless (eq? snip end) + (unless (object-or-false=? snip end) (let ([asnip (send snip copy)]) (snip-set-admin asnip #f) (set-snip-style! asnip (send sl convert (snip->style asnip))) @@ -2533,7 +2607,7 @@ (let loop ([start start] [top top] [bottom bottom]) - (if (eq? end start) + (if (object-or-false=? end start) (and (y . >= . top) (y . <= . bottom) c) @@ -2749,21 +2823,29 @@ (error who "not a WXME file") (let* ([b (make-object editor-stream-in-file-base% f)] [mf (make-object editor-stream-in% b)]) - (or (and (not (read-editor-version mf b #f #t)) + (or (and (not (send mf ok?)) + 'mf-not-initially-ok) + (and (not (read-editor-version mf b #f #t)) 'read-editor-version-failed) + (and (not (send mf ok?)) + 'mf-not-ok-after-editor-version) (and (not (read-editor-global-header mf)) 'read-editor-global-head-failed) (and (not (send mf ok?)) - 'mf-not-ok) + 'mf-not-ok-after-global-header) (and (not (read-from-file mf clear-styles?)) 'read-from-file-failed) + (and (not (send mf ok?)) + 'mf-not-okay-after-read-from-file) (and (not (read-editor-global-footer mf)) 'read-editor-gobal-footer-failed) + (and (not (send mf ok?)) + 'mf-not-okay-after-footer) (begin ;; if STD-STYLE wasn't loaded, re-create it: (send s-style-list new-named-style "Standard" (send s-style-list basic-style)) (and (not (send mf ok?)) - 'mf-not-okay-after-adding-standard-style)))))] + 'mf-not-okay-at-the-end)))))] [(or (eq? fmt 'text) (eq? fmt 'text-force-cr)) (let ([s (make-string 1024)]) (let loop ([saved-cr? #f]) @@ -2775,9 +2857,10 @@ [s2 (if (equal? #\return (string-ref s1 (sub1 len))) (substring s1 0 (sub1 len)) s1)]) - (insert (regexp-replace* #rx"\r\n" - (if saved-cr? (string-append "\r" s2) s2) - "\n")) + (let ([str (regexp-replace* #rx"\r\n" + (if saved-cr? (string-append "\r" s2) s2) + "\n")]) + (insert (string-length str) str #t)) (loop (not (eq? s1 s2)))))))) #f])]) @@ -2846,11 +2929,11 @@ (define/override (do-read-insert snip) (if (list? snip) (let ([oldlen len]) - (do-insert #f #f snip startpos startpos #t) + (do-insert #f #f snip startpos startpos #t #f) (set! read-insert (+ read-insert (- len oldlen))) #t) (let ([addpos (snip->count snip)]) - (do-insert snip #f #f startpos startpos #t) + (do-insert snip #f #f startpos startpos #t #f) (set! read-insert (+ addpos read-insert)) #t))) @@ -3003,7 +3086,7 @@ (when (and ateol?-box atsnipend? snip - (eq? snip (mline-last-snip line))) + (object-or-false=? snip (mline-last-snip line))) (set-box! ateol?-box #t)) p))))))])) @@ -3017,7 +3100,7 @@ (let loop ([snip snip] [p p]) (cond - [(eq? snip next-snip) + [(object-or-false=? snip next-snip) ;; if everything is invisible, then presumably the CR is forced, ;; so go to the beginning of the line anyway startp] @@ -3037,7 +3120,7 @@ (let ([p (if (has-flag? (snip->flags snip) INVISIBLE) (- p (snip->count snip)) p)]) - (if (eq? snip (mline-snip line)) + (if (object-or-false=? snip (mline-snip line)) (begin (set-box! p-box p) (when snip-box @@ -3082,26 +3165,27 @@ (- x)))) 0] [else - ;; binary search for position within snip: - (let loop ([range c] - [i (quotient c 2)] - [offset 0]) - (let ([dl (send snip partial-offset dc X Y (+ offset i))]) - (if (dl . > . x) - (loop i (quotient i 2) offset) - (let ([dr (send snip partial-offset dc X Y (+ offset i 1))]) - (if (dr . <= . x) - (let ([range (- range i)]) - (loop range (quotient range 2) (+ offset i))) - (begin - (when how-close - (set-box! how-close - (if ((- dr x) . < . (- x dl)) - (- dr x) - (- dl x)))) - (set! write-locked? wl?) - (set! flow-locked? fl?) - (+ i offset)))))))])))])) + ;; binary search for grapheme position within snip, returning character position: + (let ([c (snip->grapheme-count snip)]) + (let loop ([range c] + [i (quotient c 2)] + [offset 0]) + (let ([dl (send snip partial-offset dc X Y (send snip grapheme-position (+ offset i)))]) + (if (dl . > . x) + (loop i (quotient i 2) offset) + (let ([dr (send snip partial-offset dc X Y (send snip grapheme-position (+ offset i 1)))]) + (if (dr . <= . x) + (let ([range (- range i)]) + (loop range (quotient range 2) (+ offset i))) + (begin + (when how-close + (set-box! how-close + (if ((- dr x) . < . (- x dl)) + (- dr x) + (- dl x)))) + (set! write-locked? wl?) + (set! flow-locked? fl?) + (send snip grapheme-position (+ i offset)))))))))])))])) (def/public (find-line [real? y] [maybe-box? [onit? #f]]) (when onit? @@ -3160,6 +3244,30 @@ line)]) (mline-get-line line))])) + (def/public (position-grapheme [exact-nonnegative-integer? start] + [any? [eog? #f]]) + (cond + [(not (check-recalc (max-width . > . 0) #f #t)) 0] + [(start . <= . 0) 0] + [(start . >= . len) + (+ (mline-get-grapheme-position last-line) + (mline-grapheme-len last-line))] + [else + (let* ([line (mline-find-position (unbox line-root-box) start)]) + (let loop ([pos (mline-get-position line)] + [grapheme-pos (mline-get-grapheme-position line)] + [snip (mline-snip line)]) + (cond + [(= pos start) grapheme-pos] + [(not snip) grapheme-pos] + [else + (define c (snip->count snip)) + (cond + [(>= start (+ pos c)) + (loop (+ pos c) (+ grapheme-pos (snip->grapheme-count snip)) (snip->next snip))] + [else + (+ grapheme-pos (send snip position-grapheme (- start pos)))])])))])) + (def/public-final (get-snip-position-and-location [snip% thesnip] [maybe-box? pos] [maybe-box? [x #f]] [maybe-box? [y #f]]) @@ -3174,7 +3282,7 @@ [p (mline-get-position line)]) (let loop ([snip (mline-snip line)] [p p]) - (if (object=? snip thesnip) + (if (object-or-false=? snip thesnip) (begin (when pos (set-box! pos p)) @@ -3406,6 +3514,29 @@ [any? [visible-only? #t]]) (do-line-position #f i visible-only?)) + (def/public (grapheme-position [exact-nonnegative-integer? start] + [any? [eog? #f]]) + (cond + [(not (check-recalc (max-width . > . 0) #f #t)) 0] + [(start . <= . 0) 0] + [(start . >= . (+ (mline-get-grapheme-position last-line) + (mline-grapheme-len last-line))) + len] + [else + (let* ([line (mline-find-grapheme-position (unbox line-root-box) start)]) + (let loop ([pos (mline-get-position line)] + [grapheme-pos (mline-get-grapheme-position line)] + [snip (mline-snip line)]) + (cond + [(= grapheme-pos start) pos] + [(not snip) pos] + [else + (define c (snip->grapheme-count snip)) + (cond + [(>= start (+ grapheme-pos c)) + (loop (+ pos (snip->count snip)) (+ grapheme-pos c) (snip->next snip))] + [else + (+ pos (send snip grapheme-position (- start grapheme-pos)))])])))])) (def/public (line-length [exact-nonnegative-integer? i]) (cond @@ -3595,7 +3726,7 @@ [any? [bos? #t]] [any? [case-sens? #t]]) (if (check-recalc #f #f) - (do-find-string-all str direction start end #t bos? case-sens? #f) + (do-find-string-all str direction start end #t bos? case-sens? (λ (x) #f)) #f)) (def/public (find-string-all [string? str] @@ -3605,7 +3736,7 @@ [any? [bos? #t]] [any? [case-sens? #t]]) (if (check-recalc #f #f) - (do-find-string-all str direction start end #f bos? case-sens? #f) + (do-find-string-all str direction start end #f bos? case-sens? (λ (x) #f)) null)) (def/public (find-string-embedded [string? str] @@ -3613,9 +3744,10 @@ [(make-alts exact-nonnegative-integer? (symbol-in start)) [start 'start]] [(make-alts exact-nonnegative-integer? (symbol-in eof)) [end 'eof]] [any? [bos? #t]] - [any? [case-sens? #t]]) + [any? [case-sens? #t]] + #:recur-inside? [(make-procedure 1) [recur-inside? (λ (x) #t)]]) (if (check-recalc #f #f) - (do-find-string-all str direction start end #t bos? case-sens? #t) + (do-find-string-all str direction start end #t bos? case-sens? recur-inside?) #f)) (def/public (find-string-embedded-all [string? str] @@ -3623,9 +3755,10 @@ [(make-alts exact-nonnegative-integer? (symbol-in start)) [start 'start]] [(make-alts exact-nonnegative-integer? (symbol-in eof)) [end 'eof]] [any? [bos? #t]] - [any? [case-sens? #t]]) + [any? [case-sens? #t]] + #:recur-inside? [(make-procedure 1) [recur-inside? (λ (x) #t)]]) (if (check-recalc #f #f) - (do-find-string-all str direction start end #f bos? case-sens? #t) + (do-find-string-all str direction start end #f bos? case-sens? recur-inside?) null)) (def/public (find-newline [(symbol-in forward backward) [direction 'forward]] @@ -3719,15 +3852,15 @@ (cond [(not latest-snip) (define fst (find-first-snip)) - (values fst (and fst 0) (and fst (send fst get-count)))] + (values fst (and fst 0) (and fst (snip->count fst)))] [forward? - (define next (send latest-snip next)) + (define next (snip->next latest-snip)) (values next (and next (+ latest-snip-position latest-snip-len)) - (and next (send next get-count)))] + (and next (snip->count next)))] [else - (define prev (send latest-snip previous)) - (define pc (and prev (send prev get-count))) + (define prev (snip->prev latest-snip)) + (define pc (and prev (snip->count prev))) (values prev (and prev (- latest-snip-position pc)) pc)])) @@ -3743,7 +3876,7 @@ (set! latest-snip (find-snip i 'after-or-none b)) (when latest-snip (set! latest-snip-position (unbox b)) - (set! latest-snip-len (send latest-snip get-count)))]) + (set! latest-snip-len (snip->count latest-snip)))]) (when (or (not latest-snip-str) (< (string-length latest-snip-str) @@ -3754,8 +3887,8 @@ (for ([c (in-range latest-snip-len)]) (string-set! latest-snip-str c (char-downcase (string-ref latest-snip-str c))))) (cond - [(and recur-inside? - (is-a? latest-snip editor-snip%)) + [(and (is-a? latest-snip editor-snip%) + (recur-inside? latest-snip)) (let loop ([snip latest-snip]) (define ed (send snip get-editor)) (cond @@ -3771,17 +3904,18 @@ (define inner-result (let inner-loop ([inner-snip (send ed find-first-snip)]) (cond - [(is-a? inner-snip editor-snip%) + [(and (is-a? inner-snip editor-snip%) + (recur-inside? inner-snip)) (define this-one (loop inner-snip)) (if just-one? (or this-one - (inner-loop (send inner-snip next))) + (inner-loop (snip->next inner-snip))) (if this-one (cons this-one - (inner-loop (send inner-snip next))) - (inner-loop (send inner-snip next))))] + (inner-loop (snip->next inner-snip))) + (inner-loop (snip->next inner-snip))))] [(not inner-snip) (if just-one? #f '())] - [else (inner-loop (send inner-snip next))]))) + [else (inner-loop (snip->next inner-snip))]))) (and inner-result (pair? inner-result) (cons ed inner-result))]))] @@ -3907,16 +4041,16 @@ [prev-style-pos start] [p start] [gsnip start-snip]) - (if (not (eq? gsnip end-snip)) + (if (not (object-or-false=? gsnip end-snip)) ;; Change a snip style: (let* ([style (snip->style gsnip)] [style2 (or new-style (send s-style-list find-or-create-style style delta))]) - (if (not (eq? style style2)) + (if (not (object-or-false=? style style2)) (begin (set-snip-style! gsnip style2) (let-values ([(prev-style prev-style-pos) - (if (and rec (not (eq? prev-style style))) + (if (and rec (not (object-or-false=? prev-style style))) (begin (when prev-style (send rec add-style-change prev-style-pos p prev-style)) @@ -4062,7 +4196,7 @@ (let loop ([snip snips]) (when snip - (when (eq? style (snip->style snip)) + (when (object=? style (snip->style snip)) (send snip size-cache-invalid) (let ([line (snip->line snip)]) (mline-mark-recalculate line) @@ -4271,14 +4405,14 @@ (set! last-snip snip))) (define/private (insert-snip before snip) - (if (and (eq? snips last-snip) (zero? (snip->count snips))) + (if (and (object-or-false=? snips last-snip) (zero? (snip->count snips))) (append-snip snip) (begin (splice-snip snip (snip->prev before) before) (set! snip-count (add1 snip-count))))) (define/private (append-snip snip) - (if (and (eq? snips last-snip) (zero? (snip->count snips))) + (if (and (object-or-false=? snips last-snip) (zero? (snip->count snips))) ;; get rid of empty snip (begin (set! snips snip) @@ -4288,7 +4422,7 @@ (set! snip-count (add1 snip-count))))) (define/private (delete-snip snip) - (when (eq? snip prev-mouse-snip) + (when (object-or-false=? snip prev-mouse-snip) (set! prev-mouse-snip #f)) (cond [(snip->next snip) @@ -4339,9 +4473,9 @@ (set-snip-line! naya line) (when line - (when (eq? (mline-snip line) snip) + (when (object=? (mline-snip line) snip) (set-mline-snip! line naya)) - (when (eq? (mline-last-snip line) snip) + (when (object=? (mline-last-snip line) snip) (set-mline-last-snip! line naya))) (send snip set-s-admin #f) @@ -4426,8 +4560,8 @@ [prev (snip->prev snip)] [next (snip->next snip)] [style (snip->style snip)]) - (let ([at-start? (eq? (mline-snip line) snip)] - [at-end? (eq? (mline-last-snip line) snip)] + (let ([at-start? (object=? (mline-snip line) snip)] + [at-end? (object=? (mline-last-snip line) snip)] [orig snip]) (let-boxes ([ins-snip #f] [snip #f]) @@ -4481,7 +4615,7 @@ (send s-style-list basic-style))]) (set-snip-style! snip style) (let ([snip (let ([rsnip (snip-set-admin snip snip-admin)]) - (if (not (eq? snip rsnip)) + (if (not (object-or-false=? snip rsnip)) ;; uh-oh; resort to string-snip%: (let ([snip (new string-snip%)]) (set-snip-style! snip style) @@ -4509,14 +4643,14 @@ [(not gsnip) (append-snip snip) (set-snip-line! snip last-line) - (when (eq? (mline-last-snip last-line) last-snip) + (when (object-or-false=? (mline-last-snip last-line) last-snip) (set! last-snip snip)) (set-mline-last-snip! last-line snip) snip] [(= s-pos start) (insert-snip gsnip snip) (set-snip-line! snip (snip->line gsnip)) - (when (eq? (mline-snip (snip->line snip)) gsnip) + (when (object-or-false=? (mline-snip (snip->line snip)) gsnip) (set-mline-snip! (snip->line snip) snip)) snip] [else @@ -4530,11 +4664,11 @@ (when (let loop ([did-something? #f]) (let-values ([(snip1 s-pos1) (find-snip/pos start 'before)] [(snip2 s-pos2) (find-snip/pos start 'after)]) - (if (eq? snip1 snip2) + (if (object-or-false=? snip1 snip2) did-something? (if (not (and (snip->snipclass snip1) - (eq? (snip->snipclass snip1) (snip->snipclass snip2)) - (eq? (snip->style snip1) (snip->style snip2)))) + (object-or-false=? (snip->snipclass snip1) (snip->snipclass snip2)) + (object-or-false=? (snip->style snip1) (snip->style snip2)))) did-something? (if (not (and (not (has-flag? (snip->flags snip1) NEWLINE)) @@ -4545,13 +4679,13 @@ did-something? (cond [(zero? (snip->count snip1)) - (when (eq? (mline-snip (snip->line snip1)) snip1) + (when (object=? (mline-snip (snip->line snip1)) snip1) (set-mline-snip! (snip->line snip1) snip2)) (delete-snip snip1) (set-snip-flags! snip1 (remove-flag (snip->flags snip1) OWNED)) (loop #t)] [(zero? (snip->count snip2)) - (when (eq? (mline-last-snip (snip->line snip2)) snip2) + (when (object=? (mline-last-snip (snip->line snip2)) snip2) (set-mline-last-snip! (snip->line snip2) snip1) (mline-mark-recalculate (snip->line snip1)) ; need last-w updated (set! graphic-maybe-invalid? #t)) @@ -4563,8 +4697,8 @@ [prev (snip->prev snip1)] [next (snip->next snip2)] [line (snip->line snip1)]) - (let ([at-start? (eq? (mline-snip line) snip1)] - [at-end? (eq? (mline-last-snip line) snip2)] + (let ([at-start? (object=? (mline-snip line) snip1)] + [at-end? (object=? (mline-last-snip line) snip2)] [wl? write-locked?] [fl? flow-locked?]) (set! read-locked? #t) @@ -4700,7 +4834,7 @@ (def/public (find-next-non-string-snip [(make-or-false snip%) snip]) (if (or (and snip - (not (eq? (snip->admin snip) snip-admin))) + (not (object=? (snip->admin snip) snip-admin))) (zero? len)) #f (let loop ([snip (if snip @@ -4935,14 +5069,14 @@ (loop (mline-next line))))) (let ([-changed? - (if (max-width . > . 0) - (let ([wl? write-locked?] - [fl? flow-locked?]) - ;; if any flow is updated, snip sizing methods will be called - (set! write-locked? #t) - (set! flow-locked? #t) - - (let ([w (- max-width padding-l padding-t CURSOR-WIDTH)]) + (let ([w (- max-width padding-l padding-t CURSOR-WIDTH)]) + (if (w . > . 0) + (let ([wl? write-locked?] + [fl? flow-locked?]) + ;; if any flow is updated, snip sizing methods will be called + (set! write-locked? #t) + (set! flow-locked? #t) + (let loop ([-changed? #f]) (if (begin0 (mline-update-flow (unbox line-root-box) line-root-box this w dc @@ -4963,8 +5097,8 @@ (begin (set! flow-locked? fl?) (set! write-locked? wl?) - -changed?))))) - #f)]) + -changed?)))) + #f))]) (when (not (= max-width old-max-width)) (set! max-width old-max-width)) @@ -5334,16 +5468,38 @@ [fg (make-object color% (send dc get-text-foreground))] [bg (make-object color% (send dc get-text-background))] [bgmode (send dc get-text-mode)] - [rgn (send dc get-clipping-region)]) - - (send dc set-clipping-rect (- left x) (- top y) width height) + [rgn (send dc get-clipping-region)] + [extra (if (integer? (send dc get-backing-scale)) + 0 + ;; For a non-integer backing scale, the use of `->long` + ;; doesn't actually align to pixels. We don't change + ;; the alignment here, because the convention of aligning + ;; to integer *editor* coordinates has been wired in + ;; deeply, historically. Instead, we just extend the drawing + ;; area to compensate for different rounding that could + ;; otherwise leave update/clipping artifacts. + 1)]) + (cond + [rgn + (define new-rgn (new region% [dc dc])) + (send new-rgn set-rectangle + (- left x extra) (- top y extra) + (+ width (* 2 extra)) (+ height (* 2 extra))) + (send new-rgn intersect rgn) + (send dc set-clipping-region new-rgn)] + [else + (send dc set-clipping-rect + (- left x extra) (- top y extra) + (+ width (* 2 extra)) (+ height (* 2 extra)))]) (send dc suspend-flush) (dynamic-wind void (lambda () - (do-redraw dc top bottom left right (- y) (- x) show-caret show-xsel? bg-color + (do-redraw dc (- top extra) (+ bottom (* 2 extra)) + (- left extra) (+ right 98 2 extra) + (- y) (- x) show-caret show-xsel? bg-color (and (not bg-color) fg))) (lambda () (send dc set-clipping-region rgn) @@ -5461,7 +5617,7 @@ [hsys 0.0] [hsye 0.0] [old-style old-style]) - (if (eq? snip last) + (if (object-or-false=? snip last) (values hilite-some? hsxs hsxe hsys hsye old-style) (begin (send (snip->style snip) switch-to dc old-style) @@ -5488,7 +5644,7 @@ dx dy (if (pair? show-caret) (cons p (+ p (snip->count snip))) - (if (eq? snip s-caret-snip) + (if (object-or-false=? snip s-caret-snip) show-caret (if (and maybe-hilite? (-endpos . > . p) @@ -5519,7 +5675,7 @@ (and (= -endpos -startpos) pos-at-eol?) (and (not (= -endpos -startpos)) (-startpos . < . (+ p (snip->count snip)))))) - (or (not (eq? snip first)) + (or (not (object-or-false=? snip first)) ;; beginning of line: (or (not (= p -endpos)) (and (= -endpos -startpos) (not pos-at-eol?)) @@ -5582,7 +5738,7 @@ (if show-outline-for-inactive? (let ([first-hilite? (-startpos . >= . pcounter)] [last-hilite? (-endpos . <= . (+ pcounter (mline-len line)))]) - (send dc set-pen outline-inactive-pen) + (send dc set-pen (outline-inactive-pen)) (let ([prevwasfirst (cond [first-hilite? @@ -5603,13 +5759,13 @@ prevwasfirst) (let ([save-brush (send dc get-brush)]) (send dc set-pen outline-pen) - (send dc set-brush outline-brush) + (send dc set-brush (outline-brush)) (send dc draw-rectangle (+ hsxs dx) (+ hsys dy) (max 0.0 (- hsxe hsxs)) (max 0.0 (- hsye hsys))) (when ALLOW-X-STYLE-SELECTION? (when show-xsel? - (send dc set-brush outline-nonowner-brush) + (send dc set-brush (outline-brush)) (send dc draw-rectangle (+ hsxs dx) (+ hsys dy) (max 0.0 (- hsxe hsxs)) (max 0.0 (- hsye hsys))))) (send dc set-brush save-brush) diff --git a/gui-lib/mred/private/wxme/version.rkt b/gui-lib/mred/private/wxme/version.rkt index 1e88579b8..7a1f8adfd 100644 --- a/gui-lib/mred/private/wxme/version.rkt +++ b/gui-lib/mred/private/wxme/version.rkt @@ -7,5 +7,5 @@ (define MRED-READER-STR #"#reader(lib\"read.ss\"\"wxme\")") (define MRED-START-STR #"WXME") (define MRED-FORMAT-STR #"01") -(define MRED-VERSION-STR #"09") -(define MRED-VERSION-RX #rx"^0[1-9]$") +(define MRED-VERSION-STR #"11") +(define MRED-VERSION-RX #rx"^(?:0[1-9])|(?:1[0-1])$") diff --git a/gui-lib/mred/private/wxpanel.rkt b/gui-lib/mred/private/wxpanel.rkt index 71aa9c41f..37f7c07e2 100644 --- a/gui-lib/mred/private/wxpanel.rkt +++ b/gui-lib/mred/private/wxpanel.rkt @@ -7,6 +7,7 @@ "helper.rkt" "check.rkt" "wx.rkt" + "wxcanvas.rkt" "wxwindow.rkt" "wxitem.rkt" "wxcontainer.rkt") @@ -23,7 +24,8 @@ wx-grow-box-pane% wx-canvas-panel% wx-vertical-canvas-panel% - wx-horizontal-canvas-panel%)) + wx-horizontal-canvas-panel% + do-on-choice-reorder)) (define wx:windowless-panel% (class object% @@ -327,7 +329,17 @@ (child-info-x-min (car kid-info))))) (lambda (y-accum kid-info first?) (max y-accum (+ (* 2 (border)) - (child-info-y-min (car kid-info)))))))]) + (child-info-y-min (car kid-info)))))))] + + ;; request that all children that are canvases refresh their content + [request-refresh-all-canvas-children + (λ () + (for ([child (in-list children)]) + (cond + [(is-a? child wx-basic-panel<%>) + (send child request-refresh-all-canvas-children)] + [(is-a? child wx-canvas%) + (send child queue-paint)])))]) (override* [force-redraw @@ -598,6 +610,9 @@ [on-active (lambda () (for-each (lambda (c) (send c queue-active)) (get-children)))] + [on-superwindow-activate + (λ (on?) + (for-each (lambda (c) (send c queue-superwindow-activate on?)) (get-children)))] [get-window (lambda () (send (get-parent) get-window))] [set-size (lambda (x y w h) @@ -621,7 +636,11 @@ [on-active (lambda () (for-each (lambda (c) (send c queue-active)) (get-children)) - (super-on-active))]) + (super-on-active))] + [on-superwindow-activate + (λ (on?) + (for-each (lambda (c) (send c queue-superwindow-activate on?)) (get-children)) + (super on-superwindow-activate on?))]) (apply super-make-object args))) (define (wx-make-linear-panel% wx-panel%) @@ -853,14 +872,22 @@ ;; "horizontal" and "vertical." (define (wx-make-vertical-panel% wx-linear-panel%) (wx-make-horizontal/vertical-panel% wx-linear-panel% #f)) + (define-local-member-name do-on-choice-reorder) + (define (wx-make-tab% %) (class % - (inherit gets-focus?) + (inherit gets-focus? get-mred) (super-new) (define/override (tabbing-position x y w h) ;; claim that the panel is short and starts above its client area: (list this x (- y 16) w 16)) - (define/override (focus-on-self?) (gets-focus?)))) + (define/override (focus-on-self?) (gets-focus?)) + (define/override (on-choice-reorder new-positions) + (let ([mred (get-mred)]) + (when mred (send mred do-on-choice-reorder new-positions)))) + (define/override (on-choice-close pos) + (let ([mred (get-mred)]) + (when mred (send mred on-close-request pos)))))) (define wx-panel% (wx-make-panel% wx:panel%)) (define wx-control-panel% (wx-make-panel% wx:panel% const-default-x-margin const-default-y-margin)) diff --git a/gui-lib/mred/private/wxtabcanvas.rkt b/gui-lib/mred/private/wxtabcanvas.rkt new file mode 100644 index 000000000..7290a1f78 --- /dev/null +++ b/gui-lib/mred/private/wxtabcanvas.rkt @@ -0,0 +1,992 @@ +#lang racket/base +(require racket/class + racket/draw + racket/match + "wx.rkt" + "gdi.rkt" + "wx/common/event.rkt" + "wx/common/queue.rkt" + "wxcanvas.rkt" + (prefix-in compute: "panel-wob.rkt") + "misc.rkt") + +(provide wx-tab-canvas%) + +(module+ test (require rackunit)) + +(define wx-tab-canvas% + (class* wx-canvas% (wx/client-adjacent<%>) + (init choices) + (init-field style font on-close-request on-new-request on-reorder) + (init-rest init-args) + (apply super-make-object init-args) + + (define callback void) + (define/public (set-callback proc) (set! callback proc)) + + (define/private (can-reorder?) (member 'can-reorder style)) + (define/private (can-close?) (member 'can-close style)) + (define/private (has-new-button?) (member 'new-button style)) + + ;; ---------------------------------------- + + (define sibling-client #f) + (define/public (get-sibling-client) sibling-client) + (define/public (set-sibling-client c) (set! sibling-client c)) + + (inherit refresh + get-dc + [do-get-client-size get-client-size] + set-min-width set-min-height stretchable-in-y) + + (define/private (get-client-size) + (define x (box 0)) + (define y (box 0)) + (do-get-client-size x y) + (values (unbox x) (unbox y))) + + ;; ---------- + ;; internal state variables + + ;; (or/c #f (integer-in 0 (hash-count items))) + ;; the currently selected tab + (define selection #f) + (define/private (set-the-selection s) + (unless (equal? selection s) + (set! selection s) + (refresh))) + + ;; hash[natural -o> string] + ;; indicates the strings on each of the tab items + (define items (for/hash ([i (in-naturals)] + [s (in-list choices)]) + (values i s))) + + (define/private (number-of-items) (hash-count items)) + (define/private (get-item i) (hash-ref items i)) + (define/private (set-item i v) + (unless (equal? (hash-ref items i #f) v) + (set! items (hash-set items i v)) + (show-or-hide-scroll-thumb) + (update-mouse-over-drawing-state) + (set-clicked-in #f #f #f #f) + (refresh))) + (define/private (set-items is) + (define new-items + (for/hash ([i (in-naturals)] + [c (in-list is)]) + (values i c))) + (unless (equal? new-items items) + (set! items new-items) + (show-or-hide-scroll-thumb) + (update-mouse-over-drawing-state) + (set-clicked-in #f #f #f #f) + (refresh))) + (define/private (delete-item n) + (set! items (delete-item/hash items n)) + (show-or-hide-scroll-thumb) + (update-mouse-over-drawing-state) + (set-clicked-in #f #f #f #f) + (refresh)) + + (define/private (reorder-items! former-indices) + (set! items (for/hash ([old (in-list former-indices)] + [i (in-naturals)]) + (values i (hash-ref items old))))) + + ;; (or/c #f natural?) + ;; if #f there are no scroll thumbs, + ;; if a natural, it is the offset + ;; that we've scrolled over + (define scroll-offset #f) + + ;; -> boolean + ;; #t indicates that the scrollbar actually changed + (define (set-scroll-offset nv) + (define nv-constrained (and nv (ensure-in-bounds 0 nv (scroll-offset-rightmost)))) + (cond + [(equal? nv-constrained scroll-offset) #f] + [else + (set! scroll-offset nv-constrained) + (update-mouse-over-drawing-state) + (refresh) + #t])) + + ;; #t if we are between mouse enter and leave events, #f otherwise + (define mouse-entered? #f) + (define/private (set-mouse-entered? nv) + (unless (equal? mouse-entered? nv) + (set! mouse-entered? nv) + (refresh))) + + ;; (or/c #f (integer-in 0 (number-of-items))) + ;; indicates which of the tabs the mouse is currently over + (define mouse-over #f) + + ;; boolean + ;; when `mouse-over` isn't #f, if this is #t then + ;; the mouse isn't just over the tab, it is also inside + ;; the close `x` for that one + (define mouse-over-close? #f) + + ;; (or/c #f 'left 'right) + (define mouse-over-thumb #f) + + ;; boolean + (define mouse-over-new-button? #f) + + (define/private (set-mouse-over new-mouse-over + new-mouse-over-close? + new-mouse-over-thumb + new-mouse-over-new-button?) + (unless (and (equal? mouse-over new-mouse-over) + (equal? mouse-over-close? new-mouse-over-close?) + (equal? mouse-over-thumb new-mouse-over-thumb) + (equal? mouse-over-new-button? new-mouse-over-new-button?)) + (set! mouse-over new-mouse-over) + (set! mouse-over-close? new-mouse-over-close?) + (set! mouse-over-thumb new-mouse-over-thumb) + (set! mouse-over-new-button? new-mouse-over-new-button?) + (refresh))) + + ;; (or/c #f (integer-in 0 (number-of-items))) + ;; indicates which item was clicked in + ;; (either becuase it is being dragged or for the close button) + (define clicked-in #f) + + ;; (or/c #f natural?) + ;; if a natural? then + ;; - indicates the offset from the start where the + ;; clicked-in tab was first clicked in + ;; if #f then + ;; - close button was clicked in the `clicked-in` tab + ;; this is meaningful only if clicked-in is not #f + (define clicked-in-offset #f) + + ;; (or/c 'left 'right #f) + ;; when not #f, the thumb-timer is running + ;; when not #f, scroll-offset should also not be #f + (define clicked-thumb #f) + + ; boolean + (define clicked-new-button #f) + + (define/private (set-clicked-in new-clicked-in new-clicked-in-offset new-clicked-thumb new-clicked-new-button) + (unless (and (equal? clicked-in new-clicked-in) + (equal? clicked-in-offset new-clicked-in-offset) + (equal? clicked-thumb new-clicked-thumb) + (equal? clicked-new-button new-clicked-new-button)) + (set! clicked-in new-clicked-in) + (set! clicked-in-offset new-clicked-in-offset) + (set! clicked-thumb new-clicked-thumb) + (set! clicked-new-button new-clicked-new-button) + (refresh) + (maybe-start/stop-thumb-timer))) + + ;; the current coordinates of the mouse + (define mouse-x #f) + (define mouse-y #f) + + ;; ---------- + ;; public api + + (define/public (append choice) + (set-item (number-of-items) choice) + (refresh)) + (define/public (delete n) + (unless (< n (number-of-items)) + (raise-argument-error 'delete `(integer-in 0 ,(number-of-items)) n)) + (delete-item n) + (refresh)) + + (define/public (get-item-label n) (get-item n)) + (define/public (get-number) (number-of-items)) + (define/public (get-selection) selection) + (define/public (set new-choices) + (set-items new-choices) + (refresh)) + (define/public (set-label n label) (set-item n label)) + (define/public (set-selection n) (set-the-selection n)) + + ;; ---------- + ;; drawing + + (define orig-ascent 0) + + (define/override (on-paint) + (enable-cache) + (define dc (get-dc)) + (send dc set-smoothing 'smoothed) + (send dc set-font font) + (send dc set-text-foreground + (if (white-on-black-panel-scheme?) + "white" + "black")) + + ;; 1. draw the items that aren't being dragged + (define-values (cw ch) (get-client-size)) + (define tw (width-of-tab)) + (for ([i (in-range (number-of-items))]) + (define skip-this-drawing-because-it-is-moving? + (and (equal? i clicked-in) + (number? clicked-in-offset))) + (unless skip-this-drawing-because-it-is-moving? + (define ith-offset (find-ith-offset i)) + (define sp (natural-left-position (+ i ith-offset))) + (unless (< (+ sp tw) 0) ;; entirely to the left of being visible + (unless (< cw sp) ;; entirely to the right of being visible + (draw-ith-item i sp))))) + + (when (has-new-button?) + (define sp (natural-left-position (number-of-items))) + (unless (< (+ sp tw) 0) ;; entirely to the left of being visible + (unless (< cw sp) ;; entirely to the right of being visible + (draw-new-button (number-of-items) sp)))) + + ;; 2. + (draw-lines-between-items) + + ;; 3. draw the one that is being dragged (so it shows up on top) + (when (and clicked-in clicked-in-offset) + (draw-ith-item clicked-in + (get-left-edge-of-moving-tab))) + + ;; 4. + (when scroll-offset (draw-scroll-thumbs)) + + (disable-cache)) + + (define/private (draw-new-button i x-start) + (define dc (get-dc)) + (define new-icon-start (+ x-start new-button-margin)) + (define-values (cw ch) (get-client-size)) + (define cx (+ new-icon-start (/ size-of-new-icon-circle 2))) + (define cy (/ ch 2)) + + (define text-and-close-foreground-color (text-and-close-icon-bright-color)) + + (define new-circle-color + (cond + [(and clicked-new-button mouse-over-new-button?) + (mouse-down-over-close-circle-color)] + [clicked-new-button + (selected-tab-color)] + [mouse-over-new-button? + (mouse-over-close-circle-color)] + [else (natural-tab-color)])) + + (when new-circle-color + (send dc set-brush new-circle-color 'solid) + (send dc set-pen "black" 1 'transparent) + (send dc draw-ellipse + (- cx (/ size-of-new-icon-circle 2)) + (- cy (/ size-of-new-icon-circle 2)) + size-of-new-icon-circle + size-of-new-icon-circle)) + + (send dc set-pen text-and-close-foreground-color 1 'solid) + (send dc draw-line + (- cx (/ size-of-new-icon-x 2)) + cy + (+ cx (/ size-of-new-icon-x 2)) + cy) + (send dc draw-line + cx + (+ cy (/ size-of-new-icon-x 2)) + cx + (- cy (/ size-of-new-icon-x 2))) + (void)) + + (define/private (draw-scroll-thumbs) + (define dc (get-dc)) + (send dc set-pen "black" 1 'transparent) + (send dc set-brush (scrollthumb-background-color) 'solid) + (define-values (cw ch) (get-client-size)) + (define-values (sw sh) (get-scroll-thumb-size)) + (send dc draw-rectangle 0 0 sw sh) + (send dc draw-rectangle (- cw sw) 0 sw sh) + (define w-ti 1/4) + (define h-ti 1/6) + (define points (list (cons (* (- 1 w-ti) sw) (* h-ti ch)) + (cons (* (- 1 w-ti) sw) (* (- 1 h-ti) ch)) + (cons (* w-ti sw) (* ch 1/2)))) + (send dc set-brush + (cond + [(= scroll-offset 0) + (scrollthumb-all-the-way-over)] + [(equal? clicked-thumb 'left) + (scrollthumb-clicked-foreground-color)] + [(equal? mouse-over-thumb 'left) + (scrollthumb-over-foreground-color)] + [else + (scrollthumb-foreground-color)]) + 'solid) + (send dc draw-polygon points) + (send dc set-brush + (cond + [(= scroll-offset (scroll-offset-rightmost)) + (scrollthumb-all-the-way-over)] + [(equal? clicked-thumb 'right) + (scrollthumb-clicked-foreground-color)] + [(equal? mouse-over-thumb 'right) + (scrollthumb-over-foreground-color)] + [else + (scrollthumb-foreground-color)]) + 'solid) + (send dc draw-polygon (for/list ([point (in-list points)]) + (cons (- cw (car point)) + (cdr point))))) + + (define/private (draw-lines-between-items) + (define dc (get-dc)) + (send dc set-pen (text-and-close-icon-dim-color) 1 'solid) + (define-values (cw ch) (get-client-size)) + (for ([i (in-range 1 (number-of-items))]) + (define x (natural-left-position i)) + (send dc draw-line x top-item-margin x (- ch bottom-item-margin)))) + + (define/private (draw-ith-item i x-start) + (define tab-background-color + (cond + [(equal? selection i) + (selected-tab-color)] + [(or (equal? mouse-over i) (equal? clicked-in i)) + (mouse-over-tab-color)] + [else + (natural-tab-color)])) + (define text-and-close-foreground-color + (cond + [(equal? selection i) (text-and-close-icon-bright-color)] + [else (text-and-close-icon-dim-color)])) + (define close-circle-color + (cond + [(and (equal? clicked-in i) (not clicked-in-offset)) + (if mouse-over-close? + (mouse-down-over-close-circle-color) + (mouse-over-close-circle-color))] + [(and (equal? mouse-over i) mouse-over-close?) + (mouse-over-close-circle-color)] + [else tab-background-color])) + (draw-ith-item/colors i x-start + tab-background-color + text-and-close-foreground-color + close-circle-color)) + + (define/private (draw-ith-item/colors i x-start + tab-background-color + text-and-close-foreground-color + close-circle-color) + (define dc (get-dc)) + (define lab (get-item i)) + (define lab-space (- (width-of-tab) + horizontal-item-margin + horizontal-item-margin + (if (can-close?) size-of-close-icon-circle 0))) + (define-values (cw ch) (get-client-size)) + + (send dc set-brush tab-background-color 'solid) + (send dc set-pen "black" 1 'transparent) + (send dc draw-rectangle x-start 0 (width-of-tab) ch) + + (send dc set-clipping-rect + (+ x-start horizontal-item-margin) + 0 + (max 0 lab-space) + (max 0 ch)) + (send dc set-text-foreground text-and-close-foreground-color) + (define-values (tw th td ta) (send dc get-text-extent lab)) + (send dc draw-text lab + (+ x-start horizontal-item-margin) + (+ top-item-margin (- orig-ascent (- th td))) + #t) + (send dc set-clipping-region #f) + (maybe-draw-fade-at-edge lab lab-space x-start tab-background-color) + (when (can-close?) + (draw-close-icon x-start + tab-background-color + text-and-close-foreground-color + close-circle-color))) + + (define/private (maybe-draw-fade-at-edge lab lab-space x-start tab-background-color) + (define dc (get-dc)) + (define-values (cw ch) (get-client-size)) + (define-values (tw th td ta) (send dc get-text-extent lab)) + (when (tw . >= . lab-space) + #;(assert (lab-space . >= . end-of-label-horizontal-gradient-amount)) + ;; this assert should always be true because the minimum size of + ;; a tab label should always include a label that is at least as + ;; big as `end-of-label-horizontal-gradient-amount` + (define right-edge-of-label + (+ x-start horizontal-item-margin lab-space)) + (define old-brush (send dc get-brush)) + (define old-pen (send dc get-pen)) + (define gradient-stops + (list (list 0 (make-transparent tab-background-color)) + (list 1 tab-background-color))) + (send dc set-brush + (new brush% + [gradient + (new linear-gradient% + [x0 (- right-edge-of-label end-of-label-horizontal-gradient-amount)] + [y0 0] + [x1 right-edge-of-label] + [y1 0] + [stops gradient-stops])])) + (send dc set-pen "black" 1 'transparent) + (send dc draw-rectangle + (- right-edge-of-label end-of-label-horizontal-gradient-amount) + 0 + end-of-label-horizontal-gradient-amount + ch) + (send dc set-pen old-pen) + (send dc set-brush old-brush))) + + ;; pre: (can-close?) = #t + (define/private (draw-close-icon x-start + tab-background-color + text-and-close-foreground-color + close-circle-color) + (define dc (get-dc)) + (define close-icon-start (+ x-start (get-start-of-cross-x-offset))) + (define-values (cw ch) (get-client-size)) + (define cx (+ close-icon-start (/ size-of-close-icon-circle 2))) + (define cy (/ ch 2)) + (when close-circle-color + (send dc set-brush close-circle-color 'solid) + (send dc set-pen "black" 1 'transparent) + (send dc draw-ellipse + (- cx (/ size-of-close-icon-circle 2)) + (- cy (/ size-of-close-icon-circle 2)) + size-of-close-icon-circle + size-of-close-icon-circle)) + (send dc set-pen text-and-close-foreground-color 1 'solid) + (send dc draw-line + (- cx (/ size-of-close-icon-x 2)) + (- cy (/ size-of-close-icon-x 2)) + (+ cx (/ size-of-close-icon-x 2)) + (+ cy (/ size-of-close-icon-x 2))) + (send dc draw-line + (- cx (/ size-of-close-icon-x 2)) + (+ cy (/ size-of-close-icon-x 2)) + (+ cx (/ size-of-close-icon-x 2)) + (- cy (/ size-of-close-icon-x 2))) + (void)) + + ;; ------- + ;; mouse movement + + (define/override (on-event evt) + (define leaving? (send evt leaving?)) + (define entering? (send evt entering?)) + (define left-down (send evt get-left-down)) + (define button-down?-left (send evt button-down? 'left)) + (define time-stamp (send evt get-time-stamp)) + (define dragging? (send evt dragging?)) + (define button-up?-left (send evt button-up? 'left)) + (define last-mouse-x mouse-x) + (set! mouse-x (send evt get-x)) + (set! mouse-y (send evt get-y)) + + (define the-callback void) + + (define-values (cw ch) (get-client-size)) + (cond + [(or (and leaving? + (not left-down)) + (and button-up?-left + (or (not (<= 0 mouse-x cw)) + (not (<= 0 mouse-y ch))))) + ;; this cannot just be `leaving?` because the mouse being + ;; down grabs all events to the canvas. So: if the + ;; button is down we don't believe the leaving event. + ;; BUT when the mouse is eventually released we do need + ;; to consider the mouse as having left the window, so we + ;; use the `x` and `y` coordinates to determine if we're + ;; outside the window when we do see the up event + (set-mouse-over #f #f #f #f) + (set-mouse-entered? #f) + (set-clicked-in #f #f #f #f)] + [entering? + (set-mouse-entered? #t)]) + + (when mouse-entered? + (define-values (mouse-over-tab + mx-offset-in-tab + mouse-over-close? + mouse-over-thumb + mouse-over-new-button?) + (mouse->info mouse-x mouse-y)) + (cond + [button-down?-left + (when (and mouse-over-tab (not mouse-over-close?)) + (set-the-selection mouse-over-tab) + (set! the-callback + (λ () + (callback this + (new control-event% + [event-type 'tab-panel] + [time-stamp time-stamp]))))) + (cond + [(can-reorder?) + (set-clicked-in mouse-over-tab + (and (not mouse-over-close?) mx-offset-in-tab) + mouse-over-thumb + mouse-over-new-button?)] + [else + (set-clicked-in (and mouse-over-close? mouse-over-tab) + #f + mouse-over-thumb + mouse-over-new-button?)]) + (set-mouse-over mouse-over-tab mouse-over-close? mouse-over-thumb mouse-over-new-button?)] + [(and left-down dragging?) + ;; maybe this next line needs to refresh only when + ;; we are dragging a tab, not all the time? + (unless (equal? last-mouse-x mouse-x) (refresh)) + (cond + [mouse-over-thumb + (set-clicked-in #f #f mouse-over-thumb #f)] + [else + (set-mouse-over #f + (and mouse-over-close? + (equal? clicked-in mouse-over-tab)) + #f + mouse-over-new-button?)])] + [(and button-up?-left clicked-in) + (cond + [clicked-in-offset + (define n (number-of-items)) + (define to-tab (or mouse-over-tab (if (mouse-x . <= . 0) + 0 + (sub1 n)))) + (define former-indices (reordered-list n clicked-in to-tab)) + (when former-indices + (reorder-items! former-indices) + (set! the-callback + (λ () + (on-reorder former-indices))))] + [else + (when (and mouse-over-close? + (equal? clicked-in mouse-over-tab)) + (define index clicked-in) + (set! the-callback + (λ () + (on-close-request index))))]) + (set-clicked-in #f #f #f #f) + (set-mouse-over mouse-over-tab mouse-over-close? mouse-over-thumb mouse-over-new-button?)] + [button-up?-left + (when mouse-over-new-button? + (set! the-callback + (λ () + (on-new-request)))) + (set-clicked-in #f #f #f #f) + (set-mouse-over mouse-over-tab mouse-over-close? mouse-over-thumb mouse-over-new-button?)] + [else + (set-mouse-over mouse-over-tab mouse-over-close? mouse-over-thumb mouse-over-new-button?)])) + + + (the-callback)) + + (define/private (update-mouse-over-drawing-state) + (cond + [(and mouse-x mouse-y mouse-entered?) + (define-values (mouse-over-tab + mx-offset-in-tab + mouse-over-close? + mouse-over-thumb + mouse-over-new-button?) + (mouse->info mouse-x mouse-y)) + (set-mouse-over mouse-over-tab mouse-over-close? mouse-over-thumb mouse-over-new-button?)] + [else + (set-mouse-over #f #f #f #f)])) + + ;; ----- + ;; scrolling-related event handling + + (define/override (on-size) + (show-or-hide-scroll-thumb)) + + (define/override (on-char evt) + (case (send evt get-key-code) + [(wheel-left) (scroll-with-low-priority-event -1)] + [(wheel-right) (scroll-with-low-priority-event 1)])) + + (define pending-scroll-amount #f) + (define/private (scroll-with-low-priority-event amount) + (cond + [pending-scroll-amount + (set! pending-scroll-amount (+ amount pending-scroll-amount))] + [else + (set! pending-scroll-amount amount) + (queue-callback + (λ () + (when scroll-offset + (set-scroll-offset (+ scroll-offset pending-scroll-amount))) + (set! pending-scroll-amount #f)) + #f)])) + + ;; called when something that might cause scrollbars to appear or disappear + (define/private (show-or-hide-scroll-thumb) + (define-values (cw ch) (get-client-size)) + (define need-scrollbars? (cw . < . (min-size-of-all-tabs-together))) + (cond + [(and need-scrollbars? (not scroll-offset)) + (set-scroll-offset 0)] + [(and (not need-scrollbars?) scroll-offset) + (set-scroll-offset #f)])) + + (define thumb-timer-start-seconds #f) + (define thumb-timer + (new timer% + [notify-callback + (λ () + (cond + [clicked-thumb + (define number-of-seconds-since-click + (/ (- (current-inexact-milliseconds) thumb-timer-start-seconds) + 1000)) + (define rounded-up-to-nearest-1/2 + (/ (inexact->exact (ceiling (* number-of-seconds-since-click 2))) 2)) + (define thumb-speed (+ 1 rounded-up-to-nearest-1/2)) ;; go a little faster + (define moved? + (set-scroll-offset (if (equal? clicked-thumb 'left) + (- scroll-offset rounded-up-to-nearest-1/2) + (+ scroll-offset rounded-up-to-nearest-1/2)))) + (cond + [moved? + (send thumb-timer start thumb-timer-interval #t)] + [else + (set! thumb-timer-start-seconds #f)])] + [else + (set! thumb-timer-start-seconds #f)]))])) + + (define/private (maybe-start/stop-thumb-timer) + (cond + [clicked-thumb + (set! thumb-timer-start-seconds (current-inexact-milliseconds)) + (send thumb-timer start thumb-timer-interval #t)] + [else + (set! thumb-timer-start-seconds #f) + (send thumb-timer stop)])) + + ;; ----- + ;; sizes and positions + + ;; returns the position in the coordinates that + ;; we should use to draw into the canvas (so + ;; taking into account the scroll position) + (define/private (natural-left-position i) + (define-values (sw sh) (get-scroll-thumb-size)) + (+ (if scroll-offset (+ sw (- scroll-offset)) 0) + (* i (width-of-tab)))) + + ;; determines the delta (0, -1, +1) for the `ith` tab + ;; due to some other tab being dragged around + ;; pre: i ≠ clicked-in + (define/private (find-ith-offset i) + (cond + [(and clicked-in clicked-in-offset) + (define i-left (natural-left-position i)) + (define i-right (+ i-left (width-of-tab))) + (define i-middle (/ (+ i-left i-right) 2)) + (define left-edge-of-moving-tab (get-left-edge-of-moving-tab)) + (define right-edge-of-moving-tab (+ left-edge-of-moving-tab (width-of-tab))) + (cond + [(< i clicked-in) + (if (left-edge-of-moving-tab . < . i-middle) + +1 + 0)] + [(< clicked-in i) + (if (right-edge-of-moving-tab . > . i-middle) + -1 + 0)] + [else 0])] + [else 0])) + + (define/private (get-left-edge-of-moving-tab) + (ensure-in-bounds (natural-left-position 0) + (- mouse-x clicked-in-offset) + (natural-left-position (- (number-of-items) 1)))) + + (define/private (enable-cache) + (thread-cell-set! wob (compute:white-on-black-panel-scheme?)) + (set! the-width-of-tab (compute-width-of-tab))) + (define/private (disable-cache) + (thread-cell-set! wob 'compute-it) + (set! the-width-of-tab 'compute-it)) + (define the-width-of-tab 'compute-it) + (define/private (width-of-tab) + (match the-width-of-tab + ['compute-it + (compute-width-of-tab)] + [(? number? n) n])) + (define (new-button-width) + (if (has-new-button?) + (+ new-button-margin + size-of-new-icon-circle + new-button-margin) + 0)) + (define/private (compute-width-of-tab) + (define-values (cw _ch) (get-client-size)) + (define dc (get-dc)) + (define n-items (number-of-items)) + (define shrinking-required-size + (if (zero? n-items) + (- cw (new-button-width)) + (- (/ cw n-items) + (/ (new-button-width) n-items)))) + + ;; this is the maximum size that a tab will ever be + (define unconstrained-tab-size (* (send (send dc get-font) get-point-size) 12)) + (max (min shrinking-required-size + unconstrained-tab-size) + (get-min-tab-width))) + + (define/private (white-on-black-panel-scheme?) #f) + + ;; also include the size of the new button if present + (define/private (min-size-of-all-tabs-together) + (+ (* (number-of-items) (get-min-tab-width)) + (new-button-width))) + + (define/private (scroll-offset-rightmost) + (define-values (cw ch) (get-client-size)) + (define-values (sw sh) (get-scroll-thumb-size)) + (define min (min-size-of-all-tabs-together)) + (- min (- cw sw sw))) + + (define/private (get-scroll-thumb-size) + (define-values (cw ch) (get-client-size)) + (define sw (* ch 2/3)) + (values sw ch)) + + (define/private (get-min-width) + (define-values (sw sh) (get-scroll-thumb-size)) + (define min-number-of-visible-items 2) + (+ (* min-number-of-visible-items + (get-min-tab-width)) + sw ;; left scrollbar + sw)) ;; right scrollbar + + ;; -> exact natural + (define/private (get-min-tab-width) + (define dc (get-dc)) + (define-values (tw th td ta) (send dc get-text-extent "w")) + ;; width of an item showing only the letter `w` + (+ horizontal-item-margin + (max (inexact->exact (ceiling tw)) + end-of-label-horizontal-gradient-amount) + horizontal-item-margin + (if (can-close?) size-of-close-icon-circle 0))) + + ;; returns the position where the close x starts, relative + ;; to the position of the start of the tab itself + (define/private (get-start-of-cross-x-offset) + (- (width-of-tab) + horizontal-item-margin + (if (can-close?) size-of-close-icon-circle 0))) + + (define/private (mouse->info mx-in-canvas-coordinates my) + (define-values (sw sh) (get-scroll-thumb-size)) + ;; this `mx` is in coordinates such that 0 is the left + ;; edge of the tabs. The `mx-in-canvas-coordinates` is + ;; such that the left edge is the left edge of the window + ;; (even including the scroll thumbs) + (define mx (if scroll-offset + (+ mx-in-canvas-coordinates scroll-offset (- sw)) + mx-in-canvas-coordinates)) + (define-values (cw ch) (get-client-size)) + (define tab-candidate-i (floor (/ mx (width-of-tab)))) + (cond + [(and scroll-offset (<= 0 mx-in-canvas-coordinates sw)) + (values #f #f #f 'left #f)] + [(and scroll-offset (<= (- cw sw) mx-in-canvas-coordinates cw)) + (values #f #f #f 'right #f)] + [(<= 0 tab-candidate-i (- (number-of-items) 1)) + (define mx-offset-in-tab (- mx-in-canvas-coordinates (natural-left-position tab-candidate-i))) + (define start-of-cross (get-start-of-cross-x-offset)) + (define-values (cw ch) (get-client-size)) + (define in-close-x + (and (can-close?) + (<= start-of-cross + mx-offset-in-tab + (+ start-of-cross size-of-close-icon-circle)))) + (define in-close-y + (and (can-close?) + (<= (- (/ ch 2) size-of-close-icon-circle) + my + (+ (/ ch 2) size-of-close-icon-circle)))) + (values tab-candidate-i mx-offset-in-tab (and in-close-x in-close-y) #f #f)] + [(and (has-new-button?) + (not clicked-in) + (= tab-candidate-i (number-of-items)) + (>= mx (+ (* tab-candidate-i (width-of-tab)) + new-button-margin)) + (<= mx (+ (* tab-candidate-i (width-of-tab)) + new-button-margin + size-of-new-icon-circle)) + ; need to check the height as well for the case where the mouse button was held down + ; oven the new button and re-enters the widget + (>= my (/ (- ch size-of-new-icon-circle) 2)) + (<= my (- ch (/ (- ch size-of-new-icon-circle) 2)))) + (values #f #f #f #f #t)] + [else + (values #f #f #f #f #f)])) + + (let () + (define dc (get-dc)) + (send dc set-smoothing 'smoothed) + (send dc set-font font) + (define-values (tw th td ta) (send dc get-text-extent "Xy")) + (set! orig-ascent (- th td)) + (set-min-width (get-min-width)) + (set-min-height (max (+ top-item-margin + (ceiling (inexact->exact th)) + bottom-item-margin) + (if (can-close?) size-of-close-icon-circle 0)))) + + (stretchable-in-y #f))) + +;; ----- +;; size constants + +;; space around text in each item horizontally +(define horizontal-item-margin 10) +(define top-item-margin 5) +(define bottom-item-margin 3) +(define new-button-margin (/ horizontal-item-margin 2)) + +(define end-of-label-horizontal-gradient-amount 16) + +(define size-of-close-icon-x 6) +(define size-of-close-icon-circle 12) + +(define size-of-new-icon-x 8) +(define size-of-new-icon-circle 16) + +;; in msec +(define thumb-timer-interval 30) + +;; in pixels (need to be able to speed this up, so this is wrong) +(define thumb-speed 2) + +;; ------ +;; color constants +(define shade-delta 16) +(define shade-start 20) +(define colors (make-hash)) +(define (get-a-color shade-count dark?) + (unless (hash-ref colors shade-count #f) + (define offset (+ shade-start (* shade-delta shade-count))) + (define 255-of (- 255 offset)) + (hash-set! colors + shade-count + (cons (make-object color% offset offset offset) + (make-object color% 255-of 255-of 255-of)))) + (define pr (hash-ref colors shade-count)) + (if dark? (car pr) (cdr pr))) + +(define wob (make-thread-cell 'compute)) +(define (white-on-black-panel-scheme?) + (define v (thread-cell-ref wob)) + (cond + [(boolean? v) v] + [else (compute:white-on-black-panel-scheme?)])) + +(define (natural-tab-color) (get-a-color 1 (white-on-black-panel-scheme?))) +(define (mouse-over-tab-color) (get-a-color 2 (white-on-black-panel-scheme?))) +(define (selected-tab-color) (get-a-color 3 (white-on-black-panel-scheme?))) +(define (text-and-close-icon-dim-color) (get-a-color 3 (not (white-on-black-panel-scheme?)))) +(define (text-and-close-icon-bright-color) (get-a-color 1 (not (white-on-black-panel-scheme?)))) +(define (mouse-over-close-circle-color) (get-a-color 6 (white-on-black-panel-scheme?))) +(define (mouse-down-over-close-circle-color) (get-a-color 8 (white-on-black-panel-scheme?))) +(define (scrollthumb-background-color) (get-a-color 4 (white-on-black-panel-scheme?))) +(define (scrollthumb-foreground-color) (get-a-color 9 (white-on-black-panel-scheme?))) +(define (scrollthumb-over-foreground-color) (get-a-color 11 (white-on-black-panel-scheme?))) +(define (scrollthumb-clicked-foreground-color) (get-a-color 13 (white-on-black-panel-scheme?))) +(define (scrollthumb-all-the-way-over) (get-a-color 1 (white-on-black-panel-scheme?))) + +(define transparent-cache (make-hasheq)) +(define (make-transparent color) + (hash-ref! transparent-cache + color + (λ () + (make-object color% + (send color red) + (send color green) + (send color blue) + 0)))) + +(define (ensure-in-bounds low x high) + (max (min x high) low)) +(module+ test + (check-equal? (ensure-in-bounds 0 1 10) 1) + (check-equal? (ensure-in-bounds 0 8 10) 8) + (check-equal? (ensure-in-bounds 0 -1 10) 0) + (check-equal? (ensure-in-bounds 0 11 10) 10)) + +(define (delete-item/hash items n) + (define shifted-items + (for/fold ([items items]) ([i (in-range (+ n 1) (hash-count items))]) + (hash-set items (- i 1) (hash-ref items i)))) + (hash-remove shifted-items (- (hash-count items) 1))) + +(module+ test + (let () + (define ht (hash 0 "a")) + (define new-ht (delete-item/hash ht 0)) + (check-equal? new-ht (hash))) + + (let () + (define ht (hash 0 "a" + 1 "b" + 2 "c" + 3 "d")) + (define new-ht (delete-item/hash ht 0)) + (check-equal? new-ht (hash 0 "b" + 1 "c" + 2 "d"))) + + (let () + (define ht (hash 0 "a" + 1 "b" + 2 "c" + 3 "d")) + (define new-ht (delete-item/hash ht 2)) + (check-equal? new-ht (hash 0 "a" + 1 "b" + 2 "d"))) + + (let () + (define ht (hash 0 "a" + 1 "b" + 2 "c" + 3 "d")) + (define new-ht (delete-item/hash ht 3)) + (check-equal? new-ht (hash 0 "a" + 1 "b" + 2 "c")))) + +;; computes mapping of new index to old index when +;; clicked-in is dragged to mouse-over +;; returns #f if nothing would change +(define (reordered-list number-of-items clicked-in mouse-over) + (cond + [(= clicked-in mouse-over) #f] + [else + (for/list ([i (in-range number-of-items)]) + (cond + [(or (i . < . (min clicked-in mouse-over)) + (i . > . (max clicked-in mouse-over))) + i] + [(= i mouse-over) clicked-in] + [(clicked-in . < . mouse-over) (add1 i)] + [else (sub1 i)]))])) + +(module+ test + (check-equal? (reordered-list 1 0 0) #f) + (check-equal? (reordered-list 2 1 0) '(1 0)) + (check-equal? (reordered-list 5 2 3) '(0 1 3 2 4)) + (check-equal? (reordered-list 5 3 2) '(0 1 3 2 4)) + (check-equal? (reordered-list 6 2 5) '(0 1 3 4 5 2)) + (check-equal? (reordered-list 6 5 1) '(0 5 1 2 3 4)) + (check-equal? (reordered-list 6 2 2) #f)) diff --git a/gui-lib/mred/private/wxtextfield.rkt b/gui-lib/mred/private/wxtextfield.rkt index bfb8f60e8..7453e84b1 100644 --- a/gui-lib/mred/private/wxtextfield.rkt +++ b/gui-lib/mred/private/wxtextfield.rkt @@ -192,6 +192,8 @@ [set-cursor (lambda (c) (send e set-cursor c #t))] [set-focus (lambda () (when (object? c) (send c set-focus)))] + + [has-focus? (lambda () (send c has-focus?))] [place-children (lambda (children-info width height) diff --git a/gui-lib/mred/private/wxtop.rkt b/gui-lib/mred/private/wxtop.rkt index be61abae5..cf1c6ecd2 100644 --- a/gui-lib/mred/private/wxtop.rkt +++ b/gui-lib/mred/private/wxtop.rkt @@ -289,6 +289,11 @@ (set! pending-redraws? #f)))] + [request-refresh-all-canvas-children + (λ () + (when panel + (send panel request-refresh-all-canvas-children)))] + [correct-size (lambda (frame-w frame-h) (if (not panel) @@ -402,6 +407,10 @@ (lambda () (send panel queue-active) (super on-active))] + [on-superwindow-activate + (lambda (on?) + (send panel queue-superwindow-activate on?) + (super on-superwindow-activate on?))] [move (lambda (x y) (set! use-default-position? #f) (super move x y))] [center (lambda (dir) @@ -608,7 +617,7 @@ (class (make-window-glue% %) (init mred proxy) (init-rest args) - (inherit is-shown? get-mred queue-visible get-eventspace) + (inherit is-shown? get-mred queue-visible get-eventspace on-superwindow-activate) (define act-date/seconds 0) (define act-date/milliseconds 0) (define act-on? #f) @@ -659,6 +668,7 @@ (queue-window-callback this (lambda () (send (get-mred) on-activate on?))) + (on-superwindow-activate on?) (as-exit (lambda () (super on-activate on?)))))] diff --git a/gui-lib/mred/private/wxwindow.rkt b/gui-lib/mred/private/wxwindow.rkt index 0d3a9dd57..c99fd299f 100644 --- a/gui-lib/mred/private/wxwindow.rkt +++ b/gui-lib/mred/private/wxwindow.rkt @@ -35,6 +35,16 @@ (lambda () (parameterize ([wx:current-eventspace (send (get-top-level) get-eventspace)]) (wx:queue-callback (entry-point (lambda () (on-visible))) wx:middle-queue-key)))] + [on-superwindow-activate + (lambda (on?) + (unless skip-sub-events? + (as-exit + (lambda () + (send (wx->proxy this) on-superwindow-activate on?)))))] + [queue-superwindow-activate + (lambda (on?) + (parameterize ([wx:current-eventspace (send (get-top-level) get-eventspace)]) + (wx:queue-callback (entry-point (lambda () (on-superwindow-activate on?))) wx:middle-queue-key)))] [skip-subwindow-events? (case-lambda [() skip-sub-events?] @@ -154,32 +164,42 @@ ;; Look for a parent, and shift coordinates (let loop ([w orig-w]) (if w - (if (is-a? w wx/proxy<%>) - (if (eq? w orig-w) - (k (wx->proxy w) e) - (let ([bx (box (send e get-x))] - [by (box (send e get-y))]) - (send orig-w client-to-screen bx by) - (send w screen-to-client bx by) - (let ([new-e (if (e . is-a? . wx:key-event%) - (instantiate wx:key-event% () - [key-code (send e get-key-code)]) - (instantiate wx:mouse-event% () - [event-type (send e get-event-type)] - [left-down (send e get-left-down)] - [right-down (send e get-right-down)] - [middle-down (send e get-middle-down)]))]) - (when (e . is-a? . wx:key-event%) - (send new-e set-key-release-code (send e get-key-release-code))) - (send new-e set-time-stamp (send e get-time-stamp)) - (send new-e set-alt-down (send e get-alt-down)) - (send new-e set-control-down (send e get-control-down)) - (send new-e set-meta-down (send e get-meta-down)) - (send new-e set-shift-down (send e get-shift-down)) - (send new-e set-x (unbox bx)) - (send new-e set-y (unbox by)) - (k (wx->proxy w) new-e)))) - (loop (send w get-parent))) + (cond + [(is-a? w wx/client-adjacent<%>) + (loop (send w get-sibling-client))] + [(is-a? w wx/proxy<%>) + (if (eq? w orig-w) + (k (wx->proxy w) e) + (cond + [(and (is-a? e wx:mouse-event%) + (memq (send e get-event-type) '(enter leave))) + ;; suppress enter and leave events + #f] + [else + (let ([bx (box (send e get-x))] + [by (box (send e get-y))]) + (send orig-w client-to-screen bx by) + (send w screen-to-client bx by) + (let ([new-e (if (e . is-a? . wx:key-event%) + (instantiate wx:key-event% () + [key-code (send e get-key-code)]) + (instantiate wx:mouse-event% () + [event-type (send e get-event-type)] + [left-down (send e get-left-down)] + [right-down (send e get-right-down)] + [middle-down (send e get-middle-down)]))]) + (when (e . is-a? . wx:key-event%) + (send new-e set-key-release-code (send e get-key-release-code))) + (send new-e set-time-stamp (send e get-time-stamp)) + (send new-e set-alt-down (send e get-alt-down)) + (send new-e set-control-down (send e get-control-down)) + (send new-e set-meta-down (send e get-meta-down)) + (send new-e set-shift-down (send e get-shift-down)) + (send new-e set-x (unbox bx)) + (send new-e set-y (unbox by)) + (k (wx->proxy w) new-e)))]))] + [else + (loop (send w get-parent))]) #f))) (define old-w -1) (define old-h -1) diff --git a/gui-lib/mrlib/arrow-toggle-snip.rkt b/gui-lib/mrlib/arrow-toggle-snip.rkt index f8efc3600..dce867944 100644 --- a/gui-lib/mrlib/arrow-toggle-snip.rkt +++ b/gui-lib/mrlib/arrow-toggle-snip.rkt @@ -107,7 +107,7 @@ [set-brush old-brush] [set-pen old-pen])) - (define/override (get-extent dc x y w h descent space lspace rspace) + (define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f]) (define-values (size dy) (get-target-size* dc)) (set-box/f! descent 0) (set-box/f! space 0) diff --git a/gui-lib/mrlib/close-icon.rkt b/gui-lib/mrlib/close-icon.rkt index b0a4bdabc..ae7c701e5 100644 --- a/gui-lib/mrlib/close-icon.rkt +++ b/gui-lib/mrlib/close-icon.rkt @@ -25,34 +25,33 @@ (define mouse-in? #f) (define mouse-down? #f) + (define/private (set-mouse-in? new-in?) + (set-mouse-in-and-down? new-in? mouse-down?)) + (define/private (set-mouse-down? new-down?) + (set-mouse-in-and-down? mouse-in? new-down?)) + (define/private (set-mouse-in-and-down? new-in? new-down?) + (unless (and (equal? new-in? mouse-in?) + (equal? new-down? mouse-down?)) + (set! mouse-in? new-in?) + (set! mouse-down? new-down?) + (refresh))) (define/override (on-event evt) (cond [(send evt leaving?) - (set! mouse-in? #f) + (set-mouse-in? #f) (refresh)] [(send evt entering?) - (set! mouse-in? #t) + (set-mouse-in? #t) (refresh)] [(send evt button-down?) - (set! mouse-down? #t) + (set-mouse-down? #t) (refresh)] [(send evt button-up?) - (set! mouse-down? #f) + (set-mouse-down? #f) (refresh) (when mouse-in? - (callback))] - [(send evt moving?) - (let ([new-mouse-in? - (and (<= 0 - (send evt get-x) - (send icon get-width)) - (<= 0 - (send evt get-y) - (send icon get-height)))]) - (unless (equal? new-mouse-in? mouse-in?) - (set! mouse-in? new-mouse-in?) - (refresh)))])) + (callback))])) (define/override (on-paint) (let ([dc (get-dc)]) @@ -79,8 +78,11 @@ (define/override (on-superwindow-show on?) (unless on? - (set! mouse-in? #f) - (set! mouse-down? #f))) + (set-mouse-in-and-down? #f #f))) + + (define/override (on-superwindow-activate on?) + (unless on? + (set-mouse-in-and-down? #f #f))) (super-new [style '(transparent no-focus)]) (min-width (+ horizontal-pad horizontal-pad (send icon get-width))) diff --git a/gui-lib/mrlib/hierlist/hierlist-unit.rkt b/gui-lib/mrlib/hierlist/hierlist-unit.rkt index b37e02d61..e2073ca98 100644 --- a/gui-lib/mrlib/hierlist/hierlist-unit.rkt +++ b/gui-lib/mrlib/hierlist/hierlist-unit.rkt @@ -181,7 +181,7 @@ (inherit hide-caret last-position set-position set-keymap invalidate-bitmap-cache set-max-width - get-view-size) + get-extent) (rename-super [super-auto-wrap auto-wrap] [super-on-default-event on-default-event]) @@ -229,7 +229,7 @@ (set! top_ 0) (let ([wbox (box 0)] [hbox (box 0)]) - (get-view-size wbox hbox) + (get-extent wbox hbox) (set! right (unbox wbox)) (set! bottom (unbox hbox)))) (send dc set-brush (if filled? black-xor transparent)) diff --git a/gui-lib/mrlib/image-core.rkt b/gui-lib/mrlib/image-core.rkt index 18820ab18..a4fa74041 100644 --- a/gui-lib/mrlib/image-core.rkt +++ b/gui-lib/mrlib/image-core.rkt @@ -1,5 +1,4 @@ #lang racket/base - #| This library is the part of the 2htdp/image @@ -121,8 +120,11 @@ has been moved out). ;; a np-atomic-shape is: ;; -;; - (make-ellipse width height angle mode color) -(define-struct/reg-mk ellipse (width height angle mode color) #:transparent #:omit-define-syntaxes) +;; - (make-ellipse width height angle mode color (or/c #f angle)) +;; width ≠ 0, height ≠ 0 +;; (ellipse constructor makes rectangles when width/height is 0) +(define-struct/reg-mk ellipse (width height angle mode color wedge) + #:transparent #:omit-define-syntaxes) ;; ;; - (make-text string angle number color ;; number (or/c #f string) family @@ -154,7 +156,7 @@ has been moved out). ;; a polygon is: ;; -;; - (make-polygon (listof vector) mode color) +;; - (make-polygon (listof pulled-point) mode color) (define-struct/reg-mk polygon (points mode color) #:transparent #:omit-define-syntaxes) ;; a line-segment is @@ -513,7 +515,7 @@ has been moved out). (define lst (parse (fetch bytes))) (cond [(not lst) - (make-image (make-translate 50 50 (make-ellipse 100 100 0 'solid "black")) + (make-image (make-translate 50 50 (make-ellipse 100 100 0 'solid "black" #f)) (make-bb 100 100 100) #f #f)] @@ -585,6 +587,26 @@ has been moved out). 0 0)] [else p]))) (apply constructor adjusted-points (cdr parsed-args))] + [(and constructor + (equal? tag 'struct:ellipse) + (= arg-count 5)) + ;; some save files from older versions do not have the wedge + ;; field for the ellipses, but it should be #f in that case + ;; also, newer versions never build an ellipse with zero width + ;; or height, so if we find one of those, make a rectangle instead + (define-values (width height angle mode color) (apply values parsed-args)) + (cond + [(or (= width 0) (= height 0)) + (construct-polygon + (rotate-points + (list (make-point 0 0) + (make-point width 0) + (make-point width height) + (make-point 0 height)) + angle) + mode color)] + [else + (constructor width height angle mode color #f)])] [(and constructor (procedure-arity-includes? constructor arg-count)) (apply constructor parsed-args)] [(and (eq? tag 'struct:bitmap) @@ -769,12 +791,35 @@ has been moved out). (define/contract (scale-np-atomic x-scale y-scale shape) (-> number? number? np-atomic-shape? np-atomic-shape?) (cond + [(and (= 1 x-scale) (= 1 y-scale)) + ;; a special case to avoid roundoff error that + ;; might happen in the subsequent cases (ellipse, especially) + shape] [(ellipse? shape) - (make-ellipse (* x-scale (ellipse-width shape)) - (* y-scale (ellipse-height shape)) - (ellipse-angle shape) - (ellipse-mode shape) - (scale-color (ellipse-color shape) x-scale y-scale))] + (define eh (ellipse-height shape)) + (define ew (ellipse-width shape)) + (cond + [(or (= (ellipse-angle shape) 0) + ;; if ew=eh, then this is a circle and the `scale-rotated-ellipse` + ;; function won't preserve the wedge's shape (if there is a wedge) + ;; so we need to avoid calling it (plus, it introduces possible + ;; rounding error, as it calls lots of fancy functions). + (= ew eh)) + (make-ellipse (* x-scale ew) + (* y-scale eh) + (ellipse-angle shape) + (ellipse-mode shape) + (scale-color (ellipse-color shape) x-scale y-scale) + (ellipse-wedge shape))] + [else + (define-values (new-ew new-eh new-θ) + (scale-rotated-ellipse x-scale y-scale + ew eh + (ellipse-angle shape))) + (make-ellipse new-ew new-eh new-θ + (ellipse-mode shape) + (scale-color (ellipse-color shape) x-scale y-scale) + (ellipse-wedge shape))])] [(text? shape) ;; should probably do something different here so that ;; the y-scale is always greater than 1 @@ -790,17 +835,13 @@ has been moved out). (text-weight shape) (text-underline shape))] [(flip? shape) - (cond - [(and (= 1 x-scale) (= 1 y-scale)) - shape] - [else - (let ([bitmap (flip-shape shape)]) - (make-flip (flip-flipped? shape) - (make-ibitmap (ibitmap-raw-bitmap bitmap) - (ibitmap-angle bitmap) - (* x-scale (ibitmap-x-scale bitmap)) - (* y-scale (ibitmap-y-scale bitmap)) - (ibitmap-cache bitmap))))])])) + (define bitmap (flip-shape shape)) + (make-flip (flip-flipped? shape) + (make-ibitmap (ibitmap-raw-bitmap bitmap) + (ibitmap-angle bitmap) + (* x-scale (ibitmap-x-scale bitmap)) + (* y-scale (ibitmap-y-scale bitmap)) + (ibitmap-cache bitmap)))])) (define (scale-color color x-scale y-scale) (cond @@ -812,6 +853,188 @@ has been moved out). (pen-join color))] [else color])) +(define (scale-rotated-ellipse x-scale y-scale ew eh angle) + (define a (/ ew 2)) + (define b (/ eh 2)) + (define-values (new-a new-b new-angle) + (do-scale-rotated-ellipse a b angle x-scale y-scale)) + (values (* 2 new-a) + (* 2 new-b) + new-angle)) + +;; probably inling and then applying various +;; identities, one can improve this function +;; probably inling and then applying various +;; identities, one can improve this function +(define (do-scale-rotated-ellipse a b angle x-scale y-scale) + (define a180? (> angle 180)) + + (define θ (degrees->radians angle)) + (define F (* (* b a) (* b (- a)))) + (define A (/ (+ (sqr (* a (sin θ))) (sqr (* b (cos θ)))) + x-scale x-scale)) + (define B (/ (* 2 (- (sqr b) (sqr a)) (sin θ) (cos θ)) + x-scale y-scale)) + (define C (/ (+ (sqr (* a (cos θ))) (sqr (* b (sin θ)))) + y-scale y-scale)) + + (define B^2-4AC (/ (* 4 F) (sqr (* x-scale y-scale)))) + (define q (* 2 B^2-4AC F)) + (define r (sqrt (+ (sqr (- A C)) (sqr B)))) + (define (ab ±) + (/ (- (sqrt (* q (± (+ A C) r)))) + B^2-4AC)) + (define _a (ab +)) + (define _b (ab -)) + (define _raw-angle + (cond + ;; this case isn't in wikipedia but I + ;; think it corresponds to a circle + ;; and so we can just pick any angle + ;; want in that case (and 0 is going + ;; to make more things equal) + [(and (= B 0) (= A C)) 0] + + [(and (= B 0) (< A C)) 0] + [(and (= B 0) (< C A)) 90] + [else + (radians->degrees + (atan (* (/ (- C A r) B))))])) + + (define _angle (if angle>180? (+ _raw-angle 180) _raw-angle)) + (cond + [aproper-range (+ 90 _angle)))] + [else + (values _a _b (angle->proper-range _angle))])) + +(define/contract (angle->proper-range α) + (-> real? (between/c 0 360)) + (define θ (- α (* 360 (floor (/ α 360))))) + (cond [(negative? θ) (+ θ 360)] + [(>= θ 360) (- θ 360)] + [else θ])) + +(module+ test + (require rackunit) + (check-equal? (angle->proper-range 1) 1) + (check-equal? (angle->proper-range 361) 1) + (check-equal? (angle->proper-range 1/2) 1/2) + (check-equal? (angle->proper-range -1) 359) + (check-equal? (angle->proper-range #e-1.5) #e358.5) + (check-equal? (angle->proper-range #e-.1) #e359.9) + + (check-equal? (angle->proper-range 1.0) 1.0) + (check-equal? (angle->proper-range 361.0) 1.0) + (check-equal? (angle->proper-range 0.5) 0.5) + (check-equal? (angle->proper-range -1.0) 359.0) + (check-equal? (angle->proper-range -1.5) 358.5) + (check-equal? (angle->proper-range -.1) 359.9) + (check-equal? (angle->proper-range #i-7.347880794884119e-016) 0.0) + + (check-equal? (angle->proper-range 720) 0) + ) + +(module+ test + (define (do-scale-rotated-ellipse/lst a b angle x-scale y-scale) + (call-with-values (λ () (do-scale-rotated-ellipse a b angle x-scale y-scale)) + list)) + (check-within (do-scale-rotated-ellipse/lst 1 1 0 1 1) (list 1 1 0) 0.0001) + (check-within (do-scale-rotated-ellipse/lst 10 10 0 1 1) (list 10 10 0) 0.0001) + (check-within (do-scale-rotated-ellipse/lst 3 2 1 1 1) (list 3 2 1) 0.0001) + (check-within (do-scale-rotated-ellipse/lst 10 1 30 1 1) (list 10 1 30) 0.0001) + (check-within (do-scale-rotated-ellipse/lst 3 2 30 1 1) (list 3 2 30) 0.0001) + (check-within (do-scale-rotated-ellipse/lst 3 2 45 1 1) (list 3 2 45) 0.0001) + (check-within (do-scale-rotated-ellipse/lst 3 10 33 1 1) (list 3 10 33) 0.0001) + (check-within (do-scale-rotated-ellipse/lst 1 2 190 1 1) (list 1 2 190) 0.0001) + + (check-within (do-scale-rotated-ellipse/lst 20 10 0 1 2) + (list 20 20 0) + 0.001) + (check-within (do-scale-rotated-ellipse/lst 20 10 0 1/2 1) + (list 10 10 0) + 0.001) + (check-within (do-scale-rotated-ellipse/lst 20 10 30 1/2 1) + (list 14.430004681646912 + 6.930004681646913 + 62.90876282222179) + 0.001) + (check-within (do-scale-rotated-ellipse/lst 20 10 30 1 2) + (list 28.860009363293823 + 13.860009363293827 + 62.90876282222179) + 0.001) + (check-within (do-scale-rotated-ellipse/lst 20 10 45 1 2) + (list 33.24506456314176 + 12.03186112754533 + 70.67009587295496) + 0.001) +) + +(define (rotate-points in-points θ) + (define cs (map pp->c in-points)) + (define vectors (points->vectors cs)) + (define rotated-vectors (map (λ (c) (rotate-c c θ)) vectors)) + (define rotated-points (vectors->points rotated-vectors)) + (for/list ([orig-point (in-list in-points)] + [rotated-point (in-list rotated-points)]) + (cond + [(pulled-point? orig-point) + (make-pulled-point (pulled-point-lpull orig-point) + (pulled-point-langle orig-point) + (point-x rotated-point) + (point-y rotated-point) + (pulled-point-rpull orig-point) + (pulled-point-rangle orig-point))] + [else rotated-point]))) + +(define (rotate-c c θ) + (* (degrees->complex θ) c)) + +(define (degrees->complex θ) + (unless (and (<= 0 θ) + (< θ 360)) + (error 'degrees->complex "~s" θ)) + (case (and (integer? θ) (modulo θ 360)) + [(0) 1+0i] + [(90) 0+1i] + [(180) -1+0i] + [(270) 0-1i] + [else (make-polar 1 (degrees->radians θ))])) + +(define (xy->c x y) (make-rectangular x (- y))) +(define (c->xy c) + (values (real-part c) + (- (imag-part c)))) +(define (pp->c p) + (cond + [(pulled-point? p) (xy->c (pulled-point-x p) (pulled-point-y p))] + [else (xy->c (point-x p) (point-y p))])) +(define (c->point c) + (let-values ([(x y) (c->xy c)]) + (make-point x y))) + +(define (points->vectors orig-points) + (let loop ([points (cons 0 orig-points)]) + (cond + [(null? (cdr points)) '()] + [else + (cons (- (cadr points) (car points)) + (loop (cdr points)))]))) + +(define (vectors->points vecs) + (let loop ([vecs vecs] + [p 0]) + (cond + [(null? vecs) '()] + [else + (let ([next-p (+ (car vecs) p)]) + (cons (c->point next-p) + (loop (cdr vecs) + next-p)))]))) + + ; ; ; @@ -999,7 +1222,7 @@ has been moved out). [this-one (scale-np-atomic x-scale y-scale shape)]) (render-np-atomic-shape this-one dc dx dy))] [else - (error 'normalize-shape "unknown shape ~s\n" shape)]))) + (error 'render-arbitrary-shape "unknown shape ~s\n" shape)]))) (define/contract (render-poly/line-segment/curve-segment simple-shape dc dx dy) (-> (or/c polygon? line-segment? curve-segment?) any/c any/c any/c void?) @@ -1062,20 +1285,29 @@ has been moved out). (define (render-np-atomic-shape np-atomic-shape dc dx dy) (cond [(ellipse? np-atomic-shape) - (let* ([path (new dc-path%)] - [ew (ellipse-width np-atomic-shape)] - [eh (ellipse-height np-atomic-shape)] - [θ (degrees->radians (ellipse-angle np-atomic-shape))] - [color (ellipse-color np-atomic-shape)] - [mode (ellipse-mode np-atomic-shape)]) - (let-values ([(rotated-width rotated-height) (ellipse-rotated-size ew eh θ)]) - (send path ellipse 0 0 ew eh) - (send path translate (- (/ ew 2)) (- (/ eh 2))) - (send path rotate θ) - (send dc set-pen (mode-color->pen mode color)) - (send dc set-brush (mode-color->brush mode color)) - (send dc set-smoothing (mode-color->smoothing mode color)) - (send dc draw-path path dx dy)))] + (define path (new dc-path%)) + (define ew (ellipse-width np-atomic-shape)) + (define eh (ellipse-height np-atomic-shape)) + (define θ (degrees->radians (ellipse-angle np-atomic-shape))) + (define color (ellipse-color np-atomic-shape)) + (define mode (ellipse-mode np-atomic-shape)) + (define wedge (ellipse-wedge np-atomic-shape)) + (define cx (/ ew 2)) + (define cy (/ eh 2)) + (cond + [wedge + (send path move-to cx cy) + (send path arc 0 0 ew eh 0 (degrees->radians wedge)) + (send path move-to cx cy) + (send path close)] + [else + (send path ellipse 0 0 ew eh)]) + (send path translate (- cx) (- cy)) + (send path rotate θ) + (send dc set-pen (mode-color->pen mode color)) + (send dc set-brush (mode-color->brush mode color)) + (send dc set-smoothing (mode-color->smoothing mode color)) + (send dc draw-path path dx dy)] [(flip? np-atomic-shape) (cond [(flip-flipped? np-atomic-shape) @@ -1095,6 +1327,7 @@ has been moved out). (send dc translate dx dy) (send dc rotate θ) + (send dc set-smoothing 'smoothed) (define bw (send bitmap-obj get-width)) (define bh (send bitmap-obj get-height)) @@ -1358,13 +1591,54 @@ the mask bitmap and the original bitmap are all together in a single bytes! (values (* (sin θ) eh) (* (cos θ) eh))] [else - (let* ([t1 (atan (/ eh ew (exact->inexact (tan θ))))] - ; a*cos(t1),b*sin(t1) is the point on *original* ellipse which gets rotated to top. - [t2 (atan (/ (* (- eh) (tan θ)) ew))] ; the original point rotated to right side. - [rotated-height (+ (* ew (sin θ) (cos t1)) (* eh (cos θ) (sin t1)))] - [rotated-width (- (* ew (cos θ) (cos t2)) (* eh (sin θ) (sin t2)))]) - (values (abs rotated-width) - (abs rotated-height)))])) + (define-values (top-t right-t) (ellipse-angle-of-topmost-and-rightmost-points ew eh θ)) + (define rotated-height (* 2 (ellipse-t->y ew eh θ top-t))) + (define rotated-width (* 2 (ellipse-t->x ew eh θ right-t))) + (values (abs rotated-width) + (abs rotated-height))])) + +(define (ellipse-angle-of-topmost-and-rightmost-points ew eh θ) + ; a*cos(t1),b*sin(t1) is the point on *original* ellipse which gets rotated to top. + (define t1 (atan (/ eh ew (exact->inexact (tan θ))))) + ; the original point rotated to right side. + (define t2 (atan (/ (* (- eh) (tan θ)) ew))) + (values t1 t2)) + +;; given the ellipse width (ew), height (eh), rotation (θ) and the parameteric input (t) +;; find the x and y coordinates of the corresponding point on the ellipse +;; (with an extra - for the `y` to convert to computer coordinates) +(define (ellipse-t->x ew eh θ t) + (define a (/ ew 2)) + (define b (/ eh 2)) + (- (* a (cos θ) (cos t)) (* b (sin θ) (sin t)))) +(define (ellipse-t->y ew eh θ t) + (define a (/ ew 2)) + (define b (/ eh 2)) + (- (+ (* a (sin θ) (cos t)) (* b (cos θ) (sin t))))) + +;; given the ellipse width (ew), height (eh) and rotation (θ) +;; find the parameter (in radians) of the point that's the +;; widest `x` point +(define (ellipse-outermost-point-x ew eh θ) + (define a (/ ew 2)) + (define b (/ eh 2)) + (define cosθ (cos θ)) + (if (= cosθ 0) + 0 + (atan (- (/ (* b (sin θ)) + (* a cosθ)))))) + +;; given the ellipse width (ew), height (eh) and rotation (θ) +;; find the parameter (in radians) of the point that's the +;; tallest `y` point +(define (ellipse-outermost-point-y ew eh θ) + (define sinθ (sin θ)) + (define a (/ ew 2)) + (define b (/ eh 2)) + (if (= sinθ 0) + (/ pi 2) + (- (atan (- (/ (* b (cos θ)) + (* a sinθ))))))) (define (mode-color->smoothing mode color) (cond @@ -1568,7 +1842,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! make-translate translate? translate-dx translate-dy translate-shape make-scale scale? scale-x scale-y scale-shape make-crop crop? crop-points crop-shape - make-ellipse ellipse? ellipse-width ellipse-height ellipse-angle ellipse-mode ellipse-color + make-ellipse ellipse? ellipse-width ellipse-height ellipse-angle ellipse-mode ellipse-color ellipse-wedge make-text text? text-string text-angle text-y-scale text-color text-angle text-size text-face text-family text-style text-weight text-underline (contract-out [rename construct-polygon make-polygon @@ -1590,8 +1864,20 @@ the mask bitmap and the original bitmap are all together in a single bytes! (rename-out [-make-color make-color]) degrees->radians + angle->proper-range normalize-shape ellipse-rotated-size + (contract-out + [ellipse-t->x + (-> (and/c real? (not/c 0)) (and/c real? (not/c 0)) real? real? + real?)] + [ellipse-t->y + (-> (and/c real? (not/c 0)) (and/c real? (not/c 0)) real? real? + real?)] + [ellipse-outermost-point-y + (-> (and/c real? (not/c 0)) (and/c real? (not/c 0)) real? real?)] + [ellipse-outermost-point-x + (-> (and/c real? (not/c 0)) (and/c real? (not/c 0)) real? real?)]) points->ltrb-values image? @@ -1618,7 +1904,11 @@ the mask bitmap and the original bitmap are all together in a single bytes! (contract-out [definitely-same-image? (-> image? image? boolean?)]) string->color-object/f - extra-2htdp/image-colors) + extra-2htdp/image-colors + rotate-points + rotate-c + c->xy xy->c + degrees->complex) ;; method names (provide get-shape get-bb get-pinhole get-normalized? get-normalized-shape) diff --git a/gui-lib/mrlib/name-message.rkt b/gui-lib/mrlib/name-message.rkt index f4dae2cf8..a9f43a294 100644 --- a/gui-lib/mrlib/name-message.rkt +++ b/gui-lib/mrlib/name-message.rkt @@ -27,6 +27,7 @@ [grabbed? boolean?] [button-label-font (is-a?/c font%)] [bkg-color (or/c #f (is-a?/c color%) string?)]) + (#:wob? [wob? boolean?]) #:pre (w h) (w . > . (- h (* 2 border-inset))) [result void?])] @@ -47,6 +48,8 @@ stretchable-width stretchable-height get-top-level-window refresh) + (define/public (wob?) (white-on-black-panel-scheme?)) + (define short-title? #f) (define hidden? #f) @@ -123,16 +126,23 @@ menu void)]) (send i enable #f)))) + (define/override (on-superwindow-activate on?) + (unless on? + (when mouse-over? + (set! mouse-over? #f) + (refresh)))) + (define/override (on-event evt) (unless hidden? - (define-values (max-x max-y) (get-size)) - (define inside? - (and (not (send evt leaving?)) - (<= 0 (send evt get-x) max-x) - (<= 0 (send evt get-y) max-y))) - (unless (eq? inside? mouse-over?) - (set! mouse-over? inside?) - (refresh)) + (cond + [(send evt leaving?) + (when mouse-over? + (set! mouse-over? #f) + (refresh))] + [(send evt entering?) + (unless mouse-over? + (set! mouse-over? #t) + (refresh))]) (cond [(send evt button-down?) @@ -189,7 +199,8 @@ (unless hidden? (when (and (> w 5) (> h 5)) (draw-button-label dc to-draw-message 0 0 w h mouse-over? mouse-grabbed? - font (get-background-color))))) + font (get-background-color) + #:wob? (wob?))))) (define/public (get-background-color) #f) @@ -232,19 +243,20 @@ [(macosx) "darkgray"] [else (make-object color% 230 230 230)])) (define mouse-over-color-white-on-black (make-object color% 20 20 20)) -(define (get-mouse-over-color) (if (white-on-black-panel-scheme?) - mouse-over-color-white-on-black - mouse-over-color)) +(define (get-mouse-over-color wob?) + (if wob? + mouse-over-color-white-on-black + mouse-over-color)) (define mouse-grabbed-color (make-object color% 100 100 100)) (define mouse-grabbed-color-white-on-black (make-object color% 155 155 155)) -(define (get-mouse-grabbed-color) - (if (white-on-black-panel-scheme?) +(define (get-mouse-grabbed-color wob?) + (if wob? mouse-grabbed-color-white-on-black mouse-grabbed-color)) (define grabbed-fg-color (make-object color% 220 220 220)) (define grabbed-fg-color-white-on-black (make-object color% 30 30 30)) -(define (get-grabbed-fg-color) - (if (white-on-black-panel-scheme?) +(define (get-grabbed-fg-color wob?) + (if wob? grabbed-fg-color-white-on-black grabbed-fg-color)) @@ -252,8 +264,8 @@ (define triangle-height 14) (define triangle-color (make-object color% 50 50 50)) (define triangle-color-white-on-black (make-object color% 200 200 200)) -(define (get-triangle-color) - (if (white-on-black-panel-scheme?) +(define (get-triangle-color wob?) + (if wob? triangle-color-white-on-black triangle-color)) @@ -286,7 +298,8 @@ ans-w ans-h)) -(define (draw-button-label dc label dx dy full-w h mouse-over? grabbed? button-label-font bkg-color) +(define (draw-button-label dc label dx dy full-w h mouse-over? grabbed? button-label-font bkg-color + #:wob? [wob? (white-on-black-panel-scheme?)]) (define label-width (if label @@ -305,8 +318,8 @@ (when (or mouse-over? grabbed?) (define color (if grabbed? - (get-mouse-grabbed-color) - (get-mouse-over-color))) + (get-mouse-grabbed-color wob?) + (get-mouse-over-color wob?))) (define xh (- h (* 2 border-inset))) (case (system-type) [(macosx) @@ -330,14 +343,14 @@ (+ dx (- w (quotient xh 2))) (+ dy (- h 1 border-inset)))] [else - (send dc set-pen (send the-pen-list find-or-create-pen (get-triangle-color) 1 'solid)) + (send dc set-pen (send the-pen-list find-or-create-pen (get-triangle-color wob?) 1 'solid)) (send dc set-brush (send the-brush-list find-or-create-brush color 'solid)) (send dc draw-rounded-rectangle (+ dx rrect-spacer) (+ dy border-inset) (- w border-inset rrect-spacer) xh 2)])) (when label - (send dc set-text-foreground (if grabbed? (get-grabbed-fg-color) (get-label-foreground-color))) + (send dc set-text-foreground (if grabbed? (get-grabbed-fg-color wob?) (get-label-foreground-color))) (send dc set-font button-label-font) (define-values (tw th _1 _2) (send dc get-text-extent label)) (send dc draw-text label @@ -346,7 +359,7 @@ #t)) (send dc set-pen "black" 1 'transparent) - (send dc set-brush (if grabbed? (get-grabbed-fg-color) (get-triangle-color)) 'solid) + (send dc set-brush (if grabbed? (get-grabbed-fg-color wob?) (get-triangle-color wob?)) 'solid) (define x (- w triangle-width circle-spacer border-inset)) (define y (- (/ h 2) (/ triangle-height 2))) (define ul-x (+ x 1)) diff --git a/gui-lib/mrlib/private/graph.rkt b/gui-lib/mrlib/private/graph.rkt index 99b89b880..bc9f37131 100644 --- a/gui-lib/mrlib/private/graph.rkt +++ b/gui-lib/mrlib/private/graph.rkt @@ -456,11 +456,7 @@ (let ([old-font (send dc get-font)]) (when edge-label-font (send dc set-font edge-label-font)) - (cond - [pending-invalidate-rectangle - (add-to-pending-indvalidate-rectangle left top right bottom)] - [else - (draw-edges dc left top right bottom dx dy)]) + (draw-edges dc left top right bottom dx dy) (when edge-label-font (send dc set-font old-font)))) (super on-paint before? dc left top right bottom dx dy draw-caret)) @@ -713,7 +709,6 @@ [y1 (+ yf (/ hf 2))] [x2 (+ xt (/ wt 2))] [y2 (+ yt (/ ht 2))]) - (unless (or (and (x1 . <= . left) (x2 . <= . left)) (and (x1 . >= . right) diff --git a/gui-lib/mrlib/switchable-button.rkt b/gui-lib/mrlib/switchable-button.rkt index 431e0e1a3..7c387242e 100644 --- a/gui-lib/mrlib/switchable-button.rkt +++ b/gui-lib/mrlib/switchable-button.rkt @@ -1,5 +1,6 @@ #lang racket/base (require racket/gui/base + racket/contract racket/class "private/panel-wob.rkt") @@ -63,7 +64,8 @@ callback [alternate-bitmap bitmap] [vertical-tight? #f] - [min-width-includes-label? #f]) + [min-width-includes-label? #f] + [right-click-menu #f]) (define/public (get-button-label) label) (define/override (set-label l) @@ -75,6 +77,12 @@ (not (send label ok?))) (error 'switchable-button% "label bitmap is not ok?")) + (let ([rcb-pred (or/c #f (list/c string? (procedure-arity-includes/c 0)))]) + (unless (rcb-pred right-click-menu) + (error 'switchable-button% "contract violation\n expected: ~s\n got: ~e" + (contract-name rcb-pred) + right-click-menu))) + (define/override (get-label) label) (define disable-bitmap (make-dull-mask bitmap)) @@ -85,7 +93,7 @@ (make-dull-mask alternate-bitmap))) (inherit get-dc min-width min-height get-client-size refresh - client->screen) + client->screen get-top-level-window popup-menu) (define down? #f) (define in? #f) @@ -96,33 +104,52 @@ (unless (equal? disabled? (not e?)) (set! disabled? (not e?)) (set! down? #f) - (set! in? #f) - (refresh))) + (update-float (and has-label? in? (not disabled?))) + (refresh)) + (super enable e?)) (define/override (is-enabled?) (not disabled?)) (define/override (on-superwindow-show show?) (unless show? (set! in? #f) (set! down? #f) - (update-float #f) + (update-float #f) (refresh)) (super on-superwindow-show show?)) + (define/override (on-superwindow-activate active?) + (unless active? + (set! in? #f) + (set! down? #f) + (update-float #f) + (refresh)) + (super on-superwindow-show active?)) + (define/override (on-event evt) (cond [(send evt button-down? 'left) (set! down? #t) - (set! in? #t) (refresh) (update-float #t)] [(send evt button-up? 'left) (set! down? #f) - (update-in evt #t) (refresh) (when (and in? (not disabled?)) (update-float #f) (callback this))] + [(send evt button-up?) + (set! down? #f) + (refresh)] + [(send evt button-down? 'right) + (when right-click-menu + (define m (new popup-menu%)) + (new menu-item% + [label (list-ref right-click-menu 0)] + [parent m] + [callback (λ (_1 _2) ((list-ref right-click-menu 1)))]) + (define-values (cw ch) (get-client-size)) + (popup-menu m 0 ch))] [(send evt entering?) (set! in? #t) (update-float #t) @@ -132,9 +159,7 @@ (set! in? #f) (update-float #f) (unless disabled? - (refresh))] - [else - (update-in evt)])) + (refresh))])) (define/public (command) (callback this) @@ -147,8 +172,10 @@ [notify-callback (λ () (unless has-label? - (unless (equal? (send float-window is-shown?) in?) - (send float-window show in?))) + (define float-should-be-shown? (and (not disabled?) in?)) + (unless (equal? (send float-window is-shown?) + float-should-be-shown?) + (send float-window show float-should-be-shown?))) (set! timer-running? #f))])) (define timer-running? #f) @@ -166,6 +193,7 @@ (unless float-window (set! float-window (new frame% [label ""] + [parent (get-top-level-window)] [style '(no-caption no-resize-border float)] [stretchable-width #f] [stretchable-height #f])) @@ -196,17 +224,6 @@ (when float-window (send float-window show #f))]))]))) - (define/private (update-in evt [dont-refresh? #f]) - (define-values (cw ch) (get-client-size)) - (define new-in? - (and (<= 0 (send evt get-x) cw) - (<= 0 (send evt get-y) ch))) - (unless dont-refresh? - (unless (equal? new-in? in?) - (set! in? new-in?) - (refresh))) - (update-float new-in?)) - (define/override (on-paint) (define dc (get-dc)) (define-values (cw ch) (get-client-size)) @@ -296,7 +313,7 @@ (unless (equal? has-label? h?) (set! has-label? h?) (update-sizes) - (update-float (and has-label? in?)) + (update-float (and has-label? in? (not disabled?))) (refresh))) (define/public (get-label-visible) has-label?) @@ -378,30 +395,39 @@ disable-bm] [else #f])) -#; -(begin +(module+ examples (define f (new frame% [label ""])) (define vp (new vertical-pane% [parent f])) (define p (new horizontal-panel% [parent vp] [alignment '(right top)])) (define label "Run") - (define bitmap (make-object bitmap% (build-path (collection-path "icons") "run.png") 'png/mask)) - (define foot (make-object bitmap% (build-path (collection-path "icons") "foot.png") 'png/mask)) - (define foot-up - (make-object bitmap% (build-path (collection-path "icons") "foot-up.png") 'png/mask)) + (define bitmap (read-bitmap (collection-file-path "run.png" "icons"))) + (define foot (read-bitmap (collection-file-path "foot.png" "icons"))) + (define foot-up (read-bitmap (collection-file-path "foot-up.png" "icons"))) + (define small-planet (read-bitmap (collection-file-path "small-planet.png" "icons"))) (define b1 (new switchable-button% [parent p] [label label] [bitmap bitmap] [callback void])) (define b2 (new switchable-button% [parent p] [label label] [bitmap bitmap] [callback void])) (define b3 (new switchable-button% [parent p] [label "Step"] [bitmap foot] [alternate-bitmap foot-up] [callback void])) + + ;; button with a callback that enables and disables like the debugger's step button + (define b4 + (new switchable-button% + [label "Step"] + [bitmap small-planet] + [parent p] + [callback (λ (_) (send b4 enable #f) (send b4 enable #t))] + [min-width-includes-label? #t])) + (define sb (new button% [parent p] [stretchable-width #t] [label "b"])) + (define state #t) (define swap-button (new button% [parent f] [label "swap"] [callback - (define state #t) (λ (a b) (set! state (not state)) (send b1 set-label-visible state) diff --git a/gui-lib/mrlib/syntax-browser.rkt b/gui-lib/mrlib/syntax-browser.rkt index 162539cf5..429cb6022 100644 --- a/gui-lib/mrlib/syntax-browser.rkt +++ b/gui-lib/mrlib/syntax-browser.rkt @@ -23,9 +23,9 @@ needed to really make this work: (provide (contract-out [render-syntax/snip - (-> syntax? (is-a?/c snip%))] + (->* (syntax?) (#:summary-width (or/c 0 (integer-in 3 #f) +inf.0 #f)) (is-a?/c snip%))] [render-syntax/window - (-> syntax? void?)]) + (->* (syntax?) (#:summary-width (or/c 0 (integer-in 3 #f) +inf.0 #f)) void?)]) render-syntax-subtitle-color-style-name render-syntax-focused-syntax-color-style-name snip-class) @@ -40,9 +40,11 @@ needed to really make this work: (define/augment (after-set-position) (hide-caret (= (get-start-position) (get-end-position)))) (super-new))) - - (define (render-syntax/window syntax) - (define es (render-syntax/snip syntax)) + +(define default-width 32) + + (define (render-syntax/window syntax #:summary-width [summary-width default-width]) + (define es (render-syntax/snip syntax #:summary-width summary-width)) (define f (new frame% [label "frame"] [width 850] [height 500])) (define mb (new menu-bar% [parent f])) (define edit-menu (new menu% [label "Edit"] [parent mb])) @@ -52,13 +54,18 @@ needed to really make this work: (send t insert es) (send f show #t)) - (define (render-syntax/snip stx) (make-object syntax-snip% stx)) + (define (render-syntax/snip stx #:summary-width [summary-width default-width]) + (new syntax-snip% + [main-stx stx] + [summary-width summary-width])) (define syntax-snipclass% (class snip-class% (define/override (read stream) - (make-object syntax-snip% - (unmarshall-syntax (:read (open-input-bytes (send stream get-bytes)))))) + (new syntax-snip% + [main-stx (unmarshall-syntax (:read (open-input-bytes (send stream get-bytes))))] + ;; we don't save this in the stream to avoid having a new version of the snip data + [summary-width default-width])) (super-new))) (define snip-class (new syntax-snipclass%)) @@ -73,13 +80,15 @@ needed to really make this work: (define syntax-snip% (class expandable-snip% (init-field main-stx) + (init summary-width) + (define _summary-width summary-width) (unless (syntax? main-stx) (error 'syntax-snip% "got non-syntax object")) (define/public (get-syntax) main-stx) - (define/override (copy) (make-object syntax-snip% main-stx)) + (define/override (copy) (new syntax-snip% [main-stx main-stx] [summary-width _summary-width])) (define/override (write stream) (send stream put (string->bytes/utf-8 (format "~s" (marshall-syntax main-stx))))) @@ -168,7 +177,7 @@ needed to really make this work: (let loop ([obj obj]) (cond [(pair? obj) (cons (loop (car obj)) (loop (cdr obj)))] - [(syntax? obj) (make-object syntax-snip% obj)] + [(syntax? obj) (new syntax-snip% [main-stx obj] [summary-width _summary-width])] [(hash? obj) (for/hash ([(k v) (in-hash obj)]) (values (loop k) (loop v)))] @@ -255,7 +264,9 @@ needed to really make this work: (show-border details-shown?) (set-tight-text-fit (not details-shown?))))) - (send summary-t insert (format "~s" main-stx)) + (send summary-t insert + (parameterize ([print-syntax-width (or summary-width (print-syntax-width))]) + (format "~s" main-stx))) (change-the-style summary-t plain-color-style-name 0 (send summary-t last-position)) diff --git a/gui-lib/mrlib/terminal.rkt b/gui-lib/mrlib/terminal.rkt index 636e28d4d..3d075ed27 100644 --- a/gui-lib/mrlib/terminal.rkt +++ b/gui-lib/mrlib/terminal.rkt @@ -202,34 +202,32 @@ (define output-port (mk-port plain-style)) (define error-port (mk-port error-style)) - + + ;; accessed and mutated only on the handler thread of `orig-eventspace` (define completed-successfully? #f) (define installer-cust (make-custodian)) - + (thread + (lambda () + (sync (make-custodian-box installer-cust #t)) + (parameterize ([current-eventspace inst-eventspace]) + (queue-callback + (λ () + (send kill-button enable #f) + (when close-button (send close-button enable #t)) + (set! currently-can-close? #t) + (semaphore-post can-close-sema)))) + (parameterize ([current-eventspace orig-eventspace]) + (queue-callback + (lambda () + (unless completed-successfully? + (cleanup-thunk))))))) + (parameterize ([current-custodian installer-cust]) (parameterize ([current-eventspace (make-eventspace)]) (queue-callback (lambda () - (let ([installer-thread (current-thread)]) - (parameterize ([current-custodian orig-custodian]) - (thread - (lambda () - (thread-wait installer-thread) - (parameterize ([current-eventspace inst-eventspace]) - (queue-callback - (λ () - (send kill-button enable #f) - (when close-button (send close-button enable #t)) - (set! currently-can-close? #t) - (semaphore-post can-close-sema)))) - (unless completed-successfully? - (parameterize ([current-eventspace orig-eventspace]) - (queue-callback - (lambda () - (cleanup-thunk))))))))) - (let/ec k (parameterize ([current-output-port output-port] [current-error-port error-port] diff --git a/gui-lib/racket/gui/installer.rkt b/gui-lib/racket/gui/installer.rkt index 1ab1fbcc0..3f8efaccb 100644 --- a/gui-lib/racket/gui/installer.rkt +++ b/gui-lib/racket/gui/installer.rkt @@ -1,19 +1,49 @@ #lang racket/base -(require launcher - racket/path - racket/file - setup/dirs) +(require launcher) (provide installer) +(module private-install-helpers racket/base + (require setup/dirs + racket/file + racket/path) + + (provide dispatch-to-installer-maker + exists-in-another-layer? + prep-dir) + + (define (dispatch-to-installer-maker path coll user? no-main? do-installer) + (cond + [user? + (if (find-addon-tethered-console-bin-dir) + (do-installer path coll #t #t) + (do-installer path coll #t #f))] + [else + (unless no-main? + (if (find-config-tethered-console-bin-dir) + (do-installer path coll #f #t) + (do-installer path coll #f #f)))])) + + (define (exists-in-another-layer? exe-name user? tethered? #:gui? gui?) + ;; for an untethered main installation, check whether the + ;; executable exists already in an earlier layer + (and (not user?) + (not tethered?) + (let-values ([(base name dir?) (split-path exe-name)]) + (for/or ([dir (in-list (if gui? + (get-gui-bin-extra-search-dirs) + (get-console-bin-extra-search-dirs)))]) + (file-or-directory-type (build-path dir name) #f))))) + + (define (prep-dir p) + (define dir (path-only p)) + (make-directory* dir) + p)) + +(require (submod "." private-install-helpers)) + (define (installer path coll user? no-main?) - (unless no-main? - (do-installer path coll user? #f) - (when (and (not user?) - (find-config-tethered-console-bin-dir)) - (do-installer path coll #f #t))) - (when (find-addon-tethered-console-bin-dir) - (do-installer path coll #t #t))) + (dispatch-to-installer-maker path coll user? no-main? do-installer)) (define (do-installer path collection user? tethered?) (define variants (available-mred-variants)) @@ -23,31 +53,28 @@ (let ([v (findf (lambda (v) (memq v variants)) vs)]) (when v (parameterize ([current-launcher-variant v]) - (make-mred-launcher - #:tether-mode tether-mode - '("-z") - (prep-dir - (mred-program-launcher-path "gracket-text" - #:user? user? - #:tethered? tethered? - #:console? #t)) - `([subsystem . console] - [single-instance? . #f] - [relative? . ,(not (or user? tethered?))])))))) + (define exe-name (mred-program-launcher-path "gracket-text" + #:user? user? + #:tethered? tethered? + #:console? #t)) + (unless (exists-in-another-layer? exe-name user? tethered? #:gui? #f) + (make-mred-launcher + #:tether-mode tether-mode + '("-z") + (prep-dir exe-name) + `([subsystem . console] + [single-instance? . #f] + [relative? . ,(not (or user? tethered?))]))))))) ;; add a bin/gracket (in addition to lib/gracket) (for ([vs '((script-3m 3m) (script-cgc cgc) (script-cs cs))]) (let ([v (findf (lambda (v) (memq v variants)) vs)]) (when v (parameterize ([current-launcher-variant v]) - (make-mred-launcher #:tether-mode tether-mode - null - (prep-dir - (mred-program-launcher-path "GRacket" #:user? user? #:tethered? tethered?)) - `([exe-name . "GRacket"] - [relative? . ,(not (or user? tethered?))] - [exe-is-gracket . #t]))))))) - -(define (prep-dir p) - (define dir (path-only p)) - (make-directory* dir) - p) + (define exe-name (mred-program-launcher-path "GRacket" #:user? user? #:tethered? tethered?)) + (unless (exists-in-another-layer? exe-name user? tethered? #:gui? #f) + (make-mred-launcher #:tether-mode tether-mode + null + (prep-dir exe-name) + `([exe-name . "GRacket"] + [relative? . ,(not (or user? tethered?))] + [exe-is-gracket . #t])))))))) diff --git a/gui-lib/scribble/private/indentation.rkt b/gui-lib/scribble/private/indentation.rkt index 9fcb0229c..11f108d1a 100644 --- a/gui-lib/scribble/private/indentation.rkt +++ b/gui-lib/scribble/private/indentation.rkt @@ -3,7 +3,8 @@ racket/gui/base racket/contract string-constants - framework) + framework + syntax-color/racket-navigation) (provide determine-spaces paragraph-indentation keystrokes) @@ -131,7 +132,7 @@ [(is-text? txt pos) pos] [else - (define containing-start (send txt find-up-sexp pos)) + (define containing-start (find-up-sexp txt pos)) (define pos-para (send txt position-paragraph pos)) (cond [(not containing-start) @@ -199,12 +200,12 @@ ;; ;; #f means no limit (define-values (start-sexp-boundary end-sexp-boundary) - (let ([first-container (send txt find-up-sexp pos)]) + (let ([first-container (find-up-sexp txt pos)]) (cond [first-container (define start-sexp-boundary (let loop ([pos pos]) - (define container (send txt find-up-sexp pos)) + (define container (find-up-sexp txt pos)) (cond [container (define paren (send txt get-character container)) @@ -273,10 +274,27 @@ (define (empty-para? txt para) (for/and ([x (in-range (send txt paragraph-start-position para) (send txt paragraph-end-position para))]) - (char-whitespace? (send txt get-character x)))) - -;; note: this might change the number of characters in the text, if -;; it chooses to break right after a {; the result accounts for that. + (or (char-whitespace? (send txt get-character x)) + (let ([cp (send txt classify-position x)]) + (eq? cp 'comment))))) + +;; note: if "Disable" is changed below, this function might change the +;; number of characters in the text, if it chooses to break right +;; after a {, like this: +;; a long line that has @formatted{text} inside +;; => +;; a long line that has @formatted{ +;; text} inside +;; Unfortunately, reindenting later might need to take the space back, +;; and that doesn't currently happen: +;; a long line that has @formatted{ +;; text} inside +;; => +;; a long line that has @formatted{ text} inside +;; ----^ +;; It's a problem that the space is not removed, in case the text +;; started that way, but we reduce the problem for now by not introducing +;; space like that. (define (break-paragraphs txt start-position end-position width) (define δ 0) @@ -306,6 +324,8 @@ (define linebreak-candidate? (and (is-text? txt pos) (or is-whitespace? + ;; Disable breaking right after `{`: + #; (and (pos . > . 0) (equal? 'parenthesis (send txt classify-position (- pos 1))) (equal? #\{ (send txt get-character (- pos 1))))))) @@ -331,7 +351,7 @@ (define classified (send txt classify-position pos)) (or (equal? classified 'text) (and (equal? classified 'white-space) - (let ([backward (send txt find-up-sexp pos)]) + (let ([backward (find-up-sexp txt pos)]) (and backward (equal? (send txt get-character backward) #\{) (equal? (send txt classify-position backward) @@ -392,7 +412,7 @@ (cond [para-start-skip-space (define char-classify (send txt classify-position para-start-skip-space)) - (define prev-posi (send txt find-up-sexp para-start-skip-space)) + (define prev-posi (find-up-sexp txt para-start-skip-space)) (cond [prev-posi (define this-para (send txt position-paragraph prev-posi)) @@ -501,7 +521,7 @@ ;;the beginning of the line it appears (define (count-parens txt posi) (define count 0) - (do ([p posi (send txt find-up-sexp p)]);backward-containing-sexp p 0)]) + (do ([p posi (find-up-sexp txt p)]);backward-containing-sexp p 0)]) ((not p) count) (cond [(equal? #\{ (send txt get-character p)) (set! count (add1 count))] [(equal? #\[ (send txt get-character p)) @@ -559,7 +579,8 @@ (send text insert (make-string amount #\space) posi)))) #t) - +(define (find-up-sexp t start-pos) + (racket-up-sexp t start-pos)) (define/contract (insert-them t . strs) (->* ((is-a?/c text%)) #:rest (*list/c (and/c string? #rx"\n$") string?) void?) @@ -1054,8 +1075,8 @@ (string-append "#lang scribble/base\n" "\n" - "jflkda fkfjdkla f fjdklsa @figure-ref{\n" - " looping-constructs-sample}.\n")) + "jflkda fkfjdkla f fjdklsa @figure-ref{" ; used to allow a line break here + "looping-constructs-sample}.\n")) (check-equal? (let ([t (new racket:text%)]) (send t insert "#lang scribble/base\n\ntest1\n test2\n\t\ttest3\n") @@ -1202,4 +1223,6 @@ (send t set-position (string-length before-newline) (string-length before-newline)) (reindent-paragraph t 'whatever-not-an-evt) (check-equal? (send t get-text) - (string-append before-newline "\n " after-newline)))) + ;; the "" here used to be "\n ", but that kind of breaking + ;; is now disallowed: + (string-append before-newline "" after-newline)))) diff --git a/gui-test/framework/tests/README b/gui-test/framework/tests/README index 60b436701..7a8471561 100644 --- a/gui-test/framework/tests/README +++ b/gui-test/framework/tests/README @@ -36,59 +36,4 @@ signal failures when there aren't any. | This tests that exit:exit really exits and that the exit callbacks | are actually run. -- preferences: prefs.rkt -- now runs directly via raco test - - | This tests that preferences are saved and restored correctly, both - | immediately and across reboots of gracket. - - -- individual object tests: - - | These tests are simple object creation and basic operations. - | Each test assumes that the others pass; this may yield strange - | error messages when one fails. - - - frames: frame.rkt -- now runs directly via raco test. - - canvases: canvas.rkt -- now runs directly via raco test. - - texts: text.rkt -- now runs directly via raco test. - - pasteboards: |# pasteboard.rkt #| - -- keybindings: keys.rkt -- now runs directly via raco test. - - | This tests the misc (non-scheme) keybindings - -- searching: |# search.rkt #| - - | This tests the search results - -- group tests: group-test.rkt -- now runs directly via raco test - - | make sure that mred:the-frame-group records frames correctly. - | fake user input expected. - -- number snip: number-snip.rkt -- now runs directly via raco test - - | some tests for the number-snip% class - -- scheme tests: - - | Tests the scheme: section - - racket.rkt --- now runs directly via raco test - -- panel tests: - - |# panel.rkt #| - -- |# (interactive #| tests - - | these tests require intervention by people. Clicking and whatnot - - - panel:single |# panel-single.rkt #| - - - garbage collection: |# mem.rkt #| - - | These tests will create objects in various configurations and - | make sure that they are garbage collected - -|#)) +|#) diff --git a/gui-test/framework/tests/autosave.rkt b/gui-test/framework/tests/autosave.rkt new file mode 100644 index 000000000..b18b7915c --- /dev/null +++ b/gui-test/framework/tests/autosave.rkt @@ -0,0 +1,169 @@ +#lang racket +(require rackunit framework string-constants + racket/gui/base + "test-suite-utils.rkt") + +(define-syntax (in-scratch-directory stx) + (syntax-case stx () + [(_ e1 e2 ...) + #`(in-scratch-directory/proc + #,(syntax/loc stx (λ () e1 e2 ...)))])) + +(define (in-scratch-directory/proc body) + (define d + (make-temporary-file + "framework-autosave-test~a" + #:copy-from 'directory)) + (dynamic-wind + void + (λ () + (parameterize ([current-directory d]) + (body))) + (λ () (delete-directory/files d)))) + +(define (wait-for-recover) + (let loop () + (define chan (make-channel)) + (queue-callback + (λ () + (define f (test:get-active-top-level-window)) + (channel-put + chan + (and f + (equal? (string-constant recover-autosave-files-frame-title) + (send f get-label))))) + #f) + (or (channel-get chan) + (loop)))) + +(define (wait-for-recover-gone f1) + (let loop () + (define keep-going-chan (make-channel)) + (queue-callback + (λ () + (define f2 (test:get-active-top-level-window)) + (cond + [(equal? f1 f2) + (channel-put keep-going-chan #t)] + [(not f2) (channel-put keep-going-chan #f)] + [else + ;; this is some debugging code; we don't expect any + ;; new windows to show up, so printout what it is + (pretty-write + (let loop ([w f2]) + (cond + [(is-a? w area-container<%>) + (for/list ([w (in-list (send w get-children))]) + (loop w))] + [(is-a? w message%) (vector "message%" (send w get-label))] + [(is-a? w button%) (vector "button%" (send w get-label))] + [(and (is-a? w editor-canvas%) (is-a? (send w get-editor) text%)) + (vector "tet%" (send (send w get-editor) get-text))] + [else w])) + (current-error-port)) + (error 'wait-for-recover-gone "a frame that's not the recovery frame")])) + #f) + (when (channel-get keep-going-chan) + (loop)))) + +(define (fetch-content fn) + (define sp (open-output-string)) + (call-with-input-file fn (λ (p) (copy-port p sp))) + (get-output-string sp)) + +(parameterize ([test:use-focus-table #t]) + (printf "framework/tests/autosave.rkt: test that the window opens\n") + (let () + (define t + (thread + (λ () + (define f (wait-for-recover)) + (test:button-push (string-constant autosave-done)) + (wait-for-recover-gone f)))) + (in-scratch-directory + (call-with-output-file "x.rkt" void) + (autosave:restore-autosave-files/gui + (list (list #f (build-path (current-directory) "x.rkt")))) + (yield t) + (void))) + + (printf "framework/tests/autosave.rkt: test that the window opens and no files change when we just click ”done“\n") + (let () + (define t + (thread + (λ () + (define f (wait-for-recover)) + (test:button-push (string-constant autosave-done)) + (wait-for-recover-gone f)))) + (in-scratch-directory + (call-with-output-file "x.rkt" (λ (p) (displayln "x.rkt" p))) + (call-with-output-file "y.rkt" (λ (p) (displayln "y.rkt" p))) + (autosave:restore-autosave-files/gui + (list (list (build-path (current-directory) "x.rkt") + (build-path (current-directory) "y.rkt")))) + (yield t) + (check-equal? (fetch-content "x.rkt") "x.rkt\n") + (check-equal? (fetch-content "y.rkt") "y.rkt\n") + (void))) + + + (printf "framework/tests/autosave.rkt: test that the window opens with a variety of items\n") + (let () + (define t + (thread + (λ () + (define f (wait-for-recover)) + (test:button-push (string-constant autosave-done)) + (wait-for-recover-gone f)))) + (in-scratch-directory + (call-with-output-file "x.rkt" void) + (call-with-output-file "y.rkt" void) + (call-with-output-file "z.rkt" void) + (call-with-output-file "a.rkt" void) + (call-with-output-file "b.rkt" void) + (call-with-output-file "c.rkt" void) + (autosave:restore-autosave-files/gui + (list (list #f (build-path (current-directory) "x.rkt")) + (list (build-path (current-directory) "z.rkt") (build-path (current-directory) "c.rkt")) + (list #f (build-path (current-directory) "y.rkt")) + (list (build-path (current-directory) "a.rkt") (build-path (current-directory) "b.rkt")))) + (yield t) + (void))) + + (printf "framework/tests/autosave.rkt: test that we can click on the details button\n") + (let () + (define t + (thread + (λ () + (define f (wait-for-recover)) + (test:button-push (string-constant autosave-details)) + (test:button-push (string-constant autosave-done)) + (wait-for-recover-gone f)))) + (in-scratch-directory + (call-with-output-file "x.rkt" void) + (call-with-output-file "y.rkt" void) + (autosave:restore-autosave-files/gui + (list (list #f (build-path (current-directory) "x.rkt")) + (list #f (build-path (current-directory) "y.rkt")))) + (yield t) + (void))) + + (printf "framework/tests/autosave.rkt: test that we can restore a file\n") + (let () + (define t + (thread + (λ () + (define f (wait-for-recover)) + (test:button-push (string-constant autosave-recover)) + (test:button-push (string-constant autosave-done)) + (wait-for-recover-gone f)))) + (in-scratch-directory + (call-with-output-file "x.rkt" (λ (p) (displayln "x.rkt" p))) + (call-with-output-file "y.rkt" (λ (p) (displayln "y.rkt" p))) + (autosave:restore-autosave-files/gui + (list (list (build-path (current-directory) "x.rkt") + (build-path (current-directory) "y.rkt")))) + (yield t) + (check-false (file-exists? "y.rkt")) + (check-equal? (fetch-content "x.rkt") "y.rkt\n"))) + ) diff --git a/gui-test/framework/tests/color-scheme.rkt b/gui-test/framework/tests/color-scheme.rkt new file mode 100644 index 000000000..cb74602eb --- /dev/null +++ b/gui-test/framework/tests/color-scheme.rkt @@ -0,0 +1,80 @@ +#lang racket +(require framework rackunit racket/draw) + +;; just makes sure the contract is okay. +(check-true + (symbol? (color-prefs:get-current-color-scheme-name))) + + +(define-values (color-names style-names) + (color-prefs:get-color-scheme-names)) + +(check-true + (for/and ([color-name (in-set color-names)]) + (color-prefs:color-scheme-color-name? color-name))) + +(check-true + (for/and ([color-name (in-set color-names)]) + (color-prefs:known-color-scheme-name? color-name))) + +(check-true + (for/and ([style-name (in-set style-names)]) + (color-prefs:color-scheme-style-name? style-name))) + +(check-true + (for/and ([style-name (in-set style-names)]) + (color-prefs:known-color-scheme-name? style-name))) + +(define a-known-color-name 'framework:paren-match-color) + +(let () + (define called 0) + (color-prefs:register-color-scheme-entry-change-callback + a-known-color-name + (λ (x) (set! called (+ called 1)))) + (check-equal? called 0) + (define old-color (color-prefs:lookup-in-color-scheme a-known-color-name)) + (define new-color (make-object color% + (modulo (+ (send old-color red) 1) 255) + (send old-color green) + (send old-color blue))) + (color-prefs:set-in-color-scheme a-known-color-name new-color) + (check-equal? called 1) + (color-prefs:set-in-color-scheme a-known-color-name old-color) + (check-equal? called 2)) + +(let () + (define called 0) + (define proc (λ (x) (set! called (+ called 1)))) + (color-prefs:register-color-scheme-entry-change-callback a-known-color-name + proc + #t) + (check-equal? called 0) + + ;; try to clear out the callback, it should be retained because of `proc` + (for ([x (in-range 10)]) (collect-garbage)) + + (define old-color (color-prefs:lookup-in-color-scheme a-known-color-name)) + (define new-color (make-object color% + (modulo (+ (send old-color red) 1) 255) + (send old-color green) + (send old-color blue))) + + (color-prefs:set-in-color-scheme a-known-color-name new-color) + (check-equal? called 1) + (color-prefs:set-in-color-scheme a-known-color-name old-color) + (check-equal? called 2) + + ;; make a call here to `proc` so that sfs doesn't clear it + (proc 'ignored) + (check-equal? called 3) + + ;; clear it and now gc should remove the callback + (set! proc void) + (for ([x (in-range 10)]) (collect-garbage)) + + ;; these two calls shouldn't change the counter + (color-prefs:set-in-color-scheme a-known-color-name new-color) + (check-equal? called 3) + (color-prefs:set-in-color-scheme a-known-color-name old-color) + (check-equal? called 3)) diff --git a/gui-test/framework/tests/color-text.rkt b/gui-test/framework/tests/color-text.rkt index b390c5912..735770ab3 100644 --- a/gui-test/framework/tests/color-text.rkt +++ b/gui-test/framework/tests/color-text.rkt @@ -6,6 +6,11 @@ (define colors '()) (define range-start #f) (define pending #f) + (define (add-to-colors pending start end) + (set! colors (cons (list pending + start + end) + colors))) (for ([i (in-range (+ (send t last-position) 1))]) (define p (send t classify-position i)) (cond @@ -14,12 +19,11 @@ (set! range-start i)] [(and range-start (equal? pending p)) (void)] [(and range-start (not (equal? pending p))) - (set! colors (cons (list pending range-start i) colors)) + (add-to-colors pending range-start i) (set! pending p) (set! range-start i)])) (when pending - (set! colors (cons (list pending range-start (send t last-position)) - colors))) + (add-to-colors pending range-start (send t last-position))) (reverse colors)) (define (token-sym->style s) @@ -31,22 +35,71 @@ racket-lexer '((|(| |)|) (|[| |]|) (|{| |}|)))) +(define (read-a-grapheme p) + (define chars + (let loop ([state 0]) + (define next-char (peek-char p)) + (cond + [(eof-object? next-char) '()] + [else + (define-values (grapheme-terminated? new-state) (char-grapheme-step next-char state)) + (cond + [grapheme-terminated? + (if (zero? new-state) + (list (read-char p)) + '())] + [else + (cons (read-char p) + (loop new-state))])]))) + (cond + [(null? chars) eof] + [else chars])) + +(check-equal? (read-a-grapheme (open-input-string "")) eof) +(check-equal? (read-a-grapheme (open-input-string "a")) (list #\a)) +(check-equal? (read-a-grapheme (open-input-string "\r\n")) (list #\return #\newline)) +(check-equal? (read-a-grapheme (open-input-string "\n\r")) (list #\newline)) +(check-equal? (read-a-grapheme (open-input-string "\n\r")) (list #\newline)) +(check-equal? (let ([p (open-input-string "\r\n\n\r\na")]) + (list (read-a-grapheme p) + (read-a-grapheme p) + (read-a-grapheme p) + (read-a-grapheme p) + (read-a-grapheme p) + (read-a-grapheme p))) + (list (list #\return #\newline) + (list #\newline) + (list #\return #\newline) + (list #\a) + eof + eof)) +(check-equal? (read-a-grapheme (open-input-string "🏴‍☠️")) + (string->list "\U1f3f4\u200d\u2620\ufe0f")) +(check-equal? (let ([p (open-input-string "\"🏴‍☠️\"")]) + (list (read-a-grapheme p) + (read-a-grapheme p) + (read-a-grapheme p))) + (list (list #\") + (string->list "\U1f3f4\u200d\u2620\ufe0f") + (list #\"))) + (define (backing-up-lexer port offset mode) (define-values (line col pos) (port-next-location port)) - (define c (read-char port)) + (define c (read-a-grapheme port)) (cond [(eof-object? c) (values "eof" 'eof #f #f #f #f #f)] [else (define peek-port (peeking-input-port port)) - (read-char peek-port) - (define the-color (read-char peek-port)) - (values (string c) - (case the-color - [(#\a) 'symbol] - [(#\b) 'parenthesis] - [(#\c) 'constant] - [else 'no-color]) + (port-count-lines! peek-port) + (read-a-grapheme peek-port) + (define the-color (read-a-grapheme peek-port)) + (values (apply string c) + (match the-color + [(list #\a) 'symbol] + [(list #\b) 'parenthesis] + [(list #\c) 'constant] + [_ 'no-color]) #f pos (+ pos 1) @@ -187,6 +240,32 @@ (check-equal? (get-colors t) correct-result)) +(let () + (define t (new color:text%)) + (start-racket-colorer t) + (send t insert "\"🏴‍☠️\"") + (send t freeze-colorer) + (send t thaw-colorer) + + (check-equal? (get-colors t) (list '(string 0 6)))) + +(let () + (define t (new color:text%)) + (start-racket-colorer t) + (send t insert "(define 🏴‍☠️ 1)🏴‍☠️") + (send t freeze-colorer) + (send t thaw-colorer) + + (check-equal? (get-colors t) + '((parenthesis 0 1) + (symbol 1 7) + (white-space 7 8) + (symbol 8 12) + (white-space 12 13) + (constant 13 14) + (parenthesis 14 15) + (symbol 15 19)))) + (let () (define t (new color:text%)) (send t insert "aaabc") diff --git a/gui-test/framework/tests/frame.rkt b/gui-test/framework/tests/frame.rkt index 58345a385..09ea972ea 100644 --- a/gui-test/framework/tests/frame.rkt +++ b/gui-test/framework/tests/frame.rkt @@ -180,9 +180,9 @@ (channel-put c (void)))) (channel-get c) (case (system-type) - [(macos macosx) (test:keystroke #\a '(meta))] - [(unix) (test:keystroke #\a '(meta))] - [(windows) (test:keystroke #\a '(control))]) + [(macos macosx) (test:keystroke 'left '(meta))] + [(unix) (test:keystroke 'left '(meta))] + [(windows) (test:keystroke 'left '(control))]) (for-each test:keystroke (string->list (path->string tmp-file))) (test:keystroke #\return) (wait-for-frame tmp-file-name) diff --git a/gui-test/framework/tests/framework-tmp b/gui-test/framework/tests/framework-tmp new file mode 100644 index 000000000..30d74d258 --- /dev/null +++ b/gui-test/framework/tests/framework-tmp @@ -0,0 +1 @@ +test \ No newline at end of file diff --git a/gui-test/framework/tests/load.rkt b/gui-test/framework/tests/load.rkt index 3f4987746..4bae1f26c 100644 --- a/gui-test/framework/tests/load.rkt +++ b/gui-test/framework/tests/load.rkt @@ -17,7 +17,10 @@ (with-handlers ([(lambda (x) #t) (lambda (x) (if (exn? x) - (exn-message x) + (let ([sp (open-output-string)]) + (parameterize ([current-error-port sp]) + ((error-display-handler) (exn-message x) x)) + (get-output-string sp)) (format "~s" x)))]) (eval ',exp) (void)))))) diff --git a/gui-test/framework/tests/mem.rkt b/gui-test/framework/tests/mem.rkt index 891b3fe25..f43ebfe51 100644 --- a/gui-test/framework/tests/mem.rkt +++ b/gui-test/framework/tests/mem.rkt @@ -1,174 +1,174 @@ #lang racket/base -(require "test-suite-utils.rkt") - -(module test racket/base) +(require racket/gui/base + racket/class + framework) ; mem-boxes : (list-of (list string (list-of (weak-box TST)))) -(send-sexp-to-mred '(define mem-boxes null)) +(define mem-boxes null) (define mem-count 10) (define (test-allocate tag open close) - (queue-sexp-to-mred - `(let ([new-boxes - (let loop ([n ,mem-count]) - (cond - [(zero? n) null] - [else - (let* ([o (,open)] - [b (make-weak-box o)]) - (,close o) - - ;; break at least that link. - (set! o #f) - - ;; flush pending events - (let ([s (make-semaphore 0)]) - (queue-callback (lambda () (semaphore-post s)) #f) - (yield s)) - - (cons b (loop (- n 1))))]))]) - (sleep/yield 1/10) (collect-garbage) - (sleep/yield 1/10) (collect-garbage) - (sleep/yield 1/10) (collect-garbage) - (set! mem-boxes (cons (list ,tag new-boxes) mem-boxes))))) + (define new-boxes + (let loop ([n mem-count]) + (cond + [(zero? n) null] + [else + (define o (open)) + (define b (make-weak-box o)) + (close o) + + ;; break at least that link. + (set! o #f) + + ;; flush pending events + (let ([s (make-semaphore 0)]) + (queue-callback (lambda () (semaphore-post s)) #f) + (yield s)) + + (cons b (loop (- n 1)))]))) + (sleep/yield 0.01) (collect-garbage) + (sleep/yield 0.01) (collect-garbage) + (sleep/yield 0.01) (collect-garbage) + (set! mem-boxes (cons (list tag new-boxes) mem-boxes))) (define (done) - (queue-sexp-to-mred - `(begin - (yield) (collect-garbage) - (yield) (collect-garbage) - (yield) (collect-garbage) - (yield) (collect-garbage) - (yield) (collect-garbage) - (yield) (collect-garbage) - (let* ([f (make-object dialog% "Results" #f 300 500)] - [text (make-object text%)] - [ec (make-object editor-canvas% f text)] - [hp (instantiate horizontal-panel% () - (parent f) - (stretchable-width #f) - (stretchable-height #f))] - [vp (instantiate vertical-panel% () - (parent hp) - (stretchable-width #f) - (stretchable-height #f))] - [gc-canvas (make-object canvas% hp '(border))] - [anything? #f]) - - (define (update-gui) - (send text erase) - (let ([anything? #f]) - (send text begin-edit-sequence) - (for-each - (lambda (boxl) - (let* ([tag (car boxl)] - [boxes (cadr boxl)] - [calc-results - (lambda () - (let loop ([boxes boxes] - [n 0]) - (cond - [(null? boxes) n] - [else (if (weak-box-value (car boxes)) - (loop (cdr boxes) (+ n 1)) - (loop (cdr boxes) n))])))]) - (let ([res (calc-results)]) - (when (> res 0) - (set! anything? #t) - (send text insert (format "~a: ~a of ~a\n" tag res ,mem-count)))))) - (reverse mem-boxes)) - (unless anything? - (send text insert "Nothing!\n")) - (send text end-edit-sequence))) - - (update-gui) - - (let ([onb (icon:get-gc-on-bitmap)] - [offb (icon:get-gc-off-bitmap)]) - (when (and (send onb ok?) - (send offb ok?)) - (send* gc-canvas - (min-client-width (max (send gc-canvas min-width) (send onb get-width))) - (min-client-height (max (send gc-canvas min-height) (send onb get-height))) - (stretchable-width #f) - (stretchable-height #f)) - (register-collecting-blit gc-canvas - 0 0 - (send onb get-width) - (send onb get-height) - onb offb))) - - (make-object button% "Collect" vp - (lambda (x y) - (send text erase) - (send text insert "Collecting Garbage\n") - (collect-garbage)(collect-garbage)(collect-garbage) - (collect-garbage)(collect-garbage)(collect-garbage) - (collect-garbage)(collect-garbage)(collect-garbage) - (update-gui))) - (make-object button% "Close" vp (lambda (x y) (send f show #f))) - (send f show #t))))) + (yield) (collect-garbage) + (yield) (collect-garbage) + (yield) (collect-garbage) + (yield) (collect-garbage) + (yield) (collect-garbage) + (yield) (collect-garbage) + (let* ([f (make-object dialog% "Results" #f 300 500)] + [text (make-object text%)] + [ec (make-object editor-canvas% f text)] + [hp (instantiate horizontal-panel% () + (parent f) + (stretchable-width #f) + (stretchable-height #f))] + [vp (instantiate vertical-panel% () + (parent hp) + (stretchable-width #f) + (stretchable-height #f))] + [gc-canvas (make-object canvas% hp '(border))]) + + (define (calc-results boxes) + (let loop ([boxes boxes] + [n 0]) + (cond + [(null? boxes) n] + [else (if (weak-box-value (car boxes)) + (loop (cdr boxes) (+ n 1)) + (loop (cdr boxes) n))]))) + + (define (update-gui) + (send text erase) + (define anything? #f) + (send text begin-edit-sequence) + (for ([boxl (in-list (reverse mem-boxes))]) + (define tag (car boxl)) + (define boxes (cadr boxl)) + (define res (calc-results boxes)) + (when (> res 0) + (set! anything? #t) + (send text insert (format "~a: ~a of ~a\n" tag res mem-count)))) + (unless anything? + (send text insert "Nothing!\n")) + (send text end-edit-sequence) + anything?) + + (define first-try-anything? (update-gui)) + + (let ([onb (icon:get-gc-on-bitmap)] + [offb (icon:get-gc-off-bitmap)]) + (when (and (send onb ok?) + (send offb ok?)) + (send* gc-canvas + (min-client-width (max (send gc-canvas min-width) (send onb get-width))) + (min-client-height (max (send gc-canvas min-height) (send onb get-height))) + (stretchable-width #f) + (stretchable-height #f)) + (register-collecting-blit gc-canvas + 0 0 + (send onb get-width) + (send onb get-height) + onb offb))) + + (make-object button% "Collect" vp + (lambda (x y) + (send text erase) + (send text insert "Collecting Garbage\n") + (collect-garbage)(collect-garbage)(collect-garbage) + (collect-garbage)(collect-garbage)(collect-garbage) + (collect-garbage)(collect-garbage)(collect-garbage) + (update-gui))) + (make-object button% "Close" vp (lambda (x y) (send f show #f))) + (cond + [first-try-anything? + (send f show #t)] + [else + (printf "mem tests passed\n")]))) (define (test-frame-allocate %) - (let ([name (format "~s" %)]) - (queue-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f)) - (test-allocate name - `(lambda () - (let ([f (make-object ,% ,name)]) - (send f show #t) - (yield) (yield) - f)) - `(lambda (f) - (yield) (yield) - (send f close) - (when (send f is-shown?) - (error 'test-frame-allocate "~a instance didn't close" ',%)) - (yield) (yield))) - (queue-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #t)))) + (define name (format "~s" %)) + (define old-pref (preferences:get 'framework:exit-when-no-frames)) + (preferences:set 'framework:exit-when-no-frames #f) + (test-allocate (object-name %) + (lambda () + (let ([f (make-object % name)]) + (send f show #t) + (yield) (yield) + f)) + (lambda (f) + (yield) (yield) + (send f close) + (when (send f is-shown?) + (error 'test-frame-allocate "~a instance didn't close" ',%)) + (yield) (yield))) + (preferences:set 'framework:exit-when-no-frames old-pref)) (test-allocate "frame%" - '(lambda () - (let ([f (make-object frame% "test frame")]) - (send f show #t) - f)) - '(lambda (f) (send f show #f))) - -(define (test-editor-allocate object-name) - (test-allocate (symbol->string object-name) - `(lambda () (make-object ,object-name)) - '(lambda (e) (send e on-close)))) - -(test-editor-allocate 'text:basic%) -(test-editor-allocate 'text:keymap%) -(test-editor-allocate 'text:autowrap%) -(test-editor-allocate 'text:file%) -(test-editor-allocate 'text:clever-file-format%) -(test-editor-allocate 'text:backup-autosave%) -(test-editor-allocate 'text:searching%) -(test-editor-allocate 'text:info%) - -(test-editor-allocate 'pasteboard:basic%) -(test-editor-allocate 'pasteboard:keymap%) -(test-editor-allocate 'pasteboard:file%) -(test-editor-allocate 'pasteboard:backup-autosave%) -(test-editor-allocate 'pasteboard:info%) - -(test-editor-allocate 'racket:text%) + (λ () + (define f (make-object frame% "test frame")) + (send f show #t) + f) + (λ (f) (send f show #f))) + +(define (test-editor-allocate %) + (test-allocate (object-name %) + (λ () (make-object %)) + (λ (e) (send e on-close)))) + +(test-editor-allocate text:basic%) +(test-editor-allocate text:keymap%) +(test-editor-allocate text:autowrap%) +(test-editor-allocate text:file%) +(test-editor-allocate text:clever-file-format%) +(test-editor-allocate text:backup-autosave%) +(test-editor-allocate text:searching%) +(test-editor-allocate text:info%) + +(test-editor-allocate pasteboard:basic%) +(test-editor-allocate pasteboard:keymap%) +(test-editor-allocate pasteboard:file%) +(test-editor-allocate pasteboard:backup-autosave%) +(test-editor-allocate pasteboard:info%) + +(test-editor-allocate racket:text%) (test-allocate "text:return%" - '(lambda () (make-object text:return% void)) - '(lambda (t) (void))) + (lambda () (make-object text:return% void)) + (lambda (t) (void))) -(test-frame-allocate '(class frame% (inherit show) (define/public (close) (show #f)) (super-new))) -(test-frame-allocate 'frame:basic%) -(test-frame-allocate 'frame:info%) -(test-frame-allocate 'frame:text-info%) -(test-frame-allocate 'frame:pasteboard-info%) -(test-frame-allocate 'frame:standard-menus%) +(test-frame-allocate (class frame% (inherit show) (define/public (close) (show #f)) (super-new))) +(test-frame-allocate frame:basic%) +(test-frame-allocate frame:info%) +(test-frame-allocate frame:text-info%) +(test-frame-allocate frame:pasteboard-info%) +(test-frame-allocate frame:standard-menus%) -(test-frame-allocate 'frame:text%) -(test-frame-allocate 'frame:searchable%) +(test-frame-allocate frame:text%) +(test-frame-allocate frame:searchable%) -(test-frame-allocate 'frame:pasteboard%) +(test-frame-allocate frame:pasteboard%) (done) diff --git a/gui-test/framework/tests/number-snip.rkt b/gui-test/framework/tests/number-snip.rkt index d7b4ecab4..faefd3c46 100644 --- a/gui-test/framework/tests/number-snip.rkt +++ b/gui-test/framework/tests/number-snip.rkt @@ -1,9 +1,11 @@ #lang racket/base (require "test-suite-utils.rkt" racket/contract + racket/class framework file/convertible - rackunit) + rackunit + (only-in framework/private/interfaces get-fully-computed-finite-decimal-string)) (check-true (let () @@ -22,6 +24,19 @@ 'png-bytes #f))) +(define (make-fraction-snip n b) + (define s (number-snip:make-fraction-snip n b)) + (send s set-fraction-view 'decimal) + s) + (check-true (number-snip:is-number-snip? (number-snip:make-fraction-snip 3/2 #t))) (check-false (number-snip:is-number-snip? 3/2)) (check-equal? 3/2 (number-snip:get-number (number-snip:make-fraction-snip 3/2 #t))) + +(check-equal? (send (make-fraction-snip 3/2 #t) get-fully-computed-finite-decimal-string) + "#e1.5") +(check-equal? (send (make-fraction-snip 3/2 #f) get-fully-computed-finite-decimal-string) + "1.5") +(check-equal? (send (number-snip:make-repeating-decimal-snip 1/3 #f) get-fully-computed-finite-decimal-string) + #f) + diff --git a/gui-test/framework/tests/panel-single.rkt b/gui-test/framework/tests/panel-single.rkt deleted file mode 100644 index 1fd168c4d..000000000 --- a/gui-test/framework/tests/panel-single.rkt +++ /dev/null @@ -1,137 +0,0 @@ -#lang racket/base -(require "test-suite-utils.rkt") - -(module test racket/base) - -(test - 'single-panel - (lambda (x) (eq? x 'passed)) - (λ () - (queue-sexp-to-mred - `(let* ([semaphore (make-semaphore 0)] - [semaphore-frame% - (class frame% - (define/augment (on-close) (semaphore-post semaphore)) - (super-new))] - [f (make-object semaphore-frame% "Single Panel Test")] - [blue-brush (send the-brush-list find-or-create-brush "navy" 'solid)] - [green-brush (send the-brush-list find-or-create-brush "lightblue" 'solid)] - [grid-canvas% - (class canvas% - (init-field lines) - (init label) - (inherit get-dc get-client-size) - (override on-paint) - (define (on-paint) - (let-values ([(width height) (get-client-size)]) - (let ([dc (get-dc)] - [single-width (/ width lines)] - [single-height (/ height lines)]) - (send dc set-pen "black" 1 'transparent) - (let loop ([i lines]) - (cond - [(zero? i) (void)] - [else - (let loop ([j lines]) - (cond - [(zero? j) (void)] - [else - (send dc set-brush - (if (= 0 (modulo (+ i j) 2)) - blue-brush green-brush)) - (send dc draw-rectangle - (* single-width (- i 1)) - (* single-height (- j 1)) - single-width - single-height) - (loop (- j 1))])) - (loop (- i 1))]))))) - (super-instantiate ()) - - ;; soon to be obsolete, hopefully. - (inherit set-label) - (set-label label) - - (inherit min-width min-height) - (min-width 50) - (min-height 50))] - [border-panel (make-object horizontal-panel% f '(border))] - [single-panel (make-object panel:single% border-panel)] - [children - (list - (new grid-canvas% (lines 3) (parent single-panel) (label "Small") (stretchable-width #f) (stretchable-height #f)) - (new grid-canvas% (lines 3) (parent single-panel) (label "Wide") (stretchable-width #t) (stretchable-height #f)) - (new grid-canvas% (lines 3) (parent single-panel) (label "Tall") (stretchable-width #f) (stretchable-height #t)) - (new grid-canvas% (lines 3) (parent single-panel) (label "Wide and Tall") (stretchable-width #t) (stretchable-height #t)))] - [active-child (car children)] - [radios (make-object horizontal-panel% f)] - [make-radio - (lambda (label choices callback) - (let* ([panel (make-object vertical-panel% radios '(border))] - [message (make-object message% label panel)] - [radio (make-object radio-box% #f choices panel (lambda (radio _) (callback radio)))] - [button (make-object button% - "Cycle" panel - (lambda (_1 _2) - (let ([before (send radio get-selection)] - [tot (send radio get-number)]) - (let loop ([n tot]) - (unless (zero? n) - (send radio set-selection (- tot n)) - (callback radio) - (sleep/yield 1) - (loop (- n 1)))) - (send radio set-selection before) - (callback radio))))]) - radio))] - [radio - (make-radio - "Active Child" - (map (lambda (x) (send x get-label)) children) - (lambda (radio) - (let loop ([n (length children)] - [cs children]) - (cond - [(null? cs) (void)] - [else (let ([c (car cs)]) - (if (string=? (send radio get-item-label (send radio get-selection)) - (send c get-label)) - (begin (set! active-child c) - (send single-panel active-child active-child)) - (loop (- n 1) - (cdr cs))))]))))] - [vertical-alignment 'center] - [horizontal-alignment 'center] - [update-alignment (lambda () - (send single-panel set-alignment horizontal-alignment vertical-alignment))] - [horiz - (make-radio - "Horizontal Alignment" - (list "left" "center" "right") - (lambda (radio) - (set! horizontal-alignment (string->symbol (send radio get-item-label (send radio get-selection)))) - (update-alignment)))] - [vert - (make-radio - "Vertical Alignment" - (list "top" "center" "bottom") - (lambda (radio) - (set! vertical-alignment (string->symbol (send radio get-item-label (send radio get-selection)))) - (update-alignment)))] - [buttons (make-object horizontal-panel% f)] - [result 'failed] - [failed (make-object button% "Failed" buttons (lambda (_1 _2) (semaphore-post semaphore)))] - [passed (make-object button% "Passed" buttons (lambda (_1 _2) - (set! result 'passed) - (semaphore-post semaphore)))]) - (send border-panel min-width 100) - (send border-panel min-height 100) - (send vert set-selection 1) - (send horiz set-selection 1) - (send buttons stretchable-height #f) - (send buttons set-alignment 'right 'center) - (send radios stretchable-height #f) - (send f show #t) - (yield semaphore) - (send f show #f) - result)))) diff --git a/gui-test/framework/tests/panel.rkt b/gui-test/framework/tests/panel.rkt index c850777f5..7fae93d2f 100644 --- a/gui-test/framework/tests/panel.rkt +++ b/gui-test/framework/tests/panel.rkt @@ -1,118 +1,97 @@ #lang racket/base -(require "test-suite-utils.rkt") - -(module test racket/base) - -(test - 'dragable-min-size1 - (λ (min-w/min-h) (equal? min-w/min-h '(10 20))) - `(call-with-values (λ () (panel:dragable-container-size '((10 20 #f #f)) 0 #t)) - list)) - -(test - 'dragable-min-size2 - (λ (min-w/min-h) (equal? min-w/min-h '(10 20))) - `(call-with-values (λ () (panel:dragable-container-size '((10 20 #f #f)) 0 #f)) - list)) - -(test - 'dragable-min-size3 - (λ (min-w/min-h) (equal? min-w/min-h '(30 60))) - `(call-with-values (λ () (panel:dragable-container-size '((10 20 #f #f) (30 40 #f #f)) 0 #t)) - list)) - -(test - 'dragable-min-size4 - (λ (min-w/min-h) (equal? min-w/min-h '(40 40))) - `(call-with-values (λ () (panel:dragable-container-size '((10 20 #f #f) (30 40 #f #f)) 0 #f)) - list)) - -(test - 'dragable-min-size5 - (λ (min-w/min-h) (equal? min-w/min-h '(30 65))) - `(call-with-values (λ () (panel:dragable-container-size '((10 20 #f #f) (30 40 #f #f)) 5 #t)) - list)) - -(test - 'dragable-min-size6 - (λ (min-w/min-h) (equal? min-w/min-h '(45 40))) - `(call-with-values (λ () (panel:dragable-container-size '((10 20 #f #f) (30 40 #f #f)) 5 #f)) - list)) - -(test - 'dragable-place-children1 - (λ (l) (equal? l '(() ()))) - `(call-with-values (λ () (panel:dragable-place-children '() 100 200 '() 0 #t)) - list)) - -(test - 'dragable-place-children2 - (λ (l) (equal? l '(((0 0 100 200)) ()))) - `(call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f)) 100 200 '(1) 0 #t)) - list)) - -(test - 'dragable-place-children3 - (λ (l) (equal? l '(((0 0 100 200)) ()))) - `(call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f)) 100 200 '(1) 0 #f)) - list)) - -(test - 'dragable-place-children4 - (λ (l) (equal? l '(((0 0 100 150) (0 150 100 150)) ((150 150))))) - `(call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (10 10 #t #f)) 100 300 '(1/2 1/2) 0 #t)) - list)) - -(test - 'dragable-place-children5 - (λ (l) (equal? l '(((0 0 50 300) (50 0 50 300)) ((50 50))))) - `(call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (10 10 #t #f)) 100 300 '(1/2 1/2) 0 #f)) - list)) - -(test - 'dragable-place-children5 - (λ (l) (equal? l '(((0 0 100 100) (0 100 100 200)) ((100 100))))) - `(call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (10 10 #t #f)) 100 300 '(1/3 2/3) 0 #t)) - list)) - -(test - 'dragable-place-children6 - (λ (l) (equal? l '(((0 0 10 300) (10 0 90 300)) ((10 10))))) - `(call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (10 10 #t #f)) 100 300 '(1/10 9/10) 0 #f)) - list)) - -(test - 'dragable-place-children7 - (λ (l) (equal? l '(((0 0 10 300) (20 0 90 300)) ((10 20))))) - `(call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (10 10 #t #f)) 110 300 '(1/10 9/10) 10 #f)) - list)) - -(test - 'dragable-place-children8 - (λ (l) (equal? l '(((0 0 10 300) (20 0 20 300) (50 0 70 300)) ((10 20) (40 50))))) - `(call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (10 10 #t #f) (10 10 #t #f)) 120 300 '(1/10 2/10 7/10) 10 #f)) - list)) - -(test - 'dragable-place-children9 - (λ (l) (equal? l '(((0 0 30 300) (30 0 70 300)) ((30 30))))) - `(call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (70 10 #t #f)) 100 300 '(1/2 1/2) 0 #f)) - list)) - -(test - 'dragable-place-children10 - (λ (l) (equal? l '(((0 0 70 300) (70 0 30 300)) ((70 70))))) - `(call-with-values (λ () (panel:dragable-place-children '((70 10 #t #f) (10 10 #t #f)) 100 300 '(1/2 1/2) 0 #f)) - list)) - -(test - 'dragable-place-children11 - (λ (l) (equal? l '(((0 0 70 300) (70 0 10 300) (80 0 20 300)) ((70 70) (80 80))))) - `(call-with-values (λ () (panel:dragable-place-children '((70 10 #t #f) (10 10 #t #f) (20 10 #t #f)) 100 300 '(1/2 1/4 1/4) 0 #f)) - list)) - -(test - 'dragable-place-children12 - (λ (l) (equal? l '(((0 0 242 629) (247 0 243 629)) ((242 247))))) - `(call-with-values (λ () (panel:dragable-place-children '((30 30 #t #t) (30 30 #t #t)) 490 629 '(1/2 1/2) 5 #f)) - list)) +(require framework rackunit) + +(check-equal? + (call-with-values (λ () (panel:dragable-container-size '((10 20 #f #f)) 0 #t)) + list) + '(10 20)) + +(check-equal? + (call-with-values (λ () (panel:dragable-container-size '((10 20 #f #f)) 0 #f)) + list) + '(10 20)) + +(check-equal? + (call-with-values (λ () (panel:dragable-container-size '((10 20 #f #f) (30 40 #f #f)) 0 #t)) + list) + '(30 60)) + +(check-equal? + (call-with-values (λ () (panel:dragable-container-size '((10 20 #f #f) (30 40 #f #f)) 0 #f)) + list) + '(40 40)) + +(check-equal? + (call-with-values (λ () (panel:dragable-container-size '((10 20 #f #f) (30 40 #f #f)) 5 #t)) + list) + '(30 65)) + +(check-equal? + (call-with-values (λ () (panel:dragable-container-size '((10 20 #f #f) (30 40 #f #f)) 5 #f)) + list) + '(45 40)) + +(check-equal? + (call-with-values (λ () (panel:dragable-place-children '() 100 200 '() 0 #t)) + list) + '(() ())) + +(check-equal? + (call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f)) 100 200 '(1) 0 #t)) + list) + '(((0 0 100 200)) ())) + +(check-equal? + (call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f)) 100 200 '(1) 0 #f)) + list) + '(((0 0 100 200)) ())) + +(check-equal? + (call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (10 10 #t #f)) 100 300 '(1/2 1/2) 0 #t)) + list) + '(((0 0 100 150) (0 150 100 150)) ((150 150)))) + +(check-equal? + (call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (10 10 #t #f)) 100 300 '(1/2 1/2) 0 #f)) + list) + '(((0 0 50 300) (50 0 50 300)) ((50 50)))) + +(check-equal? + (call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (10 10 #t #f)) 100 300 '(1/3 2/3) 0 #t)) + list) + '(((0 0 100 100) (0 100 100 200)) ((100 100)))) + +(check-equal? + (call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (10 10 #t #f)) 100 300 '(1/10 9/10) 0 #f)) + list) + '(((0 0 10 300) (10 0 90 300)) ((10 10)))) + +(check-equal? + (call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (10 10 #t #f)) 110 300 '(1/10 9/10) 10 #f)) + list) + '(((0 0 10 300) (20 0 90 300)) ((10 20)))) + +(check-equal? + (call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (10 10 #t #f) (10 10 #t #f)) 120 300 '(1/10 2/10 7/10) 10 #f)) + list) + '(((0 0 10 300) (20 0 20 300) (50 0 70 300)) ((10 20) (40 50)))) + +(check-equal? + (call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (70 10 #t #f)) 100 300 '(1/2 1/2) 0 #f)) + list) + '(((0 0 30 300) (30 0 70 300)) ((30 30)))) + +(check-equal? + (call-with-values (λ () (panel:dragable-place-children '((70 10 #t #f) (10 10 #t #f)) 100 300 '(1/2 1/2) 0 #f)) + list) + '(((0 0 70 300) (70 0 30 300)) ((70 70)))) + +(check-equal? + (call-with-values (λ () (panel:dragable-place-children '((70 10 #t #f) (10 10 #t #f) (20 10 #t #f)) 100 300 '(1/2 1/4 1/4) 0 #f)) + list) + '(((0 0 70 300) (70 0 10 300) (80 0 20 300)) ((70 70) (80 80)))) + +(check-equal? + (call-with-values (λ () (panel:dragable-place-children '((30 30 #t #t) (30 30 #t #t)) 490 629 '(1/2 1/2) 5 #f)) + list) + '(((0 0 242 629) (247 0 243 629)) ((242 247)))) diff --git a/gui-test/framework/tests/pasteboard.rkt b/gui-test/framework/tests/pasteboard.rkt index 9fc1a2c33..a22c556d7 100644 --- a/gui-test/framework/tests/pasteboard.rkt +++ b/gui-test/framework/tests/pasteboard.rkt @@ -1,49 +1,82 @@ #lang racket/base -(require "test-suite-utils.rkt") +(require "test-suite-utils.rkt" + rackunit + framework + racket/gui/base + racket/class) -(module test racket/base) +(define (test-creation the-frame% the-editor% name) + (check-not-exn + (λ () + (define c (make-channel)) + (queue-callback + (λ () + (define f + (new (class the-frame% + (define/override (get-editor%) the-editor%) + (super-new)))) + (preferences:set 'framework:exit-when-no-frames #f) + (send f show #t) + (channel-put c (send f get-label)))) + (define frame-label (channel-get c)) + (define seconds 2) + (define resolution 1/100) + (let loop ([n (* seconds resolution)]) + (cond + [(zero? n) + (error 'test-creation "never saw the frame\n test: ~a" name)] + [(let ([f (get-top-level-focus-window)]) + (and f (equal? (send f get-label) frame-label))) + (void)] + [else + (sleep resolution) + (loop (- n 1))])) + (queue-callback + (λ () + (send (get-top-level-focus-window) close) + (channel-put c (void)))) + (channel-get c)))) -(define (test-creation frame class name) - (test - name - (lambda (x) #t) - (lambda () - (let ([frame-label - (queue-sexp-to-mred - `(let* ([f (new (class ,frame - (define/override (get-editor%) ,class) - (super-new)))]) - (preferences:set 'framework:exit-when-no-frames #f) - (send f show #t) - (send f get-label)))]) - (wait-for-frame frame-label) - (queue-sexp-to-mred - `(send (get-top-level-focus-window) close)))))) +(define (run-tests) + (test-creation frame:editor% + (editor:basic-mixin pasteboard%) + 'editor:basic-mixin-creation) + (test-creation frame:editor% + pasteboard:basic% + 'pasteboard:basic-creation) -(test-creation 'frame:editor% - '(editor:basic-mixin pasteboard%) - 'editor:basic-mixin-creation) -(test-creation 'frame:editor% - 'pasteboard:basic% - 'pasteboard:basic-creation) + (test-creation frame:editor% + (editor:file-mixin pasteboard:keymap%) + 'editor:file-mixin-creation) + (test-creation frame:editor% + pasteboard:file% + 'pasteboard:file-creation) -(test-creation 'frame:editor% - '(editor:file-mixin pasteboard:keymap%) - 'editor:file-mixin-creation) -(test-creation 'frame:editor% - 'pasteboard:file% - 'pasteboard:file-creation) + (test-creation frame:editor% + (editor:backup-autosave-mixin pasteboard:file%) + 'editor:backup-autosave-mixin-creation) + (test-creation frame:editor% + pasteboard:backup-autosave% + 'pasteboard:backup-autosave-creation) -(test-creation 'frame:editor% - '(editor:backup-autosave-mixin pasteboard:file%) - 'editor:backup-autosave-mixin-creation) -(test-creation 'frame:editor% - 'pasteboard:backup-autosave% - 'pasteboard:backup-autosave-creation) + (test-creation frame:pasteboard% + (editor:info-mixin pasteboard:backup-autosave%) + 'editor:info-mixin-creation) + (test-creation frame:pasteboard% + pasteboard:info% + 'pasteboard:info-creation)) -(test-creation 'frame:pasteboard% - '(editor:info-mixin pasteboard:backup-autosave%) - 'editor:info-mixin-creation) -(test-creation 'frame:pasteboard% - 'pasteboard:info% - 'pasteboard:info-creation) +(void + (yield + (thread + run-tests))) + +;; this seems to be needed so that the autosave timer's +;; weak boxes empty, so the autosave timer turns itself +;; off, so that racket exits +(void + (thread + (λ () + (for ([i (in-range 10)]) + (collect-garbage) + (sleep 1))))) diff --git a/gui-test/framework/tests/racket-parens-behavior.rkt b/gui-test/framework/tests/racket-parens-behavior.rkt new file mode 100644 index 000000000..ec59ca7cd --- /dev/null +++ b/gui-test/framework/tests/racket-parens-behavior.rkt @@ -0,0 +1,431 @@ +#lang racket/base + +(require "private/util.rkt" + rackunit + racket/class + framework + framework/private/color-local-member-name + racket/gui/base) + +(module+ test + (with-private-prefs + (auto-parens-tests))) + +;; this takes an initial editor state (specified by the text before the cursor, +;; some selected text (may be blank string), and text after the cursor), and +;; a key(s), and runs tests to check what happens when that key(s) is/are +;; typed - in both possible settings of the 'automatic-parens preference +;; +;; final-states is a list of 2-pairs of strings. each pair is the final text before +;; and after the cursor, for auto-parens disabled and enabled respectively +;; (NB. final-states could also contain 3-pairs of strings, the middle portion +;; representing text that is selected after the insertion) +(define (test-parens-behavior/full which + init-text-before init-text-selected init-text-after + keys + final-states) + (define initial-text (string-append init-text-before init-text-selected init-text-after)) + (define initial-start-pos (string-length init-text-before)) + (define initial-end-pos (+ initial-start-pos (string-length init-text-selected))) + (for ([auto? (in-list '(#f #t))] + [final-pair (in-list final-states)]) + (cond + [(= 3 (length final-pair)) + (check-equal? + (run-auto-parens initial-text + (list initial-start-pos initial-end-pos) + keys + auto?) + (list (string-length (car final-pair)) + (string-length (string-append (car final-pair) + (cadr final-pair))) + (apply string-append final-pair)))] + [else + (define final-pos (string-length (car final-pair))) + (check-equal? + (run-auto-parens initial-text + (list initial-start-pos initial-end-pos) + keys + auto?) + (list final-pos + final-pos + (apply string-append final-pair)))]))) + +(define SPECIAL-CHARS '(#\( #\) #\[ #\] #\" #\| #\{ #\})) + +(define (auto-parens-tests) + (for ([k SPECIAL-CHARS]) + ;; test that character literals never result in a pair of characters typed... + (test-parens-behavior/full (format "literal-~a" k) + "(list 1 #\\" "" ")" + k + `([,(string-append "(list 1 #\\" (string k)) ")"] + [,(string-append "(list 1 #\\" (string k)) ")"])) + ;; test that auto-delete doesn't delete closing paren in the above cases, even for literal-( + (test-parens-behavior/full (format "backspace-after-literal-~a" k) + (string-append "(list 1 #\\" (string k)) "" ")" + #\backspace + '(["(list 1 #\\" ")"] ["(list 1 #\\" ")"])) + ;; test of basic cases for auto-parens followed by auto-delete + (test-parens-behavior/full (format "backspace-after-~a" k) + "" "" "" + (list k #\backspace) + '([""] [""])) + ;; test that escaped characters in a string never result in a pair of characters typed... + ;; except for | which is a hard case to detect, because the tokenizer ends up + ;; in an error state + (unless (or (eq? #\| k)) + (test-parens-behavior/full (format "literal-~a-in-string" k) + "\"abc \\" "" "def\"" + k + `([,(string-append "\"abc \\" (string k)) "def\""] + [,(string-append "\"abc \\" (string k)) "def\""]))) + ;; test that auto-parens has no effect in strings, *except for double quotes* + (unless (eq? #\" k) + (test-parens-behavior/full (format "~a-in-string" k) + "\" abc def " "" " \"" + k + `([,(string-append "\" abc def " (string k)) " \""] + [,(string-append "\" abc def " (string k)) " \""]))) + + ;; test that auto-parens has no effect in various comment situations + (define scenarios + ; description before-cursor after-cursor + '(("in-line-comment" ";; abc def " " ghi ") + ("end-of-line-comment" ";; abc def " "") + ("end-of-line-comment-with-newline" ";; abc def " "\n") + ("end-of-line-comment-with-close-paren" ";; abc def " " ) \n )") + ("in-block-comment" "#| abc def " " ghi |#") + )) + (for ([s scenarios]) + (let* ([before (cadr s)] + [after (caddr s)] + [before-final (string-append before (string k))] + [result (list before-final after)]) + (test-parens-behavior/full (format "~a-~a" k (car s)) + before "" after k `(,result ,result))))) + + ;;; assorted other scenarios... + (test-parens-behavior/full 'open-parens + "abcd" "" "efg" ; editor state: before, selected, after + #\( ; key(s) pressed + '(["abcd(" "efg"] ; result state sep by cursor, no auto-parens + ["abcd(" ")efg"])) ; result state with auto-parens + + (test-parens-behavior/full 'open-parens + "ab🏴‍☠️cd" "" "efg" ; editor state: before, selected, after + #\( ; key(s) pressed + '(["ab🏴‍☠️cd(" "efg"] ; result state sep by cursor, no auto-parens + ["ab🏴‍☠️cd(" ")efg"])) + + (test-parens-behavior/full 'open-parens-before-string + "abcd" "" "\"efg\"" + #\( + '(["abcd(" "\"efg\""] ["abcd(" ")\"efg\""])) + (test-parens-behavior/full 'open-parens-before-comment + "abcd" "" "; efg" + #\( + '(["abcd(" "; efg"] ["abcd(" "); efg"])) + + (test-parens-behavior/full 'close-1 + "abcd" "" "efg" + #\) + '(["abcd)" "efg"] ["abcd)" "efg"])) + (test-parens-behavior/full 'close-2 + "(abcd" "" "efg" + #\) + '(["(abcd)" "efg"] ["(abcd)" "efg"])) + (test-parens-behavior/full 'close-3 + "(abcd" "" ")efg" + #\) + '(["(abcd)" ")efg"] ["(abcd)" "efg"])) + (test-parens-behavior/full 'close-4 + "(abcd efg " "" " ) efg" + #\) + '(["(abcd efg )" " ) efg"] + ["(abcd efg )" " efg"])) + (test-parens-behavior/full 'close-5 + "(define before+afters `([\"\" abc \"efg\" 12345 xyz]) [84])" + "" + "" + #\) + '(["(define before+afters `([\"\" abc \"efg\" 12345 xyz]) [84]))" ""] + ["(define before+afters `([\"\" abc \"efg\" 12345 xyz]) [84]))" ""])) + (test-parens-behavior/full 'close-6 + "(define before+afters `([\"\" abc \"efg\"" + "" + " 12345 xyz]) [84])" + #\) + '(["(define before+afters `([\"\" abc \"efg\"]" " 12345 xyz]) [84])"] + ["(define before+afters `([\"\" abc \"efg\"]" " 12345 xyz]) [84])"])) + + + (test-parens-behavior/full 'close-skip-1 + "(define before+afters `([\"\" abc \"efg\" 12345 xyz]" + "" + " ) [84])" + #\) + '(["(define before+afters `([\"\" abc \"efg\" 12345 xyz])" " ) [84])"] + ["(define before+afters `([\"\" abc \"efg\" 12345 xyz] )" " [84])"])) + (test-parens-behavior/full 'close-skip-fixup-1 + "(define before+afters `{[abc 123]" + "" + " ) [84])" + #\) ; here the next close after ) doesn't match the {, so no skip happens + '(["(define before+afters `{[abc 123]}" " ) [84])"] + ["(define before+afters `{[abc 123]}" " ) [84])"])) + (test-parens-behavior/full 'close-skip-fixup-2 + "(define before+afters `{[abc 123]" + "" + " } [84])" + #\) ; here the next close does match the {, so skip + '(["(define before+afters `{[abc 123]}" " } [84])"] + ["(define before+afters `{[abc 123] }" " [84])"])) + + (test-parens-behavior/full 'surround-open-1 + "abcd" "ef" "g" + #\( + '(["abcd(" "g"] ["abcd(" "ef)g"])) + + (test-parens-behavior/full 'double-quote-1 + "" "" "" + #\" + '(["\"" ""] ["\"" "\""])) + (test-parens-behavior/full 'double-quote-2 + "abc " "" "" + #\" + '(["abc \"" ""] ["abc \"" "\""])) + (test-parens-behavior/full 'double-quote-selection-1 + "(abc " "def 123" " xyz]" + #\" + '(["(abc \"" " xyz]"] ["(abc \"" "def 123\" xyz]"])) + (test-parens-behavior/full 'double-quote-skip-1 + "\"abc def " "" "\" 123" + #\" + '(["\"abc def \"" "\" 123"] ["\"abc def \"" " 123"])) + (test-parens-behavior/full 'double-quote-escaped-1 + "\"abcd \\" "" "" + #\" + '(["\"abcd \\\"" ""] + ["\"abcd \\\"" "\""])) ; this inserts double since string was not closed + (test-parens-behavior/full 'double-quote-escaped-2 + "\"abcd \\" "" "\"" + #\" + '(["\"abcd \\\"" "\""] + ["\"abcd \\\"" "\""])) + (test-parens-behavior/full 'double-quote-before-comment + "" "" "; 123" + #\" + '(["\"" "; 123"] ["\"" "\"; 123"])) + (test-parens-behavior/full 'double-quote-before-later-string + "" "" " \"\" " + #\" + '(["\"" " \"\" "] ["\"" "\" \"\" "])) + + (test-parens-behavior/full 'bar + "abc " "" "123" + #\| + '(["abc |" "123"] ["abc |" "|123"])) + (test-parens-behavior/full 'bar-literal + "(list 1 #\\" "" ")" + #\| + '(["(list 1 #\\|" ")"] ["(list 1 #\\|" ")"])) + (test-parens-behavior/full 'bar-skip + "abc |def" "" "|123" + #\| + '(["abc |def|" "|123"] ["abc |def|" "123"])) + (test-parens-behavior/full 'bar-selection + "abc |def " "hij" "|123" + #\| + '(["abc |def |" "|123"] ["abc |def |" "hij||123"])) + (test-parens-behavior/full 'bar-before-string + "abc " "" "\"123\"" + #\| + '(["abc |" "\"123\""] ["abc |" "|\"123\""])) + (test-parens-behavior/full 'bar-before-comment + "abc " "" "; 123" + #\| + '(["abc |" "; 123"] ["abc |" "|; 123"])) + + + (test-parens-behavior/full 'block-comment-1 + " #" "" "" + #\| + '([" #|" ""] + [" #|" "|#"])) + (test-parens-behavior/full 'block-comment-2 + "(123 abc#" "" " def 456)" + #\| + '(["(123 abc#|" " def 456)"] + ["(123 abc#|" "|# def 456)"])) + (test-parens-behavior/full 'block-comment-skip-1 + "#| (123 abc" "" "|# def 456)" + #\| + '(["#| (123 abc|" "|# def 456)"] + ["#| (123 abc|#" " def 456)"])) + + (test-parens-behavior/full 'close-adjusts-properly-when-space-follows-paren + "( x" "" "" + #\] + '(["( x)" "" ""] + ["( x)" "" ""])) + (test-parens-behavior/full 'close-adjusts-properly-when-inside-a-comment + "[();" "" "" + #\) + '(["[();)" "" ""] + ["[();)" "" ""])) + (test-parens-behavior/full 'close-adjusts-properly-when-inside-a-comment.2 + "[;" "" "\n" + #\) + '(["[;)" "" "\n"] + ["[;)" "" "\n"])) + (test-parens-behavior/full 'close-adjusts-properly-at-eol-of-line-comment + "(;" "" "\n)" + #\) + '(["(;)" "" "\n)"] + ["(;)" "" "\n)"])) + (test-parens-behavior/full 'close-adjusts-properly-after-a-block-comment + "(#||#" "" "\n)" + #\) + '(["(#||#)" "" "\n)"] + ["(#||#\n)" "" ""])) + (test-parens-behavior/full 'close-adjusts-properly-when-inside-an-unclosed-string + "[()\"" "" "" + #\) + '(["[()\")" "" ""] + ["[()\")" "" ""])) + (test-parens-behavior/full 'close-adjusts-properly-when-inside-a-string + "[()\"" "" "\"" + #\) + '(["[()\")" "" "\""] + ["[()\")" "" "\""])) + + (test-parens-behavior/full 'close-adjusts-properly-when-no-containing-sexp + ")" "" "" + #\] + '([")]" "" ""] + [")]" "" ""])) + + (test-parens-behavior/full '|"-splits-string| + " \"abcd" "" "efg\" " + #\" + '([" \"abcd\"" "efg\" "] + [" \"abcd\" " "\"efg\" "])) + (test-parens-behavior/full '|"-splits-string-at-beginning| + " \"" "" "abcdefg\" " + #\" + '([" \"\"" "abcdefg\" "] + [" \"\" " "\"abcdefg\" "])) + (test-parens-behavior/full '|"-splits-out-selected-string| + " \"abc" "def" "ghi\" " + #\" + '([" \"abc\"" "" "ghi\" "] + ; test that "def" remains selected afterwards... + [" \"abc\" " "\"def\"" " \"ghi\" "])) + + (test-parens-behavior/full 'delete-empty-block-comment + " #|" "" "|#" + #\backspace + '([" #" "|#"] + [" #" ""])) + (test-parens-behavior/full 'delete-bars-with-hash + " |" "" "|#" + #\backspace + '([" " "|#"] + [" " "#"])) + (test-parens-behavior/full 'delete-one-bar-between-hashes-in-string + " \"#|" "" "|#\"" + #\backspace + '([" \"#" "|#\""] + [" \"#" "|#\""])) + (test-parens-behavior/full 'delete-escaped-double-quote-in-string + "\"abcd \\\"" "" "\"" + #\backspace + '(["\"abcd \\" "\""] + ["\"abcd \\" "\""])) ; don't delete the non-escaped double quote + + ;; test that backspace only removes one character in most cases in non-empty strings and comments + (for ([open '("(" "[" "{" "\"" "|")] + [close '(")" "]" "}" "\"" "|")]) + (define single-delete-scenarios + ; description before-cursor after-cursor + '(("in-line-comment" ";; abc def " " ghi ") + ("in-block-comment" "#| abc def " " ghi |#") + ("in-string" "\" abc def " " ghi \"") + )) + (for ([s single-delete-scenarios] + #:unless (and (string=? "\"" open) + (string=? "in-string" (car s)))) + (let* ([before (cadr s)] + [after (string-append close (caddr s))] + [before-and-open (string-append before open)] + [result (list before after)]) + (test-parens-behavior/full (format "~a-~a" (string-append open close) (car s)) + before-and-open "" after #\backspace `(,result ,result))))) + + (let () + (define fixup-open-parens (preferences:get 'framework:fixup-open-parens)) + (define k (new key-event% + [key-code #\[] + [control-down #t])) + (preferences:set 'framework:fixup-open-parens #t) + (test-parens-behavior/full 'open-parens + "abc" "def" "ghi" ; editor state: before, selected, after + (list k) ; key(s) pressed + '(["abc[" "ghi"] ; result state sep by cursor, no auto-parens + ["abc[" "def]ghi"])) ; result state with auto-parens + (preferences:set 'framework:fixup-open-parens fixup-open-parens)) + + #| for these, the key-event with meta-down doesn't seem to work... maybe a Mac OS + issue; and may cause problems with these tests on another platform? .nah. |# + (when (equal? 'macosx (system-type)) + (test-parens-behavior/full 'meta-open-1 + "abcd" "" "efg" + '(escape #\() ; '((new key-event% [key-code #\(] [meta-down #t])) + '(["abcd(" ")efg"] ["abcd(" ")efg"])) + + (test-parens-behavior/full 'meta-close-skip-1 + "(define before (list 1 2" "" " 3 4)" + '(escape #\)) ; '((new key-event% [key-code #\)] [meta-down #t])) + '(["(define before (list 1 2 3 4)" ""] + ["(define before (list 1 2 3 4)" ""])) + (test-parens-behavior/full + 'meta-close-skip-2 + "#lang racket\n(define before+afters `([\"\" abc \"efg\"" + "" + " 12345 xyz] [84])" + '(escape #\)) ;'((new key-event% [key-code #\)] [meta-down #t])) + '(["#lang racket\n(define before+afters `([\"\" abc \"efg\" 12345 xyz]" " [84])"] + ["#lang racket\n(define before+afters `([\"\" abc \"efg\" 12345 xyz]" " [84])"])) + (test-parens-behavior/full 'meta-close-skip-3 + "(define before" "" " (list 1 2 3 4)" + '(escape #\)) ; '((new key-event% [key-code #\)] [meta-down #t])) + '(["(define before (list 1 2 3 4)" ""] + ["(define before (list 1 2 3 4)" ""])))) + + +(define (run-auto-parens initial-text initial-pos keys [auto-parens? #f]) + (define t (new racket:text%)) + (define f (new frame% [label ""] [width 600] [height 600])) + (define ec (new editor-canvas% [parent f] [editor t])) + (preferences:set 'framework:fixup-parens #t) + (preferences:set 'framework:automatic-parens auto-parens?) + (send f reflow-container) + (send t insert initial-text) + (if (number? initial-pos) + (send t set-position initial-pos) + (send t set-position (car initial-pos) (cadr initial-pos))) + (for ([k (in-list (if (list? keys) keys (list keys)))]) + (cond + [(char? k) + (send (racket:get-keymap) handle-key-event t (new key-event% [key-code k]))] + [(string? k) + (send (racket:get-keymap) handle-key-event t + (new key-event% [key-code (car (string->list k))]))] + [(symbol? k) + (send (racket:get-keymap) + handle-key-event t (new key-event% [key-code k]))] + [else (send (racket:get-keymap) handle-key-event t k)])) + (list (send t get-start-position) + (send t get-end-position) + (send t get-text))) diff --git a/gui-test/framework/tests/racket.rkt b/gui-test/framework/tests/racket.rkt index eec148d36..9c6773ec7 100644 --- a/gui-test/framework/tests/racket.rkt +++ b/gui-test/framework/tests/racket.rkt @@ -4,17 +4,194 @@ rackunit racket/class framework + framework/private/color-local-member-name racket/gui/base) (module+ test (with-private-prefs + (test-commenting) (test-get-matching-paren-string) (open-paren-typing) + (test-forward-match) (test-text-balanced) + (test-highlighting) (indentation-tests) (magic-square-bracket-tests) (insert-return-tests) - (test-message-send))) + (test-message-send) + (ensure-new-racket-mode-parameter-preserves-alt-as-meta-keys))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; testing comment-out-selection and related methods +;; + +(define (test-commenting) + + (let () + (define t (new racket:text%)) + (send t comment-out-selection) + (check-equal? (send t get-text) ";")) + + (let () + (define t (new racket:text%)) + (send t insert "ab\ncd") + (send t set-position 0 (send t last-position)) + (send t comment-out-selection) + (check-equal? (send t get-text) ";ab\n;cd")) + + (let () + (define t (new racket:text%)) + (send t insert "ab\ncd") + (send t set-position 1 (- (send t last-position) 1)) + (send t comment-out-selection) + (check-equal? (send t get-text) ";ab\n;cd")) + + (let () + (define t (new racket:text%)) + (send t insert "ab\ncd") + (send t set-position 1 (- (send t last-position) 1)) + (send t comment-out-selection #:start "#") + (check-equal? (send t get-text) "#ab\n#cd")) + + (let () + (define t (new racket:text%)) + (send t insert "ab\ncd") + (send t set-position 1 (- (send t last-position) 1)) + (send t comment-out-selection #:start "#" #:padding " ") + (check-equal? (send t get-text) "# ab\n# cd")) + + (let () + (define t (new racket:text%)) + (send t insert "ab\ncd") + (send t set-position 1 2) + (send t region-comment-out-selection) + (check-equal? (send t get-text) + "a#| b |#\ncd")) + (let () + (define t (new racket:text%)) + (send t insert "ab\ncd") + (send t set-position 1 4) + (send t region-comment-out-selection) + (check-equal? (send t get-text) + "a#| b\nc |#d")) + (let () + (define t (new racket:text%)) + (send t insert "ab\ncd\nef") + (send t set-position 1 7) + (send t region-comment-out-selection) + (check-equal? (send t get-text) + "a#| b\n cd\ne |#f")) + + (let () + (define t (new racket:text%)) + (send t insert " # ab\n ;cd") + (send t set-position 0 (send t last-position)) + (check-equal? (send t commented-out/line? #:start "#") #t) + (check-equal? (send t commented-out/line? #:start ";") #t) + (check-equal? (send t commented-out/line? #:start ";" 0 0) #f) + (check-equal? (send t commented-out/line? #:start ";" + (send t last-position) (send t last-position)) + #t) + (check-equal? (send t commented-out/line? #:start "#" 0 0) #t) + (check-equal? (send t commented-out/line? #:start "#" + (send t last-position) (send t last-position)) + #f)) + + (let () + (define t (new racket:text%)) + (send t insert " #| ab\n c |# d") + (send t set-position 0 (send t last-position)) + (check-equal? (send t commented-out/region?) #t)) + + (let () + (define t (new racket:text%)) + (send t insert " #| ab\n qq\n c |# d") + (send t set-position 0 (send t last-position)) + (check-equal? (send t commented-out/region?) #t)) + + (let () + (define t (new racket:text%)) + (send t insert "a #| |# z") + (send t set-position 0 (send t last-position)) + (check-equal? (send t commented-out/region?) #t)) + + (let () + (define t (new racket:text%)) + (send t insert ";ab\n;cd") + (send t set-position 0 (send t last-position)) + (send t uncomment-selection) + (check-equal? (send t get-text) "ab\ncd")) + + (let () + (define t (new racket:text%)) + (send t insert ";ab\n;cd") + (send t set-position 1 (- (send t last-position) 1)) + (send t uncomment-selection) + (check-equal? (send t get-text) "ab\ncd")) + + (let () + (define t (new racket:text%)) + (send t insert " ; ab\n ;cd") + (send t set-position 1 (- (send t last-position) 1)) + (send t uncomment-selection) + (check-equal? (send t get-text) " ab\n cd")) + + (let () + (define t (new racket:text%)) + (send t insert "#ab\n#cd") + (send t set-position 0 (send t last-position)) + (send t uncomment-selection #:start "#") + (check-equal? (send t get-text) "ab\ncd")) + + (let () + (define t (new racket:text%)) + (send t insert "##ab\n##cd") + (send t set-position 0 (send t last-position)) + (send t uncomment-selection #:start "##") + (check-equal? (send t get-text) "ab\ncd")) + + (let () + (define t (new racket:text%)) + (send t insert " # ab\n #cd") + (send t set-position 1 (- (send t last-position) 1)) + (send t uncomment-selection #:start "#") + (check-equal? (send t get-text) " ab\n cd")) + + (let () + (define t (new racket:text%)) + (send t insert " # ab\n # cd\n# ef\n#g") + (send t set-position 1 (- (send t last-position) 1)) + (send t uncomment-selection #:start "#" #:padding " ") + (check-equal? (send t get-text) " ab\n cd\nef\ng")) + + (let () + (define t (new racket:text%)) + (send t insert " #| ab\n c |# d") + (send t set-position 0 (send t last-position)) + (send t uncomment-selection/region) + (check-equal? (send t get-text) " ab\n c d")) + + (let () + (define t (new racket:text%)) + (send t insert " #| ab\n qq\n c |# d") + (send t set-position 0 (send t last-position)) + (send t uncomment-selection/region) + (check-equal? (send t get-text) " ab\n qq\n c d")) + + (let () + (define t (new racket:text%)) + (send t insert " #| ab\n qq\n c |# d") + (send t set-position 0 (send t last-position)) + (send t uncomment-selection/region) + (check-equal? (send t get-text) " ab\n qq\n c d")) + + (let () + (define t (new racket:text%)) + (send t insert "a #| |# z") + (send t set-position 0 (send t last-position)) + (send t uncomment-selection/region) + (check-equal? (send t get-text) "a z"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -43,12 +220,15 @@ ;; testing inserting parens and the automatic-parens prefs ;; -(define (type-something to-type [control-down #f]) +(define (type-something to-type + #:control-down [control-down #f] + #:stop-colorer? [stop-colorer? #f]) (define f (new frame:basic% [label ""])) (define t (new racket:text%)) (define ec (new canvas:basic% [parent (send f get-area-container)] [editor t])) + (when stop-colorer? (send t stop-colorer)) (send t on-char (new key-event% [key-code to-type] [control-down control-down])) (send t get-text)) @@ -60,11 +240,17 @@ (check-equal? (type-something #\() "(") (check-equal? (type-something #\[) "[") (check-equal? (type-something #\") "\"") + (check-equal? (type-something #\( #:stop-colorer? #t) "(") + (check-equal? (type-something #\[ #:stop-colorer? #t) "[") + (check-equal? (type-something #\" #:stop-colorer? #t) "\"") (preferences:set 'framework:automatic-parens #t) (check-equal? (type-something #\() "()") (check-equal? (type-something #\[) "[]") (check-equal? (type-something #\") "\"\"") + (check-equal? (type-something #\( #:stop-colorer? #t) "()") + (check-equal? (type-something #\[ #:stop-colorer? #t) "[]") + (check-equal? (type-something #\" #:stop-colorer? #t) "\"\"") (preferences:set 'framework:fixup-parens #f) (preferences:set 'framework:fixup-open-parens #t) @@ -72,13 +258,21 @@ (preferences:set 'framework:automatic-parens #f) (check-equal? (type-something #\() "(") (check-equal? (type-something #\[) "(") - (check-equal? (type-something #\[ #t) "[") + (check-equal? (type-something #\[ #:control-down #t) "[") (check-equal? (type-something #\") "\"") + (check-equal? (type-something #\( #:stop-colorer? #t) "(") + (check-equal? (type-something #\[ #:stop-colorer? #t) "[") ;; if the colorer is off, no auto parens + (check-equal? (type-something #\[ #:stop-colorer? #t #:control-down #t) "[") + (check-equal? (type-something #\" #:stop-colorer? #t) "\"") (preferences:set 'framework:automatic-parens #t) (check-equal? (type-something #\() "()") (check-equal? (type-something #\[) "()") - (check-equal? (type-something #\[ #t) "[]") + (check-equal? (type-something #\[ #:control-down #t) "[]") (check-equal? (type-something #\") "\"\"") + (check-equal? (type-something #\( #:stop-colorer? #t) "()") + (check-equal? (type-something #\[ #:stop-colorer? #t) "[]") ;; if the colorer is off, no auto parens + (check-equal? (type-something #\[ #:stop-colorer? #t #:control-down #t) "[]") + (check-equal? (type-something #\" #:stop-colorer? #t) "\"\"") (preferences:set 'framework:fixup-parens #t) (preferences:set 'framework:fixup-open-parens #f) @@ -87,10 +281,13 @@ (check-equal? (type-something #\() "(") (check-equal? (type-something #\[) "[") (check-equal? (type-something #\") "\"") + (check-equal? (type-something #\( #:stop-colorer? #t) "(") + (check-equal? (type-something #\[ #:stop-colorer? #t) "[") + (check-equal? (type-something #\" #:stop-colorer? #t) "\"") (preferences:set 'framework:automatic-parens #t) - (check-equal? (type-something #\() "()") - (check-equal? (type-something #\[) "[]") - (check-equal? (type-something #\") "\"\"") + (check-equal? (type-something #\( #:stop-colorer? #t) "()") + (check-equal? (type-something #\[ #:stop-colorer? #t) "[]") + (check-equal? (type-something #\" #:stop-colorer? #t) "\"\"") (preferences:set 'framework:fixup-parens #t) (preferences:set 'framework:fixup-open-parens #t) @@ -99,34 +296,109 @@ (check-equal? (type-something #\() "(") (check-equal? (type-something #\[) "(") (check-equal? (type-something #\") "\"") + (check-equal? (type-something #\( #:stop-colorer? #t) "(") + (check-equal? (type-something #\[ #:stop-colorer? #t) "[") ;; if the colorer is off, no auto parens + (check-equal? (type-something #\" #:stop-colorer? #t) "\"") (preferences:set 'framework:automatic-parens #t) (check-equal? (type-something #\() "()") (check-equal? (type-something #\[) "()") - (check-equal? (type-something #\") "\"\"")) + (check-equal? (type-something #\") "\"\"") + (check-equal? (type-something #\( #:stop-colorer? #t) "()") + (check-equal? (type-something #\[ #:stop-colorer? #t) "[]") ;; if the colorer is off, no auto parens + (check-equal? (type-something #\" #:stop-colorer? #t) "\"\"")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; testing highlight-range method ;; +; - -(define (text-balanced? number str start end) +(define (text-balanced? str start end) (define t (new racket:text%)) (send t insert str) (racket:text-balanced? t start end)) (define (test-text-balanced) - (check-equal? (text-balanced? 0 "" 0 #f) #f) - (check-equal? (text-balanced? 1 " \n " 0 #f) #f) - (check-equal? (text-balanced? 2 "foo)" 0 #f) #t) - (check-equal? (text-balanced? 3 "(foo" 0 #f) #f) - (check-equal? (text-balanced? 4 "(foo)" 0 #f) #t) - (check-equal? (text-balanced? 5 "(foo 'bar))" 0 #f) #t) - (check-equal? (text-balanced? 6 "(foo) bar ([buz])" 0 #f) #t) - (check-equal? (text-balanced? 7 "(foo]" 0 #f) #t) - (check-equal? (text-balanced? 8 "{foo} ((bar) [5.9])" 0 #f) #t) - (check-equal? (text-balanced? 9 "#(1 2 . 3)" 0 #f) #t)) + (check-equal? (text-balanced? "" 0 #f) #f) + (check-equal? (text-balanced? " \n " 0 #f) #f) + (check-equal? (text-balanced? "foo)" 0 #f) #t) + (check-equal? (text-balanced? "(foo" 0 #f) #f) + (check-equal? (text-balanced? "(foo)" 0 #f) #t) + (check-equal? (text-balanced? "(🏴‍☠️)" 0 6) #t) + (check-equal? (text-balanced? "(🏴‍☠️)" 0 #f) #t) + (check-equal? (text-balanced? "(foo 'bar))" 0 #f) #t) + (check-equal? (text-balanced? "(foo) bar ([buz])" 0 #f) #t) + (check-equal? (text-balanced? "(foo]" 0 #f) #t) + (check-equal? (text-balanced? "{foo} ((bar) [5.9])" 0 #f) #t) + (check-equal? (text-balanced? "#(1 2 . 3)" 0 #f) #t)) + +(define (test-forward-match) + (define t (new racket:text%)) + (send t insert " (\n") + (send t reset-regions '((3 3) (5 end))) + (send t insert "> (f 01234 56 789 2 3\n") + (send t freeze-colorer) + (send t thaw-colorer) + (check-equal? (send t forward-match 8 (send t last-position)) 13) + (check-equal? (send t forward-match 13 (send t last-position)) 16)) + +(define shrubbery-available? + (with-handlers ([exn:fail? (lambda (x) #f)]) + (collection-path "shrubbery") + #t)) +(unless shrubbery-available? + (printf "racket.rkt: skipping tests that require shrubbery\n")) + +(define (test-highlighting) + (preferences:set 'framework:paren-color-scheme 'shades-of-gray) + (define t (new racket:text%)) + (define f (new frame% [label ""] [width 600] [height 600])) + (define ec (new editor-canvas% [parent f] [editor t])) + (send f reflow-container) + (send t freeze-colorer) + + (define (check-parens str pos) + (send t thaw-colorer) + (send t erase) + (send t insert str) + (send t set-position pos) + (send t freeze-colorer) + (send t match-parens) + (sort + (for/list ([r (in-list (send t get-highlighted-ranges))]) + (list (text:range-start r) + (text:range-end r))) + rangelist k))]))] - [(symbol? k) - (send (racket:get-keymap) - handle-key-event t (new key-event% [key-code k]))] - [else (send (racket:get-keymap) handle-key-event t k)])) - (list (send t get-start-position) - (send t get-end-position) - (send t get-text))) - - -;; this takes an initial editor state (specified by the text before the cursor, -;; some selected text (may be blank string), and text after the cursor), and -;; a key(s), and runs tests to check what happens when that key(s) is/are -;; typed - in both possible settings of the 'automatic-parens preference -;; -;; final-states is a list of 2-pairs of strings. each pair is the final text before -;; and after the cursor, for auto-parens disabled and enabled respectively -;; (NB. final-states could also contain 3-pairs of strings, the middle portion -;; representing text that is selected after the insertion) -(define (test-parens-behavior/full which - init-text-before init-text-selected init-text-after - keys - final-states) - (define initial-text (string-append init-text-before init-text-selected init-text-after)) - (define initial-start-pos (string-length init-text-before)) - (define initial-end-pos (+ initial-start-pos (string-length init-text-selected))) - (for ([auto? (in-list '(#f #t))] - [final-pair (in-list final-states)]) - (cond - [(= 3 (length final-pair)) - (check-equal? - (run-auto-parens initial-text - (list initial-start-pos initial-end-pos) - keys - auto?) - (list (string-length (car final-pair)) - (string-length (string-append (car final-pair) - (cadr final-pair))) - (apply string-append final-pair)))] - [else - (define final-pos (string-length (car final-pair))) - (check-equal? - (run-auto-parens initial-text - (list initial-start-pos initial-end-pos) - keys - auto?) - (list final-pos - final-pos - (apply string-append final-pair)))]))) - - -(define SPECIAL-CHARS '(#\( #\) #\[ #\] #\" #\| #\{ #\})) - -(for ([k SPECIAL-CHARS]) - ;; test that character literals never result in a pair of characters typed... - (test-parens-behavior/full (format "literal-~a" k) - "(list 1 #\\" "" ")" - k - `([,(string-append "(list 1 #\\" (string k)) ")"] - [,(string-append "(list 1 #\\" (string k)) ")"])) - ;; test that auto-delete doesn't delete closing paren in the above cases, even for literal-( - (test-parens-behavior/full (format "backspace-after-literal-~a" k) - (string-append "(list 1 #\\" (string k)) "" ")" - #\backspace - '(["(list 1 #\\" ")"] ["(list 1 #\\" ")"])) - ;; test of basic cases for auto-parens followed by auto-delete - (test-parens-behavior/full (format "backspace-after-~a" k) - "" "" "" - (list k #\backspace) - '([""] [""])) - ;; test that escaped characters in a string never result in a pair of characters typed... - ;; except for | which is a hard case to detect, because the tokenizer ends up - ;; in an error state - (unless (or (eq? #\| k)) - (test-parens-behavior/full (format "literal-~a-in-string" k) - "\"abc \\" "" "def\"" - k - `([,(string-append "\"abc \\" (string k)) "def\""] - [,(string-append "\"abc \\" (string k)) "def\""]))) - ;; test that auto-parens has no effect in strings, *except for double quotes* - (unless (eq? #\" k) - (test-parens-behavior/full (format "~a-in-string" k) - "\" abc def " "" " \"" - k - `([,(string-append "\" abc def " (string k)) " \""] - [,(string-append "\" abc def " (string k)) " \""]))) - - ;; test that auto-parens has no effect in various comment situations - (define scenarios - ; description before-cursor after-cursor - '(("in-line-comment" ";; abc def " " ghi ") - ("end-of-line-comment" ";; abc def " "") - ("end-of-line-comment-with-newline" ";; abc def " "\n") - ("end-of-line-comment-with-close-paren" ";; abc def " " ) \n )") - ("in-block-comment" "#| abc def " " ghi |#") - )) - (for ([s scenarios]) - (let* ([before (cadr s)] - [after (caddr s)] - [before-final (string-append before (string k))] - [result (list before-final after)]) - (test-parens-behavior/full (format "~a-~a" k (car s)) - before "" after k `(,result ,result))))) - -;;; assorted other scenarios... -(test-parens-behavior/full 'open-parens - "abcd" "" "efg" ; editor state: before, selected, after - #\( ; key(s) pressed - '(["abcd(" "efg"] ; result state sep by cursor, no auto-parens - ["abcd(" ")efg"])) ; result state with auto-parens - -(test-parens-behavior/full 'open-parens-before-string - "abcd" "" "\"efg\"" - #\( - '(["abcd(" "\"efg\""] ["abcd(" ")\"efg\""])) -(test-parens-behavior/full 'open-parens-before-comment - "abcd" "" "; efg" - #\( - '(["abcd(" "; efg"] ["abcd(" "); efg"])) - -(test-parens-behavior/full 'close-1 - "abcd" "" "efg" - #\) - '(["abcd)" "efg"] ["abcd)" "efg"])) -(test-parens-behavior/full 'close-2 - "(abcd" "" "efg" - #\) - '(["(abcd)" "efg"] ["(abcd)" "efg"])) -(test-parens-behavior/full 'close-3 - "(abcd" "" ")efg" - #\) - '(["(abcd)" ")efg"] ["(abcd)" "efg"])) -(test-parens-behavior/full 'close-4 - "(abcd efg " "" " ) efg" - #\) - '(["(abcd efg )" " ) efg"] - ["(abcd efg )" " efg"])) -(test-parens-behavior/full 'close-5 - "(define before+afters `([\"\" abc \"efg\" 12345 xyz]) [84])" - "" - "" - #\) - '(["(define before+afters `([\"\" abc \"efg\" 12345 xyz]) [84]))" ""] - ["(define before+afters `([\"\" abc \"efg\" 12345 xyz]) [84]))" ""])) -(test-parens-behavior/full 'close-6 - "(define before+afters `([\"\" abc \"efg\"" - "" - " 12345 xyz]) [84])" - #\) - '(["(define before+afters `([\"\" abc \"efg\"]" " 12345 xyz]) [84])"] - ["(define before+afters `([\"\" abc \"efg\"]" " 12345 xyz]) [84])"])) - - -(test-parens-behavior/full 'close-skip-1 - "(define before+afters `([\"\" abc \"efg\" 12345 xyz]" - "" - " ) [84])" - #\) - '(["(define before+afters `([\"\" abc \"efg\" 12345 xyz])" " ) [84])"] - ["(define before+afters `([\"\" abc \"efg\" 12345 xyz] )" " [84])"])) -(test-parens-behavior/full 'close-skip-fixup-1 - "(define before+afters `{[abc 123]" - "" - " ) [84])" - #\) ; here the next close after ) doesn't match the {, so no skip happens - '(["(define before+afters `{[abc 123]}" " ) [84])"] - ["(define before+afters `{[abc 123]}" " ) [84])"])) -(test-parens-behavior/full 'close-skip-fixup-2 - "(define before+afters `{[abc 123]" - "" - " } [84])" - #\) ; here the next close does match the {, so skip - '(["(define before+afters `{[abc 123]}" " } [84])"] - ["(define before+afters `{[abc 123] }" " [84])"])) - -(test-parens-behavior/full 'surround-open-1 - "abcd" "ef" "g" - #\( - '(["abcd(" "g"] ["abcd(" "ef)g"])) - -(test-parens-behavior/full 'double-quote-1 - "" "" "" - #\" - '(["\"" ""] ["\"" "\""])) -(test-parens-behavior/full 'double-quote-2 - "abc " "" "" - #\" - '(["abc \"" ""] ["abc \"" "\""])) -(test-parens-behavior/full 'double-quote-selection-1 - "(abc " "def 123" " xyz]" - #\" - '(["(abc \"" " xyz]"] ["(abc \"" "def 123\" xyz]"])) -(test-parens-behavior/full 'double-quote-skip-1 - "\"abc def " "" "\" 123" - #\" - '(["\"abc def \"" "\" 123"] ["\"abc def \"" " 123"])) -(test-parens-behavior/full 'double-quote-escaped-1 - "\"abcd \\" "" "" - #\" - '(["\"abcd \\\"" ""] - ["\"abcd \\\"" "\""])) ; this inserts double since string was not closed -(test-parens-behavior/full 'double-quote-escaped-2 - "\"abcd \\" "" "\"" - #\" - '(["\"abcd \\\"" "\""] - ["\"abcd \\\"" "\""])) -(test-parens-behavior/full 'double-quote-before-comment - "" "" "; 123" - #\" - '(["\"" "; 123"] ["\"" "\"; 123"])) -(test-parens-behavior/full 'double-quote-before-later-string - "" "" " \"\" " - #\" - '(["\"" " \"\" "] ["\"" "\" \"\" "])) - -(test-parens-behavior/full 'bar - "abc " "" "123" - #\| - '(["abc |" "123"] ["abc |" "|123"])) -(test-parens-behavior/full 'bar-literal - "(list 1 #\\" "" ")" - #\| - '(["(list 1 #\\|" ")"] ["(list 1 #\\|" ")"])) -(test-parens-behavior/full 'bar-skip - "abc |def" "" "|123" - #\| - '(["abc |def|" "|123"] ["abc |def|" "123"])) -(test-parens-behavior/full 'bar-selection - "abc |def " "hij" "|123" - #\| - '(["abc |def |" "|123"] ["abc |def |" "hij||123"])) -(test-parens-behavior/full 'bar-before-string - "abc " "" "\"123\"" - #\| - '(["abc |" "\"123\""] ["abc |" "|\"123\""])) -(test-parens-behavior/full 'bar-before-comment - "abc " "" "; 123" - #\| - '(["abc |" "; 123"] ["abc |" "|; 123"])) - - -(test-parens-behavior/full 'block-comment-1 - " #" "" "" - #\| - '([" #|" ""] - [" #|" "|#"])) -(test-parens-behavior/full 'block-comment-2 - "(123 abc#" "" " def 456)" - #\| - '(["(123 abc#|" " def 456)"] - ["(123 abc#|" "|# def 456)"])) -(test-parens-behavior/full 'block-comment-skip-1 - "#| (123 abc" "" "|# def 456)" - #\| - '(["#| (123 abc|" "|# def 456)"] - ["#| (123 abc|#" " def 456)"])) - -(test-parens-behavior/full 'close-adjusts-properly-when-space-follows-paren - "( x" "" "" - #\] - '(["( x)" "" ""] - ["( x)" "" ""])) -(test-parens-behavior/full 'close-adjusts-properly-when-inside-a-comment - "[();" "" "" - #\) - '(["[();)" "" ""] - ["[();)" "" ""])) -(test-parens-behavior/full 'close-adjusts-properly-when-inside-a-comment.2 - "[;" "" "\n" - #\) - '(["[;)" "" "\n"] - ["[;)" "" "\n"])) -(test-parens-behavior/full 'close-adjusts-properly-at-eol-of-line-comment - "(;" "" "\n)" - #\) - '(["(;)" "" "\n)"] - ["(;)" "" "\n)"])) -(test-parens-behavior/full 'close-adjusts-properly-after-a-block-comment - "(#||#" "" "\n)" - #\) - '(["(#||#)" "" "\n)"] - ["(#||#\n)" "" ""])) -(test-parens-behavior/full 'close-adjusts-properly-when-inside-an-unclosed-string - "[()\"" "" "" - #\) - '(["[()\")" "" ""] - ["[()\")" "" ""])) -(test-parens-behavior/full 'close-adjusts-properly-when-inside-a-string - "[()\"" "" "\"" - #\) - '(["[()\")" "" "\""] - ["[()\")" "" "\""])) - -(test-parens-behavior/full 'close-adjusts-properly-when-no-containing-sexp - ")" "" "" - #\] - '([")]" "" ""] - [")]" "" ""])) - -(test-parens-behavior/full '|"-splits-string| - " \"abcd" "" "efg\" " - #\" - '([" \"abcd\"" "efg\" "] - [" \"abcd\" " "\"efg\" "])) -(test-parens-behavior/full '|"-splits-string-at-beginning| - " \"" "" "abcdefg\" " - #\" - '([" \"\"" "abcdefg\" "] - [" \"\" " "\"abcdefg\" "])) -(test-parens-behavior/full '|"-splits-out-selected-string| - " \"abc" "def" "ghi\" " - #\" - '([" \"abc\"" "" "ghi\" "] - ; test that "def" remains selected afterwards... - [" \"abc\" " "\"def\"" " \"ghi\" "])) - -(test-parens-behavior/full 'delete-empty-block-comment - " #|" "" "|#" - #\backspace - '([" #" "|#"] - [" #" ""])) -(test-parens-behavior/full 'delete-bars-with-hash - " |" "" "|#" - #\backspace - '([" " "|#"] - [" " "#"])) -(test-parens-behavior/full 'delete-one-bar-between-hashes-in-string - " \"#|" "" "|#\"" - #\backspace - '([" \"#" "|#\""] - [" \"#" "|#\""])) -(test-parens-behavior/full 'delete-escaped-double-quote-in-string - "\"abcd \\\"" "" "\"" - #\backspace - '(["\"abcd \\" "\""] - ["\"abcd \\" "\""])) ; don't delete the non-escaped double quote - -;; test that backspace only removes one character in most cases in non-empty strings and comments -(for ([open '("(" "[" "{" "\"" "|")] - [close '(")" "]" "}" "\"" "|")]) - (define single-delete-scenarios - ; description before-cursor after-cursor - '(("in-line-comment" ";; abc def " " ghi ") - ("in-block-comment" "#| abc def " " ghi |#") - ("in-string" "\" abc def " " ghi \"") - )) - (for ([s single-delete-scenarios] - #:unless (and (string=? "\"" open) - (string=? "in-string" (car s)))) - (let* ([before (cadr s)] - [after (string-append close (caddr s))] - [before-and-open (string-append before open)] - [result (list before after)]) - (test-parens-behavior/full (format "~a-~a" (string-append open close) (car s)) - before-and-open "" after #\backspace `(,result ,result))))) - - -#| for these, the key-event with meta-down doesn't seem to work... maybe a Mac OS - issue; and may cause problems with these tests on another platform? .nah. |# -(when (equal? 'macosx (system-type)) - (test-parens-behavior/full 'meta-open-1 - "abcd" "" "efg" - '(escape #\() ; '((new key-event% [key-code #\(] [meta-down #t])) - '(["abcd(" ")efg"] ["abcd(" ")efg"])) - - (test-parens-behavior/full 'meta-close-skip-1 - "(define before (list 1 2" "" " 3 4)" - '(escape #\)) ; '((new key-event% [key-code #\)] [meta-down #t])) - '(["(define before (list 1 2 3 4)" ""] - ["(define before (list 1 2 3 4)" ""])) - (test-parens-behavior/full - 'meta-close-skip-2 - "#lang racket\n(define before+afters `([\"\" abc \"efg\"" - "" - " 12345 xyz] [84])" - '(escape #\)) ;'((new key-event% [key-code #\)] [meta-down #t])) - '(["#lang racket\n(define before+afters `([\"\" abc \"efg\" 12345 xyz]" " [84])"] - ["#lang racket\n(define before+afters `([\"\" abc \"efg\" 12345 xyz]" " [84])"])) - (test-parens-behavior/full 'meta-close-skip-3 - "(define before" "" " (list 1 2 3 4)" - '(escape #\)) ; '((new key-event% [key-code #\)] [meta-down #t])) - '(["(define before (list 1 2 3 4)" ""] - ["(define before (list 1 2 3 4)" ""]))) + (define keys-with-default-mode (send (send t get-keymap) get-map-function-table)) + (send t set-surrogate mode) + (define keys-without-paren (send (send t get-keymap) get-map-function-table)) + (check-equal? keys-with-default-mode keys-without-paren) + (preferences:set 'framework:alt-as-meta alt-as-meta-before)) diff --git a/gui-test/framework/tests/search.rkt b/gui-test/framework/tests/search.rkt index 896bbd10b..d258cfaf6 100644 --- a/gui-test/framework/tests/search.rkt +++ b/gui-test/framework/tests/search.rkt @@ -1,204 +1,261 @@ #lang racket/base (require (for-syntax racket/base) - "test-suite-utils.rkt") - -(module test racket/base) + racket/gui/base + racket/class + racket/format + framework + rackunit) (define-syntax (test-search stx) (syntax-case stx () - [(_ args ...) - (with-syntax ([line (syntax-line stx)]) - #'(test-search/proc line args ...))])) + [(_ commands ... bubble-table) + (with-syntax ([line (syntax-line stx)] + [col (syntax-column stx)]) + #`(test-search/proc line col (list (λ (#,(datum->syntax stx 't)) commands) ...) bubble-table))])) ;; creates a search text, binds it to 't' and then, ;; for each expression in 'commands', evaluates it in a let ;; binding 't'. In between each call to commands, it waits ;; for the search text to quiesce and then finally gets ;; the search bubbles, comparing them to 'bubble-table' -(define (test-search/proc line commands bubble-table) - ;(printf "running test on line ~s\n" line) - (test - (string->symbol (format "search.rkt: line ~a pos immediately" line)) - (lambda (x) (equal? bubble-table x)) - (lambda () - (send-sexp-to-mred - `(let ([c (make-channel)]) - (queue-callback - (λ () (channel-put c (new (text:searching-mixin (editor:keymap-mixin text:basic%)))))) - (define t (channel-get c)) - (define (wait) - (let loop () - (queue-callback - (λ () - (channel-put c (send t search-updates-pending?))) - #f) - (when (channel-get c) - (loop)))) - ,@(apply - append - (for/list ([command (in-list commands)]) - (list `(queue-callback (λ () ,command (channel-put c #f))) - '(channel-get c) - '(wait)))) +(define (test-search/proc line col commands bubble-table) + (check-equal? + (let ([c (make-channel)]) + (queue-callback + (λ () (channel-put c (new (text:searching-mixin (editor:keymap-mixin text:basic%)))))) + (define t (channel-get c)) + (define (wait) + (let loop () (queue-callback (λ () - (define (to-simple-sexp x) - (let loop ([x x]) - (cond - [(is-a? x text%) (vector (send x get-text 0 (send x last-position)))] - [(pair? x) (cons (loop (car x)) (loop (cdr x)))] - [else x]))) - (channel-put c (to-simple-sexp (send t get-search-bubbles)))) + (channel-put c (send t search-updates-pending?))) #f) - (channel-get c)))))) + (when (channel-get c) + (loop)))) + (for ([command (in-list commands)]) + (queue-callback (λ () (command t) (channel-put c #f))) + (channel-get c) + (wait)) + (queue-callback + (λ () + (define (to-simple-sexp x) + (let loop ([x x]) + (cond + [(is-a? x text%) (vector (send x get-text 0 (send x last-position)))] + [(pair? x) (cons (loop (car x)) (loop (cdr x)))] + [else x]))) + (channel-put c (to-simple-sexp (send t get-search-bubbles)))) + #f) + (channel-get c)) + bubble-table + (format "search.rkt:~a:~a" line col))) + +(define testing-thread + (thread + (λ () + (test-search (begin (send t insert "") + (send t set-searching-state "aba" #t #f) + (send t set-position 0 0)) + '()) + (test-search (begin (send t insert "") + (send t set-searching-state "aba" #t #f)) + (send t set-position 0 0) + '()) + (test-search (begin (send t insert "aba") + (send t set-searching-state "aba" #t #f) + (send t set-position 0 0)) + `(((0 . 3) normal-search-color))) + (test-search (begin (send t insert "aba") + (send t set-searching-state "aba" #t #f)) + (send t set-position 0 0) + `(((0 . 3) normal-search-color))) -(test-search (list '(begin (send t insert "") - (send t set-searching-state "aba" #t #f) - (send t set-position 0 0))) - '()) -(test-search (list '(begin (send t insert "") - (send t set-searching-state "aba" #t #f)) - '(send t set-position 0 0)) - '()) -(test-search (list '(begin (send t insert "aba") - (send t set-searching-state "aba" #t #f) - (send t set-position 0 0))) - `(((0 . 3) normal-search-color))) -(test-search (list '(begin (send t insert "aba") - (send t set-searching-state "aba" #t #f) ) - '(send t set-position 0 0)) - `(((0 . 3) normal-search-color))) + (test-search (begin (send t insert "aba aba") + (send t set-searching-state "aba" #t #f) + (send t set-position 0 0)) + `(((0 . 3) normal-search-color) + ((4 . 3) normal-search-color))) + (test-search (begin (send t insert "aba aba") + (send t set-searching-state "aba" #t #f)) + (send t set-position 0 0) + `(((0 . 3) normal-search-color) + ((4 . 3) normal-search-color))) -(test-search (list '(begin (send t insert "aba aba") - (send t set-searching-state "aba" #t #f) - (send t set-position 0 0))) - `(((0 . 3) normal-search-color) - ((4 . 3) normal-search-color))) -(test-search (list '(begin (send t insert "aba aba") - (send t set-searching-state "aba" #t #f)) - '(send t set-position 0 0)) - `(((0 . 3) normal-search-color) - ((4 . 3) normal-search-color))) + (test-search (begin (send t insert "abaaba") + (send t set-searching-state "aba" #t #f) + (send t set-position 0 0)) + `(((0 . 3) normal-search-color) + ((3 . 3) normal-search-color))) + (test-search (begin (send t insert "abaaba") + (send t set-searching-state "aba" #t #f)) + (send t set-position 0 0) + `(((0 . 3) normal-search-color) + ((3 . 3) normal-search-color))) + (test-search (begin (send t insert "abababa") + (send t set-searching-state "aba" #t #f) + (send t set-position 0 0)) + `(((0 . 3) normal-search-color) + ((4 . 3) normal-search-color))) + (test-search (begin (send t insert "abababa") + (send t set-searching-state "aba" #t #f)) + (send t set-position 0 0) + `(((0 . 3) normal-search-color) + ((4 . 3) normal-search-color))) -(test-search (list '(begin (send t insert "abaaba") - (send t set-searching-state "aba" #t #f) - (send t set-position 0 0))) - `(((0 . 3) normal-search-color) - ((3 . 3) normal-search-color))) -(test-search (list '(begin (send t insert "abaaba") - (send t set-searching-state "aba" #t #f)) - '(send t set-position 0 0)) - `(((0 . 3) normal-search-color) - ((3 . 3) normal-search-color))) + (test-search (begin (send t insert "Aba") + (send t set-searching-state "aba" #t #f) + (send t set-position 0 0)) + '()) + (test-search (begin (send t insert "Aba") + (send t set-searching-state "aba" #t #f)) + (send t set-position 0 0) + '()) + (test-search (begin (send t insert "Aba") + (send t set-searching-state "aba" #f #f) + (send t set-position 0 0)) + `(((0 . 3) normal-search-color))) + (test-search (begin (send t insert "Aba") + (send t set-searching-state "aba" #f #f)) + (send t set-position 0 0) + `(((0 . 3) normal-search-color))) -(test-search (list '(begin (send t insert "abababa") - (send t set-searching-state "aba" #t #f) - (send t set-position 0 0))) - `(((0 . 3) normal-search-color) - ((4 . 3) normal-search-color))) -(test-search (list '(begin (send t insert "abababa") - (send t set-searching-state "aba" #t #f)) - '(send t set-position 0 0)) - `(((0 . 3) normal-search-color) - ((4 . 3) normal-search-color))) + (test-search (begin (send t set-searching-state "aba" #t 0) + (send t set-position 0)) + '()) -(test-search (list '(begin (send t insert "Aba") - (send t set-searching-state "aba" #t #f) - (send t set-position 0 0))) - '()) -(test-search (list '(begin (send t insert "Aba") - (send t set-searching-state "aba" #t #f)) - '(send t set-position 0 0)) - '()) -(test-search (list '(begin (send t insert "Aba") - (send t set-searching-state "aba" #f #f) - (send t set-position 0 0))) - `(((0 . 3) normal-search-color))) -(test-search (list '(begin (send t insert "Aba") - (send t set-searching-state "aba" #f #f)) - '(send t set-position 0 0)) - `(((0 . 3) normal-search-color))) + (test-search (begin (send t insert "aba") + (send t set-searching-state "aba" #f #t) + (send t set-position 0 0)) + `(((0 . 3) dark-search-color))) + (test-search (begin (send t insert "aba") + (send t set-searching-state "aba" #f #t)) + (send t set-position 0 0) + `(((0 . 3) dark-search-color))) -(test-search (list '(begin (send t set-searching-state "aba" #t 0) - (send t set-position 0))) - '()) + (test-search (begin (send t insert "abababa") + (send t set-searching-state "aba" #f #t) + (send t set-position 0 0)) + `(((0 . 3) dark-search-color) + ((4 . 3) light-search-color))) + (test-search (begin (send t insert "abababa") + (send t set-searching-state "aba" #f #t)) + (send t set-position 0 0) + `(((0 . 3) dark-search-color) + ((4 . 3) light-search-color))) -(test-search (list '(begin (send t insert "aba") - (send t set-searching-state "aba" #f #t) - (send t set-position 0 0))) - `(((0 . 3) dark-search-color))) -(test-search (list '(begin (send t insert "aba") - (send t set-searching-state "aba" #f #t)) - '(send t set-position 0 0)) - `(((0 . 3) dark-search-color))) + (test-search (begin (send t insert "aba aba aba") + (send t set-searching-state "aba" #f #t) + (send t set-position 1 1)) + `(((0 . 3) light-search-color) + ((4 . 3) dark-search-color) + ((8 . 3) light-search-color))) + (test-search (begin (send t insert "aba aba aba") + (send t set-searching-state "aba" #f #t)) + (send t set-position 1 1) + `(((0 . 3) light-search-color) + ((4 . 3) dark-search-color) + ((8 . 3) light-search-color))) -(test-search (list '(begin (send t insert "abababa") - (send t set-searching-state "aba" #f #t) - (send t set-position 0 0))) - `(((0 . 3) dark-search-color) - ((4 . 3) light-search-color))) -(test-search (list '(begin (send t insert "abababa") - (send t set-searching-state "aba" #f #t)) - '(send t set-position 0 0)) - `(((0 . 3) dark-search-color) - ((4 . 3) light-search-color))) + (test-search (begin (send t insert "aba") + (send t set-searching-state "aba" #f #t)) + (send t set-position 0 0) + (send t set-position 3 3) + `(((0 . 3) light-search-color))) + (test-search (begin (send t insert "aba") + (send t set-searching-state "aba" #f #t)) + (send t set-position 0 0) + (send t set-position 1 1) + `(((0 . 3) light-search-color))) + (test-search (begin (send t insert "aba") + (send t set-searching-state "aba" #f #t)) + (send t set-searching-state #f #f #f) + `()) + (test-search (let () + (define inner-t (new text%)) + (define inner-inner-t (new text%)) + (define inner-es (new editor-snip%)) + (send inner-es set-editor inner-inner-t) + (define es (new editor-snip%)) + (send es set-editor inner-t) + (send inner-inner-t insert "x") + (send inner-t insert inner-es) + (send t insert "x ") + (send t insert es) + (send t set-position 1 1) + (send t set-searching-state "x" #f #t #t)) + (send t set-position 2 2) + ;; we don't see some of the hits here because + ;; the embedded texts aren't searching-embedded<%> + '(((0 . 1) light-search-color))) + (test-search (let () + (define inner-t (new (text:searching-embedded-mixin text%))) + (define inner-inner-t (new (text:searching-embedded-mixin text%))) + (define inner-es (new editor-snip%)) + (send inner-es set-editor inner-inner-t) + (define es (new editor-snip%)) + (send es set-editor inner-t) + (send inner-inner-t insert "x") + (send inner-t insert inner-es) + (send t insert "x ") + (send t insert es) + (send t set-position 1 1) + (send t set-searching-state "x" #f #t #t)) + (send t set-position 2 2) + '((((#(".") #("x") . 0) . 1) dark-search-color) + ((0 . 1) light-search-color))) + (test-search (let () + (define inner-t (new text%)) + (define inner-inner-t (new text%)) + (define inner-es (new editor-snip% [editor inner-inner-t])) + (define es (new editor-snip% [editor inner-t])) + (send inner-inner-t insert "x") + (send inner-t insert inner-es) + (send t insert "x ") + (send t insert es) + (send t set-position 1 1) + (send t set-searching-state "x" #f #t #t)) + (send t set-position 2 2) + (send t set-position 0 0) + ;; we don't see some of the hits here because + ;; the embedded texts aren't searching-embedded<%> + '(((0 . 1) dark-search-color))) + (test-search (let () + (define inner-t (new (text:searching-embedded-mixin text%))) + (define inner-inner-t (new (text:searching-embedded-mixin text%))) + (define inner-es (new editor-snip% [editor inner-inner-t])) + (define es (new editor-snip% [editor inner-t])) + (send inner-inner-t insert "x") + (send inner-t insert inner-es) + (send t insert "x ") + (send t insert es) + (send t set-position 1 1) + (send t set-searching-state "x" #f #t #t)) + (send t set-position 2 2) + (send t set-position 0 0) + '((((#(".") #("x") . 0) . 1) light-search-color) + ((0 . 1) dark-search-color))) -(test-search (list '(begin (send t insert "aba aba aba") - (send t set-searching-state "aba" #f #t) - (send t set-position 1 1))) - `(((0 . 3) light-search-color) - ((4 . 3) dark-search-color) - ((8 . 3) light-search-color))) -(test-search (list '(begin (send t insert "aba aba aba") - (send t set-searching-state "aba" #f #t)) - '(send t set-position 1 1)) - `(((0 . 3) light-search-color) - ((4 . 3) dark-search-color) - ((8 . 3) light-search-color))) + (test-search (let () + (let loop ([t t] + [n 4]) + (unless (zero? n) + (send t insert (~a n "a")) + (define inner-t (new (text:searching-embedded-mixin text%))) + (define es (new editor-snip% [editor inner-t])) + (send t insert es) + (send t insert "a") + (loop inner-t (- n 1)))) + (send t set-searching-state "a" #f #t #t)) + (send t set-position 2 2) + (send t set-position 0 0) + '((((#("3a.a") #("2a.a") #("1a.a") . 1) . 1) light-search-color) + (((#("3a.a") #("2a.a") #("1a.a") . 3) . 1) light-search-color) + (((#("3a.a") #("2a.a") . 1) . 1) light-search-color) + (((#("3a.a") #("2a.a") . 3) . 1) light-search-color) + (((#("3a.a") . 1) . 1) light-search-color) + (((#("3a.a") . 3) . 1) light-search-color) + ((1 . 1) dark-search-color) + ((3 . 1) light-search-color)))))) -(test-search (list '(begin (send t insert "aba") - (send t set-searching-state "aba" #f #t)) - '(send t set-position 0 0) - '(send t set-position 3 3)) - `(((0 . 3) light-search-color))) -(test-search (list '(begin (send t insert "aba") - (send t set-searching-state "aba" #f #t)) - '(send t set-position 0 0) - '(send t set-position 1 1)) - `(((0 . 3) light-search-color))) -(test-search (list '(begin (send t insert "aba") - (send t set-searching-state "aba" #f #t)) - '(send t set-searching-state #f #f #f)) - `()) -(test-search (list '(let () - (define inner-t (new text%)) - (define inner-inner-t (new text%)) - (define inner-es (new editor-snip%)) - (send inner-es set-editor inner-inner-t) - (define es (new editor-snip%)) - (send es set-editor inner-t) - (send inner-inner-t insert "x") - (send inner-t insert inner-es) - (send t insert "x ") - (send t insert es) - (send t set-position 1 1) - (send t set-searching-state "x" #f #t #t)) - '(send t set-position 2 2)) - '((((#(".") #("x") . 0) . 1) dark-search-color) - ((0 . 1) light-search-color))) -(test-search (list '(let () - (define inner-t (new text%)) - (define inner-inner-t (new text%)) - (define inner-es (new editor-snip% [editor inner-inner-t])) - (define es (new editor-snip% [editor inner-t])) - (send inner-inner-t insert "x") - (send inner-t insert inner-es) - (send t insert "x ") - (send t insert es) - (send t set-position 1 1) - (send t set-searching-state "x" #f #t #t)) - '(send t set-position 2 2) - '(send t set-position 0 0)) - '((((#(".") #("x") . 0) . 1) light-search-color) - ((0 . 1) dark-search-color))) +(void (yield testing-thread)) diff --git a/gui-test/framework/tests/text-indent-guides-test.rkt b/gui-test/framework/tests/text-indent-guides-test.rkt new file mode 100644 index 000000000..2d22a765a --- /dev/null +++ b/gui-test/framework/tests/text-indent-guides-test.rkt @@ -0,0 +1,203 @@ +#lang racket/base +(require framework + framework/private/guide-struct + rackunit + racket/gui/base + racket/set + racket/class + data/skip-list) + +(let () + (define t (new (text:indent-guides-mixin text%))) + (send t insert #<<-- +#lang racket + +(define (f x) + (cond + [(empty? x) + 1] + [else 2]) + (void)) + +-- + ) + (send t set-filename #f) + + (check-equal? + (skip-list->list (send t get-guides)) + (list + (cons 0 (guide 0 0 '())) + (cons 1 (guide #f #f '())) + (cons 2 (guide 0 0 '())) + (cons 3 (guide 2 0 '())) + (cons 4 (guide 4 0 '(2))) + (cons 5 (guide 5 0 '(2 4))) + (cons 6 (guide 4 0 '(2))) + (cons 7 (guide 2 0 '())) + (cons 8 (guide #f #f '())))) + + + (define lines (set)) + (send t draw-the-lines + (λ (x-in-editor-coordinates x y-start y-end) + (set! lines (set-add lines (list x y-start y-end)))) + 0 + (send t last-paragraph)) + (check-equal? lines + (set '(2 4 6) + '(4 5 5)))) + +(let () + (define t (new (text:indent-guides-mixin text%))) + (send t insert "\n abc\n d\n e\n\n g\n h\n") + (send t set-filename #f) + + (check-equal? + (skip-list->list (send t get-guides)) + (list + (cons 0 (guide #f #f '())) + (cons 1 (guide 1 0 '())) + (cons 2 (guide 3 0 '(1))) + (cons 3 (guide 3 0 '(1))) + (cons 4 (guide #f #f '(1 3))) + (cons 5 (guide 3 0 '(1))) + (cons 6 (guide 3 0 '(1))) + (cons 7 (guide #f #f '())))) + + (let () + (define lines (set)) + (send t draw-the-lines + (λ (x-in-editor-coordinates x y-start y-end) + (set! lines (set-add lines (list x y-start y-end)))) + 0 + (send t last-paragraph)) + (check-equal? lines + (set '(1 2 6) '(3 4 4)))) + + (let () + (define lines (set)) + (send t draw-the-lines + (λ (x-in-editor-coordinates x y-start y-end) + (set! lines (set-add lines (list x y-start y-end)))) + 5 5) + (check-equal? lines + (set '(1 5 5))))) + +(let () + (define t (new (text:indent-guides-mixin text%))) + (send t insert "abc\n d\n e\n f\n g\n") + (send t set-filename #f) + + (check-equal? + (skip-list->list (send t get-guides)) + (list + (cons 0 (guide 0 0 '())) + (cons 1 (guide 2 0 '())) + (cons 2 (guide 3 0 '(2))) + (cons 3 (guide 5 0 '(2 3))) + (cons 4 (guide 2 0 '())) + (cons 5 (guide #f #f '())))) + + (let () + (define lines (set)) + (send t draw-the-lines + (λ (x-in-editor-coordinates x y-start y-end) + (set! lines (set-add lines (list x y-start y-end)))) + 0 + (send t last-paragraph)) + (check-equal? lines + (set '(3 3 3) '(2 2 3)))) + + (let () + (define lines (set)) + (send t draw-the-lines + (λ (x-in-editor-coordinates x y-start y-end) + (set! lines (set-add lines (list x y-start y-end)))) + 2 + 4) + (check-equal? lines + (set '(3 3 3) '(2 2 3))))) + +(let () + (define t (new (text:indent-guides-mixin text%))) + (send t insert "q\n a\n e\n") + (send t set-filename #f) + + (check-equal? + (skip-list->list (send t get-guides)) + (list + (cons 0 (guide 0 0 '())) + (cons 1 (guide 2 0 '())) + (cons 2 (guide 4 0 '(2))) + (cons 3 (guide #f #f '())))) + + (let () + (define lines (set)) + (send t draw-the-lines + (λ (x-in-editor-coordinates x y-start y-end) + (set! lines (set-add lines (list x y-start y-end)))) + 0 + (send t last-paragraph)) + (check-equal? lines + (set '(2 2 2)))) + + (let () + (define lines (set)) + (send t delete 6 12) + (send t draw-the-lines + (λ (x-in-editor-coordinates x y-start y-end) + (set! lines (set-add lines (list x y-start y-end)))) + 1 + 2) + (check-equal? lines + (set)))) + +(define shrubbery-available? + (with-handlers ([exn:fail? (lambda (x) #f)]) + (collection-path "shrubbery") + #t)) +(unless shrubbery-available? + (printf "text-indent-guides-test.rkt: skipping tests that require shrubbery\n")) +(when shrubbery-available? + (define t (new (text:indent-guides-mixin text%))) + (send t insert + (string-append + "#lang shrubbery\n" + "\n" + "\n" + "/*\n" + "begin:\n" + " apple\n" + " \n" + " banana\n" + " */\n")) + (check-equal? + (skip-list->list (send t get-guides)) + (list + (cons 0 (guide 0 0 '())) + (cons 1 (guide #f #f '())) + (cons 2 (guide #f #f '())) + (cons 3 (guide 0 0 '())) + (cons 4 (guide 0 0 '())) + (cons 5 (guide 2 0 '())) + (cons 6 (guide #f #f '(2))) + (cons 7 (guide 2 0 '())) + (cons 8 (guide 2 0 '())) + (cons 9 (guide #f #f '())))) + + (send t insert "\n\n" (send t paragraph-start-position 2)) + (check-equal? + (skip-list->list (send t get-guides)) + (list + (cons 0 (guide 0 0 '())) + (cons 1 (guide #f #f '())) + (cons 2 (guide #f #f '())) + (cons 3 (guide #f #f '())) + (cons 4 (guide #f #f '())) + (cons 5 (guide 0 0 '())) + (cons 6 (guide 0 0 '())) + (cons 7 (guide 2 0 '())) + (cons 8 (guide #f #f '(2))) + (cons 9 (guide 2 0 '())) + (cons 10 (guide 2 0 '())) + (cons 11 (guide #f #f '()))))) diff --git a/gui-test/framework/tests/text.rkt b/gui-test/framework/tests/text.rkt index 7da68fbd1..88b3e7b32 100644 --- a/gui-test/framework/tests/text.rkt +++ b/gui-test/framework/tests/text.rkt @@ -4,7 +4,8 @@ "private/gui.rkt" rackunit racket/gui/base - framework) + framework + simple-tree-text-markup/construct) (module+ test (with-private-prefs @@ -19,7 +20,8 @@ (move/copy-to-edit-tests) (move/copy-to-edit-random-tests) (ascii-art-tests) - (autocomplete-tests))) + (autocomplete-tests) + (get-max-width-paragraph-tests))) (define (highlight-range-tests) (check-equal? @@ -330,6 +332,62 @@ (send t set-searching-state "b" #f #f))) (list 1 1)) + (check-equal? + (run-search-test + (λ (t) + (send t insert " a b a b a") + (send t set-position 0 0) + (send t set-searching-state "a" #f #f))) + (list 0 3)) + + (check-equal? + (run-search-test + (λ (t) + (send t insert " a b a b a") + (send t set-position 1 1) + (send t set-searching-state "a" #f #f))) + (list 1 3)) + + (check-equal? + (run-search-test + (λ (t) + (send t insert " a b a b a") + (send t set-position 2 2) + (send t set-searching-state "a" #f #f))) + (list 1 3)) + + (check-equal? + (run-search-test + (λ (t) + (send t insert " a b a b a") + (send t set-position 3 3) + (send t set-searching-state "a" #f #f))) + (list 1 3)) + + (check-equal? + (run-search-test + (λ (t) + (send t insert " a b a b a") + (send t set-position 4 4) + (send t set-searching-state "a" #f #f))) + (list 1 3)) + + (check-equal? + (run-search-test + (λ (t) + (send t insert " a b a b a") + (send t set-position 5 5) + (send t set-searching-state "a" #f #f))) + (list 2 3)) + + (check-equal? + (run-search-test + (λ (t) + (send t insert " a b a b a") + (send t set-position 2 2) + (send t set-searching-state "a" #f #f))) + (list 1 3)) + (check-equal? (run-search-test (λ (t) @@ -340,6 +398,20 @@ (send t2 insert "abc") (send t set-position 0 0) (send t set-searching-state "b" #f #f))) + ;; we don't see some of the hits here because + ;; the embedded texts aren't searching-embedded<%> + (list 0 1)) + + (check-equal? + (run-search-test + (λ (t) + (send t insert "abc") + (define t2 (new (text:searching-embedded-mixin text%))) + (send t2 insert "abc") + (send t insert (new editor-snip% [editor t2])) + (send t2 insert "abc") + (send t set-position 0 0) + (send t set-searching-state "b" #f #f))) (list 0 3)) (check-equal? @@ -352,6 +424,20 @@ (send t insert "abc") (send t set-position (send t last-position) (send t last-position)) (send t set-searching-state "b" #f #f))) + ;; we don't see some of the hits here because + ;; the embedded texts aren't searching-embedded<%> + (list 2 2)) + + (check-equal? + (run-search-test + (λ (t) + (send t insert "abc") + (define t2 (new (text:searching-embedded-mixin text%))) + (send t2 insert "abc") + (send t insert (new editor-snip% [editor t2])) + (send t insert "abc") + (send t set-position (send t last-position) (send t last-position)) + (send t set-searching-state "b" #f #f))) (list 3 3)) (check-equal? @@ -368,6 +454,24 @@ (send t insert "abc") (send t set-position (send t last-position) (send t last-position)) (send t set-searching-state "b" #f #f))) + ;; we don't see some of the hits here because + ;; the embedded texts aren't searching-embedded<%> + (list 2 2)) + + (check-equal? + (run-search-test + (λ (t) + (send t insert "abc") + (define t2 (new (text:searching-embedded-mixin text%))) + (send t2 insert "abc") + (define t3 (new (text:searching-embedded-mixin text%))) + (send t3 insert "abc") + (send t2 insert (new editor-snip% [editor t3])) + (send t2 insert "abc") + (send t insert (new editor-snip% [editor t2])) + (send t insert "abc") + (send t set-position (send t last-position) (send t last-position)) + (send t set-searching-state "b" #f #f))) (list 5 5)) (check-equal? @@ -384,6 +488,24 @@ (send t insert "abc") (send t set-position 0 0) (send t set-searching-state "b" #f #f))) + ;; we don't see some of the hits here because + ;; the embedded texts aren't searching-embedded<%> + (list 0 2)) + + (check-equal? + (run-search-test + (λ (t) + (send t insert "abc") + (define t2 (new (text:searching-embedded-mixin text%))) + (send t2 insert "abc") + (define t3 (new (text:searching-embedded-mixin text%))) + (send t3 insert "abc") + (send t2 insert (new editor-snip% [editor t3])) + (send t2 insert "abc") + (send t insert (new editor-snip% [editor t2])) + (send t insert "abc") + (send t set-position 0 0) + (send t set-searching-state "b" #f #f))) (list 0 5)) (check-equal? @@ -649,7 +771,134 @@ (send t undo) (loop))) (define after (get-colors)) - (list before after)))) + (list before after))) + + (let () + (define t (new (text:ports-mixin text:wide-snip%))) + (define op (send t get-out-port)) + (write-special (horizontal "a" "b" "c") op) + (flush-output op) + (check-equal? (send t get-text) "abc")) + + (let () + (define t (new (text:ports-mixin text:wide-snip%))) + (define op (send t get-out-port)) + (write-special (vertical "a" "b" "c") op) + (flush-output op) + (check-equal? (send t get-text) "a\nb\nc")) + + (let () + (define t (new (text:ports-mixin text:wide-snip%))) + (define op (send t get-out-port)) + (write-special (framed-markup (horizontal "a" "b" "c")) op) + (flush-output op) + (check-true (is-a? (send t find-first-snip) editor-snip%)) + (check-equal? (send (send (send t find-first-snip) get-editor) get-text) "abc")) + + (let () + (define t (new (text:ports-mixin text:wide-snip%))) + (define op (send t get-out-port)) + (define w 4) + (define h 6) + (define bmp (make-bitmap w h)) + (define pixels (make-bytes (* w h 4))) + (for ([x (in-range (bytes-length pixels))]) + (bytes-set! pixels + x + (if (zero? (modulo x 4)) + 255 + (modulo x 255)))) + (send bmp set-argb-pixels 0 0 w h pixels) + (write-special (horizontal "a" (image-markup bmp "x") "b") op) + (flush-output op) + (check-equal? (send t get-text) "a.b") + (define image-snip (send (send t find-first-snip) next)) + (check-true (is-a? image-snip image-snip%)) + (define bmp2 (send image-snip get-bitmap)) + (check-false (object=? bmp bmp2)) + (check-equal? (send bmp2 get-width) w) + (check-equal? (send bmp2 get-height) h) + (define pixels2 (make-bytes (* w h 4))) + (send bmp2 get-argb-pixels 0 0 w h pixels2) + (check-equal? pixels pixels2) + ) + + (let () + (define t (new (text:ports-mixin text:wide-snip%))) + (define op (send t get-out-port)) + (write-special (horizontal + (number 1/3 #:exact-prefix 'never #:inexact-prefix 'never #:fraction-view 'decimal) + " " + (number 4/3 #:exact-prefix 'never #:inexact-prefix 'never #:fraction-view 'mixed) + " " + (number 4/3 #:exact-prefix 'never #:inexact-prefix 'never #:fraction-view 'improper) + " " + (number #i0.5 #:exact-prefix 'never #:inexact-prefix 'never #:fraction-view 'decimal) + " " + (number #e0.5 #:exact-prefix 'never #:inexact-prefix 'never #:fraction-view 'decimal)) + op) + (flush-output op) + (check-equal? (send t get-text) "0.3 1 1/3 4/3 0.5 0.5") + (define snip1 (send t find-first-snip)) + (check-true (number-snip:is-number-snip? snip1)) + (check-equal? (send snip1 get-text 0 10 #t) "0.3") + (define snip2 (send (send snip1 next) next)) + (check-true (number-snip:is-number-snip? snip2)) + (check-equal? (send snip2 get-text 0 10 #t) "1 1/3") + (define snip3 (send (send snip2 next) next)) + (check-true (number-snip:is-number-snip? snip3)) + (check-equal? (send snip3 get-text 0 10 #t) "4/3")) + + (let () + (define t (new (text:ports-mixin text:wide-snip%))) + (define op (send t get-out-port)) + (write-special (horizontal + (number 1/3 #:exact-prefix 'never #:inexact-prefix 'never #:fraction-view 'decimal) + " " + (number 4/3 #:exact-prefix 'never #:inexact-prefix 'never #:fraction-view 'mixed) + " " + (number 4/3 #:exact-prefix 'never #:inexact-prefix 'never #:fraction-view 'improper) + " " + (number #i0.5 #:exact-prefix 'never #:inexact-prefix 'always #:fraction-view 'decimal) + " " + (number #e0.5 #:exact-prefix 'always #:inexact-prefix 'never #:fraction-view 'decimal)) + op) + (flush-output op) + (check-equal? (send t get-text) "0.3 1 1/3 4/3 #i0.5 #e0.5") + (define snip1 (send t find-first-snip)) + (check-true (number-snip:is-number-snip? snip1)) + (check-equal? (send snip1 get-text 0 10 #t) "0.3") + (define snip2 (send (send snip1 next) next)) + (check-true (number-snip:is-number-snip? snip2)) + (check-equal? (send snip2 get-text 0 10 #t) "1 1/3") + (define snip3 (send (send snip2 next) next)) + (check-true (number-snip:is-number-snip? snip3)) + (check-equal? (send snip3 get-text 0 10 #t) "4/3")) + + (let () + (define t (new (text:ports-mixin text:wide-snip%))) + (send t insert "one\n") + (send t do-submission) + (send t insert " two\n") + (send t do-submission) + (define ip (send t get-in-port)) + (check-equal? #\o (read-char ip)) + (check-equal? '(1 1 2) (call-with-values (lambda () (port-next-location ip)) list)) + (check-equal? #\n (read-char ip)) + (check-equal? #\e (read-char ip)) + (check-equal? '(1 3 4) (call-with-values (lambda () (port-next-location ip)) list)) + (check-equal? #\newline (read-char ip)) + (check-equal? '(2 0 5) (call-with-values (lambda () (port-next-location ip)) list)) + (check-equal? #\space (read-char ip)) + (check-equal? '(2 1 6) (call-with-values (lambda () (port-next-location ip)) list)) + (check-equal? #\t (read-char ip)) + (check-equal? #\w (read-char ip)) + (check-equal? #\o (read-char ip)) + (check-equal? '(2 4 9) (call-with-values (lambda () (port-next-location ip)) list)) + (check-equal? #\newline (read-char ip)) + (check-equal? '(3 0 10) (call-with-values (lambda () (port-next-location ip)) list))) + + ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -922,9 +1171,9 @@ (check-equal? (edit-string "ABCDEF" 1 3 0 #t) "BCADEF") (check-equal? (edit-string "ABCDEF" 1 3 5 #f) "ABCDEBCF") (check-equal? (edit-string "ABCDEF" 1 3 5 #t) "ADEBCF") - (for ([i (in-range 100)]) + (for ([i (in-range 10)]) (random-check-edit-string)) - (for ([i (in-range 100)]) + (for ([i (in-range 10)]) (check-move/copy+delete-property))) (define (ascii-art-enlarge-boxes before position overwrite? chars) @@ -1019,3 +1268,94 @@ [key-code #\return])) (check-equal? (send t get-text) "pqr abcd xyz")) + +(define (get-max-width-paragraph-tests) + (struct ins (str pos) #:transparent) + + (define (calc-widest t) + (define-values (widest-para widest-width) + (for/fold ([widest-para 0] + [widest-width 0]) + ([para (in-inclusive-range 0 (send t last-paragraph))]) + (define this-width (- (send t paragraph-end-position para) + (send t paragraph-start-position para))) + (cond + [(<= this-width widest-width) + (values widest-para widest-width)] + [else + (values para this-width)]))) + widest-para) + + (define (try loins) + (define t (new (text:max-width-paragraph-mixin text:basic%))) + (for ([a-ins (in-list loins)]) + (match-define (ins str pos) a-ins) + (send t insert str pos)) + (define should-be (calc-widest t)) + (define is (send t get-max-width-paragraph)) + (unless (equal? should-be is) + (eprintf "test failed; got ~s expected ~s\n" is should-be) + (pretty-print loins (current-error-port)) + (eprintf "~s\n" (send t get-text)))) + + (try '()) + (try (list (ins "a" 0))) + (try (list (ins "a" 0) + (ins "\n" 0) + (ins "aa" 0))) + (try (list (ins "aaaa" 0) + (ins "\n" 0) + (ins "aa" 0))) + (try (list (ins "aaaa" 0) + (ins "\n" 4) + (ins "aa" 5))) + (try (list (ins "aaaa" 0) + (ins "\n" 4) + (ins "aa" 5) + (ins "a" 0))) + + (define (mk) + (let loop ([s 0]) + (cond + [(zero? (random 10)) '()] + [else + (define str + (make-string (+ (random 3) 1) + (case (random 4) + [(0) #\a] + [(1) #\b] + [(2) #\c] + [(3) #\newline]))) + (cons (ins str (random (+ s 1))) + (loop (+ s (string-length str))))]))) + + (for ([i (in-range 100)]) + (try (mk))) + + (let () + (define mw #f) + (define called? #f) + (define t (new (class (text:max-width-paragraph-mixin text:basic%) + (inherit get-max-width-paragraph) + (define/augment (after-max-width-paragraph-change) + (set! called? #t) + (set! mw (get-max-width-paragraph))) + (super-new)))) + (send t insert "a") + (check-equal? mw 0) + (send t insert "b\nc") + (check-equal? mw 0) + + (send t insert "dddddd") + (check-equal? mw 1) + + (send t insert "\n") + (check-equal? mw 1) + + (send t insert "a") + (check-equal? mw 1) + + (set! called? #f) + (send t insert "d") + (check-equal? called? #f)) + ) diff --git a/gui-test/framework/tests/zzzz-panel-signal.rkt b/gui-test/framework/tests/zzzz-panel-signal.rkt new file mode 100644 index 000000000..4f251c3ff --- /dev/null +++ b/gui-test/framework/tests/zzzz-panel-signal.rkt @@ -0,0 +1,117 @@ +#lang racket/base +(require racket/class + racket/gui/base + framework + rackunit) + +(define (run-tests) + (define semaphore (make-semaphore 0)) + (define semaphore-frame% + (class frame% + (define/augment (on-close) (semaphore-post semaphore)) + (super-new))) + (define f (make-object semaphore-frame% "Single Panel Test")) + (define navy-blue-brush (send the-brush-list find-or-create-brush "navy" 'solid)) + (define light-blue-brush (send the-brush-list find-or-create-brush "lightblue" 'solid)) + (define grid-canvas% + (class canvas% + (init-field lines) + (init label) + (inherit get-dc get-client-size) + (override on-paint) + (define (on-paint) + (define-values (width height) (get-client-size)) + (define dc (get-dc)) + (define single-width (/ width lines)) + (define single-height (/ height lines)) + (send dc set-pen "black" 1 'transparent) + (for* ([i (in-range lines)] + [j (in-range lines)]) + (send dc set-brush + (if (= 0 (modulo (+ i j) 2)) + navy-blue-brush light-blue-brush)) + (send dc draw-rectangle + (* single-width i) + (* single-height j) + single-width + single-height))) + (super-new) + ;; soon to be obsolete, hopefully. + (inherit set-label) + (set-label label) + (inherit min-width min-height) + (min-width 50) + (min-height 50))) + (define border-panel (make-object horizontal-panel% f '(border))) + (define single-panel (make-object panel:single% border-panel)) + (define children + (list + (new grid-canvas% (lines 3) (parent single-panel) (label "Small") (stretchable-width #f) (stretchable-height #f)) + (new grid-canvas% (lines 3) (parent single-panel) (label "Wide") (stretchable-width #t) (stretchable-height #f)) + (new grid-canvas% (lines 3) (parent single-panel) (label "Tall") (stretchable-width #f) (stretchable-height #t)) + (new grid-canvas% (lines 3) (parent single-panel) (label "Wide and Tall") (stretchable-width #t) (stretchable-height #t)))) + (define active-child (car children)) + (define radios (make-object horizontal-panel% f)) + (define (make-radio label choices callback) + (define panel (make-object vertical-panel% radios '(border))) + (define message (make-object message% label panel)) + (define radio (make-object radio-box% #f choices panel (λ (radio _) (callback radio)))) + (define button (make-object button% + "Cycle" panel + (λ (_1 _2) + (define before (send radio get-selection)) + (define tot (send radio get-number)) + (for ([n (in-range tot)]) + (send radio set-selection n) + (callback radio) + (sleep/yield 1)) + (send radio set-selection before) + (callback radio)))) + radio) + (define radio + (make-radio + "Active Child" + (map (λ (x) (send x get-label)) children) + (λ (radio) + (for ([c (in-list children)]) + (when (string=? (send radio get-item-label (send radio get-selection)) + (send c get-label)) + (set! active-child c) + (send single-panel active-child active-child)))))) + (define vertical-alignment 'center) + (define horizontal-alignment 'center) + (define (update-alignment) + (send single-panel set-alignment horizontal-alignment vertical-alignment)) + (define horiz + (make-radio + "Horizontal Alignment" + (list "left" "center" "right") + (λ (radio) + (set! horizontal-alignment (string->symbol (send radio get-item-label (send radio get-selection)))) + (update-alignment)))) + (define vert + (make-radio + "Vertical Alignment" + (list "top" "center" "bottom") + (λ (radio) + (set! vertical-alignment (string->symbol (send radio get-item-label (send radio get-selection)))) + (update-alignment)))) + (define buttons (make-object horizontal-panel% f)) + (define result 'failed) + (define failed (make-object button% "Failed" buttons (λ (_1 _2) (semaphore-post semaphore)))) + (define passed (make-object button% "Passed" buttons (λ (_1 _2) (set! result 'passed) (semaphore-post semaphore)))) + (send border-panel min-width 100) + (send border-panel min-height 100) + (send vert set-selection 1) + (send horiz set-selection 1) + (send buttons stretchable-height #f) + (send buttons set-alignment 'right 'center) + (send radios stretchable-height #f) + (send f show #t) + (void (yield semaphore)) + (send f show #f) + (check-equal? result 'passed)) + +(module+ test + (unless (getenv "PLTDRDR") + (run-tests))) diff --git a/gui-test/info.rkt b/gui-test/info.rkt index 55a6a1db0..70f40af28 100644 --- a/gui-test/info.rkt +++ b/gui-test/info.rkt @@ -2,10 +2,11 @@ (define collection 'multi) -(define deps '("base")) +(define deps '("base" "string-constants-lib")) (define build-deps '("racket-index" "scheme-lib" "draw-lib" + "data-lib" "racket-test" "sgl" "snip-lib" @@ -16,6 +17,7 @@ "pconvert-lib" "compatibility-lib" "sandbox-lib" + "simple-tree-text-markup-lib" "pict-lib" "pict-snip-lib")) (define update-implies '("gui-lib")) @@ -23,3 +25,6 @@ (define pkg-desc "tests for \"gui\"") (define pkg-authors '(mflatt robby)) + +(define license + '(Apache-2.0 OR MIT)) diff --git a/gui-test/tests/gracket/editor.rktl b/gui-test/tests/gracket/editor.rktl index c2b144b61..2846502cc 100644 --- a/gui-test/tests/gracket/editor.rktl +++ b/gui-test/tests/gracket/editor.rktl @@ -376,6 +376,60 @@ (test #\a 'snips-joined4 char1) (test "bcd" 'snips-joined5 chars)) +(let () + (define t (new text%)) + (define p (open-output-text-editor t)) + (displayln "abc" p) + (close-output-port p) + (test "abc\n" 'wrote-text (send t get-text))) + +(let () + (define t (new text%)) + (define bts1 #"a\302") + (define bts2 #"\267 \302\267") + (define p (open-output-text-editor t)) + (write-bytes bts1 p) + (flush-output p) + (write-bytes bts2 p) + (close-output-port p) + (test "a· ·" 'unicode-code-point-broken-up (send t get-text))) + +(let () + (define t (new text%)) + (send t set-styles-sticky #f) + (define bts #"\360\237\217\264\342\200\215\342\230\240\357\270\217") + (define p (open-output-text-editor t)) + (write-bytes bts p) + (close-output-port p) + (test 1 'pirate-flag-all-at-once (send t position-grapheme (send t last-position)))) + +(let () + (define t (new text%)) + (define bts #"\360\237\217\264\342\200\215\342\230\240\357\270\217") + (define p (open-output-text-editor t)) + (for ([b (in-bytes bts)]) + (write-byte b p) + (flush-output p)) + (close-output-port p) + (test 1 'pirate-flag-piece-by-piece (send t position-grapheme (send t last-position)))) + +(let () + (define bts '(#"\360\237\217\264" #"\342\200\215" #"\342\230\240" #"\357\270\217")) + (define txt (new text%)) + (send txt set-styles-sticky #f) + (send txt insert "az") + (for ([b (in-list bts)] + [i (in-naturals)]) + (define p (open-output-text-editor txt (- (send txt last-position) 1))) + (write-bytes b p) + (close-output-port p) + (when (= i 0) + (send txt change-style (make-object style-delta% 'change-bold) 1 2))) + (test '(0 1 5 6) + 'pirate-flag-char-by-char + (for/list ([i (in-list '(0 1 2 3))]) + (send txt grapheme-position i)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Snips and Streams ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -674,6 +728,27 @@ (unless (<= 0 count2 (/ N 2)) (error 'notifications "not weak enough? ~e" count2))) +(let () + (define t (new text%)) + (define sl (new style-list%)) + (send t set-style-list sl) + (define cb-called? #f) + (define (cb s) + (set! cb-called? #t) + (send sl begin-style-change-sequence) + (send sl end-style-change-sequence)) + (define notification-key (send sl notify-on-change cb)) + (define b (send sl find-named-style "Basic")) + (define b2 (send sl new-named-style "Basic2" b)) + (send b2 set-delta (make-object style-delta% 'change-bigger 1)) + (define notification-key2 (send sl notify-on-change cb)) + (send sl begin-style-change-sequence) + (send b2 set-delta (make-object style-delta% 'change-bigger 1)) + (send sl end-style-change-sequence) + (set! cb-called? #f) + (send b2 set-delta (make-object style-delta% 'change-bigger 1)) + (test #t 'style-change-sequence-during-callback-works cb-called?)) + ;; ---------------------------------------- ;; make sure splitting a large string snip works: @@ -694,6 +769,39 @@ (test #f 'undef-style-delta% (impersonator? (new style-delta%))) (test #f 'undef-style<%> (impersonator? (send (new style-list%) basic-style))) +;; ---------------------------------------- +;; sha1 computing +(let ([t (new text%)]) + (test #f 'sha1-off-by-default.1 (send t is-sha1-enabled?)) + (send t enable-sha1) + (test #t 'sha1-off-by-default.3 (send t is-sha1-enabled?)) + (test #f 'sha1-off-by-default.4 (send t get-file-sha1)) + (define sha1-test-file (build-path dir "sha1-test-file")) + (define sha1-test-file-content #"123\n") + (call-with-output-file sha1-test-file (λ (port) (display sha1-test-file-content port))) + (send t load-file sha1-test-file) + (test (sha1-bytes sha1-test-file-content) 'sha1-of-content (send t get-file-sha1)) + (send t insert "0" 0 0) + (send t save-file) + (test (sha1-bytes (bytes-append #"0" sha1-test-file-content)) + 'sha1-of-content + (send t get-file-sha1))) + +;; ---------------------------------------- +;; image-snip equality + +(let () + (define i1 + (make-object image-snip% + (collection-file-path "recycle.png" "icons"))) + (test #t 'equal-image-self (equal? i1 i1)) + (define i2 + (make-object (class image-snip% + (super-new)) + (collection-file-path "recycle.png" "icons"))) + (test #t 'equal-image-sub (equal? i1 i2)) + (test #t 'equal-sub-image (equal? i2 i1))) + ;; ---------------------------------------- (delete-directory/files dir #:must-exist? #f) diff --git a/gui-test/tests/gracket/image-snip-unmarshalling.rkt b/gui-test/tests/gracket/image-snip-unmarshalling.rkt index 28d4d4253..cd8016d7b 100644 --- a/gui-test/tests/gracket/image-snip-unmarshalling.rkt +++ b/gui-test/tests/gracket/image-snip-unmarshalling.rkt @@ -27,13 +27,13 @@ and compares a bunch of properties of them (set! tests (+ tests 1)) (define t (new text%)) (send t insert is) - (define sp (open-output-string)) - (void (send t save-port sp)) - (define wp (wxme-port->port (open-input-string (get-output-string sp)))) + (define bp (open-output-bytes)) + (void (send t save-port bp)) + (define wp (wxme-port->port (open-input-bytes (get-output-bytes bp)))) (define wxme-is (read-char-or-special wp)) (define t2 (new text%)) - (send t2 insert-port (open-input-string (get-output-string sp))) + (send t2 insert-port (open-input-bytes (get-output-bytes bp))) (define copy-is (send t2 find-first-snip)) (define (warn . args) diff --git a/gui-test/tests/gracket/info.rkt b/gui-test/tests/gracket/info.rkt index fb5bb3606..d596cdcc6 100644 --- a/gui-test/tests/gracket/info.rkt +++ b/gui-test/tests/gracket/info.rkt @@ -6,3 +6,5 @@ "showkey.rkt" "unflushed-circle.rkt" "wxme-random.rkt")) + +(define test-xvfb-paths '("wxme.rkt")) diff --git a/gui-test/tests/gracket/item.rkt b/gui-test/tests/gracket/item.rkt index f158e204f..f6f8d221b 100644 --- a/gui-test/tests/gracket/item.rkt +++ b/gui-test/tests/gracket/item.rkt @@ -583,6 +583,7 @@ (define (big-frame h-radio? v-label? null-label? stretchy? font initially-disabled? alternate-init? msg-auto? panel-style) + (define closable-tabs? alternate-init?) (define f (make-frame (if use-dialogs? active-dialog% active-frame%) @@ -613,7 +614,9 @@ (define tp (if #f (make-object group-box-panel% "Sub" fp null (or font small-control-font)) - (make-object tab-panel% '("Sub" "Panel") fp void '(no-border) ($ font)))) + (make-object tab-panel% '("Sub" "Panel") fp void + (append '(no-border can-reorder) (if closable-tabs? '(can-close) null)) + ($ font)))) (when initially-disabled? (send tp enable #f)) @@ -1800,17 +1803,20 @@ (instructions p "combo-steps.txt") (send f show #t)) +(define slider-frame-style 'horizontal) +(define slider-frame-max 11) + (define (slider-frame style) (define f (make-frame frame% "Slider Test")) (define p (make-object vertical-panel% f)) (define old-list null) (define commands (list 'slider)) - (define s (make-object slider% "Slide Me" -1 11 p + (define s (make-object slider% "Slide Me" -1 slider-frame-max p (lambda (sl e) (check-callback-event s sl e commands #f) (printf "slid: ~a\n" (send s get-value))) 3 - (cons 'horizontal style))) + (cons slider-frame-style style))) (define c (make-object button% "Check" p (lambda (c e) (for-each @@ -2464,6 +2470,17 @@ (make-object vertical-pane% gsp) ; filler (make-object button% "Make Slider Frame" gsp (lambda (b e) (slider-frame null))) (make-object button% "Make Plain Slider Frame" gsp (lambda (b e) (slider-frame '(plain)))) +(make-object choice% #f '("Left" "Down" "Up" "Left^" "Down^" "Up^") + gsp (lambda (c e) + (set! slider-frame-style + (case (send c get-selection) + [(0 3) 'horizontal] + [(1 4) 'vertical] + [(2 5) 'upward])) + (set! slider-frame-max + (case (send c get-selection) + [(0 1 2) 11] + [(3 4 5) 1023])))) (make-object vertical-pane% gsp) ; filler (make-object button% "Make Tab Panel" gsp (lambda (b e) (test-tab-panel #f))) (make-object button% "Make Tabs" gsp (lambda (b e) (test-tab-panel #t))) diff --git a/gui-test/tests/gracket/pr195.rkt b/gui-test/tests/gracket/pr195.rkt new file mode 100644 index 000000000..76e62b85d --- /dev/null +++ b/gui-test/tests/gracket/pr195.rkt @@ -0,0 +1,21 @@ +#lang racket/gui + +;; Test case for https://github.com/racket/gui/pull/195, note that with the +;; bug present, this code should hang and not terminate. + +(define frame + (new frame% [label "my frame"] [width 400] [height 300])) + +(define canvas (new editor-canvas% [parent frame])) +(define text (new text%)) + +(send canvas set-editor text) ;; won't hang if this is called below + +(send text auto-wrap #t) +(send text set-padding 10 10 10 10) ;; hangs here + +;; (send canvas set-editor text) ;; won't hang if this is called here + +(send frame show #t) +(sleep/yield 0.5) +(send frame show #f) diff --git a/gui-test/tests/gracket/showkey.rkt b/gui-test/tests/gracket/showkey.rkt index 05b36faf1..0d6e0619b 100644 --- a/gui-test/tests/gracket/showkey.rkt +++ b/gui-test/tests/gracket/showkey.rkt @@ -18,12 +18,13 @@ (class canvas% (super-new) (define/override (on-event ev) - (printf "~a~a MOUSE ~a (~a,~a)\n mods:~a~a~a~a~a~a~a~a\n buttons:~a~a~a~a~a~a~a\n" + (printf "~a~a MOUSE ~a (~a,~a) @~a\n mods:~a~a~a~a~a~a~a~a\n buttons:~a~a~a~a~a~a~a\n" (es-check) iter (send ev get-event-type) (send ev get-x) (send ev get-y) + (send ev get-time-stamp) (if (send ev get-meta-down) " META" "") (if (send ev get-control-down) " CTL" "") (if (send ev get-alt-down) " ALT" "") @@ -49,13 +50,14 @@ ""))) (define/override (on-char ev) (set! iter (add1 iter)) - (printf "~a~a KEY: ~a\n rel-code: ~a\n other-codes: ~a\n mods:~a~a~a~a~a~a~a~a~a\n" + (printf "~a~a KEY: ~a @~a\n rel-code: ~a\n other-codes: ~a\n mods:~a~a~a~a~a~a~a~a~a\n" (es-check) iter (let ([v (send ev get-key-code)]) (if (symbol? v) v (format "~s = ASCII ~a" (string v) (char->integer v)))) + (send ev get-time-stamp) (let ([v (send ev get-key-release-code)]) (if (symbol? v) v diff --git a/gui-test/tests/gracket/windowing.rktl b/gui-test/tests/gracket/windowing.rktl index c39a590cb..7f2cc5966 100644 --- a/gui-test/tests/gracket/windowing.rktl +++ b/gui-test/tests/gracket/windowing.rktl @@ -643,7 +643,12 @@ (new slider% [parent parent] [label #f] [min-value 10] [max-value 9])) (mismatch (new slider% [parent parent] [label #f] [min-value 10] [max-value 11] [init-value 12])) - (letrec ([s (make-object slider% + (letrec ([style (case (random 3) + [(0) '(horizontal)] + [(1) '(vertical)] + [(2) '(upward)])] + [horiz? (and (memq 'horizontal style) #t)] + [s (make-object slider% "&Slider" -2 8 parent @@ -653,7 +658,7 @@ (set! side-effect 'slider) 'oops) 3 - '(horizontal))]) + style)]) (label-test s "Slider") (stv s command (make-object control-event% 'slider)) (test 'slider 'slider-callback side-effect) @@ -666,7 +671,7 @@ (stv s set-value 8) (st 8 s get-value) - (containee-window-tests s #t #f parent frame 2)) + (containee-window-tests s horiz? (not horiz?) parent frame 2)) (let ([test-list-control (lambda (l choice? multi?) @@ -1069,6 +1074,7 @@ (define (panel-tests frame% show? #:shorter? [shorter? shorter?]) (define (panel-test % win? #:choices? [choices? #f] + #:choices [choices '("A" "B")] #:label? [label? #f] #:margin [m 0] #:style [style '()]) @@ -1076,7 +1082,7 @@ [panel (if % (cond [choices? - (new % [parent frame] [choices '("A" "B")] [style style])] + (new % [parent frame] [choices choices] [style style])] [label? (new % [parent frame] [label "Stuff"])] [else (new % [parent frame])]) @@ -1105,6 +1111,10 @@ (panel-test horizontal-panel% #t) (panel-test tab-panel% #t #:choices? #t)) (panel-test tab-panel% #t #:choices? #t #:style '(no-border)) + (unless shorter? + (panel-test tab-panel% #t #:choices? #t #:choices '() #:style '(no-border)) + (panel-test tab-panel% #t #:choices? #t #:style '(no-border flat-portable)) + (panel-test tab-panel% #t #:choices? #t #:choices '() #:style '(no-border flat-portable))) (panel-test group-box-panel% #t #:label? #t #:margin 2)) (panel-tests dialog% #f) diff --git a/gui-test/tests/gracket/wxme-random.rkt b/gui-test/tests/gracket/wxme-random.rkt index 5948182fb..a7666cdb0 100644 --- a/gui-test/tests/gracket/wxme-random.rkt +++ b/gui-test/tests/gracket/wxme-random.rkt @@ -1,6 +1,6 @@ #lang scheme/gui -(define seed (abs (current-milliseconds))) +(define seed (modulo (abs (current-milliseconds)) (expt 2 31))) (random-seed seed) (define use-nested? #t) diff --git a/gui-test/tests/gracket/wxme-stream.rkt b/gui-test/tests/gracket/wxme-stream.rkt index af21976c7..4514c9b3c 100644 --- a/gui-test/tests/gracket/wxme-stream.rkt +++ b/gui-test/tests/gracket/wxme-stream.rkt @@ -94,9 +94,9 @@ (expect (send fbo2 get-bytes) (bytes-append #"\n3 2.0 3 #\"hi\\0\"\n3 #\"bye\"\n80\n" - #"(0\n" - #" #\"0123456789abcdefghij0123456789ABCD\"\n" - #" #\"EFGHIJ0123456789abcdefghij0123456\\\"89ABCDEFGHIJ\"\n" + #"(0 80\n" + #"0123456789abcdefghij0123456789ABCDEFGHIJ0123456789abcdefghij0123456\"89ABCDEFGHIJ" + #"\n" #")")) (define fbo3 (make-object editor-stream-out-bytes-base%)) @@ -217,6 +217,56 @@ #"") (expect (send fi2 ok?) #f)) +;; this is a duplicate of the previous test, but using a newer format +;; for the underlying data +(let () + (define fbi2 (make-object editor-stream-in-bytes-base% + (bytes-append #"1 ; comment \n 2 " + #"#| | x # #| |# q |# 4.0" + #" 2 #\"hi\"" + #" 3 #\"hi\\\"\"" + #" 23 (0 23\n0123456789ABCDEFapple!\0\n) 88"))) + (define fi2 (make-object editor-stream-in% fbi2)) + + (expect (send fi2 ok?) #t) + (expect (send fi2 tell) 0) + (expect (let ([b (box 0)]) (send fi2 get b) (unbox b)) 1) + (expect (send fi2 ok?) #t) + (expect (send fi2 tell) 1) + (expect (let ([b (box 0)]) (send fi2 get b) (unbox b)) 2) + (expect (send fi2 ok?) #t) + (expect (let ([b (box 0.0)]) (send fi2 get b) (unbox b)) 4.0) + (expect (send fi2 ok?) #t) + (expect (send fi2 tell) 3) + (expect (send fi2 get-unterminated-bytes) #"hi") + (expect (send fi2 ok?) #t) + (expect (send fi2 tell) 5) + (expect (send fi2 get-unterminated-bytes) #"hi\"") + (expect (send fi2 ok?) #t) + (expect (send fi2 get-bytes) #"0123456789ABCDEFapple!") + (expect (send fi2 ok?) #t) + (expect (send fi2 tell) 9) + + (send fi2 jump-to 3) + (expect (send fi2 tell) 3) + (expect (send fi2 get-unterminated-bytes) #"hi") + (send fi2 skip 4) + (expect (let ([b (box 0)]) (send fi2 get b) (unbox b)) 88) + (expect (send fi2 ok?) #t) + (expect (send fi2 tell) 10) + + (send fi2 jump-to 3) + (send fi2 set-boundary 2) + (expect (send fi2 get-unterminated-bytes) #"hi") + (send fi2 jump-to 3) + (expect (send fi2 ok?) #t) + (expect (send fi2 tell) 3) + (send fi2 set-boundary 1) + (expect (with-handlers ([values (lambda (exn) #"")]) + (send fi2 get-unterminated-bytes)) + #"") + (expect (send fi2 ok?) #f)) + (let () ;; this test ensures that no matter which way a bytes is @@ -258,6 +308,28 @@ (define four (send fi tell)) (expect four (+ three the-allowed-delta))) +(let () + ;; test that both inexacts and exacts written to the + ;; stream come back from the `get-exact` method + (define fbo2 (make-object editor-stream-out-bytes-base%)) + (define fo (make-object editor-stream-out% fbo2)) + + (void (send fo put 2)) + (send fbo2 get-bytes) + (void (send fo put 2.0)) + (send fbo2 get-bytes) + + (define fbi2 (make-object editor-stream-in-bytes-base% + (send fbo2 get-bytes))) + (define fi2 (make-object editor-stream-in% fbi2)) + + (define n1 (send fi2 get-exact)) + (define n2 (send fi2 get-exact)) + (expect (exact? n1) #t) + (expect (= n1 2) #t) + (expect (exact? n2) #f) + (expect (= n1 2) #t)) + (let () (define (wash-it b) (define out-base (new editor-stream-out-bytes-base%)) @@ -321,7 +393,7 @@ (define (check-em got expected) (unless (equal? got expected) (set! wrong-cnt (+ wrong-cnt 1)) - (eprintf "failure!\n index: ~a\n got: ~s\n expected: ~s\n ~s\n" + (eprintf "failure!\n index: ~a\n got: ~s\n expected: ~s\n whats: ~s\n" i got expected @@ -422,6 +494,6 @@ (for ([x (in-range 1000)]) (in/out (contract-random-generate - (list/c what/c)))) + (listof what/c)))) (done) diff --git a/gui-test/tests/gracket/wxme.rkt b/gui-test/tests/gracket/wxme.rkt index fb90767e7..7956b7901 100644 --- a/gui-test/tests/gracket/wxme.rkt +++ b/gui-test/tests/gracket/wxme.rkt @@ -2,6 +2,7 @@ (require racket/class racket/contract racket/file + racket/draw (only-in racket/gui/base color% font% @@ -18,7 +19,8 @@ "test-editor-admin.rkt" mred/private/wxme/keymap mred/private/wxme/editor-snip - (for-syntax racket/base)) + (for-syntax racket/base) + (only-in ffi/unsafe void/reference-sink)) (define wrong-cnt 0) (define test-cnt 0) @@ -68,10 +70,12 @@ (expect (mline-get-line m20) 1) (expect (mline-get-position m00) 0) (expect (mline-get-position m20) 0) -(void (mline-set-length m00 5)) -(void (mline-set-length m20 20)) +(void (mline-set-length m00 5 4)) +(void (mline-set-length m20 20 8)) (expect (mline-get-position m00) 0) (expect (mline-get-position m20) 5) +(expect (mline-get-grapheme-position m20) 4) +(expect (mline-grapheme-len m20) 8) (mline-check-consistent (unbox root-box)) @@ -81,21 +85,24 @@ (define m5 (mline-insert m20 root-box #t)) (mline-check-consistent (unbox root-box)) -(void (mline-set-length m5 10)) +(void (mline-set-length m5 10 8)) (expect (mline-get-position m00) 0) (expect (mline-get-position m5) 5) (expect (mline-get-position m20) 15) +(expect (mline-get-grapheme-position m20) 12) (mline-delete m5 root-box) (expect (mline-get-position m20) 5) +(expect (mline-get-grapheme-position m20) 4) (set! m5 (mline-insert m20 root-box #t)) -(void (mline-set-length m5 8)) +(void (mline-set-length m5 8 7)) (expect (mline-get-position m00) 0) (expect (mline-get-position m5) 5) (expect (mline-get-position m20) 13) +(expect (mline-get-grapheme-position m20) 11) (mline-delete m5 root-box) @@ -121,7 +128,7 @@ (define m05 (mline-insert m00 root-box #f)) -(void (mline-set-length m05 2)) +(void (mline-set-length m05 2 2)) (expect (mline-get-line m00) 0) (expect (mline-get-line m05) 1) @@ -248,6 +255,60 @@ (define s2-modern (send sl2 convert s-modern)) (expect (send s2-modern get-family) 'modern) +(let () + (define changes '()) + (define t% + (class text% + (define/override (style-has-changed s) + (set! changes (cons s changes))) + (super-new))) + (define sl (new style-list%)) + (define t (new t%)) + (send t set-style-list sl) + (define d1 (new style-delta%)) + (send d1 set-weight-on 'bold) + (define d2 (new style-delta%)) + (send d2 set-underlined-on #t) + (expect changes '()) + (define named-style1 (send sl new-named-style "named-style1" (send sl basic-style))) + (define named-style2 (send sl new-named-style "named-style2" (send sl basic-style))) + (set! changes '()) + + (send named-style1 set-delta d1) + (expect changes (list #f named-style1)) + (set! changes '()) + + (send named-style2 set-delta d1) + (expect changes (list #f named-style2)) + (set! changes '()) + + (send sl begin-style-change-sequence) + (send named-style1 set-delta d2) + (expect changes '()) + (send named-style2 set-delta d2) + (expect changes '()) + (send sl end-style-change-sequence) + (expect (car changes) #f) + (expect (length changes) 3) + (expect (and (member named-style1 changes) #t) #t) + (expect (and (member named-style2 changes) #t) #t) + (set! changes '()) + + (send sl begin-style-change-sequence) + (send sl begin-style-change-sequence) + (send named-style1 set-delta d1) + (expect changes '()) + (send named-style2 set-delta d1) + (expect changes '()) + (send sl end-style-change-sequence) + (send sl end-style-change-sequence) + (expect (length changes) 3) + (expect (and (pair? changes) (equal? (car changes) #f)) #t) + (expect (and (member named-style1 changes) #t) #t) + (expect (and (member named-style2 changes) #t) #t) + (set! changes '()) + (void/reference-sink t)) + ;; ---------------------------------------- ;; Lines, positions, paragraphs @@ -371,7 +432,7 @@ (send t set-position 0 0) t) (define (kmp-search txt str all?) - (send txt do-find-string-all str 'forward 0 (send txt last-position) (not all?) #t #t #f)) + (send txt do-find-string-all str 'forward 0 (send txt last-position) (not all?) #t #t (λ (x) #f))) (expect (kmp-search (txt "x") "x" #f) 0) (expect (kmp-search (txt "yx") "x" #f) 1) @@ -385,52 +446,52 @@ (expect (kmp-search (txt "xyxy") "x" #t) '(0 2)) (expect (kmp-search (txt " x\n ") "x" #t) '(1)) (expect (kmp-search (txt "") "x" #t) '()) - (expect (send (txt " x\n ") do-find-string-all "X" 'forward 0 'eof #f #t #f #f) + (expect (send (txt " x\n ") do-find-string-all "X" 'forward 0 'eof #f #t #f (λ (x) #f)) '(1)) - (expect (send (txt "xXxXxX") do-find-string-all "x" 'forward 0 'eof #f #t #f #f) + (expect (send (txt "xXxXxX") do-find-string-all "x" 'forward 0 'eof #f #t #f (λ (x) #f)) '(0 1 2 3 4 5)) - (expect (send (txt "xXxXxX") do-find-string-all "x" 'forward 2 4 #f #t #f #f) + (expect (send (txt "xXxXxX") do-find-string-all "x" 'forward 2 4 #f #t #f (λ (x) #f)) '(2 3)) - (expect (send (txt "xyxyxyxyxyx") do-find-string-all "xy" 'forward 2 5 #f #t #t #f) + (expect (send (txt "xyxyxyxyxyx") do-find-string-all "xy" 'forward 2 5 #f #t #t (λ (x) #f)) '(2)) - (expect (send (txt "abcdabcdabcd") do-find-string-all "abcd" 'forward 0 'eof #f #f #t #f) + (expect (send (txt "abcdabcdabcd") do-find-string-all "abcd" 'forward 0 'eof #f #f #t (λ (x) #f)) '(4 8 12)) - (expect (send (txt "qqabcdabcdabcd") do-find-string-all "abcd" 'forward 0 'eof #t #f #t #f) + (expect (send (txt "qqabcdabcdabcd") do-find-string-all "abcd" 'forward 0 'eof #t #f #t (λ (x) #f)) 6) - (expect (send (txt "qqabcdabcdabcd") do-find-string-all "abcd" 'forward 0 'eof #t #t #t #f) + (expect (send (txt "qqabcdabcdabcd") do-find-string-all "abcd" 'forward 0 'eof #t #t #t (λ (x) #f)) 2) - (expect (send (txt "abcdabcdabcd") do-find-string-all "abcd" 'backward 12 0 #f #t #t #f) + (expect (send (txt "abcdabcdabcd") do-find-string-all "abcd" 'backward 12 0 #f #t #t (λ (x) #f)) '(12 8 4)) - (expect (send (txt "abcdabcdabcd") do-find-string-all "abcd" 'backward 12 0 #f #f #t #f) + (expect (send (txt "abcdabcdabcd") do-find-string-all "abcd" 'backward 12 0 #f #f #t (λ (x) #f)) '(8 4 0)) - (expect (send (txt "abcd\nabcdabcd") do-find-string-all "abcd" 'backward 12 0 #f #t #t #f) + (expect (send (txt "abcd\nabcdabcd") do-find-string-all "abcd" 'backward 12 0 #f #t #t (λ (x) #f)) '(9 4)) - (expect (send (txt "abcd\nabcdabcd") do-find-string-all "abcd" 'backward 13 0 #f #t #t #f) + (expect (send (txt "abcd\nabcdabcd") do-find-string-all "abcd" 'backward 13 0 #f #t #t (λ (x) #f)) '(13 9 4)) - (expect (send (txt "abcdabcd\nabcd") do-find-string-all "abcd" 'backward 12 0 #f #t #t #f) + (expect (send (txt "abcdabcd\nabcd") do-find-string-all "abcd" 'backward 12 0 #f #t #t (λ (x) #f)) '(8 4)) - (expect (send (txt "abcdabcd\nabcd") do-find-string-all "abcd" 'backward 13 0 #f #t #t #f) + (expect (send (txt "abcdabcd\nabcd") do-find-string-all "abcd" 'backward 13 0 #f #t #t (λ (x) #f)) '(13 8 4)) - (expect (send (txt "abcdabcd\nabcd") do-find-string-all "abcd" 'backward 8 0 #f #t #t #f) + (expect (send (txt "abcdabcd\nabcd") do-find-string-all "abcd" 'backward 8 0 #f #t #t (λ (x) #f)) '(8 4)) - (expect (send (txt "abcdabcd\nabcd") do-find-string-all "abcd" 'forward 4 13 #f #t #t #f) + (expect (send (txt "abcdabcd\nabcd") do-find-string-all "abcd" 'forward 4 13 #f #t #t (λ (x) #f)) '(4 9)) - (expect (send (txt "xyz") do-find-string-all "xyz" 'backward 3 0 #t #f #t #f) + (expect (send (txt "xyz") do-find-string-all "xyz" 'backward 3 0 #t #f #t (λ (x) #f)) 0) - (expect (send (txt "xyz") do-find-string-all "xyz" 'backward 3 0 #t #t #t #f) + (expect (send (txt "xyz") do-find-string-all "xyz" 'backward 3 0 #t #t #t (λ (x) #f)) 3) (let ([t (new text%)]) (send t insert "abc") (send t insert "abc") (send t insert "abc") - (expect (send t do-find-string-all "abc" 'forward 0 (send t last-position) #f #t #t #t) + (expect (send t do-find-string-all "abc" 'forward 0 (send t last-position) #f #t #t (λ (x) #t)) '(0 3 6)) - (expect (send t do-find-string-all "abc" 'backward (send t last-position) 0 #f #t #t #t) + (expect (send t do-find-string-all "abc" 'backward (send t last-position) 0 #f #t #t (λ (x) #t)) '(9 6 3)) - (expect (send t do-find-string-all "ca" 'forward 0 (send t last-position) #f #t #t #t) + (expect (send t do-find-string-all "ca" 'forward 0 (send t last-position) #f #t #t (λ (x) #t)) '(2 5)) - (expect (send t do-find-string-all "ca" 'backward (send t last-position) 0 #f #t #t #t) + (expect (send t do-find-string-all "ca" 'backward (send t last-position) 0 #f #t #t (λ (x) #t)) '(7 4))) (let ([t1 (new text%)] @@ -439,13 +500,13 @@ (send t1 insert (new editor-snip% [editor t2])) (send t1 insert "abc") (send t2 insert "abc") - (expect (send t1 do-find-string-all "abc" 'forward 0 (send t1 last-position) #f #t #t #t) + (expect (send t1 do-find-string-all "abc" 'forward 0 (send t1 last-position) #f #t #t (λ (x) #t)) (list 0 (list t2 0) 4)) - (expect (send t1 do-find-string-all "abc" 'backward (send t1 last-position) 0 #f #t #t #t) + (expect (send t1 do-find-string-all "abc" 'backward (send t1 last-position) 0 #f #t #t (λ (x) #t)) (list 7 (list t2 3) 3)) - (expect (send t1 do-find-string-all "abca" 'forward 0 (send t1 last-position) #f #t #t #t) + (expect (send t1 do-find-string-all "abca" 'forward 0 (send t1 last-position) #f #t #t (λ (x) #t)) '()) - (expect (send t1 do-find-string-all "cabc" 'forward 0 (send t1 last-position) #f #t #t #t) + (expect (send t1 do-find-string-all "cabc" 'forward 0 (send t1 last-position) #f #t #t (λ (x) #t)) '())) (let ([t1 (new text%)] @@ -453,10 +514,24 @@ (send t1 insert "abc") (send t1 insert (new editor-snip% [editor t2])) (send t2 insert "abc") - (expect (send t1 do-find-string-all "abc" 'forward 0 (send t1 last-position) #f #t #t #t) + (expect (send t1 do-find-string-all "abc" 'forward 0 (send t1 last-position) #f #t #t (λ (x) #t)) (list 0 (list t2 0))) - (expect (send t1 do-find-string-all "abc" 'backward (send t1 last-position) 0 #f #t #t #t) + (expect (send t1 do-find-string-all "abc" 'backward (send t1 last-position) 0 #f #t #t (λ (x) #t)) (list (list t2 3) 3))) + + (let ([t1 (new text%)] + [t2 (new text%)]) + (send t1 insert "abc") + (send t1 insert (new editor-snip% [editor t2])) + (send t2 insert "abc") + (expect (send t1 do-find-string-all "abc" 'forward 0 (send t1 last-position) #f #t #t + (λ (x) + (not (object=? (send x get-editor) t2)))) + (list 0)) + (expect (send t1 do-find-string-all "abc" 'backward (send t1 last-position) 0 #f #t #t + (λ (x) + (not (object=? (send x get-editor) t2)))) + (list 3))) (let ([t1 (new text%)] [t2 (new text%)]) @@ -464,7 +539,7 @@ (send t1 insert (new editor-snip% [editor t2])) (send t1 insert "abcd") (send t2 insert "abc") - (expect (send t1 do-find-string-all "abcd" 'forward 0 (send t1 last-position) #t #t #t #t) + (expect (send t1 do-find-string-all "abcd" 'forward 0 (send t1 last-position) #t #t #t (λ (x) #t)) 4)) (let ([t1 (new text%)] @@ -473,7 +548,7 @@ (send t1 insert (new editor-snip% [editor t2])) (send t1 insert "abc") (send t2 insert "abcd") - (expect (send t1 do-find-string-all "abcd" 'forward 0 (send t1 last-position) #t #t #t #t) + (expect (send t1 do-find-string-all "abcd" 'forward 0 (send t1 last-position) #t #t #t (λ (x) #t)) (cons t2 0))) (let ([t1 (new text%)] @@ -484,7 +559,7 @@ (send pb insert (new editor-snip% [editor t2])) (send t1 insert "abc") (send t2 insert "abcd") - (expect (send t1 do-find-string-all "abcd" 'forward 0 (send t1 last-position) #t #t #t #t) + (expect (send t1 do-find-string-all "abcd" 'forward 0 (send t1 last-position) #t #t #t (λ (x) #t)) (list* pb t2 0))) (let ([t1 (new text%)] @@ -498,19 +573,36 @@ (send t1 insert "abc") (send t2 insert "abcd") (send t3 insert "abcd") - (expect (send t1 do-find-string-all "abcd" 'forward 0 (send t1 last-position) #f #t #t #t) + (expect (send t1 do-find-string-all "abcd" 'forward 0 (send t1 last-position) #f #t #t (λ (x) #t)) (list (list pb (list t2 0) (list t3 0))))) + + (let ([t1 (new text%)] + [t2 (new text%)] + [t3 (new text%)] + [pb (new pasteboard%)]) + (send t1 insert "abc") + (send t1 insert (new editor-snip% [editor pb])) + (send pb insert (new editor-snip% [editor t2])) + (send pb insert (new editor-snip% [editor t3])) + (send t1 insert "abc") + (send t2 insert "abcd") + (send t3 insert "abcd") + (expect (send t1 do-find-string-all "abcd" 'forward 0 (send t1 last-position) #f #t #t + (λ (x) + (and (not (object=? (send x get-editor) t2)) + (not (object=? (send x get-editor) t3))))) + (list))) (let ([t1 (new text%)]) (send t1 insert "abc") (define es (new editor-snip%)) (send t1 insert es) (send t1 insert "abc") - (expect (send t1 do-find-string-all "abcd" 'forward 0 (send t1 last-position) #f #t #t #t) + (expect (send t1 do-find-string-all "abcd" 'forward 0 (send t1 last-position) #f #t #t (λ (x) #t)) '()) - (expect (send t1 do-find-string-all "abca" 'forward 0 (send t1 last-position) #f #t #t #t) + (expect (send t1 do-find-string-all "abca" 'forward 0 (send t1 last-position) #f #t #t (λ (x) #t)) '()) - (expect (send t1 do-find-string-all "cabc" 'forward 0 (send t1 last-position) #f #t #t #t) + (expect (send t1 do-find-string-all "cabc" 'forward 0 (send t1 last-position) #f #t #t (λ (x) #t)) '())) (let ([t1 (new text%)] @@ -520,11 +612,11 @@ (send t1 insert "abc") (send pb insert (new editor-snip%)) (send pb insert (new editor-snip%)) - (expect (send t1 do-find-string-all "abcd" 'forward 0 (send t1 last-position) #f #t #t #t) + (expect (send t1 do-find-string-all "abcd" 'forward 0 (send t1 last-position) #f #t #t (λ (x) #t)) '()) - (expect (send t1 do-find-string-all "abca" 'forward 0 (send t1 last-position) #f #t #t #t) + (expect (send t1 do-find-string-all "abca" 'forward 0 (send t1 last-position) #f #t #t (λ (x) #t)) '()) - (expect (send t1 do-find-string-all "cabc" 'forward 0 (send t1 last-position) #f #t #t #t) + (expect (send t1 do-find-string-all "cabc" 'forward 0 (send t1 last-position) #f #t #t (λ (x) #t)) '())) (expect (send (txt "aaa") find-string-all "a") '(0 1 2)) @@ -609,6 +701,183 @@ (fast-string-search thing-to-search-for text-to-search-in) #:extra-stuff (list thing-to-search-for thing-to-search-in)))) +;; ---------------------------------------- +;; Graphemes + +(let () + (define t (new text%)) + (send t insert "he\u300llo") + (expect (send t position-grapheme 5) 4) + (expect (send t grapheme-position 5) 6) + (send t insert "a" 1) + (expect (send t position-grapheme 0) 0) + (expect (send t position-grapheme 1) 1) + (expect (send t position-grapheme 2) 2) + (expect (send t position-grapheme 5) 4) + (expect (send t grapheme-position 5) 6) + (expect (send t last-position) 7) + (send t set-position 4) + (send t delete) + (expect (send t last-position) 5) + (send t insert "e\u300") + (expect (send t last-position) 7) + (expect (send t grapheme-position 6) 7) + (expect (send t position-grapheme 2) 2) + (expect (send t position-grapheme 3) 2) + (expect (send t position-grapheme 4) 3) + (expect (send t position-grapheme 7) 6) + (send t insert "\n" 1) + (expect (send t last-position) 8) + (expect (send t position-grapheme 8) 7) + (expect (send t position-grapheme 3) 3) + (expect (send t position-grapheme 5) 4)) + +(let () + (define prog + (apply string-append + (map (lambda (l) (string-append l "\n")) + '("#lang racket" + "" + "'🏴‍☠️" + "'(🏳️‍🌈 🇦🇩 📸 ☮️)" + "(list '🏴‍☠️" + " '🏴‍☠️" + " '🏴‍☠️" + " '🏴‍☠️" + " '⏰)" + "" + "#false")))) + (define (check-prog t) + (let loop ([snip (send t find-first-snip)]) + (when snip + (define s (send snip get-text 0 (send snip get-count))) + (expect (send snip get-grapheme-count) (string-grapheme-count s)) + (loop (send snip next)))) + (expect (send t last-position) (string-length prog)) + (expect (send t position-grapheme (send t last-position)) (string-grapheme-count prog)) + (let ([counts (make-vector (add1 (string-length prog)) 0)]) + (let loop ([n 0] [i 0]) + (cond + [(= i (string-length prog)) + (vector-set! counts i n)] + [else + (define len (string-grapheme-span prog i)) + (for ([j (in-range len)]) + (vector-set! counts (+ i j) n)) + (loop (add1 n) (+ i len))])) + (for ([i (in-range (string-length prog))]) + (unless (= (send t position-grapheme i) (vector-ref counts i)) + (printf "wrong at ~a: ~a ~a\n" i (send t position-grapheme i) (vector-ref counts i)))))) + ;; whole string + (let () + (define t (new text%)) + (send t insert prog) + (check-prog t)) + ;; char by char + (let () + (define t (new text%)) + (for ([i (in-string prog)]) + (send t insert i)) + (check-prog t)) + ;; reverse chars + (let () + (define t (new text%)) + (for ([i (in-list (reverse (string->list prog)))]) + (send t insert i 0 0)) + (check-prog t)) + ;; grapheme-by-grapheme + (let () + (define t (new text%)) + (let loop ([i 0]) + (unless (= i (string-length prog)) + (define len (string-grapheme-span prog i)) + (send t insert (substring prog i (+ i len))) + (loop (+ i len)))) + (check-prog t)) + ;; 3 bytes at a time, request merging, need for merging triggered by style change + (let () + (define t (new text%)) + (define normal (send (send t get-style-list) basic-style)) + (define bold (send (send t get-style-list) find-or-create-style normal (make-object style-delta% 'change-bold))) + (let loop ([i 0]) + (unless (= i (string-length prog)) + (define len (min 3 (- (string-length prog) i))) + (define end (+ i len)) + (send t insert (substring prog i end) (send t get-end-position) 'same #f #t) ; <- `#t` here matters + (define start (send t grapheme-position (send t position-grapheme i))) + (send t change-style bold start end) + (send t change-style normal end end) + (loop (+ i len)))) + (check-prog t)) + + (void)) + +(let () + ;; Regression test for a style change that involves a split + ;; where the number of split-off characters matches the delta + ;; between chars and graphemes + (define t (new text%)) + + (define normal (send (send t get-style-list) basic-style)) + (define bold (send (send t get-style-list) find-or-create-style normal (make-object style-delta% 'change-bold))) + (define underline (send (send t get-style-list) find-or-create-style normal (make-object style-delta% 'change-underline))) + + (send t insert "(ความกว้าง 500)") + (send t change-style underline 0 10) + (send t change-style bold 1 1) + (expect (for/list ([i (in-range (send t last-position))]) + (send t position-grapheme i)) + '(0 1 2 3 4 5 6 6 7 8 9 10 11 12 13)) + (expect (for/list ([i (in-range (send t last-position))]) + (send t grapheme-position i)) + '(0 1 2 3 4 5 6 8 9 10 11 12 13 14 15))) + +(let () + ;; these strings are picked in a way to make the final insert + ;; shift a buffer content leaving #\uFE0F just after the content + (define pre0 "xx") + (define pre1 "\ufe0f\ufe0f\ufe0f") + (define pre (string-append pre0 pre1)) + (define str "\u200d\u2620\ufe0f") + + (define s (make-object string-snip% pre0)) + (send s insert pre1 (string-length pre1) (string-length pre1)) + (send s insert str (string-length str) (string-length pre)) + (define s2 + (let ([a (box #f)] + [b (box #f)]) + (send s split (string-length pre) a b) + (unbox b))) + + (send s2 insert "z" 1 (string-length str)) + + (define bm (make-object bitmap% 10 10)) + (define dc (send bm make-dc)) + + (expect + (let ([w (box 0)]) + (send s2 get-extent dc 0 0 w) + (unbox w)) + (send s2 partial-offset dc 0 0 (add1 (string-length str))))) + +(let () + (define bts '(#"\360\237\217\264" #"\342\200\215" #"\342\230\240" #"\357\270\217")) + (define txt (new text%)) + (send txt set-styles-sticky #f) + (send txt insert "az") + (for ([b (in-list bts)] + [i (in-naturals)]) + (send txt insert (bytes->string/utf-8 b) + (- (send txt last-position) 1) + (- (send txt last-position) 1) + #t #t) + (when (= i 0) + (send txt change-style (make-object style-delta% 'change-bold) 1 2))) + (expect (for/list ([i (in-list '(0 1 2 3))]) + (send txt grapheme-position i)) + '(0 1 5 6))) + + ;; ---------------------------------------- ;; Insert very long strings to test max-string-length handling diff --git a/gui/info.rkt b/gui/info.rkt index 2711de0bd..d0fedef4d 100644 --- a/gui/info.rkt +++ b/gui/info.rkt @@ -10,3 +10,6 @@ (define pkg-desc "Graphical user interface toolkit") (define pkg-authors '(mflatt robby)) + +(define license + '(Apache-2.0 OR MIT)) diff --git a/tex-table/info.rkt b/tex-table/info.rkt index 63be29814..4daa5060d 100644 --- a/tex-table/info.rkt +++ b/tex-table/info.rkt @@ -6,3 +6,6 @@ (define pkg-desc "Table of TeX-style abbreviations") (define pkg-authors '(robby)) + +(define license + '(Apache-2.0 OR MIT)) diff --git a/tex-table/tex-table.rkt b/tex-table/tex-table.rkt index c75a84ff7..a7df0c76f 100644 --- a/tex-table/tex-table.rkt +++ b/tex-table/tex-table.rkt @@ -1,5 +1,5 @@ #lang racket/base -(require racket/contract) +(require racket/contract racket/match) (define (string-len-one? x) (and (string? x) @@ -9,7 +9,36 @@ [tex-shortcut-table (listof (list/c string? string-len-one?))]) +(define blackboard-bold + (append + (for*/list ([i (in-string "ABCDEFGHIJKLMNOPQRSTUVWXYZ")] + [case (in-list '(lower upper))]) + (cond + [(and (equal? case 'upper) (member i (string->list "CHNPQRZ"))) + (list (format "b~a" i) + (match i + [#\C "ℂ"] + [#\H "ℍ"] + [#\N "ℕ"] + [#\P "ℙ"] + [#\Q "ℚ"] + [#\R "ℝ"] + [#\Z "ℤ"]))] + [else + (define bo (match case + ['upper (- (char->integer #\𝔸) (char->integer #\A))] + ['lower (- (char->integer #\𝕒) (char->integer #\A))])) + (define co (match case + ['upper 0] + ['lower (- (char->integer #\a) (char->integer #\A))])) + (list (format "b~a" (integer->char (+ (char->integer i) co))) + (string (integer->char (+ (char->integer i) bo))))])) + (for/list ([i (in-inclusive-range 0 9)]) + (list (format "b~a" i) + (string (integer->char (+ (char->integer #\𝟘) i))))))) + (define tex-shortcut-table + (append '(("Downarrow" "⇓") ("nwarrow" "↖") ("downarrow" "↓") @@ -133,6 +162,7 @@ ("land" "∧") ("lnot" "¬") ("triangleleft" "◃") + ("angle" "∠") ("odot" "⊙") ("star" "★") ("dagger" "†") @@ -157,6 +187,8 @@ ("simeq" "≃") ("ll" "≪") ("gg" "≫") + ("guillemetleft" "«") + ("guillemetright" "»") ("asymp" "≍") ("parallel" "∥") ("subset" "⊂") @@ -165,7 +197,9 @@ ("bowtie" "⋈") ("subseteq" "⊆") ("supseteq" "⊇") - ("cong" "≌") + ("nsubseteq" "⊈") + ("subsetneq" "⊊") + ("cong" "≅") ("sqsubsetb" "⊏") ("sqsupsetb" "⊐") ("neq" #;"≠" "≠") @@ -186,7 +220,11 @@ ("coprod" "∐") ("int" "∫") + ("iint" "∬") + ("iiint" "∭") ("oint" "∮") + ("oiint" "∯") + ("oiiint" "∰") ("sqrt" "√") @@ -194,10 +232,12 @@ ("smiley" "☺") ("blacksmiley" "☻") ("frownie" "☹") - + + ("Re" "ℜ") + ("Im" "ℑ") ("S" "§") ("l" "ł") - + ("newpage" "\f") ("vdots" "⋮") @@ -217,10 +257,10 @@ ("leftmultimap" "⟜") ("multimapinv" "⟜") ("leftlollipop" "⟜") - )) + ) + blackboard-bold)) (module+ test - (require racket/match) (define name-ht (make-hash)) (define val-ht (make-hash)) (for ([line (in-list tex-shortcut-table)])