Allow packages to register scripts declaratively

base.rkt

@@ -1,205 +1,5 @@
-#lang at-exp racket/base
-(require racket/contract
-         racket/dict
-         racket/format
-         racket/file
-         racket/path
-         racket/runtime-path
-         compiler/compilation-path
-         compiler/cm
-         "exn-gobbler.rkt")
-
-(provide (all-defined-out))
-
-(module+ test
-  (require rackunit))
-
-(define version-bytes (string->bytes/utf-8 (version)))
-(define vm-bytes (string->bytes/utf-8 (symbol->string (system-type 'vm))))
-
-(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")))
-
-(define library-file
-  (build-path quickscript-dir "library.rktd"))
-
-(define user-script-dir
-  (build-path quickscript-dir "user-scripts"))
-
-(define (path-free? p-str)
-  (not (path-only p-str)))
-
-(define (path-string->string p-str)
-  (if (string? p-str)
-      p-str
-      (path->string p-str)))
-
-(define (script-file? f)
-  (equal? (path-get-extension f) #".rkt"))
-
-(define (path-string=? dir1 dir2)
-  (string=? (path-string->string dir1)
-            (path-string->string dir2)))
-
-(module+ test
-
-  (check-true (path-free? "a.rkt"))
-  (check-false (path-free? "b/a.rkt"))
-  (check-false (path-free? "b/a"))
-  (when (eq? (system-path-convention-type) 'unix)
-    (check-true
-     (path-string=? "a/b/c.rkt"
-                    (build-path "a" "b/c.rkt")))))
-
-(define-syntax-rule (time-info str body ...)
-  (let ([ms (current-milliseconds)])
-    (log-quickscript-info (string-append "Begin: " str "..."))
-    (begin0
-      (begin body ...)
-      (log-quickscript-info
-       (string-append "End  : " str ". Took " (number->string (- (current-milliseconds) ms)) "ms")))))
-
-(define props-default
-  `((name             . #f)
-    (filepath         . #f)
-    (label            . #f) ; Should be mandatory
-    (menu-path        . ())
-    (shortcut         . #f)
-    (shortcut-prefix  . #f) ; should be (get-default-shortcut-prefix), but this depends on gui/base
-    (help-string      . "My amazing script")
-    (output-to        . selection) ; outputs the result in a new tab
-    (persistent?      . #f)
-    (os-types         . (unix macosx windows)) ; list of supported os types
-    ))
-
-(define this-os-type (system-type 'os))
-
-;; proc-name : string?
-;; label : string?
-;; TODO: extend this with a given property-dict
-(define (make-simple-script-string proc-name label
-                                   #:script-help-string [script-help-string #f])
-  ;; See the manual in the Scripts|Manage Scripts|Help menu for more information.
-  @string-append{
 #lang racket/base
-
-(require quickscript)
-@(if script-help-string (string-append "\n(script-help-string " (~s script-help-string) ")\n") "")
-;; Returns a replacement string for the selected string `selection`
-;; ("" if no text is selected), or `#f` to leave the selection as is.
-(define-script @proc-name
-  #:label "@label"
-  (λ (selection)
-    #f))
-})
-
-;; script-filename : path-string?
-(define (make-submod-path script-filename)
-  (list 'submod
-        (list 'file (path-string->string script-filename))
-        '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)
-                   'quickscript-module-help-string
-                   (λ () #f)))
-
-(define (property-dict? v)
-  (and (dict? v)
-       (dict-has-key? v 'label)))
-
-;; Returns a list of dictionaries of the properties of the scripts in script-filename,
-;; augmented with the scripts' function and the script filepath.
-;; IMPORTANT: Loads the file in the current namespace, so a new namespace should probably
-;; be created with (make-base-empty-namespace).
-;; 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)
-
-  (define the-submod (make-submod-path script-filepath))
-  (dynamic-require the-submod #f)
-  (define-values (vars syntaxes) (module->exports the-submod))
-  (define funs (map car (dict-ref vars 0)))
-  (define property-dicts
-    (filter values
-            (for/list ([fun (in-list funs)])
-              (define maybe-props (dynamic-require the-submod fun))
-              (and (property-dict? maybe-props)
-                   (list*
-                    (cons 'name fun)
-                    (cons 'filepath script-filepath)
-                    maybe-props)))))
-  property-dicts)
-
-(define (prop-dict-ref props key)
-  (dict-ref props key (dict-ref props-default key)))
-
-(module+ test
-  (require racket/file)
-  (define dir (find-system-path 'temp-dir))
-  (define filename "tmp-script.rkt")
-  (define filepath (build-path dir filename))
-  (define proc-sym 'my-first-script)
-  (define proc-name (symbol->string proc-sym))
-  (define label "My First Script")
-  (define help-str "The help-string of the script.")
-  (display-to-file (make-simple-script-string proc-name label
-                                              #:script-help-string help-str)
-                   filepath
-                   #:exists 'replace)
-
-  ; Note: because the script requires `quickscript/script`,
-  ; quickscript must be installed as package/collection for the following to work.
-  (define-values (prop-dicts help-str2)
-    (parameterize ([current-namespace (make-base-empty-namespace)])
-      (values (get-property-dicts filepath)
-              (get-script-help-string filepath))))
-  (check = (length prop-dicts) 1)
-  (define props (car prop-dicts))
-  (check string=?
-         (dict-ref props 'label)
-         label)
-  (check eq?
-         (prop-dict-ref props 'name)
-         proc-sym)
-  (check string=?
-         help-str2
-         help-str))
-
-;===================;
-;=== 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?)]
-       [#:exn-gobbler exn-gobbler?]
-       exn-gobbler?)
-
-  ; Synchronous version:
-  (parameterize ([current-namespace (make-base-empty-namespace)])
-    (define cmc (make-caching-managed-compile-zo))
-    (for ([f (in-list files)])
-      (with-handlers* ([exn:fail? (λ (e) (gobble gb e (path->string f)))])
-        (time-info (format "Compiling ~a" (path->string f))
-                   (cmc f)))))
-  (log-quickscript-info (exn-gobbler->string gb))
-  gb)
-
-(define (zo-file src-file)
-  (get-compilation-bytecode-file src-file #:modes '("compiled")))
+(require "private/base.rkt")
+(provide get-script-help-string
+         script-file?
+         user-script-dir)

library.rkt

@@ -1,130 +1,16 @@
 #lang racket/base
-(require racket/contract
-         racket/dict
-         racket/file
-         racket/set
-         "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).
-;; 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)
+;; 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".
 
-(define (library? lib)
-  (hash? lib))
+(require "private/base.rkt")
 
-(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))))
+(provide add-third-party-script-directory!
+         remove-third-party-script-directory!)
 
 (define (add-third-party-script-directory! dir [excl '()])
-  (define lib (load))
-  (add-directory! lib dir excl)
-  (save! lib))
+  (log-quickscript-error "add-third-party-script-directory! is deprecated and has no effect"))
 
 (define (remove-third-party-script-directory! dir)
-  (define lib (load))
-  (remove-directory! lib dir)
-  (save! lib))
-
-(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?)]
- )
+  (log-quickscript-error "remove-third-party-script-directory! is deprecated and has no effect"))