From 1c44fd5bf1786139ebeefce7f1f312b94a0218e7 Mon Sep 17 00:00:00 2001 From: Philip McGrath Date: Sat, 6 Jan 2024 16:21:23 -0500 Subject: [PATCH 01/18] docs: stop recommending add-third-party-script-directory! Related to https://github.com/Metaxal/quickscript/issues/73 --- scribblings/quickscript.scrbl | 36 +++++++++-------------------------- 1 file changed, 9 insertions(+), 27 deletions(-) diff --git a/scribblings/quickscript.scrbl b/scribblings/quickscript.scrbl index af61c2d..4b873c4 100644 --- a/scribblings/quickscript.scrbl +++ b/scribblings/quickscript.scrbl @@ -446,33 +446,15 @@ or on @hyperlink["http://pasterack.org/"]{PasteRack}, and share the link. A user can then copy/paste the contents into a new script. Don't forget to include a permissive license such as MIT/Apache 2. - -The @emph{best} way to distribute scripts is by creating a package---the user only has to install -the package. -Assuming your scripts are stored in the @racket["scripts"] subdirectory, -include a file (say @racket["register.rkt"]) at the root directory of -the package containing the following code: -@margin-note{If the file @racket["register.rkt"] is not at the root, - the runtime-path needs to be modified accordingly.} -@codeblock|{ -#lang racket/base -(require (for-syntax racket/base - racket/runtime-path - (only-in quickscript/library - add-third-party-script-directory!))) - -;; This file is going to be called during setup and will automatically -;; register the scripts subdirectory in quickscript's library. -(begin-for-syntax - (define-runtime-path script-dir "scripts") - (add-third-party-script-directory! script-dir)) - }| - -You can see an example with -@hyperlink["https://github.com/Metaxal/quickscript-extra"]{quickscript-extra}. - -Don't forget to register your package on the -@hyperlink["https://pkgs.racket-lang.org/"]{Racket server}. +@; The @emph{best} way to distribute scripts is by creating a package---the user only has to install +@; the package. +@; ... but the current mechanism is broken, see https://github.com/Metaxal/quickscript/issues/79 ... +@; +@; You can see an example with +@; @hyperlink["https://github.com/Metaxal/quickscript-extra"]{quickscript-extra}. +@; +@; Don't forget to register your package on the +@; @hyperlink["https://pkgs.racket-lang.org/"]{Racket server}. @section{License} From 470ffa1a14d5e0e93f2b8d222828677cc4d22293 Mon Sep 17 00:00:00 2001 From: Philip McGrath Date: Fri, 5 Jan 2024 21:37:48 -0500 Subject: [PATCH 02/18] move most modules to "private" directory Related to https://github.com/Metaxal/quickscript/issues/73 --- base.rkt => private/base.rkt | 27 ++++++++++++++++--- exn-gobbler.rkt => private/exn-gobbler.rkt | 0 library-gui.rkt => private/library-gui.rkt | 0 library.rkt => private/library.rkt | 0 .../shadow-script.rkt | 0 tests/library.rkt | 4 +-- tool.rkt | 8 +++--- 7 files changed, 30 insertions(+), 9 deletions(-) rename base.rkt => private/base.rkt (90%) rename exn-gobbler.rkt => private/exn-gobbler.rkt (100%) rename library-gui.rkt => private/library-gui.rkt (100%) rename library.rkt => private/library.rkt (100%) rename shadow-script.rkt => private/shadow-script.rkt (100%) diff --git a/base.rkt b/private/base.rkt similarity index 90% rename from base.rkt rename to private/base.rkt index 28b5ec7..96b2a95 100644 --- a/base.rkt +++ b/private/base.rkt @@ -4,12 +4,30 @@ racket/format racket/file racket/path - racket/runtime-path compiler/compilation-path compiler/cm "exn-gobbler.rkt") -(provide (all-defined-out)) +(provide log-quickscript-fatal + log-quickscript-error + log-quickscript-warning + log-quickscript-info + log-quickscript-debug + quickscript-logger + get-script-help-string + make-simple-script-string + prop-dict-ref + compile-user-scripts + compile-user-script + this-os-type + time-info + path-free? + path-string=? + script-file? + user-script-dir + get-property-dicts + path-string->string + library-file) (module+ test (require rackunit)) @@ -39,7 +57,10 @@ (path->string p-str))) (define (script-file? f) - (equal? (path-get-extension f) #".rkt")) + (and (equal? (path-get-extension f) #".rkt") + (not (equal? f (if (string? f) + "info.rkt" + (string->path-element "info.rkt")))))) (define (path-string=? dir1 dir2) (string=? (path-string->string dir1) diff --git a/exn-gobbler.rkt b/private/exn-gobbler.rkt similarity index 100% rename from exn-gobbler.rkt rename to private/exn-gobbler.rkt diff --git a/library-gui.rkt b/private/library-gui.rkt similarity index 100% rename from library-gui.rkt rename to private/library-gui.rkt diff --git a/library.rkt b/private/library.rkt similarity index 100% rename from library.rkt rename to private/library.rkt diff --git a/shadow-script.rkt b/private/shadow-script.rkt similarity index 100% rename from shadow-script.rkt rename to private/shadow-script.rkt diff --git a/tests/library.rkt b/tests/library.rkt index 73d9570..e565c46 100644 --- a/tests/library.rkt +++ b/tests/library.rkt @@ -1,8 +1,8 @@ #lang racket ;; Tests n a separate file to test the contracts too. (require rackunit - quickscript/base - quickscript/library) + "../private/base.rkt" + "../private/library.rkt") (define my-lib (new-library)) (check set=? diff --git a/tool.rkt b/tool.rkt index e18463d..6861484 100644 --- a/tool.rkt +++ b/tool.rkt @@ -12,10 +12,10 @@ racket/list racket/string racket/unit - "base.rkt" - "exn-gobbler.rkt" - (prefix-in lib: "library.rkt") - "library-gui.rkt") + "private/base.rkt" + "private/exn-gobbler.rkt" + (prefix-in lib: "private/library.rkt") + "private/library-gui.rkt") (provide tool@) #| From 8d0f369f51aa019eee4478803b3b2c853415646c Mon Sep 17 00:00:00 2001 From: Philip McGrath Date: Sat, 6 Jan 2024 16:06:09 -0500 Subject: [PATCH 03/18] add compatibility stubs for quickscript-extra Related to https://github.com/Metaxal/quickscript/issues/73 --- base.rkt | 5 +++++ library.rkt | 16 ++++++++++++++++ 2 files changed, 21 insertions(+) create mode 100644 base.rkt create mode 100644 library.rkt diff --git a/base.rkt b/base.rkt new file mode 100644 index 0000000..4b4376c --- /dev/null +++ b/base.rkt @@ -0,0 +1,5 @@ +#lang racket/base +(require "private/base.rkt") +(provide get-script-help-string + script-file? + user-script-dir) diff --git a/library.rkt b/library.rkt new file mode 100644 index 0000000..5c77233 --- /dev/null +++ b/library.rkt @@ -0,0 +1,16 @@ +#lang racket/base + +;; This module provides limited backwards compatibility for packages +;; that followed the old, broken recommendations for registering scripts. +;; The Quickscript library is now actually implemented in "private/library.rkt". + +(require "private/base.rkt") + +(provide add-third-party-script-directory! + remove-third-party-script-directory!) + +(define (add-third-party-script-directory! dir [excl '()]) + (log-quickscript-error "add-third-party-script-directory! is deprecated and has no effect")) + +(define (remove-third-party-script-directory! dir) + (log-quickscript-error "remove-third-party-script-directory! is deprecated and has no effect")) From edcc56fc9ad8a5df10e0a77e127df622122e37a2 Mon Sep 17 00:00:00 2001 From: Philip McGrath Date: Sat, 6 Jan 2024 16:08:40 -0500 Subject: [PATCH 04/18] [wip] declarative script registration for pkgs Closes https://github.com/Metaxal/quickscript/issues/73 (when finished) --- private/base.rkt | 7 +- private/library-gui.rkt | 124 ++++++------ private/library.rkt | 402 +++++++++++++++++++++++++++----------- private/shadow-script.rkt | 6 +- tool.rkt | 9 +- 5 files changed, 360 insertions(+), 188 deletions(-) diff --git a/private/base.rkt b/private/base.rkt index 96b2a95..0bcb834 100644 --- a/private/base.rkt +++ b/private/base.rkt @@ -25,9 +25,9 @@ path-string=? script-file? user-script-dir + quickscript-dir get-property-dicts - path-string->string - library-file) + path-string->string) (module+ test (require rackunit)) @@ -42,9 +42,6 @@ (or (getenv "PLTQUICKSCRIPTDIR") (build-path (find-system-path 'pref-dir) "quickscript"))) -(define library-file - (build-path quickscript-dir "library.rktd")) - (define user-script-dir (build-path quickscript-dir "user-scripts")) diff --git a/private/library-gui.rkt b/private/library-gui.rkt index 7664702..fd153a2 100644 --- a/private/library-gui.rkt +++ b/private/library-gui.rkt @@ -11,52 +11,58 @@ (provide make-library-gui) -(define check-sym #\☑) -(define uncheck-sym #\☐) - -(define (un/checked-file->check+file cf) - (define checked? (char=? check-sym (string-ref cf 0))) - (values checked? (substring cf 2))) - -(define (check+file->un/checked-file c f) - (string-append - (string (if c uncheck-sym check-sym) - #\space) - f)) - -(define (make-library-gui [the-lib-file library-file] - #:parent-frame [parent-frame #f] +(define (check+file->un/checked-file checked? f) + (string-append-immutable (if checked? "☑ " "☐ ") + f)) + +(define data-list-box% + (class list-box% + (init [(d->s datum->string)] + [choices '()]) + (define datum->string d->s) + (super-new [choices '()]) + (set choices) + (inherit append clear get-data get-number get-selection set-selection) + (define/override (set choices) + (clear) + (for ([d (in-list choices)]) + (append (datum->string d) d))) + (define/public (set-datum-selection d) + (unless (for/first ([i (in-range (get-number))] + #:when (equal? d (get-data i))) + (set-selection i) + #t) + (raise-arguments-error '|set-datum-selection in data-list-box%| + "no item matching the given datum" + "given" d))) + (define/public (get-datum-selection) + (define i (get-selection)) + (and i (get-data i))))) + +(define (make-library-gui #:parent-frame [parent-frame #f] #:drracket-parent? [drracket-parent? #f]) ;; Load the files in a new namespace so that if the file is changed ;; the library can pick up the changes. (parameterize ([current-namespace (make-base-empty-namespace)]) (log-quickscript-info "Starting the library GUI.") - (define the-lib (lib:load the-lib-file)) - (define (save!) (lib:save! the-lib the-lib-file)) + (define the-lib (lib:load)) + (define (save! new-lib) + (lib:save! new-lib) + (set! the-lib new-lib)) (define (files-lb-selection-values) - (define cf (send files-lb get-string-selection)) + (define cf (send files-lb get-datum-selection)) (if cf - (un/checked-file->check+file cf) + (values (car cf) (cdr cf)) (values #f #f))) - (define (set-files-lb dir) - (define files - (if (directory-exists? dir) - (map path->string - (filter (λ (f) (script-file? (build-path dir f))) - (directory-list dir #:build? #f))) - '())) - (define excluded-files (lib:exclusions the-lib dir)) - (send files-lb set - (map (λ (f) (check+file->un/checked-file (member f excluded-files) f)) - files))) + (send files-lb set (lib:directory->enabled+file the-lib dir))) ;; Returns the current selected dir, file and whether it is checked, ;; if all have a value, otherwise returns #f for all 3 values. (define (get-dir+check+file) - (define dir (send dir-lb get-string-selection)) + (define dir (send dir-lb get-datum-selection)) (if dir (let-values ([(checked? file) (files-lb-selection-values)]) (if file @@ -68,22 +74,19 @@ (unless dir (set! dir (get-directory "Choose a script directory to add to the library" - fr - (find-user-pkgs-dir)))) + fr))) (when dir - (lib:add-directory! the-lib dir) - (save!) + (save! (lib:add-directory the-lib dir)) (reload-dir-lb) - (send dir-lb set-string-selection (path->string dir)) + (send dir-lb set-datum-selection dir) (dir-lb-select dir))) (define (remove-directory dir) - (lib:remove-directory! the-lib dir) - (save!) + (save! (lib:remove-directory the-lib dir)) (reload-dir-lb)) (define (remove-selected-dir) - (define dir (send dir-lb get-string-selection)) + (define dir (send dir-lb get-datum-selection)) (when dir (remove-directory dir) (send files-lb clear))) @@ -92,15 +95,15 @@ (define (ex/include-selected-file [force #f]) (define-values (dir checked? file) (get-dir+check+file)) (when file - (cond [(eq? force 'exclude) (lib:exclude! the-lib dir file)] - [(eq? force 'include) (lib:include! the-lib dir file)] - [checked? (lib:exclude! the-lib dir file)] - [else (lib:include! the-lib dir file)]) - (save!) - (define files-lb-selection (send files-lb get-selection)) + (define include? + (case force + [(exclude) #f] + [(include) #t] + [else (not checked?)])) + (save! ((if include? lib:include lib:exclude) the-lib dir file)) (set-files-lb dir) ; Restore the previously selected item - (send files-lb set-selection files-lb-selection)) + (send files-lb set-datum-selection (cons include? file))) (update-bt-files-un/check)) (define (shadow-selected-file) @@ -115,7 +118,7 @@ This will: 1) Disable the script file - @(path->string (build-path dir file)) + @(lib:directory->pretty-string the-lib dir #:file file)) 2) Create a new 'shadow' script file @(path->string new-script-path) @@ -147,7 +150,8 @@ '(caution ok-cancel))))) (when overwrite? (display-to-file - (make-shadow-script (build-path dir file)) + (let ([pth (build-path dir file)]) + (make-shadow-script pth (lib:path->writable-module-path the-lib pth))) new-script-path #:exists 'replace) (ex/include-selected-file 'exclude) @@ -155,19 +159,16 @@ (when drracket-parent? (send parent-frame open-in-new-tab new-script-path)))))) - (define (dir-lb-select [dir (send dir-lb get-string-selection)]) + (define (dir-lb-select [dir (send dir-lb get-datum-selection)]) (when dir - (set! dir (path-string->string dir)) (set-files-lb dir) - (send dir-lb set-string-selection dir) - (define not-user-script-dir? - (not (path-string=? dir user-script-dir))) - (send bt-dir-remove enable not-user-script-dir?) - (send bt-files-shadow enable not-user-script-dir?))) + (send dir-lb set-datum-selection dir) + (send bt-dir-remove enable (lib:removable-directory? the-lib dir)) + (send bt-files-shadow enable (not (equal? dir user-script-dir))))) (define (reload-dir-lb) (send dir-lb clear) - (send dir-lb set (lib:directories the-lib))) + (send dir-lb set (lib:directories the-lib #:sorted? #t))) (define (set-msg-help-string dir file) (when (and dir file) @@ -188,9 +189,11 @@ (define dir-panel (new vertical-panel% [parent panels] [style '(auto-hscroll auto-vscroll)])) - (define dir-lb (new list-box% [parent dir-panel] + (define dir-lb (new data-list-box% [parent dir-panel] [label "Directories"] - [choices (lib:directories the-lib)] + [choices (lib:directories the-lib #:sorted? #t)] + [datum->string (λ (dir) + (lib:directory->pretty-string the-lib dir))] [style '(single vertical-label)] [callback (λ (lb ev) (dir-lb-select))])) @@ -210,9 +213,12 @@ (define files-panel (new vertical-panel% [parent panels] [style '(auto-hscroll auto-vscroll)])) (define files-lb - (new list-box% [parent files-panel] + (new data-list-box% [parent files-panel] [label "Scripts"] [choices '()] + [datum->string + (λ (x) + (check+file->un/checked-file (car x) (path->string (cdr x))))] [style '(extended vertical-label)] [callback (λ (lb ev) diff --git a/private/library.rkt b/private/library.rkt index 95d2173..eb3261b 100644 --- a/private/library.rkt +++ b/private/library.rkt @@ -2,129 +2,295 @@ (require racket/contract racket/dict racket/file + racket/path racket/set - "base.rkt" - ) + racket/serialize + racket/mutability + framework/preferences + pkg/path + setup/collection-search + setup/collects + setup/getinfo + setup/path-to-relative + "base.rkt") -;; A library is a hash where a key is a directory (as a string) -;; and a value is a list of files (string without path) to *not* include (called exclusions). +;; Conceptually, a library encapsulates: +;; - a set of directories containing script files; and +;; - a set of script files to *not* include (called exclusions). ;; That is, by default all non-excluded files are included (in particular the new ones). -(define (new-library) - (define lib (make-hash)) - (add-directory! lib (path->string user-script-dir)) - lib) - -(define (library? lib) - (hash? lib)) - -(define (load [file library-file]) - (if (file-exists? file) - (hash-copy (file->value file)) - (new-library))) - -(define (save! lib [file library-file]) - (make-directory* user-script-dir) - (write-to-file lib file #:exists 'replace)) - -(define (directories lib) - (dict-keys lib)) - -(define (exclusions lib dir #:build? [build? #f]) - (define exs (dict-ref lib (path-string->string dir) '())) - (if build? - (map (λ (x) (build-path dir x)) exs) - exs)) - -;; Returns the list of script files in the given directory. -;; If exclude is not #f, then only such files that are not listed as exclusions -;; in the library are returned. -(define (files lib [dir user-script-dir] #:exclude? [exclude? #t]) - (define script-files - (map path->string - (filter (λ (f) (script-file? (build-path dir f))) - (if (directory-exists? dir) - (directory-list dir #:build? #f) - '())))) - (cond [exclude? - (define except-list (exclusions lib dir)) - (set-subtract script-files except-list)] - [else script-files])) - -;; Returns the list full paths of script files --in all listed directories of the library. -;; The keyword argument `exclude?' is as in `files'. -(define (all-files lib #:exclude? [exclude? #t]) - (for*/list ([dir (in-dict-keys lib)] - [f (in-list (files lib dir #:exclude? exclude?))]) - (build-path dir f))) - - -(define (add-directory! lib dir [excl '()]) - (dict-ref! lib (path-string->string dir) excl) - (void)) - -(define (remove-directory! lib dir) - (dict-remove! lib (path-string->string dir))) - -(define (exclude! lib dir filename) - (dict-update! lib - (path-string->string dir) - (λ (excl) (set-add excl filename)))) - -(define (include! lib dir filename) - (dict-update! lib - (path-string->string dir) - (λ (excl) (set-remove excl filename)))) - -(define (add-third-party-script-directory! dir [excl '()]) - (define lib (load)) - (add-directory! lib dir excl) - (save! lib)) - -(define (remove-third-party-script-directory! dir) - (define lib (load)) - (remove-directory! lib dir) - (save! lib)) +;; +;; For user-script-dir and other directories configured by the user, +;; which contain ad-hoc scripts schared across Racket versions, +;; we store a hash table mapping paths to sets of file names to exclude. +;; +;; For scripts installed as part of a Racket package---or, more generally, +;; in a collection---the situation is a bit more complicated. +;; These directories are registered declaratively by including +;; `(define quickscript-directory #t)` in an info.rkt file. +;; Observe that the info.rkt file applies to a specific directory: +;; “collection splicing” means that a given collection may have files in +;; multiple directories, none, all, or perhaps only some of which may +;; be Quickscript directories. +;; Furthermore, package authors expect to be able to change which package +;; supplies a particular module as long as they declare appropriate dependencies +;; to maintain compatibility. +;; Therefore: +;; - For display to users, we preserve the distinctions among directories +;; using path->relative-string/library, which includes package information. +;; - For persistent storage, we represent an collection-based exclusion as a +;; normalized-lib-module-path?, which will continue to apply regardless of +;; what package (or even direct link) supplies the collection. +;; - The set of collection-based script directories is already stored as part +;; of the Racket installation (in the info.rkt files and caches). +;; We do not store it again with our saved state. + +;; the library data we save (shared across Racket versions) +(serializable-struct + ;; can evolve in the future using serializable-struct/versions + library-data (table collection-based-exclusions) + #:guard (struct-guard/c + (and/c (hash/c #:immutable #t + #:flat? #t + path? + (set/c path-element? #:cmp 'equal-always)) + hash-equal-always?) + (set/c (and/c normalized-lib-module-path? + (list/c 'lib immutable-string?)) + #:cmp 'equal-always)) + #:transparent) +(define (make-library-data) + (library-data (hashalw user-script-dir (setalw)) + (setalw))) + +;; a wrapper with installation info and some caches +(struct library (lib collects-dirs setup-cache mp-cache pretty-cache) + #:transparent) +(define (library-data->library lib) + (library lib + (find-collection-based-script-directories) + (make-hash) + (make-hash) + (make-hash))) + +(define find-collection-based-script-directories + (let ([absent (gensym)]) + (define (find-collection-based-script-directories) + (for*/setalw ([dir (find-relevant-directories '(quickscript-directory))] + [info (in-value (get-info/full dir))] + #:when info + [v (in-value (info 'quickscript-directory (λ () absent)))] + #:when (cond + [(eq? #t v)] + [else + (unless (eq? absent v) + (log-quickscript-error + "~a\n expected: ~e\n given: ~e\n directory: ~e" + "bad value for quickscript-directory in info file" + #t + v + dir)) + #f])) + dir)) + find-collection-based-script-directories)) + +;; library-data is stored using the framework/preferences system, +;; which provides help for future changes without breaking compatibility +(define pref-key 'plt:quickscript:library) +(preferences:set-default pref-key (make-library-data) library-data?) +(preferences:set-un/marshall pref-key + (λ (x) + (with-handlers ([exn:fail? (λ (e) 'corrupt)]) + (serialize x))) + (λ (x) + (with-handlers ([exn:fail? void]) + (deserialize x)))) +(define (load) + (library-data->library (preferences:get pref-key))) +(define (save! lib) + (preferences:set pref-key (library-lib lib))) + +(define (directorypretty-string + ;; - unknown paths sorted by pathpkg a #:cache cache)] + [b-pkg (path->pkg b #:cache cache)]) + (cond + [(equal? a-pkg b-pkg) + (stringpretty-string lib a) + (directory->pretty-string lib b))] + [(and a-pkg b-pkg) + (stringpretty-string lib dir #:file [file #f]) + (define full + (if file + (build-path dir file) + dir)) + (hash-ref! + (library-pretty-cache lib) + full + (λ () + (string->immutable-string + (if (hash-has-key? (library-data-table (library-lib lib)) dir) + (path->string full) + (path->relative-string/library full #:cache (library-setup-cache lib))))))) + +(define (path->normalized-lib-module-path lib pth) + (hash-ref! + (library-mp-cache lib) + pth + (λ () + (define rslt + (path->module-path pth #:cache (library-setup-cache lib))) + (and (normalized-lib-module-path? lib) + `(lib ,(string->immutable-string (cadr rslt))))))) + +(define (path->writable-module-path lib pth) + (or (path->normalized-lib-module-path lib pth) + `(file ,(string->immutable-string (path->string pth))))) + +(define (directories lib #:sorted? [sorted? #f]) + (if sorted? + (sort (directories lib) + (λ (a b) + (directorylist (library-collects-dirs lib))))) + +(define (directory->enabled+file lib dir) + (define data (library-data lib)) + (define enabled? + (cond + [(hash-ref (library-data-table data) dir #f) + => (λ (excludes) + (λ (name) + (not (set-member? excludes name))))] + [else + (define excludes (library-data-collection-based-exclusions data)) + (λ (name) + (define pth (build-path dir name)) + (not (set-member? excludes (path->normalized-lib-module-path lib pth))))])) + (for/list ([name (in-list (if (directory-exists? dir) + (directory-list dir #:build? #f) + '()))] + #:when (and (script-file? name) + (file-exists? (build-path dir name)))) + (cons (enabled? name) name))) + +(define (all-enabled-scripts lib) + (for*/list ([dir (in-list (directories lib))] + [enabled+file (in-list (directory->enabled+file lib dir))] + #:when (car enabled+file)) + (build-path dir (cdr enabled+file)))) + +(define (removable-directory? lib dir) + (and (hash-has-key? (library-lib (library-data-table lib)) dir) + (not (equal? user-script-dir dir)))) + +(define (add-directory lib dir) + (define data (library-lib lib)) + (struct-copy library lib + [lib (struct-copy library-data data + [table (hash-update (library-data-table data) + dir + values + setalw)])])) + +(define (remove-directory lib dir) + (define data (library-lib lib)) + (struct-copy library lib + [lib (struct-copy library-data data + [table (hash-remove (library-data-table data) + dir)])])) + +(define (in/exclude set-change lib dir filename) + (define data (library-lib lib)) + (struct-copy library lib + [lib (if (set-member? (library-collects-dirs lib) dir) + (struct-copy + library-data data + [collection-based-exclusions + (set-add (library-data-collection-based-exclusions data) + (path->normalized-lib-module-path lib (build-path dir filename)))]) + (struct-copy + library-data data + [table (hash-update (library-data-table data) + filename + (λ (excludes) + (set-add excludes filename)))]))])) + +(define (exclude lib dir filename) + (in/exclude set-add lib dir filename)) + +(define (include lib dir filename) + (in/exclude set-remove lib dir filename)) (provide/contract [library? (any/c . -> . boolean?)] + #; [new-library (-> library?)] - [load ([] - [path-string?] ; does not need to exist - . ->* . library?)] - [save! ([library?] - [path-string?] - . ->* . void?)] - [directories (library? - . -> . (listof string?))] - [exclusions ([library? path-string?] - [#:build? boolean?] - . ->* . (listof path-string?))] - [files ([library?] - [path-string? #:exclude? boolean?] - . ->* . (listof string?))] - [all-files ([library?] - [#:exclude? boolean?] - . ->* . (listof path-string?))] - [add-directory! ([library? - (and/c path-string? absolute-path? directory-exists?)] - [list?] - . ->* . void?)] - [remove-directory! (library? - (and/c path-string? absolute-path?) - . -> . void?)] - [exclude! (library? - (and/c path-string? absolute-path?) - (and/c string? path-free?) - . -> . void?)] - [include! (library? - (and/c path-string? absolute-path?) - (and/c string? path-free?) - . -> . void?)] - [add-third-party-script-directory! - ([(and/c path-string? absolute-path?)] - [(listof (and/c string? path-free?))] - . ->* . void?)] - [remove-third-party-script-directory! - ((and/c path-string? absolute-path?) - . -> . void?)] + [load (-> library?)] + [save! (library? . -> . void?)] + [directories ([library?] + [#:sorted? any/c] + . ->* . (listof path?))] + [directory->enabled+file (library? + path? + . -> . (listof (cons/c boolean? path-element?)))] + [all-enabled-scripts (library? . -> . (listof path?))] + [directory . boolean?)] + [directory->pretty-string ([library? path?] + [#:file (or/c #f path-element?)] + . ->* . immutable-string?)] + [path->writable-module-path (library? + path? + . -> . (and/c (list/c (or/c 'file 'lib) immutable-string?) + module-path?))] + [add-directory (library? + (and/c path? absolute-path?) + . -> . library?)] + [removable-directory? (library? path? . -> . boolean?)] + [remove-directory (library? + (and/c path? absolute-path?) + . -> . library?)] + [exclude (library? + (and/c path? absolute-path?) + path-element? + . -> . library?)] + [include (library? + (and/c path? absolute-path?) + path-element? + . -> . library?)] ) diff --git a/private/shadow-script.rkt b/private/shadow-script.rkt index a97b484..66d64f4 100644 --- a/private/shadow-script.rkt +++ b/private/shadow-script.rkt @@ -8,11 +8,11 @@ (define shadow-prefix "shadow:") -(define (make-header f) +(define (make-header writable-module-path) @string-append{ #lang racket/base (require quickscript - (prefix-in @shadow-prefix (file @(~s (path->string f))))) + (prefix-in @shadow-prefix @(~s writable-module-path))) ;;; This is a 'shadow' script. ;;; The script functions below call the functions of the original script, @@ -41,7 +41,7 @@ }) -(define (make-shadow-script f) +(define (make-shadow-script f writable-module-path) (parameterize ([current-namespace (make-base-empty-namespace)]) (define props-dict (get-property-dicts f)) (define funs (dict-keys props-dict)) diff --git a/tool.rkt b/tool.rkt index 6861484..1b5cd5d 100644 --- a/tool.rkt +++ b/tool.rkt @@ -2,7 +2,7 @@ (require (for-syntax racket/base) ; for help menu drracket/tool ; necessary to build a drracket plugin - framework ; for preferences (too heavy a package?) + framework help/search net/sendurl ; for the help menu racket/class @@ -12,6 +12,7 @@ racket/list racket/string racket/unit + setup/getinfo "private/base.rkt" "private/exn-gobbler.rkt" (prefix-in lib: "private/library.rkt") @@ -32,8 +33,8 @@ The maximize button of the frame also disappears, as if the X11 maximize propert (define orig-display-handler #f) ; will be set in the unit. -(define (user-script-files #:exclude? [exclude? #t]) - (lib:all-files (lib:load library-file) #:exclude? exclude?)) +(define (user-script-files) + (lib:all-enabled-scripts (lib:load))) (define (error-message-box str e) (define sp (open-output-string)) @@ -379,6 +380,8 @@ The maximize button of the frame also disappears, as if the X11 maximize propert (set! menu-reload-count (add1 menu-reload-count)) (log-quickscript-info "Script menu rebuild #~a..." menu-reload-count) + (reset-relevant-directories-state!) + (load-properties!) (let* ([property-dicts From 8ce488f59c1620b193d4b61b736ae2e387eb36c1 Mon Sep 17 00:00:00 2001 From: Philip McGrath Date: Sun, 7 Jan 2024 03:05:47 -0500 Subject: [PATCH 05/18] [wip] restore default scripts --- private/library.rkt | 1 + scripts/eyes.rkt | 93 +++++++++++++++++++++++++++++++++++++++ scripts/info.rkt | 2 + scripts/open-terminal.rkt | 27 ++++++++++++ tool.rkt | 2 +- 5 files changed, 124 insertions(+), 1 deletion(-) create mode 100644 scripts/eyes.rkt create mode 100644 scripts/info.rkt create mode 100644 scripts/open-terminal.rkt diff --git a/private/library.rkt b/private/library.rkt index eb3261b..ec2c99f 100644 --- a/private/library.rkt +++ b/private/library.rkt @@ -63,6 +63,7 @@ (setalw))) ;; a wrapper with installation info and some caches +;; this is NOT thread-safe, due to hash mutation (struct library (lib collects-dirs setup-cache mp-cache pretty-cache) #:transparent) (define (library-data->library lib) diff --git a/scripts/eyes.rkt b/scripts/eyes.rkt new file mode 100644 index 0000000..89a24b1 --- /dev/null +++ b/scripts/eyes.rkt @@ -0,0 +1,93 @@ +#lang racket/gui +(require quickscript) + +;;; Author: Stephen De Gabrielle https://github.com/spdegabrielle +;;; License: [Apache License, Version 2.0](http://www.apache.org/licenses/LICENSE-2.0) or +;;; [MIT license](http://opensource.org/licenses/MIT) at your option. +;;; From: https://github.com/Quickscript-Competiton/July2020entries/issues/7 + +(script-help-string "Eyeballs are following you.") + +(define (eye-canvas-mixin %) + (class % + (init-field (eye-diameter 100)) + (inherit refresh get-dc client->screen screen->client get-top-level-window) + (define pupil-diameter (/ eye-diameter 3)) + (define pupil-r (* 1/2 pupil-diameter)) + (define r (/ eye-diameter 2)) + + (define/override (on-paint) + ;save the state + (define dc (get-dc)) + (define pen (send dc get-pen)) + (define brush (send dc get-brush)) + (define f (get-top-level-window)) + ;; now draw the eye + (send dc set-pen "black" 1 'solid) + (send dc set-brush "white" 'solid) + (send dc draw-ellipse 0 0 eye-diameter eye-diameter) + + ;As for the magic number, the difference between + ;get-current-mouse-state and client->screen may be + ;get-display-left-top-inset. + + (define-values (not-used-x fsy) (get-display-left-top-inset)) + + + (define-values (ms l) (get-current-mouse-state)) + (define mouse-sx (round (send ms get-x))) ; screen coords + (define mouse-sy (+ fsy (round (send ms get-y)))) + (define-values (mcx mcy) (send this screen->client mouse-sx mouse-sy)) + (define-values (screen-eye-x screen-eye-y) (client->screen r r)) + (define Δx (- screen-eye-x mouse-sx)) + (define Δy (- screen-eye-y mouse-sy)) + (define mag (magnitude (make-rectangular Δx Δy))) + + (if (< mag (- r pupil-r)) + (begin + (send dc set-brush "black" 'solid) + (send dc draw-ellipse (- mcx pupil-r) (- mcy pupil-r) pupil-diameter pupil-diameter)) + (let ((direction (atan Δy Δx))) + (define pupilΔx (- (round (* (cos direction) (* r 2/3))))) + (define pupilΔy (- (round (* (sin direction) (* r 2/3))))) + (define (tocentre n) (- (+ r n) pupil-r)) + (define px (tocentre pupilΔx)) + (define py (tocentre pupilΔy)) + (send dc set-brush "black" 'solid) + (send dc draw-ellipse px py pupil-diameter pupil-diameter))) + (send dc set-pen pen) + (send dc set-brush brush) + (super on-paint)) + (super-new [style '(transparent)]))) + + +(define-script eyes + #:label "Eyes" + #:menu-path ("&Games and fun") + #:help-string "Eyeballs are following you." + #:persistent + (λ (selection) + + (define frame (new frame% [label "Eyes"] [width 80] [height 90])) + (define h (new horizontal-panel% [parent frame])) + (define c (new (eye-canvas-mixin canvas%) [parent h](eye-diameter 40))) + (define c2 (new (eye-canvas-mixin canvas%) [parent h](eye-diameter 40))) + (send frame show #t) + + (define t (new timer% + [notify-callback (λ () (send c refresh)(send c2 refresh))] + [interval 100] + [just-once? #f])) + #f)) + +(module+ main + (define frame (new frame% [label "Eyes"] [width 80] [height 90])) + (define h (new horizontal-panel% [parent frame])) + (define c (new (eye-canvas-mixin canvas%) [parent h](eye-diameter 40))) + (define c2 (new (eye-canvas-mixin canvas%) [parent h](eye-diameter 40))) + (send frame show #t) + + (define t (new timer% + [notify-callback (λ () (send c refresh)(send c2 refresh))] + [interval 100] + [just-once? #f]))) diff --git a/scripts/info.rkt b/scripts/info.rkt new file mode 100644 index 0000000..aaacb35 --- /dev/null +++ b/scripts/info.rkt @@ -0,0 +1,2 @@ +#lang info +(define quickscript-directory #t) diff --git a/scripts/open-terminal.rkt b/scripts/open-terminal.rkt new file mode 100644 index 0000000..6b57233 --- /dev/null +++ b/scripts/open-terminal.rkt @@ -0,0 +1,27 @@ +#lang racket/base +(require racket/system + racket/path + quickscript) + +(script-help-string "Open a terminal in the directory of the current file.") + +(define-script open-terminal + #:label "Open terminal here" + #:menu-path ("&Utils") + #:os-types (unix macosx windows) + (λ (str #:file f) + (unless f + (set! f (current-directory))) + (define dir (path->string (path-only f))) + (case (system-type 'os) + [(unix) + (system (string-append "gnome-terminal" + " --working-directory=\"" dir "\"" + " -t \"" dir "\"" + "&"))] + [(macosx) + (system + (string-append "osascript -e 'tell app \"Terminal\" to do script \"cd \\\"" dir "\\\"\"'" ))] + [(windows) + (shell-execute #f "cmd.exe" "" dir 'sw_shownormal)]) + #false)) diff --git a/tool.rkt b/tool.rkt index 1b5cd5d..df1a446 100644 --- a/tool.rkt +++ b/tool.rkt @@ -381,7 +381,7 @@ The maximize button of the frame also disappears, as if the X11 maximize propert (log-quickscript-info "Script menu rebuild #~a..." menu-reload-count) (reset-relevant-directories-state!) - + (load-properties!) (let* ([property-dicts From 26060393264fee50109ffd50afbe039d9a911745 Mon Sep 17 00:00:00 2001 From: Philip McGrath Date: Sun, 7 Jan 2024 16:37:48 -0500 Subject: [PATCH 06/18] [wip] fixup from interactive testing Closes https://github.com/Metaxal/quickscript-extra/issues/27 (when finished) --- private/library.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/private/library.rkt b/private/library.rkt index ec2c99f..557d48b 100644 --- a/private/library.rkt +++ b/private/library.rkt @@ -191,7 +191,7 @@ (set->list (library-collects-dirs lib))))) (define (directory->enabled+file lib dir) - (define data (library-data lib)) + (define data (library-lib lib)) (define enabled? (cond [(hash-ref (library-data-table data) dir #f) @@ -217,7 +217,7 @@ (build-path dir (cdr enabled+file)))) (define (removable-directory? lib dir) - (and (hash-has-key? (library-lib (library-data-table lib)) dir) + (and (hash-has-key? (library-data-table (library-lib lib)) dir) (not (equal? user-script-dir dir)))) (define (add-directory lib dir) From 76cc414d2042eda11dd4b12831c933ace00bb142 Mon Sep 17 00:00:00 2001 From: Philip McGrath Date: Thu, 18 Jan 2024 20:11:55 -0500 Subject: [PATCH 07/18] [wip] fix shadowing pkg scripts; import user-scripts-dir exclusions --- private/base.rkt | 16 +++-- private/library-gui.rkt | 18 +++--- private/library.rkt | 129 ++++++++++++++++++++++++-------------- private/shadow-script.rkt | 2 +- 4 files changed, 102 insertions(+), 63 deletions(-) diff --git a/private/base.rkt b/private/base.rkt index 0bcb834..c57d7f4 100644 --- a/private/base.rkt +++ b/private/base.rkt @@ -25,7 +25,7 @@ path-string=? script-file? user-script-dir - quickscript-dir + deprecated-library-file get-property-dicts path-string->string) @@ -37,13 +37,19 @@ (define-logger quickscript) -;; TODO: What if (find-system-path 'pref-dir) does not exist? (define quickscript-dir - (or (getenv "PLTQUICKSCRIPTDIR") - (build-path (find-system-path 'pref-dir) "quickscript"))) + ;; not guaranteed to exist + (let ([env (getenv "PLTQUICKSCRIPTDIR")]) + (if (and env (path-string? env)) + (string->path env) + (build-path (find-system-path 'pref-dir) "quickscript")))) (define user-script-dir - (build-path quickscript-dir "user-scripts")) + (path->complete-path + (path->directory-path (build-path quickscript-dir "user-scripts")))) + +(define deprecated-library-file + (path->complete-path (build-path quickscript-dir "library.rktd"))) (define (path-free? p-str) (not (path-only p-str))) diff --git a/private/library-gui.rkt b/private/library-gui.rkt index fd153a2..3bc8848 100644 --- a/private/library-gui.rkt +++ b/private/library-gui.rkt @@ -71,15 +71,15 @@ (values #f #f #f))) (define (add-directory [dir #f]) - (unless dir - (set! dir - (get-directory "Choose a script directory to add to the library" - fr))) - (when dir - (save! (lib:add-directory the-lib dir)) - (reload-dir-lb) - (send dir-lb set-datum-selection dir) - (dir-lb-select dir))) + (let* ([dir (or dir + (get-directory "Choose a script directory to add to the library" + fr))] + [dir (and dir (path->complete-path (path->directory-path dir)))]) + (when dir + (save! (lib:add-directory the-lib dir)) + (reload-dir-lb) + (send dir-lb set-datum-selection dir) + (dir-lb-select dir)))) (define (remove-directory dir) (save! (lib:remove-directory the-lib dir)) diff --git a/private/library.rkt b/private/library.rkt index 557d48b..aa5c81d 100644 --- a/private/library.rkt +++ b/private/library.rkt @@ -14,6 +14,57 @@ setup/path-to-relative "base.rkt") +(provide (contract-out + [library? + (-> any/c boolean?)] + [load + (-> library?)] + [save! + (-> library? void?)] + [directory-path? + (-> path? boolean?)] + [directories + (->* [library?] + [#:sorted? any/c] + (listof (and/c path? complete-path? directory-path?)))] + [directory->enabled+file + (-> library? + (and/c path? complete-path? directory-path?) + (listof (cons/c boolean? path-element?)))] + [all-enabled-scripts + (-> library? (listof (and/c path? complete-path?)))] + [directory library? path? path? boolean?)] + [directory->pretty-string + (->* [library? path?] + [#:file (or/c #f path-element?)] + immutable-string?)] + [path->writable-module-path + (-> library? + (and/c path? complete-path?) + (and/c (list/c (or/c 'file 'lib) immutable-string?) + module-path?))] + [add-directory + (-> library? + (and/c path? complete-path? directory-path?) + library?)] + [removable-directory? + (-> library? path? boolean?)] + [remove-directory + (-> library? + (and/c path? complete-path? directory-path?) + library?)] + [exclude + (-> library? + (and/c path? complete-path? directory-path?) + path-element? + library?)] + [include + (-> library? + (and/c path? complete-path? directory-path?) + path-element? + library?)])) + ;; Conceptually, a library encapsulates: ;; - a set of directories containing script files; and ;; - a set of script files to *not* include (called exclusions). @@ -21,7 +72,11 @@ ;; ;; For user-script-dir and other directories configured by the user, ;; which contain ad-hoc scripts schared across Racket versions, -;; we store a hash table mapping paths to sets of file names to exclude. +;; we store a hash table mapping complete paths to sets of file names to exclude. +;; More specifically, keys must syntactically specify directories: +;; this uniformity eases comparison, even though it does not solve the +;; general problem, which is complex, potentially filesystem-dependent, +;; and not needed in this context. ;; ;; For scripts installed as part of a Racket package---or, more generally, ;; in a collection---the situation is a bit more complicated. @@ -44,6 +99,9 @@ ;; of the Racket installation (in the info.rkt files and caches). ;; We do not store it again with our saved state. +(define (directory-path? x) + (eq? x (path->directory-path x))) + ;; the library data we save (shared across Racket versions) (serializable-struct ;; can evolve in the future using serializable-struct/versions @@ -51,15 +109,15 @@ #:guard (struct-guard/c (and/c (hash/c #:immutable #t #:flat? #t - path? + (and/c path? complete-path? directory-path?) (set/c path-element? #:cmp 'equal-always)) hash-equal-always?) (set/c (and/c normalized-lib-module-path? (list/c 'lib immutable-string?)) #:cmp 'equal-always)) #:transparent) -(define (make-library-data) - (library-data (hashalw user-script-dir (setalw)) +(define (default-library-data) + (library-data (hashalw user-script-dir (user-script-exclusions-from-deprecated-library)) (setalw))) ;; a wrapper with installation info and some caches @@ -91,13 +149,26 @@ v dir)) #f])) - dir)) + (path->directory-path dir))) find-collection-based-script-directories)) +(define (user-script-exclusions-from-deprecated-library) + (or (and (file-exists? deprecated-library-file) + (with-handlers ([exn:fail? (λ (e) + (log-quickscript-error "error importing from ~e: ~v" + deprecated-library-file + (exn-message e)) + #f)]) + (for/first ([{dir lst} (in-hash (file->value deprecated-library-file))] + #:when (equal? user-script-dir (path->directory-path dir))) + (for/setalw ([s (in-list lst)]) + (string->path-element s))))) + (setalw))) + ;; library-data is stored using the framework/preferences system, ;; which provides help for future changes without breaking compatibility (define pref-key 'plt:quickscript:library) -(preferences:set-default pref-key (make-library-data) library-data?) +(preferences:set-default pref-key (default-library-data) library-data?) (preferences:set-un/marshall pref-key (λ (x) (with-handlers ([exn:fail? (λ (e) 'corrupt)]) @@ -175,7 +246,7 @@ (λ () (define rslt (path->module-path pth #:cache (library-setup-cache lib))) - (and (normalized-lib-module-path? lib) + (and (normalized-lib-module-path? rslt) `(lib ,(string->immutable-string (cadr rslt))))))) (define (path->writable-module-path lib pth) @@ -243,55 +314,17 @@ (struct-copy library-data data [collection-based-exclusions - (set-add (library-data-collection-based-exclusions data) - (path->normalized-lib-module-path lib (build-path dir filename)))]) + (set-change (library-data-collection-based-exclusions data) + (path->normalized-lib-module-path lib (build-path dir filename)))]) (struct-copy library-data data [table (hash-update (library-data-table data) filename (λ (excludes) - (set-add excludes filename)))]))])) + (set-change excludes filename)))]))])) (define (exclude lib dir filename) (in/exclude set-add lib dir filename)) (define (include lib dir filename) (in/exclude set-remove lib dir filename)) - -(provide/contract - [library? (any/c . -> . boolean?)] - #; - [new-library (-> library?)] - [load (-> library?)] - [save! (library? . -> . void?)] - [directories ([library?] - [#:sorted? any/c] - . ->* . (listof path?))] - [directory->enabled+file (library? - path? - . -> . (listof (cons/c boolean? path-element?)))] - [all-enabled-scripts (library? . -> . (listof path?))] - [directory . boolean?)] - [directory->pretty-string ([library? path?] - [#:file (or/c #f path-element?)] - . ->* . immutable-string?)] - [path->writable-module-path (library? - path? - . -> . (and/c (list/c (or/c 'file 'lib) immutable-string?) - module-path?))] - [add-directory (library? - (and/c path? absolute-path?) - . -> . library?)] - [removable-directory? (library? path? . -> . boolean?)] - [remove-directory (library? - (and/c path? absolute-path?) - . -> . library?)] - [exclude (library? - (and/c path? absolute-path?) - path-element? - . -> . library?)] - [include (library? - (and/c path? absolute-path?) - path-element? - . -> . library?)] - ) diff --git a/private/shadow-script.rkt b/private/shadow-script.rkt index 66d64f4..5ec2bdf 100644 --- a/private/shadow-script.rkt +++ b/private/shadow-script.rkt @@ -46,7 +46,7 @@ (define props-dict (get-property-dicts f)) (define funs (dict-keys props-dict)) (string-append - (make-header f) + (make-header writable-module-path) "\n" (string-join (for/list ([props (in-list props-dict)]) From 80babfab7d1bb47b7341ff285953357f6f614c43 Mon Sep 17 00:00:00 2001 From: Philip McGrath Date: Thu, 18 Jan 2024 20:16:52 -0500 Subject: [PATCH 08/18] [wip] --- private/base.rkt | 8 +++++--- private/shadow-script.rkt | 2 +- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/private/base.rkt b/private/base.rkt index c57d7f4..d427a8d 100644 --- a/private/base.rkt +++ b/private/base.rkt @@ -59,11 +59,13 @@ p-str (path->string p-str))) +(define info.rkt-element (string->path-element "info.rkt")) + (define (script-file? f) - (and (equal? (path-get-extension f) #".rkt") - (not (equal? f (if (string? f) + (and (not (equal? f (if (string? f) "info.rkt" - (string->path-element "info.rkt")))))) + info.rkt-element))) + (equal? (path-get-extension f) #".rkt"))) (define (path-string=? dir1 dir2) (string=? (path-string->string dir1) diff --git a/private/shadow-script.rkt b/private/shadow-script.rkt index 5ec2bdf..0eba2dc 100644 --- a/private/shadow-script.rkt +++ b/private/shadow-script.rkt @@ -74,4 +74,4 @@ (define qs-path (resolve-module-path 'quickscript-extra)) (define f (build-path (path-only qs-path) "scripts" "bookmarks.rkt")) - (displayln (make-shadow-script f)))) + (displayln (make-shadow-script f #|FIXME|#)))) From be86e02ff78c4a9e1b198e9d5d0c7c1b8a591929 Mon Sep 17 00:00:00 2001 From: Philip McGrath Date: Thu, 18 Jan 2024 20:43:59 -0500 Subject: [PATCH 09/18] [wip] validate name of new script more --- tool.rkt | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/tool.rkt b/tool.rkt index df1a446..24065df 100644 --- a/tool.rkt +++ b/tool.rkt @@ -126,11 +126,18 @@ The maximize button of the frame also disappears, as if the X11 maximize propert (get-interactions-text))) (define/private (new-script) + (define (name-ok? name) + (and (non-empty-string? name) + (string->path-element name 'false-on-non-element) + (not (string-ci=? name "info")))) (define name (get-text-from-user "Script name" "Enter the name of the new script:" this - #:validate non-empty-string? + #f + "" + '(disallow-invalid) + #:validate name-ok? #:dialog-mixin frame:focus-table-mixin)) - (when name + (when (and name (name-ok? name)) (define filename (string-append (string-foldcase (string-replace name " " "-")) ".rkt")) (define file-path (build-path user-script-dir filename)) (define proc-name (string-foldcase (string-replace name " " "-"))) From 87b4630c78ba536565f1761c15f83354cc173a20 Mon Sep 17 00:00:00 2001 From: Philip McGrath Date: Thu, 18 Jan 2024 21:59:42 -0500 Subject: [PATCH 10/18] [wip] try using separate quickscript-prefs.rktd file --- private/base.rkt | 4 ++++ private/library.rkt | 34 ++++++++++++++++++++++++---------- 2 files changed, 28 insertions(+), 10 deletions(-) diff --git a/private/base.rkt b/private/base.rkt index d427a8d..a2deac2 100644 --- a/private/base.rkt +++ b/private/base.rkt @@ -26,6 +26,7 @@ script-file? user-script-dir deprecated-library-file + quickscript-prefs.rktd get-property-dicts path-string->string) @@ -51,6 +52,9 @@ (define deprecated-library-file (path->complete-path (build-path quickscript-dir "library.rktd"))) +(define quickscript-prefs.rktd + (path->complete-path (build-path quickscript-dir "quickscript-prefs.rktd"))) + (define (path-free? p-str) (not (path-only p-str))) diff --git a/private/library.rkt b/private/library.rkt index aa5c81d..42f90c3 100644 --- a/private/library.rkt +++ b/private/library.rkt @@ -168,18 +168,32 @@ ;; library-data is stored using the framework/preferences system, ;; which provides help for future changes without breaking compatibility (define pref-key 'plt:quickscript:library) -(preferences:set-default pref-key (default-library-data) library-data?) -(preferences:set-un/marshall pref-key - (λ (x) - (with-handlers ([exn:fail? (λ (e) 'corrupt)]) - (serialize x))) - (λ (x) - (with-handlers ([exn:fail? void]) - (deserialize x)))) +(define (call-with-quickscript-prefs thunk) + (parameterize ([preferences:low-level-get-preference + (λ (name [fail (λ () #f)]) + (get-preference name fail 'timestamp quickscript-prefs.rktd))] + [preferences:low-level-put-preferences + (λ (ks vs) + (put-preferences ks vs #f quickscript-prefs.rktd))]) + (thunk))) +(call-with-quickscript-prefs + (λ () + (preferences:set-default pref-key (default-library-data) library-data?) + (preferences:set-un/marshall pref-key + (λ (x) + (with-handlers ([exn:fail? (λ (e) 'corrupt)]) + (serialize x))) + (λ (x) + (with-handlers ([exn:fail? void]) + (deserialize x)))))) (define (load) - (library-data->library (preferences:get pref-key))) + (call-with-quickscript-prefs + (λ () + (library-data->library (preferences:get pref-key))))) (define (save! lib) - (preferences:set pref-key (library-lib lib))) + (call-with-quickscript-prefs + (λ () + (preferences:set pref-key (library-lib lib))))) (define (directory Date: Sat, 20 Jan 2024 12:13:41 -0500 Subject: [PATCH 11/18] [wip] disable compilation for now --- private/base.rkt | 10 +++++----- tool.rkt | 9 ++++++--- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/private/base.rkt b/private/base.rkt index a2deac2..1b3502d 100644 --- a/private/base.rkt +++ b/private/base.rkt @@ -17,8 +17,8 @@ get-script-help-string make-simple-script-string prop-dict-ref - compile-user-scripts - compile-user-script + #;compile-user-scripts + #;compile-user-script this-os-type time-info path-free? @@ -152,7 +152,7 @@ ;; script-filename : path-string? (define (get-property-dicts script-filepath) ; Ensure the script is compiled for the correct version of Racket - (compile-user-script script-filepath) + #;(compile-user-script script-filepath) (define the-submod (make-submod-path script-filepath)) (dynamic-require the-submod #f) @@ -207,14 +207,14 @@ ;===================; ;=== Compilation ===; ;===================; - +#; (define/contract (compile-user-script file) (-> path-string? any) ;; Simple wrapper for now, but may be specialized for efficiency later. (void) #;(compile-user-scripts (list file))) - +#; (define/contract (compile-user-scripts files #:exn-gobbler [gb (make-exn-gobbler "Compiling scripts")]) (->* [(listof path-string?)] diff --git a/tool.rkt b/tool.rkt index 24065df..a536752 100644 --- a/tool.rkt +++ b/tool.rkt @@ -65,12 +65,14 @@ The maximize button of the frame also disappears, as if the X11 maximize propert '(caution ok)))) ;; -> exn-gobbler? +#; (define (compile-library) (time-info "Recompiling library" (parameterize ([error-display-handler orig-display-handler]) (compile-user-scripts (user-script-files))))) ;; -> void? +#; (define (compile-library/frame) (define fr #false) (dynamic-wind @@ -240,7 +242,7 @@ The maximize button of the frame also disappears, as if the X11 maximize propert ; See HelpDesk for "Manipulating namespaces" (let ([f (parameterize ([current-namespace ns]) ; Ensure the script is compiled for the correct version of Racket - (compile-user-script fpath) + #;(compile-user-script fpath) (dynamic-require fpath name))] [kw-dict (append @@ -457,6 +459,7 @@ The maximize button of the frame also disappears, as if the X11 maximize propert ("&Reload menu" . ,(λ () (unload-persistent-scripts) (reload-scripts-menu))) + #; ("&Compile scripts" . ,(λ () (unload-persistent-scripts) (compile-library/frame) @@ -473,7 +476,7 @@ The maximize button of the frame also disappears, as if the X11 maximize propert (new separator-menu-item% [parent scripts-menu]) ;; Show the error messages that happened during the initial compilation. - (exn-gobbler-message-box init-compile-exn-gobbler "Quickscript: Error during compilation") + #;(exn-gobbler-message-box init-compile-exn-gobbler "Quickscript: Error during compilation") (reload-scripts-menu) (on-startup))) @@ -569,7 +572,7 @@ The maximize button of the frame also disappears, as if the X11 maximize propert ; This must be done before building the menus. ; The compilation is done at this point so that the splash screen doesn't disappear, ; but the message box will be shown after the DrRacket frame is shown up. - (define init-compile-exn-gobbler (compile-library)) + #;(define init-compile-exn-gobbler (compile-library)) ;; Search for "Extending the Existing DrRacket Classes" to see what can be extended: (drracket:get/extend:extend-definitions-text text-mixin) From d368ab47b471e53799ff18b60ccc5a26032720b1 Mon Sep 17 00:00:00 2001 From: Philip McGrath Date: Sat, 20 Jan 2024 12:14:15 -0500 Subject: [PATCH 12/18] [wip] add FIXME re submodule path construction --- private/base.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/private/base.rkt b/private/base.rkt index 1b3502d..406fc65 100644 --- a/private/base.rkt +++ b/private/base.rkt @@ -130,14 +130,14 @@ ;; script-filename : path-string? (define (make-submod-path script-filename) (list 'submod - (list 'file (path-string->string script-filename)) + (list 'file (path-string->string script-filename)) ;FIXME 'script-info)) ;; script-filename : path-string? ;; Returns #f or a string. ;; Important: see note for get-property-dicts (define (get-script-help-string script-filename) - (dynamic-require (make-submod-path script-filename) + (dynamic-require (make-submod-path script-filename) ;FIXME 'quickscript-module-help-string (λ () #f))) @@ -154,7 +154,7 @@ ; Ensure the script is compiled for the correct version of Racket #;(compile-user-script script-filepath) - (define the-submod (make-submod-path script-filepath)) + (define the-submod (make-submod-path script-filepath)) ;FIXME (dynamic-require the-submod #f) (define-values (vars syntaxes) (module->exports the-submod)) (define funs (map car (dict-ref vars 0))) From 33d818ceeb7b897c058dcefb789f5c8f09c7229b Mon Sep 17 00:00:00 2001 From: Philip McGrath Date: Sat, 20 Jan 2024 12:14:52 -0500 Subject: [PATCH 13/18] Revert "[wip] try using separate quickscript-prefs.rktd file" This reverts commit 87b4630c78ba536565f1761c15f83354cc173a20. --- private/base.rkt | 4 ---- private/library.rkt | 34 ++++++++++------------------------ 2 files changed, 10 insertions(+), 28 deletions(-) diff --git a/private/base.rkt b/private/base.rkt index 406fc65..0bfac76 100644 --- a/private/base.rkt +++ b/private/base.rkt @@ -26,7 +26,6 @@ script-file? user-script-dir deprecated-library-file - quickscript-prefs.rktd get-property-dicts path-string->string) @@ -52,9 +51,6 @@ (define deprecated-library-file (path->complete-path (build-path quickscript-dir "library.rktd"))) -(define quickscript-prefs.rktd - (path->complete-path (build-path quickscript-dir "quickscript-prefs.rktd"))) - (define (path-free? p-str) (not (path-only p-str))) diff --git a/private/library.rkt b/private/library.rkt index 42f90c3..aa5c81d 100644 --- a/private/library.rkt +++ b/private/library.rkt @@ -168,32 +168,18 @@ ;; library-data is stored using the framework/preferences system, ;; which provides help for future changes without breaking compatibility (define pref-key 'plt:quickscript:library) -(define (call-with-quickscript-prefs thunk) - (parameterize ([preferences:low-level-get-preference - (λ (name [fail (λ () #f)]) - (get-preference name fail 'timestamp quickscript-prefs.rktd))] - [preferences:low-level-put-preferences - (λ (ks vs) - (put-preferences ks vs #f quickscript-prefs.rktd))]) - (thunk))) -(call-with-quickscript-prefs - (λ () - (preferences:set-default pref-key (default-library-data) library-data?) - (preferences:set-un/marshall pref-key - (λ (x) - (with-handlers ([exn:fail? (λ (e) 'corrupt)]) - (serialize x))) - (λ (x) - (with-handlers ([exn:fail? void]) - (deserialize x)))))) +(preferences:set-default pref-key (default-library-data) library-data?) +(preferences:set-un/marshall pref-key + (λ (x) + (with-handlers ([exn:fail? (λ (e) 'corrupt)]) + (serialize x))) + (λ (x) + (with-handlers ([exn:fail? void]) + (deserialize x)))) (define (load) - (call-with-quickscript-prefs - (λ () - (library-data->library (preferences:get pref-key))))) + (library-data->library (preferences:get pref-key))) (define (save! lib) - (call-with-quickscript-prefs - (λ () - (preferences:set pref-key (library-lib lib))))) + (preferences:set pref-key (library-lib lib))) (define (directory Date: Sat, 20 Jan 2024 20:05:02 -0500 Subject: [PATCH 14/18] [wip] comment --- private/library.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/private/library.rkt b/private/library.rkt index aa5c81d..8f8ac3d 100644 --- a/private/library.rkt +++ b/private/library.rkt @@ -278,7 +278,7 @@ (directory-list dir #:build? #f) '()))] #:when (and (script-file? name) - (file-exists? (build-path dir name)))) + (file-exists? (build-path dir name)))) ; to exclude directories (cons (enabled? name) name))) (define (all-enabled-scripts lib) From 3ca28b625b484c7f2dab121a817533762724db3d Mon Sep 17 00:00:00 2001 From: Philip McGrath Date: Sat, 20 Jan 2024 20:15:05 -0500 Subject: [PATCH 15/18] [wip] delay importing deprecated library --- private/library.rkt | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/private/library.rkt b/private/library.rkt index 8f8ac3d..0475d38 100644 --- a/private/library.rkt +++ b/private/library.rkt @@ -167,8 +167,10 @@ ;; library-data is stored using the framework/preferences system, ;; which provides help for future changes without breaking compatibility +;; Calling (default-library-data) may consult the filesystem, so do it +;; during (load), not when instantiating this module. (define pref-key 'plt:quickscript:library) -(preferences:set-default pref-key (default-library-data) library-data?) +(preferences:set-default pref-key #f (or/c library-data? #f)) (preferences:set-un/marshall pref-key (λ (x) (with-handlers ([exn:fail? (λ (e) 'corrupt)]) @@ -177,7 +179,8 @@ (with-handlers ([exn:fail? void]) (deserialize x)))) (define (load) - (library-data->library (preferences:get pref-key))) + (library-data->library (or (preferences:get pref-key) + (default-library-data)))) (define (save! lib) (preferences:set pref-key (library-lib lib))) From 6d10fa4bf3b692a2ab38906ea75786e22f5c7fc9 Mon Sep 17 00:00:00 2001 From: Philip McGrath Date: Thu, 25 Jan 2024 00:18:25 -0500 Subject: [PATCH 16/18] [wip] change user-script-dir handling --- base.rkt | 9 +- private/base.rkt | 16 ---- private/library-gui.rkt | 10 +- private/library.rkt | 199 +++++++++++++++++++++++++++------------- tool.rkt | 11 ++- 5 files changed, 154 insertions(+), 91 deletions(-) diff --git a/base.rkt b/base.rkt index 4b4376c..7247788 100644 --- a/base.rkt +++ b/base.rkt @@ -1,5 +1,12 @@ #lang racket/base -(require "private/base.rkt") +(require "private/base.rkt" + (for-syntax racket/base + syntax/transformer) + (prefix-in lib: "private/library.rkt")) (provide get-script-help-string script-file? user-script-dir) +(define-syntax user-script-dir + (make-variable-like-transformer #'(get-user-script-dir))) +(define (get-user-script-dir) + (lib:user-script-dir (lib:load))) diff --git a/private/base.rkt b/private/base.rkt index 0bfac76..b14d9a8 100644 --- a/private/base.rkt +++ b/private/base.rkt @@ -24,8 +24,6 @@ path-free? path-string=? script-file? - user-script-dir - deprecated-library-file get-property-dicts path-string->string) @@ -37,20 +35,6 @@ (define-logger quickscript) -(define quickscript-dir - ;; not guaranteed to exist - (let ([env (getenv "PLTQUICKSCRIPTDIR")]) - (if (and env (path-string? env)) - (string->path env) - (build-path (find-system-path 'pref-dir) "quickscript")))) - -(define user-script-dir - (path->complete-path - (path->directory-path (build-path quickscript-dir "user-scripts")))) - -(define deprecated-library-file - (path->complete-path (build-path quickscript-dir "library.rktd"))) - (define (path-free? p-str) (not (path-only p-str))) diff --git a/private/library-gui.rkt b/private/library-gui.rkt index 3bc8848..890e407 100644 --- a/private/library-gui.rkt +++ b/private/library-gui.rkt @@ -49,6 +49,8 @@ (define (save! new-lib) (lib:save! new-lib) (set! the-lib new-lib)) + (define (user-script-dir) + (lib:user-script-dir the-lib)) (define (files-lb-selection-values) (define cf (send files-lb get-datum-selection)) @@ -110,7 +112,7 @@ (define-values (dir checked? file) (get-dir+check+file)) (when file (define new-script-path - (build-path user-script-dir file)) + (build-path (user-script-dir) file)) (define proceed? (eq? 'yes (message-box "Create shadow script?" @@ -155,7 +157,7 @@ new-script-path #:exists 'replace) (ex/include-selected-file 'exclude) - (dir-lb-select user-script-dir) + (dir-lb-select (user-script-dir)) (when drracket-parent? (send parent-frame open-in-new-tab new-script-path)))))) @@ -164,7 +166,7 @@ (set-files-lb dir) (send dir-lb set-datum-selection dir) (send bt-dir-remove enable (lib:removable-directory? the-lib dir)) - (send bt-files-shadow enable (not (equal? dir user-script-dir))))) + (send bt-files-shadow enable (not (equal? dir (user-script-dir)))))) (define (reload-dir-lb) (send dir-lb clear) @@ -275,7 +277,7 @@ [label "&Close"] [callback (λ (bt ev) (send fr show #f))])) - (dir-lb-select user-script-dir) + (dir-lb-select (user-script-dir)) (send fr show #t))) diff --git a/private/library.rkt b/private/library.rkt index 0475d38..63b3522 100644 --- a/private/library.rkt +++ b/private/library.rkt @@ -26,10 +26,12 @@ [directories (->* [library?] [#:sorted? any/c] - (listof (and/c path? complete-path? directory-path?)))] + (listof complete-directory-path/c))] + [rename library-user-script-dir user-script-dir + (-> library? complete-directory-path/c)] [directory->enabled+file (-> library? - (and/c path? complete-path? directory-path?) + complete-directory-path/c (listof (cons/c boolean? path-element?)))] [all-enabled-scripts (-> library? (listof (and/c path? complete-path?)))] @@ -44,24 +46,32 @@ (and/c path? complete-path?) (and/c (list/c (or/c 'file 'lib) immutable-string?) module-path?))] - [add-directory - (-> library? - (and/c path? complete-path? directory-path?) - library?)] [removable-directory? - (-> library? path? boolean?)] + (-> library? complete-directory-path/c boolean?)] + [library-has-directory? + (-> library? complete-directory-path/c boolean?)] + [add-directory + (->i #:chaperone + ([lib library?] + [dir complete-directory-path/c]) + #:pre (lib dir) (not (library-has-directory? lib dir)) + [_ library?])] [remove-directory - (-> library? - (and/c path? complete-path? directory-path?) - library?)] + (->i #:chaperone + ([lib library?] + [dir complete-directory-path/c]) + #:pre (lib dir) (removable-directory? lib dir) + [_ library?])] [exclude - (-> library? - (and/c path? complete-path? directory-path?) - path-element? - library?)] + (->i #:chaperone + ([lib library?] + [dir complete-directory-path/c] + [_ path-element?]) + #:pre (lib dir) (library-has-directory? lib dir) + [_ library?])] [include (-> library? - (and/c path? complete-path? directory-path?) + complete-directory-path/c path-element? library?)])) @@ -70,12 +80,15 @@ ;; - a set of script files to *not* include (called exclusions). ;; That is, by default all non-excluded files are included (in particular the new ones). ;; -;; For user-script-dir and other directories configured by the user, -;; which contain ad-hoc scripts schared across Racket versions, +;; The user-script-dir contains ad-hoc scripts shared across Racket versions +;; and is where new scripts are created by the UI. +;; It is part of the library by definition: we store only a set of file names to exclude. +;; +;; The user may add additional ad-hoc directories (also shared across Racket versions), ;; we store a hash table mapping complete paths to sets of file names to exclude. ;; More specifically, keys must syntactically specify directories: ;; this uniformity eases comparison, even though it does not solve the -;; general problem, which is complex, potentially filesystem-dependent, +;; general problem of path “equivalence”, which is complex, potentially filesystem-dependent, ;; and not needed in this context. ;; ;; For scripts installed as part of a Racket package---or, more generally, @@ -94,42 +107,79 @@ ;; using path->relative-string/library, which includes package information. ;; - For persistent storage, we represent an collection-based exclusion as a ;; normalized-lib-module-path?, which will continue to apply regardless of -;; what package (or even direct link) supplies the collection. +;; what package (or even direct collection link) supplies the collection. ;; - The set of collection-based script directories is already stored as part ;; of the Racket installation (in the info.rkt files and caches). ;; We do not store it again with our saved state. (define (directory-path? x) (eq? x (path->directory-path x))) +(define/final-prop path-element-set/c + (set/c path-element? #:cmp 'equal-always)) +(define/final-prop complete-directory-path/c + (and/c path? complete-path? directory-path?)) ;; the library data we save (shared across Racket versions) (serializable-struct ;; can evolve in the future using serializable-struct/versions - library-data (table collection-based-exclusions) + library-data (user-exclusions table collection-exclusions) #:guard (struct-guard/c + path-element-set/c (and/c (hash/c #:immutable #t #:flat? #t - (and/c path? complete-path? directory-path?) - (set/c path-element? #:cmp 'equal-always)) + complete-directory-path/c + path-element-set/c) hash-equal-always?) (set/c (and/c normalized-lib-module-path? (list/c 'lib immutable-string?)) #:cmp 'equal-always)) #:transparent) -(define (default-library-data) - (library-data (hashalw user-script-dir (user-script-exclusions-from-deprecated-library)) - (setalw))) +(define (empty-library-data) + (library-data (setalw) #hashalw() (setalw))) ;; a wrapper with installation info and some caches ;; this is NOT thread-safe, due to hash mutation -(struct library (lib collects-dirs setup-cache mp-cache pretty-cache) +(struct library (user-script-dir lib collects-script-dirs setup-cache mp-cache pretty-cache) #:transparent) -(define (library-data->library lib) - (library lib - (find-collection-based-script-directories) - (make-hash) - (make-hash) - (make-hash))) +(define (library-data->library maybe-lib) + (let* ([quickscript-dir (or (test-quickscript-dir) standard-quickscript-dir)] + [user-script-dir (path->directory-path (build-path quickscript-dir "user-scripts"))] + [lib (or maybe-lib (struct-copy + library-data (empty-library-data) + [user-exclusions (user-exclusions-from-deprecated-library + #:user-script-dir user-script-dir)]))] + [lib (cond + [(hash-ref (library-data-table lib) user-script-dir #f) + (λ (st) + (log-quickscript-error + "saved library data contained user-scripts-dir as an extra directory") + (struct-copy library-data lib + [table (hash-remove (library-data-table lib) user-script-dir)] + [user-exclusions (set-union st (library-data-user-exclusions st))]))] + [else + lib])] + [setup-cache (make-hash)] + [collects-script-dirs (find-collection-based-script-directories)] + [collects-scripts-dirs + (if (test-quickscript-dir) + (for/setalw ([dir (in-immutable-set collects-script-dirs)] + #:when (equal? "quickscript" (path->pkg dir #:cache setup-cache))) + dir) + collects-script-dirs)]) + (library user-script-dir + lib + collects-scripts-dirs + setup-cache + (make-hash) + (make-hash)))) + +(define standard-quickscript-dir + ;; not guaranteed to exist + (build-path (find-system-path 'pref-dir) "quickscript")) +(define test-quickscript-dir + ;; #f means we are not currently testing, so use standard-quickscript-dir + (make-parameter #f (λ (x) + (and x (path->complete-path x))))) (define find-collection-based-script-directories (let ([absent (gensym)]) @@ -152,7 +202,9 @@ (path->directory-path dir))) find-collection-based-script-directories)) -(define (user-script-exclusions-from-deprecated-library) +(define (user-exclusions-from-deprecated-library #:user-script-dir user-script-dir) + (define deprecated-library-file + (build-path user-script-dir 'up "library.rktd")) (or (and (file-exists? deprecated-library-file) (with-handlers ([exn:fail? (λ (e) (log-quickscript-error "error importing from ~e: ~v" @@ -160,7 +212,8 @@ (exn-message e)) #f)]) (for/first ([{dir lst} (in-hash (file->value deprecated-library-file))] - #:when (equal? user-script-dir (path->directory-path dir))) + #:when (equal? user-script-dir + (path->complete-path (path->directory-path dir)))) (for/setalw ([s (in-list lst)]) (string->path-element s))))) (setalw))) @@ -179,8 +232,7 @@ (with-handlers ([exn:fail? void]) (deserialize x)))) (define (load) - (library-data->library (or (preferences:get pref-key) - (default-library-data)))) + (library-data->library (preferences:get pref-key))) (define (save! lib) (preferences:set pref-key (library-lib lib))) @@ -193,7 +245,8 @@ ;; * then sorted by directory->pretty-string ;; - unknown paths sorted by pathimmutable-string (path->string pth))))) (define (directories lib #:sorted? [sorted? #f]) - (if sorted? - (sort (directories lib) - (λ (a b) - (directorylist (library-collects-dirs lib))))) + (cond + [sorted? + (sort (directories lib #:sorted? #f) + (λ (a b) + (directorylist (library-collects-script-dirs lib))))])) (define (directory->enabled+file lib dir) (define data (library-lib lib)) (define enabled? (cond - [(hash-ref (library-data-table data) dir #f) + [(if (equal? dir (library-user-script-dir lib)) + (library-data-user-exclusions data) + (hash-ref (library-data-table data) dir #f)) => (λ (excludes) (λ (name) (not (set-member? excludes name))))] [else - (define excludes (library-data-collection-based-exclusions data)) + (define excludes (library-data-collection-exclusions data)) (λ (name) (define pth (build-path dir name)) (not (set-member? excludes (path->normalized-lib-module-path lib pth))))])) @@ -281,7 +339,7 @@ (directory-list dir #:build? #f) '()))] #:when (and (script-file? name) - (file-exists? (build-path dir name)))) ; to exclude directories + (file-exists? (build-path dir name)))) ; i.e., not a directory (cons (enabled? name) name))) (define (all-enabled-scripts lib) @@ -291,17 +349,21 @@ (build-path dir (cdr enabled+file)))) (define (removable-directory? lib dir) - (and (hash-has-key? (library-data-table (library-lib lib)) dir) - (not (equal? user-script-dir dir)))) + (hash-has-key? (library-data-table (library-lib lib)) dir)) + +(define (library-has-directory? lib dir) + (or (equal? dir (library-user-script-dir lib)) + (removable-directory? lib dir) + (set-member? (library-collects-script-dirs lib) dir))) (define (add-directory lib dir) (define data (library-lib lib)) (struct-copy library lib - [lib (struct-copy library-data data - [table (hash-update (library-data-table data) - dir - values - setalw)])])) + [lib (struct-copy library-data data + [table (hash-update (library-data-table data) + dir + values + setalw)])])) (define (remove-directory lib dir) (define data (library-lib lib)) @@ -313,18 +375,25 @@ (define (in/exclude set-change lib dir filename) (define data (library-lib lib)) (struct-copy library lib - [lib (if (set-member? (library-collects-dirs lib) dir) - (struct-copy - library-data data - [collection-based-exclusions - (set-change (library-data-collection-based-exclusions data) - (path->normalized-lib-module-path lib (build-path dir filename)))]) - (struct-copy - library-data data - [table (hash-update (library-data-table data) - filename - (λ (excludes) - (set-change excludes filename)))]))])) + [lib (cond + [(equal? dir (library-user-script-dir lib)) + (struct-copy + library-data data + [user-exclusions (set-change (library-data-user-exclusions data) filename)])] + [(set-member? (library-collects-script-dirs lib) dir) + (struct-copy + library-data data + [collection-exclusions + (set-change (library-data-collection-exclusions data) + (path->normalized-lib-module-path lib (build-path dir filename)))])] + [else + (struct-copy + library-data data + [table (hash-update (library-data-table data) + filename + (λ (excludes) + (set-change excludes filename)) + setalw)])])])) (define (exclude lib dir filename) (in/exclude set-add lib dir filename)) diff --git a/tool.rkt b/tool.rkt index a536752..1917626 100644 --- a/tool.rkt +++ b/tool.rkt @@ -33,9 +33,6 @@ The maximize button of the frame also disappears, as if the X11 maximize propert (define orig-display-handler #f) ; will be set in the unit. -(define (user-script-files) - (lib:all-enabled-scripts (lib:load))) - (define (error-message-box str e) (define sp (open-output-string)) (parameterize ([current-error-port sp]) @@ -354,6 +351,7 @@ The maximize button of the frame also disappears, as if the X11 maximize propert ;; All menu item scripts have are at the key `#f` in property-dicts. ;; The key for other scripts (hooks, not menu entries) is the script's identifier (name). (define property-dicts (make-hasheq)) + (define user-script-dir 'user-script-dir-not-loaded) (define/private (load-properties!) (set! property-dicts (make-hasheq)) @@ -361,8 +359,10 @@ The maximize button of the frame also disappears, as if the X11 maximize propert ;; Create an empty namespace to load all the scripts (in the same namespace). (parameterize ([current-namespace (make-base-empty-namespace)] [error-display-handler orig-display-handler]) + (define lib (lib:load)) + (set! user-script-dir (lib:user-script-dir lib)) ;; For all script files in the script directory. - (for ([f (in-list (user-script-files))]) + (for ([f (in-list (lib:all-enabled-scripts lib))]) (time-info (string-append "Loading file " (path->string f)) (with-handlers* ([exn:fail? @@ -389,7 +389,8 @@ The maximize button of the frame also disappears, as if the X11 maximize propert (set! menu-reload-count (add1 menu-reload-count)) (log-quickscript-info "Script menu rebuild #~a..." menu-reload-count) - (reset-relevant-directories-state!) + (unless (eq? user-script-dir 'user-script-dir-not-loaded) + (reset-relevant-directories-state!)) (load-properties!) From de87ab521ce5bc23fb5fc7fcffcba9bb051ccbee Mon Sep 17 00:00:00 2001 From: Philip McGrath Date: Thu, 30 May 2024 15:43:48 -0400 Subject: [PATCH 17/18] [wip] get tests/library.rkt working --- info.rkt | 7 +- main.rkt | 2 +- private/library.rkt | 43 +++++-- tests/library.rkt | 265 +++++++++++++++++++++++++++++++++----------- 4 files changed, 232 insertions(+), 85 deletions(-) diff --git a/info.rkt b/info.rkt index 7641a6c..cb2210c 100644 --- a/info.rkt +++ b/info.rkt @@ -1,9 +1,8 @@ #lang info (define deps - '("base" + '(["base" #:version "8.13.0.2"] ; for equal-always? fix "drracket-plugin-lib" - "drracket" "gui-lib" "net-lib" "scribble-lib")) @@ -13,7 +12,6 @@ "drracket" "gui-doc" "racket-doc" - "draw-doc" "rackunit-lib")) (define name "Quickscript") @@ -23,8 +21,5 @@ (define scribblings '(("scribblings/quickscript.scrbl" () (drracket-plugin) "quickscript"))) -(define compile-omit-paths - '()) - (define license '(Apache-2.0 OR MIT)) diff --git a/main.rkt b/main.rkt index 14f0a41..4008130 100644 --- a/main.rkt +++ b/main.rkt @@ -1,6 +1,6 @@ #lang racket/base -;;; Re-experts quickscript/script for simplicity in the scripts +;;; Re-exports quickscript/script for simplicity in the scripts (require quickscript/script) (provide (all-from-out quickscript/script)) diff --git a/private/library.rkt b/private/library.rkt index 63b3522..0fdcf73 100644 --- a/private/library.rkt +++ b/private/library.rkt @@ -1,6 +1,5 @@ #lang racket/base (require racket/contract - racket/dict racket/file racket/path racket/set @@ -14,6 +13,12 @@ setup/path-to-relative "base.rkt") +(module+ for-test + (provide (contract-out + [test-quickscript-dir + (parameter/c (or/c #f path-string?) + (or/c #f complete-directory-path/c))]))) + (provide (contract-out [library? (-> any/c boolean?)] @@ -21,6 +26,8 @@ (-> library?)] [save! (-> library? void?)] + [library=? + (-> library? library? boolean?)] [directory-path? (-> path? boolean?)] [directories @@ -69,11 +76,13 @@ [_ path-element?]) #:pre (lib dir) (library-has-directory? lib dir) [_ library?])] - [include - (-> library? - complete-directory-path/c - path-element? - library?)])) + [include ; TODO: removal of exclusions for absent collections (needs different API: no path) + (->i #:chaperone + ([lib library?] + [dir complete-directory-path/c] + [_ path-element?]) + #:pre (lib dir) (library-has-directory? lib dir) + [_ library?])])) ;; Conceptually, a library encapsulates: ;; - a set of directories containing script files; and @@ -85,7 +94,7 @@ ;; It is part of the library by definition: we store only a set of file names to exclude. ;; ;; The user may add additional ad-hoc directories (also shared across Racket versions), -;; we store a hash table mapping complete paths to sets of file names to exclude. +;; for which we store a hash table mapping complete paths to sets of file names to exclude. ;; More specifically, keys must syntactically specify directories: ;; this uniformity eases comparison, even though it does not solve the ;; general problem of path “equivalence”, which is complex, potentially filesystem-dependent, @@ -105,7 +114,7 @@ ;; Therefore: ;; - For display to users, we preserve the distinctions among directories ;; using path->relative-string/library, which includes package information. -;; - For persistent storage, we represent an collection-based exclusion as a +;; - For persistent storage, we represent a collection-based exclusion as a ;; normalized-lib-module-path?, which will continue to apply regardless of ;; what package (or even direct collection link) supplies the collection. ;; - The set of collection-based script directories is already stored as part @@ -178,8 +187,10 @@ (build-path (find-system-path 'pref-dir) "quickscript")) (define test-quickscript-dir ;; #f means we are not currently testing, so use standard-quickscript-dir + ;; When non-false, this parameter also arranges for (load) to ignore + ;; collection-based scripts that do not come from the "quickscript" package. (make-parameter #f (λ (x) - (and x (path->complete-path x))))) + (and x (path->directory-path (path->complete-path x)))))) (define find-collection-based-script-directories (let ([absent (gensym)]) @@ -236,6 +247,14 @@ (define (save! lib) (preferences:set pref-key (library-lib lib))) +(define (library=? a b) + ;; ignores caches + (define-syntax-rule (cf fld ...) + (and (equal-always? (fld a) (fld b)) ...)) + (cf library-user-script-dir + library-lib + library-collects-script-dirs)) + (define (directoryimmutable-string (cadr rslt))))))) (define (path->writable-module-path lib pth) + ;; TODO: maybe "read" able, since we mean that we can `write` the path, not write TO the path (or (path->normalized-lib-module-path lib pth) `(file ,(string->immutable-string (path->string pth))))) @@ -390,10 +410,9 @@ (struct-copy library-data data [table (hash-update (library-data-table data) - filename + dir (λ (excludes) - (set-change excludes filename)) - setalw)])])])) + (set-change excludes filename)))])])])) (define (exclude lib dir filename) (in/exclude set-add lib dir filename)) diff --git a/tests/library.rkt b/tests/library.rkt index e565c46..fd4529a 100644 --- a/tests/library.rkt +++ b/tests/library.rkt @@ -1,69 +1,202 @@ #lang racket -;; Tests n a separate file to test the contracts too. +;; Tests in a separate file to test the contracts too. (require rackunit "../private/base.rkt" - "../private/library.rkt") - -(define my-lib (new-library)) -(check set=? - (directories my-lib) - (map path-string->string (list user-script-dir))) - -(define dummy-dir (build-path (find-system-path 'temp-dir) - "dummy-script-dir")) -; Make sure we control what the directory contains. -(make-directory* dummy-dir) -(for-each delete-file (directory-list dummy-dir #:build? #t)) - -(define lib-path (build-path dummy-dir "library.rktd")) - -(set! my-lib (load lib-path)) - -(add-directory! my-lib dummy-dir) -(check set=? - (directories my-lib) - (map path-string->string (list user-script-dir dummy-dir))) - - -(define script1 "script1.rkt") -(define script2 "script2.rkt") -(define not-a-script "script.notrkt") -(display-to-file "\n" (build-path dummy-dir script1)) -(display-to-file "\n" (build-path dummy-dir script2)) -(display-to-file "\n" (build-path dummy-dir not-a-script)) -(check set=? - (files my-lib dummy-dir) - (list script1 script2)) - -(exclude! my-lib dummy-dir script1) -(check set=? - (files my-lib dummy-dir) - (list script2)) -(exclude! my-lib dummy-dir script2) -(check set=? - (files my-lib dummy-dir) - '()) - -(include! my-lib dummy-dir script1) -(check set=? - (files my-lib dummy-dir) - (list script1)) - -(remove-directory! my-lib dummy-dir) -(check set=? - (directories my-lib) - (map path-string->string (list user-script-dir))) - -;; Check load and save! -(add-directory! my-lib dummy-dir) -(exclude! my-lib dummy-dir script2) -(define my-lib-file (build-path dummy-dir "my-lib.rktd")) -(save! my-lib my-lib-file) -(define my-lib2 (load my-lib-file)) -(check set=? (dict-keys my-lib) (dict-keys my-lib2)) -(for ([(dir excl-list) (in-dict my-lib)]) - (check-equal? excl-list (exclusions my-lib2 dir))) -(check set=? - (all-files my-lib) - (all-files my-lib2)) -#;(all-files my-lib2) + "../private/library.rkt" + (submod "../private/library.rkt" for-test) + (only-in pkg/lib pkg-directory) + (only-in setup/getinfo reset-relevant-directories-state!) + framework/preferences) + +(define-binary-check (check-equal-always? equal-always? actual expected)) +(define-binary-check (check-library=? library=? actual expected)) +(define-simple-check (check-not-library=? v1 v2) + (not (library=? v1 v2))) + +(define (pe s) + (string->path-element s)) + +(define (touch* #:in dir . files) + (make-directory* dir) + (for ([f (in-list files)]) + (call-with-output-file* (build-path dir f) void))) + +(define prefs-table + (make-hash)) + +(define tmp-qs-dir + (path->directory-path (make-temporary-directory))) + +(define-syntax-rule (in-test-context body ...) + (parameterize ([test-quickscript-dir tmp-qs-dir] + [preferences:low-level-get-preference + (λ (name [fail (λ () #f)]) + (hash-ref prefs-table name fail))] + [preferences:low-level-put-preferences + (λ (names vals) + (for ([name (in-list names)] + [val (in-list vals)]) + (hash-set! prefs-table name val)))]) + (preferences:restore-defaults) + (reset-relevant-directories-state!) + (dynamic-wind + void + (λ () + (call-with-continuation-barrier + (λ () + body ...))) + (λ () + (delete-directory/files tmp-qs-dir #:must-exist? #f))))) + +(in-test-context + + (define the-user-script-dir + (build-path tmp-qs-dir "user-scripts/")) + + (define quickscript-pkg-directory + (cond + [(pkg-directory "quickscript") + => simplify-path] + [else + (fail-check "tests require the \"quickscript\" package to be installed")])) + (define the-pkg-script-dir + (build-path quickscript-pkg-directory "scripts/")) + (define expected-pkg-enabled+file + `([#t . ,(pe "eyes.rkt")] + [#t . ,(pe "open-terminal.rkt")])) + + (define my-lib (load)) + + (check-equal? (user-script-dir my-lib) + the-user-script-dir + "user-script-dir configured for testing") + + (check-equal-always? (directories my-lib) + (list the-user-script-dir + the-pkg-script-dir) + "default library directories") + + (check-equal-always? (directory->enabled+file my-lib the-user-script-dir) + '() + "no user script yet") + + (check-equal-always? (directory->enabled+file my-lib the-pkg-script-dir) + expected-pkg-enabled+file + "expected package scripts") + + (define extra-dir + (build-path tmp-qs-dir "extra/")) + + (define lib+extra + (add-directory my-lib extra-dir)) + + (check-equal-always? (directories lib+extra) + (list the-user-script-dir + extra-dir + the-pkg-script-dir) + "add-directory") + + (check-equal-always? (directory->enabled+file lib+extra extra-dir) + '() + "extra-dir does not exist yet") + + (define script1 (pe "script1.rkt")) + (define script2 (pe "script2.rkt")) + (define not-a-script (pe "script3.notrkt")) + (touch* #:in extra-dir script1 script2 not-a-script) + + (check-equal-always? (directory->enabled+file lib+extra extra-dir) + `([#t . ,script1] + [#t . ,script2]) + "correct scripts in extra directory") + + (define lib+excludes + (for/fold ([lib lib+extra]) + ([d (list extra-dir + the-pkg-script-dir + the-user-script-dir)] + [f (list script1 + (cdar expected-pkg-enabled+file) + (pe "excluded.rkt"))]) ; does not exist yet + (exclude lib d f))) + + (check-equal-always? (directory->enabled+file lib+excludes the-pkg-script-dir) + `([#f . ,(cdar expected-pkg-enabled+file)] + ,@(cdr expected-pkg-enabled+file)) + "package script exclusions") + + (check-equal-always? (directory->enabled+file + (include lib+excludes + the-pkg-script-dir + (cdar expected-pkg-enabled+file)) + the-pkg-script-dir) + expected-pkg-enabled+file + "include for package script") + + (check-equal-always? (directory->enabled+file lib+excludes extra-dir) + `([#f . ,script1] + [#t . ,script2]) + "extra-dir excludes") + + (check-equal-always? (directory->enabled+file + (include (exclude lib+excludes extra-dir script2) + extra-dir + script1) + extra-dir) + `([#t . ,script1] + [#f . ,script2]) + "extra-dir: swap includes and excludes") + + (define extra+pkg-enabled-scripts + (cons (build-path extra-dir script2) + (for/list ([pr (in-list (cdr expected-pkg-enabled+file))]) + (build-path the-pkg-script-dir (cdr pr))))) + + (check-equal-always? (all-enabled-scripts lib+excludes) + extra+pkg-enabled-scripts + "expected enabled scripts before user") + + (touch* #:in the-user-script-dir "user.rkt" "excluded.rkt") + + (check-equal-always? (all-enabled-scripts lib+excludes) + (cons (build-path the-user-script-dir "user.rkt") + extra+pkg-enabled-scripts) + "should detect added user script") + + (check-equal-always? (directory->enabled+file lib+excludes the-user-script-dir) + `([#f . ,(pe "excluded.rkt")] + [#t . ,(pe "user.rkt")]) + "should recognize pre-excluded user script") + + (check-equal-always? (directory->enabled+file + (include lib+excludes the-user-script-dir (pe "excluded.rkt")) + the-user-script-dir) + `([#t . ,(pe "excluded.rkt")] + [#t . ,(pe "user.rkt")]) + "include user script") + + (delete-file (build-path the-user-script-dir "user.rkt")) + + (check-equal-always? (all-enabled-scripts lib+excludes) + extra+pkg-enabled-scripts + "should detect deleted user script") + + (check-equal-always? (directories + (remove-directory lib+excludes extra-dir)) + (list the-user-script-dir + the-pkg-script-dir) + "can remove extra-dir") + + ;; TODO: test correct errors from add remove include exclude + + ;; Check load and save! + (check-not-library=? my-lib + lib+excludes + "my-lib is different than lib+excludes") + (check-library=? (load) + my-lib + "(load) reproduces my-lib") + (save! lib+excludes) + (check-library=? (load) + lib+excludes + "save and restore lib+excludes")) From 3353b22a4ecac2d7be09a801cacbdd06df507273 Mon Sep 17 00:00:00 2001 From: Philip McGrath Date: Thu, 30 May 2024 16:31:39 -0400 Subject: [PATCH 18/18] [wip] info.rkt: define version, collection, pkg-name, and pkg-desc --- info.rkt | 27 ++++++++++++++++----------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/info.rkt b/info.rkt index cb2210c..a287c33 100644 --- a/info.rkt +++ b/info.rkt @@ -1,7 +1,22 @@ #lang info +(define pkg-name "quickscript") +(define collection "quickscript") +(define name "Quickscript") +(define version "1.1") +(define pkg-desc "Scripting engine for DrRacket.") +(define license + '(Apache-2.0 OR MIT)) + +(define drracket-tools '(("tool.rkt"))) +(define drracket-tool-names '("Quickscript")) +(define drracket-tool-icons '(#f)) + +(define scribblings + '(("scribblings/quickscript.scrbl" () (drracket-plugin) "quickscript"))) + (define deps - '(["base" #:version "8.13.0.2"] ; for equal-always? fix + '(["base" #:version "8.13.0.2"] ; for path equal-always? fix "drracket-plugin-lib" "gui-lib" "net-lib" @@ -13,13 +28,3 @@ "gui-doc" "racket-doc" "rackunit-lib")) - -(define name "Quickscript") -(define drracket-tools '(("tool.rkt"))) -(define drracket-tool-names '("Quickscript")) -(define drracket-tool-icons '(#f)) - -(define scribblings '(("scribblings/quickscript.scrbl" () (drracket-plugin) "quickscript"))) - -(define license - '(Apache-2.0 OR MIT))