├── .gitignore ├── make-readme.sh ├── scripts ├── reverse-selection.rkt ├── number-tabs.rkt ├── pasterack.rkt ├── current-file-example.rkt ├── open-dir.rkt ├── filepath-to-clipboard.rkt ├── insert-pict.rkt ├── sort-lines.rkt ├── gui-tools.rkt ├── surround-selection.rkt ├── add-menu.rkt ├── persistent-counter.rkt ├── open-collect-file.rkt ├── open-terminal.rkt ├── goto-line.rkt ├── enter-submod.rkt ├── abstract-variable.rkt ├── all-tabs.rkt ├── color-chooser.rkt ├── backup-file.rkt ├── reorder-tabs.rkt ├── git.rkt ├── sections.rkt ├── provided-by.rkt ├── author-date.rkt ├── dynamic-abbrev.rkt ├── complete-word.rkt ├── regexp-replace.rkt ├── color-theme.rkt ├── tweet.rkt ├── bookmarks.rkt ├── indent-table.rkt ├── url2script.rkt ├── extract-function.rkt └── def-signatures.rkt ├── unregister.rkt ├── register.rkt ├── info.rkt ├── LICENSE ├── .travis.yml ├── scribblings └── quickscript-extra.scrbl └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | \#* 3 | .\#* 4 | .DS_Store 5 | compiled/ 6 | /doc/ 7 | -------------------------------------------------------------------------------- /make-readme.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | scribble --markdown --dest-name README.md scribblings/quickscript-extra.scrbl 3 | 4 | -------------------------------------------------------------------------------- /scripts/reverse-selection.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require quickscript) 3 | 4 | (script-help-string "(Example) The simplest script example: reverse the selected string.") 5 | 6 | (define-script reverse-selection 7 | #:label "Reverse selection" 8 | #:menu-path ("E&xamples") 9 | (λ (selection) 10 | (list->string (reverse (string->list selection))))) 11 | -------------------------------------------------------------------------------- /unregister.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require quickscript/library 3 | racket/runtime-path) 4 | 5 | ;;; To remove the script directory from Quickscript's library, 6 | ;;; run this file in DrRacket, or on the command line with 7 | ;;; $ racket -l quickscript-extra/register 8 | 9 | (define-runtime-path script-dir "scripts") 10 | (remove-third-party-script-directory! script-dir) 11 | -------------------------------------------------------------------------------- /scripts/number-tabs.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require quickscript 3 | racket/class) 4 | 5 | (script-help-string "(Example) displays the number of opened tabs in a message box.") 6 | 7 | (define-script number-tabs 8 | #:label "Number of tabs" 9 | #:menu-path ("E&xamples") 10 | #:output-to message-box 11 | (λ (selection #:frame fr) 12 | (format "Number of tabs in DrRacket: ~a" 13 | (send fr get-tab-count)))) 14 | -------------------------------------------------------------------------------- /scripts/pasterack.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require browser/external 3 | quickscript) 4 | 5 | (script-help-string "Opens Pasterack in the browser.") 6 | 7 | ; Launch http://pasterack.org/ in browser 8 | (define-script pasterack 9 | #:label "Pasterack (browser)" 10 | #:menu-path ("&Utils") 11 | #:help-string "Opens 'PasteRack' An evaluating pastebin for Racket." 12 | (λ (str) 13 | (send-url "http://pasterack.org/") 14 | #f)) 15 | -------------------------------------------------------------------------------- /register.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base 3 | racket/runtime-path 4 | (only-in quickscript/library add-third-party-script-directory!))) 5 | 6 | ;; This is going to be called during setup and will automatically 7 | ;; register quickscript-extra in quickscript's library. 8 | (begin-for-syntax 9 | (define-runtime-path script-dir "scripts") 10 | (add-third-party-script-directory! script-dir)) 11 | -------------------------------------------------------------------------------- /scripts/current-file-example.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require quickscript) 3 | 4 | (script-help-string 5 | "(Example) Displays the current file and the current selected string in a message box.") 6 | 7 | (define-script current-file-example 8 | #:label "Current file example" 9 | #:menu-path ("E&xamples") 10 | #:output-to message-box 11 | (λ (selection #:file f) 12 | (string-append "File: " (if f (path->string f) "no-file") 13 | "\nSelection: " selection))) 14 | -------------------------------------------------------------------------------- /scripts/open-dir.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/system 3 | racket/path 4 | quickscript) 5 | 6 | (script-help-string "Open the system's file browser in the current directory.") 7 | 8 | (define cmd 9 | (case (system-type 'os) 10 | [(unix) "xdg-open"] ; or maybe mimeopen -n ? 11 | [(windows) "explorer"] 12 | [(macosx) "open"])) 13 | 14 | (define-script open-file-directory 15 | #:label "Open file directory" 16 | #:menu-path ("&Utils") 17 | (λ (str #:file f) 18 | (system (string-append cmd " \"" (path->string (path-only f)) "\"")) 19 | #f)) 20 | -------------------------------------------------------------------------------- /scripts/filepath-to-clipboard.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require quickscript 3 | racket/path) 4 | 5 | (script-help-string "Write the path of the current file in the clipboard.") 6 | 7 | (define-script filepath-to-clipboard 8 | #:label "Filepath to clipboard" 9 | #:menu-path ("&Utils") 10 | #:output-to clipboard 11 | (λ (selection #:file f) 12 | (path->string f))) 13 | 14 | (define-script directory-to-clipboard 15 | #:label "File directory to clipboard" 16 | #:menu-path ("&Utils") 17 | #:output-to clipboard 18 | (λ (selection #:file f) 19 | (path->string (path-only f)))) 20 | -------------------------------------------------------------------------------- /scripts/insert-pict.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/gui/base 4 | quickscript 5 | pict) 6 | 7 | (script-help-string "(Example) Insert a `pict` at the current position.") 8 | 9 | (define (pict->snip pic) 10 | (make-object image-snip% (pict->bitmap pic))) 11 | 12 | (define-script insert-slideshow 13 | #:label "Insert slideshow pict" 14 | #:menu-path ("E&xamples") 15 | (λ (str) 16 | (pict->snip 17 | (hc-append -10 18 | (colorize (angel-wing 100 80 #t) "orange") 19 | (jack-o-lantern 100) 20 | (colorize (angel-wing 100 80 #f) "orange"))))) 21 | -------------------------------------------------------------------------------- /scripts/sort-lines.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/string 3 | quickscript) 4 | 5 | (script-help-string "Sorts the selected lines in (anti-)alphabetical order.") 6 | 7 | (define ((sort-selection cmp) selection) 8 | (string-join (sort (string-split selection "\n" #:trim? #t) 9 | cmp) 10 | "\n" #:after-last "\n")) 11 | 12 | (define-script sort-lines-alpha 13 | #:label "&Alphabetically" 14 | #:menu-path ("Sele&ction" "&Sort lines") 15 | (sort-selection string<=?)) 16 | 17 | (define-script sort-lines-anti-alpha 18 | #:label "A&nti-alphabetically" 19 | #:menu-path ("Sele&ction" "&Sort lines") 20 | (sort-selection string>=?)) 21 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection "quickscript-extra") 3 | (define deps '("base" 4 | "quickscript" 5 | "at-exp-lib" 6 | "drracket" 7 | "gui-lib" 8 | "pict-lib" 9 | "racket-index" 10 | "scribble-lib" 11 | "search-list-box" 12 | "srfi-lite-lib" 13 | "net-lib" 14 | "web-server-lib")) 15 | (define build-deps '(#;"scribble-lib" "racket-doc" "rackunit-lib")) 16 | (define scribblings '(("scribblings/quickscript-extra.scrbl" ()))) 17 | (define pkg-desc "Description Here") 18 | (define version "0.0") 19 | (define pkg-authors '(orseau)) 20 | -------------------------------------------------------------------------------- /scripts/gui-tools.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp racket/base 2 | (require quickscript) 3 | 4 | (script-help-string "Code snippets for racket/gui widgets. Meant as a demo.") 5 | 6 | (define-script add-frame 7 | #:label "Add frame" 8 | #:menu-path ("Gui tools") 9 | (λ (str) 10 | (set! str (if (string=? str "") "my-frame" str)) 11 | @string-append{ 12 | (define @str 13 | (new frame% 14 | [label "@str"] 15 | [min-width 200] [min-height 200])) 16 | })) 17 | 18 | (define-script add-message 19 | #:label "Add message" 20 | #:menu-path ("Gui tools") 21 | (λ (str) 22 | (set! str (if (string=? str "") "my-message" str)) 23 | @string-append{ 24 | (new message% [parent #f] [label "@str"]) 25 | })) 26 | 27 | 28 | -------------------------------------------------------------------------------- /scripts/surround-selection.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require quickscript) 3 | 4 | (script-help-string "(Example) Surround the selected text with various characters.") 5 | 6 | (define-script surround-with-dashes 7 | #:label "Surround with dashes" 8 | #:menu-path ("E&xamples" "&Surround") 9 | #:help-string "Surrounds the selection with dashes" 10 | (λ (selection) 11 | (string-append "-" selection "-"))) 12 | 13 | (define-script surround-with-stars 14 | #:label "Surround with stars" 15 | #:menu-path ("E&xamples" "&Surround") 16 | #:help-string "Surrounds the selection with stars" 17 | (λ (selection) 18 | (string-append "*" selection "*"))) 19 | 20 | (define-script surround-with-slashes 21 | #:menu-path ("E&xamples" "&Surround") 22 | #:label "Surround with slashes" 23 | (λ (selection) 24 | (string-append "/" selection "/"))) 25 | -------------------------------------------------------------------------------- /scripts/add-menu.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/gui/base 3 | racket/class 4 | quickscript) 5 | 6 | (script-help-string "(Example) Shows how to dynamically add a menu to DrRacket.") 7 | 8 | (define-script add-menu 9 | #:label "Add menu" 10 | #:menu-path ("E&xamples") 11 | (λ (str #:frame fr) 12 | (define menu-bar (send fr get-menu-bar)) 13 | (define menu (new menu% [parent menu-bar] [label "M&y Menu"])) 14 | (new menu-item% [parent menu] [label "&Remove me"] 15 | [callback (λ _ (send menu delete))]) 16 | (define count 0) 17 | (new menu-item% [parent menu] [label "&Count me"] 18 | [callback (λ _ 19 | (set! count (add1 count)) 20 | (message-box "Count" (string-append "Count: " (number->string count))) 21 | )]) 22 | #f)) 23 | 24 | -------------------------------------------------------------------------------- /scripts/persistent-counter.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require quickscript) 3 | 4 | (script-help-string "(Example) Shows how the `#:persistent` property works.") 5 | 6 | (define count 0) 7 | 8 | (define-script increase-counter 9 | #:label "&Increase counter" 10 | #:menu-path ("E&xamples" "&Counter") 11 | #:persistent 12 | #:output-to message-box 13 | (λ (selection) 14 | (set! count (+ count 1)) 15 | (number->string count))) 16 | 17 | (define-script show-counter 18 | #:label "&Show counter" 19 | #:menu-path ("E&xamples" "&Counter") 20 | #:persistent 21 | #:output-to message-box 22 | (λ (selection) 23 | (number->string count))) 24 | 25 | (define-script show-counter/non-persistent 26 | #:label "S&how counter (non-persistent)" 27 | #:menu-path ("E&xamples" "&Counter") 28 | #:output-to message-box 29 | (λ (selection) 30 | (number->string count))) -------------------------------------------------------------------------------- /scripts/open-collect-file.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/gui/base 3 | racket/class 4 | setup/dirs 5 | quickscript) 6 | 7 | (script-help-string "Open a file in DrRacket, starting in racket's collections base path.") 8 | 9 | ;; WARNING: This currently does not work because of `open-in-new-tab` 10 | ;; that requires a direct call to the frame in the initial namespace. 11 | ;; Needs a particular property to use the namespace anchor? 12 | 13 | (define-script open-collects-file 14 | #:label "Open collects file" 15 | #:menu-path ("&Utils") 16 | (λ (str #:frame frame) 17 | (define f (get-file "Open a script" #f (find-collects-dir) #f #f '() 18 | '(("Racket" "*.rkt")))) 19 | (when f 20 | (send frame open-in-new-tab f)) 21 | #f)) 22 | 23 | ;; TODO: Extend with (find-user-collects-dir) (find-pkgs-dir) (find-user-pkgs-dir) -------------------------------------------------------------------------------- /scripts/open-terminal.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/system 3 | racket/path 4 | quickscript) 5 | 6 | (script-help-string "Open a terminal in the directory of the current file.") 7 | 8 | (define-script open-terminal 9 | #:label "Open terminal here" 10 | #:menu-path ("&Utils") 11 | #:os-types (unix macosx windows) 12 | (λ (str #:file f) 13 | (unless f 14 | (set! f (current-directory))) 15 | (define dir (path->string (path-only f))) 16 | (case (system-type 'os) 17 | [(unix) 18 | (system (string-append "gnome-terminal" 19 | " --working-directory=\"" dir "\"" 20 | " -t \"" dir "\"" 21 | "&"))] 22 | [(macosx) 23 | (system 24 | (string-append "osascript -e 'tell app \"Terminal\" to do script \"cd \\\"" dir "\\\"\"'" ))] 25 | [(windows) 26 | (shell-execute #f "cmd.exe" "" dir 'sw_shownormal)]) 27 | #false)) 28 | -------------------------------------------------------------------------------- /scripts/goto-line.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/gui/base 3 | racket/class 4 | quickscript) 5 | 6 | (script-help-string "Jump to a given line number in the current editor.") 7 | 8 | (define-script goto-line 9 | #:label "Go to &line..." 10 | (λ (str #:editor ed) 11 | (define line-str (get-text-from-user "Goto line" "Line number:" 12 | #f 13 | (number->string 14 | (add1 15 | (send ed position-paragraph 16 | (send ed get-end-position)))) 17 | #:validate string->number)) 18 | (define line (and line-str (string->number line-str))) 19 | (when (exact-nonnegative-integer? line) 20 | (send ed set-position (send ed paragraph-start-position 21 | (sub1 line)))) 22 | #f)) 23 | -------------------------------------------------------------------------------- /scripts/enter-submod.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | quickscript) 4 | 5 | 6 | (script-help-string 7 | "Easily enter a submodule (main, test, drracket, etc.) in the interaction window.") 8 | ;;; Sends a snippet of text to the interactions window that, once entered, 9 | ;;; will enter (evaluate and make visible) the corresponding submodule. 10 | 11 | (define ((enter-submod submod) str #:interactions editor) 12 | (send* editor 13 | (insert 14 | (format "(require (only-in racket/enter dynamic-enter!) 15 | (only-in syntax/location quote-module-path)) 16 | (dynamic-enter! (quote-module-path ~a))" submod)))) 17 | 18 | (define-script enter-drracket 19 | #:label "&drracket" 20 | #:menu-path ("&Enter submodule") 21 | #:shortcut f5 22 | #:shortcut-prefix (shift) 23 | (enter-submod 'drracket)) 24 | 25 | (define-script enter-test 26 | #:label "&test" 27 | #:menu-path ("&Enter submodule") 28 | (enter-submod 'test)) 29 | 30 | (define-script enter-main 31 | #:label "&main" 32 | #:menu-path ("&Enter submodule") 33 | (enter-submod 'main)) 34 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Laurent Orseau 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /scripts/abstract-variable.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/gui 3 | quickscript) 4 | 5 | (script-help-string 6 | "Create a variable from the selected expression 7 | [video](https://www.youtube.com/watch?v=qgjAZd4eBBY)") 8 | 9 | (define-script abstract-variable 10 | #:label "&Abstract variable" 11 | #:menu-path ("Re&factor") 12 | (λ (str) 13 | (cond 14 | [(string=? str "") 15 | (message-box "Empty selection" 16 | "No expression selected" 17 | #f 18 | '(ok caution))] 19 | [else 20 | (define var (get-text-from-user "Variable Abstraction" "Variable name:" 21 | #:validate (λ (s) #t))) 22 | (if var 23 | (begin 24 | (send the-clipboard set-clipboard-string 25 | (string-append "(define " var " " str ")") 26 | 0) 27 | var) 28 | str)]))) 29 | 30 | ;; Select `"badinka"`, then click on Script>Abstract variable, enter `my-var`, 31 | ;; add a newline just after `begin` and past what's in the clipboard. 32 | #;(begin 33 | (string-append "zorglub" "badinka")) -------------------------------------------------------------------------------- /scripts/all-tabs.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/gui/base 3 | racket/class 4 | quickscript) 5 | 6 | ;;; The default 'Tabs' menu in DrRacket lists only the first 10 tabs. 7 | ;;; This script displays all tabs, which is particularly convenient when 8 | ;;; there are many tabs and not all of them are visible. 9 | 10 | (script-help-string 11 | "Have a menu that displays all open tabs in DrRacket.") 12 | 13 | (define-script all-tabs 14 | #:label "All tabs" 15 | (λ (str #:frame fr) 16 | (define menu-bar (send fr get-menu-bar)) 17 | (define menu 18 | (new menu% [parent menu-bar] [label "All Tabs"] 19 | [demand-callback 20 | (λ (menu) 21 | (send fr begin-container-sequence) 22 | (for ([it (in-list (send menu get-items))]) 23 | (send it delete)) 24 | (new menu-item% [parent menu] [label "&Remove menu"] 25 | [callback (λ _ (send menu delete))]) 26 | (for ([t (in-range (send fr get-tab-count))] 27 | [tab (in-list (send fr get-tabs))]) 28 | (new menu-item% [parent menu] 29 | [label (format "~a: ~a" t (send fr get-tab-filename t))] 30 | [callback (λ _ (send fr change-to-tab tab))])) 31 | (send fr end-container-sequence))])) 32 | #f)) 33 | 34 | -------------------------------------------------------------------------------- /scripts/color-chooser.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/gui/base 3 | racket/class 4 | racket/match 5 | racket/port 6 | quickscript) 7 | 8 | (script-help-string 9 | "Pick a color in the palette and insert it in DrRacket's current file.") 10 | 11 | (define-script color-chooser 12 | #:label "Color chooser" 13 | #:menu-path ("&Utils") 14 | (λ (str) 15 | (define-values 16 | (r g b new-str) 17 | (match (port->list read (open-input-string str)) 18 | [`((make-object color% ,(? number? r) ,(? number? g) ,(? number? b))) 19 | (values r g b "(make-object color% ~a ~a ~a)")] 20 | [`((make-color ,(? number? r) ,(? number? g) ,(? number? b))) 21 | (values r g b "(make-color ~a ~a ~a)")] 22 | [`(,(? number? r) ,(? number? g) ,(? number? b)) 23 | (values r g b "~a ~a ~a")] 24 | [`(#(,(? number? r) ,(? number? g) ,(? number? b))) 25 | (values r g b "#(~a ~a ~a)")] 26 | [else (values 255 0 0 "(make-color ~a ~a ~a)")])) 27 | (let ([c (get-color-from-user #f #f (make-color r g b))]) 28 | (and c 29 | (format new-str 30 | (send c red) 31 | (send c green) 32 | (send c blue)))))) 33 | 34 | ; Select the following s-exp and click on the color-chooser script menu item: 35 | ; (make-object color% 90 158 163) 36 | ; 65 65 156 37 | ; (make-color 142 199 194) 38 | ; #(1 2 149) 39 | -------------------------------------------------------------------------------- /scripts/backup-file.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require quickscript 4 | racket/path 5 | racket/format 6 | racket/date 7 | racket/file) 8 | 9 | (script-help-string "Copies the current file in the 'backups' subdirectory with a time stamp") 10 | 11 | (define backup-sub-dir "backups") 12 | 13 | (define (date->my-format d) 14 | (string-append 15 | (~r (date-year d) #:min-width 4 #:pad-string "0") 16 | "-" 17 | (~r (date-month d) #:min-width 2 #:pad-string "0") 18 | "-" 19 | (~r (date-day d) #:min-width 2 #:pad-string "0") 20 | "--" 21 | (~r (date-hour d) #:min-width 2 #:pad-string "0") 22 | "-" 23 | (~r (date-minute d) #:min-width 2 #:pad-string "0") 24 | "-" 25 | (~r (date-second d) #:min-width 2 #:pad-string "0"))) 26 | 27 | (define-script backup-file 28 | #:label "Back&up current file" 29 | #:menu-path ("&Utils") 30 | #:output-to message-box 31 | (λ (selection #:file f) 32 | (when f 33 | (define dir (path-only f)) 34 | (define filename (file-name-from-path f)) 35 | (define backup-dir (build-path dir backup-sub-dir)) 36 | (make-directory* backup-dir) 37 | (define date-str 38 | (date->my-format (current-date)) 39 | ;; The iso format includes "T" for date/time separator, which is hard to read, 40 | ;; and ":" as another separator, which may behave badly in filenames on some OSes. 41 | #;(parameterize ([date-display-format 'iso-8601]) 42 | (date->string (current-date) #t))) 43 | (define backup-filename (string-append date-str "--" (path->string filename))) 44 | (define new-file (build-path backup-dir backup-filename)) 45 | (copy-file f new-file) 46 | (string-append (path->string f) 47 | "\nCopied to\n" 48 | (path->string new-file))))) 49 | -------------------------------------------------------------------------------- /scripts/reorder-tabs.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/list 4 | racket/format 5 | racket/gui/base 6 | quickscript 7 | (only-in srfi/1 list-index)) 8 | 9 | (script-help-string "(Example) Move DrRacket's tabs around.") 10 | 11 | (define-script move-left 12 | #:label "Move left" 13 | #:menu-path ("E&xamples" "&Tabs") 14 | #:persistent ; for loading speed 15 | (λ (str #:frame fr) 16 | (send fr move-current-tab-left) 17 | #f)) 18 | 19 | (define-script move-right 20 | #:label "Move right" 21 | #:menu-path ("E&xamples" "&Tabs") 22 | #:persistent 23 | (λ (str #:frame fr) 24 | (send fr move-current-tab-right) 25 | #f)) 26 | 27 | (define-script move-to-last 28 | #:label "Move to last" 29 | #:menu-path ("E&xamples" "&Tabs") 30 | #:persistent 31 | (λ (str #:frame fr) 32 | (define cur-tab (send fr get-current-tab)) 33 | (define tabs (send fr get-tabs)) 34 | (define cur-tab-idx (list-index (λ (t) (eq? t cur-tab)) tabs)) 35 | (send fr reorder-tabs 36 | (append (remove cur-tab-idx (range (length tabs))) 37 | (list cur-tab-idx))) 38 | #f)) 39 | 40 | (define-script move-to-first 41 | #:label "Move to first" 42 | #:menu-path ("E&xamples" "&Tabs") 43 | #:persistent 44 | (λ (str #:frame fr) 45 | (define cur-tab (send fr get-current-tab)) 46 | (define tabs (send fr get-tabs)) 47 | (define cur-tab-idx (list-index (λ (t) (eq? t cur-tab)) tabs)) 48 | (send fr reorder-tabs 49 | (cons cur-tab-idx 50 | (remove cur-tab-idx (range (length tabs))))) 51 | #f)) 52 | 53 | (define-script reverse-tabs 54 | #:label "Reverse tabs" 55 | #:menu-path ("E&xamples" "&Tabs") 56 | #:persistent 57 | (λ (str #:frame fr) 58 | (send fr reorder-tabs 59 | (reverse (range (length (send fr get-tabs))))) 60 | #f)) 61 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | # Based from: https://github.com/greghendershott/travis-racket 4 | 5 | # Optional: Remove to use Travis CI's older infrastructure. 6 | sudo: false 7 | 8 | env: 9 | global: 10 | # Supply a global RACKET_DIR environment variable. This is where 11 | # Racket will be installed. A good idea is to use ~/racket because 12 | # that doesn't require sudo to install and is therefore compatible 13 | # with Travis CI's newer container infrastructure. 14 | - RACKET_DIR=~/racket 15 | matrix: 16 | # Supply at least one RACKET_VERSION environment variable. This is 17 | # used by the install-racket.sh script (run at before_install, 18 | # below) to select the version of Racket to download and install. 19 | # 20 | # Supply more than one RACKET_VERSION (as in the example below) to 21 | # create a Travis-CI build matrix to test against multiple Racket 22 | # versions. 23 | - RACKET_VERSION=6.0 24 | - RACKET_VERSION=6.5 25 | - RACKET_VERSION=6.11 26 | - RACKET_VERSION=HEAD 27 | 28 | matrix: 29 | allow_failures: 30 | # - env: RACKET_VERSION=HEAD 31 | fast_finish: true 32 | 33 | before_install: 34 | - git clone https://github.com/greghendershott/travis-racket.git ~/travis-racket 35 | - cat ~/travis-racket/install-racket.sh | bash # pipe to bash not sh! 36 | - export PATH="${RACKET_DIR}/bin:${PATH}" #install-racket.sh can't set for us 37 | 38 | install: 39 | - raco pkg install --deps search-auto 40 | 41 | before_script: 42 | 43 | # Here supply steps such as raco make, raco test, etc. You can run 44 | # `raco pkg install --deps search-auto` to install any required 45 | # packages without it getting stuck on a confirmation prompt. 46 | script: 47 | - raco test -x -p quickscript-extra2 48 | 49 | after_success: 50 | - raco setup --check-pkg-deps --pkgs quickscript-extra2 51 | - raco pkg install --deps search-auto cover cover-coveralls 52 | - raco cover -b -f coveralls -d $TRAVIS_BUILD_DIR/coverage . 53 | -------------------------------------------------------------------------------- /scripts/git.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/gui/base 3 | racket/class 4 | racket/system 5 | racket/path 6 | quickscript 7 | ) 8 | 9 | (script-help-string "Some git commands (linux only). Currently meant as a demo.") 10 | 11 | ;; Modify this command to suit your needs 12 | (define (make-cmd sub-cmd) 13 | (string-append "xterm -hold -e '" (regexp-replace* #rx"'" sub-cmd "''") "'")) 14 | 15 | (define (cmd-system sub-cmd) 16 | (define cmd (make-cmd sub-cmd)) 17 | ;(message-box "Runnning command" cmd) 18 | (system (string-append cmd "&"))) 19 | 20 | (define-syntax-rule (lambda/dir-of-file (f) body ...) 21 | (lambda (fun _str #:file f) 22 | (when f 23 | (define dir (path-only f)) 24 | (parameterize ([current-directory dir]) 25 | body ... 26 | )))) 27 | 28 | (define-script git-commit-file 29 | #:label "Commit &file" 30 | #:menu-path ("&Git") 31 | #:os-types (unix) 32 | (lambda/dir-of-file (f) 33 | (define filename (file-name-from-path f)) 34 | (cmd-system (string-append "git commit \"" (path->string filename) "\"")))) 35 | 36 | (define-script git-add-file 37 | #:label "A&dd file" 38 | #:menu-path ("&Git") 39 | #:os-types (unix) 40 | (lambda/dir-of-file (f) 41 | (define filename (file-name-from-path f)) 42 | (cmd-system (string-append "git add \"" (path->string filename) "\"")))) 43 | 44 | (define-script git-commit-all 45 | #:label "Commit &all" 46 | #:menu-path ("&Git") 47 | #:os-types (unix) 48 | (lambda/dir-of-file (f) 49 | ; todo: save all files? 50 | (cmd-system "git commit -a"))) 51 | 52 | (define-script git-push 53 | #:label "&Push" 54 | #:menu-path ("&Git") 55 | #:os-types (unix) 56 | (lambda/dir-of-file (f) 57 | (cmd-system "git push"))) 58 | 59 | (define-script git-pull-rebase 60 | #:label "P&ull --rebase" 61 | #:menu-path ("&Git") 62 | #:os-types (unix) 63 | (lambda/dir-of-file (f) 64 | (cmd-system "git pull --rebase"))) 65 | -------------------------------------------------------------------------------- /scripts/sections.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require srfi/13 3 | (only-in racket/gui/base get-text-from-user) 4 | quickscript) 5 | 6 | (script-help-string "Surrounds the selected text by comments ASCII frames.") 7 | ;;; Asks for input if nothing is selected. 8 | 9 | (define (surround-char str char [prefix ""] [suffix (string-reverse prefix)]) 10 | (let ([line (string-append prefix (build-string (+ 4 (string-length str)) (λ (i) char)) suffix "\n")]) 11 | (string-append 12 | line 13 | prefix (string char) " " str " " (string char) suffix "\n" 14 | line))) 15 | 16 | (define (string-or-from-user section str) 17 | (if (string=? str "") 18 | (get-text-from-user section (string-append "Enter a " section ":")) 19 | str)) 20 | 21 | (define-syntax-rule (define-section (fun label shortcut str2) body ...) 22 | (define-script fun 23 | #:label label 24 | #:menu-path ("Sele&ction" "Se&ctions") 25 | #:shortcut shortcut 26 | #:shortcut-prefix (ctl shift) 27 | (λ (str) 28 | (define str2 (string-or-from-user label str)) 29 | (and str2 30 | (begin body ...))))) 31 | 32 | (define-section (title "Title" #\1 str) 33 | (let* ([str (string-titlecase str)] 34 | [spaces (build-string (max 0 (quotient (- 77 (string-length str)) 2)) 35 | (λ (n) #\space))]) 36 | (surround-char 37 | (string-append spaces str spaces) 38 | #\* ";***"))) 39 | 40 | (define-section (section "Section" #\2 str) 41 | (surround-char str #\= ";==")) 42 | 43 | (define-section (subsection "Subsection" #\3 str) 44 | (surround-char str #\: ";:")) 45 | 46 | (define-section (subsubsection "Subsubsection" #\4 str) 47 | (surround-char str #\- ";")) 48 | 49 | (module+ drracket 50 | (displayln (title "this is the title")) 51 | (displayln (section "Section")) 52 | (displayln (subsection "Subsection")) 53 | (displayln (subsubsection "Subsubsection")) 54 | 55 | (displayln (title "")) 56 | ) 57 | -------------------------------------------------------------------------------- /scripts/provided-by.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require setup/xref 3 | scribble/xref 4 | scribble/manual-struct 5 | racket/class 6 | racket/list 7 | racket/format 8 | racket/string 9 | quickscript) 10 | 11 | (script-help-string "Displays a list of modules that `provide` the procedure under the cursor.") 12 | 13 | (define x (load-collections-xref)) 14 | (define idx (xref-index x)) ; list of `entry's 15 | 16 | (define (search-approximate word) 17 | (filter (λ (e) (regexp-match word (first (entry-words e)))) ; approximate search 18 | idx)) 19 | 20 | (define (search-exact word) 21 | (sort 22 | (flatten 23 | (for/list ([e (in-list idx)] 24 | #:when (string=? word (first (entry-words e)))) 25 | (exported-index-desc-from-libs (entry-desc e)))) 26 | symbollist e) 29 | (list (entry-words e) 30 | (entry-tag e) 31 | (entry-desc e))) 32 | 33 | (define (entry->string e) 34 | (define desc (entry-desc e)) 35 | (if (exported-index-desc? desc) 36 | (format "~a\n Provided by: ~a\n" 37 | (first (entry-words e)) 38 | (exported-index-desc-from-libs desc)) 39 | "")) 40 | 41 | (define-script provided-by 42 | #:label "&Provided by" 43 | #:help-string "Displays in a message box the list of modules that provided the word under the cursor" 44 | #:persistent ; to avoid reloading it at each invokation 45 | #:output-to message-box 46 | (λ (s #:editor ed) 47 | (define start-pos (send ed get-start-position)) 48 | (define end-pos (send ed get-end-position)) 49 | (define start-exp-pos 50 | (or (send ed get-backward-sexp start-pos) start-pos)) 51 | (define end-exp-pos 52 | (or (send ed get-forward-sexp (- end-pos 1)) end-pos)) 53 | (define str 54 | (send ed get-text start-exp-pos end-exp-pos)) 55 | (define res 56 | (search-exact str)) 57 | (string-append 58 | "[" str "] is provided (at least) by the following modules:\n\n" 59 | (if (empty? res) 60 | "No documented module found." 61 | (string-join (map ~a res) "\n"))))) 62 | -------------------------------------------------------------------------------- /scripts/author-date.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/date 3 | quickscript) 4 | 5 | (script-help-string 6 | "Insert text snippets with author, date, time, and licence.") 7 | 8 | ;;; 4 shortcuts to print the author [email] date [time] 9 | ;;; Laurent Orseau -- 2012-04-19 10 | 11 | ; Replace by your own data: 12 | (define auth "Firstname Lastname") 13 | (define email "") 14 | 15 | (define (date-iso [time? #f]) 16 | (parameterize ([date-display-format 'iso-8601]) 17 | (date->string (current-date) time?))) 18 | 19 | (define (author [email? #f]) 20 | (if email? 21 | (string-append auth " " email) 22 | auth)) 23 | 24 | (define (author-date-all [email? #f] [time? #f]) 25 | (string-append (author email?) " -- " 26 | (date-iso time?))) 27 | 28 | (define-script author-date 29 | #:label "Author &date" 30 | #:menu-path ("&Author date") 31 | (λ (str) (author-date-all #f #f))) 32 | 33 | (define-script author-date-time 34 | #:label "Author date &time" 35 | #:menu-path ("&Author date") 36 | (λ (str) (author-date-all #f #t))) 37 | 38 | (define-script author-email-date 39 | #:label "Author &email date" 40 | #:menu-path ("&Author date") 41 | (λ (str) (author-date-all #t #f))) 42 | 43 | (define-script author-email-date-time 44 | #:label "A&uthor email date time" 45 | #:menu-path ("&Author date") 46 | (λ (str) (author-date-all #t #t))) 47 | 48 | (define-script license-cc-by4 49 | #:label "&CC-BY 4.0" 50 | #:menu-path ("&Author date") 51 | (λ (str) "License: [CC-BY 4.0](https://creativecommons.org/licenses/by/4.0/)")) 52 | 53 | (define-script license-dual-mit-apache2 54 | #:label "Dual A&pache2.0/MIT License" 55 | #:menu-path ("&Author date") 56 | (λ (str) 57 | #<list non-word-str)) 18 | (define non-word-re (regexp-quote non-word-str)) 19 | 20 | ;; Returns the first position that is not a word-like symbol 21 | ;; dir is -1 (for left) or 1 (for right) 22 | (define (word-pos ed pos dir) 23 | (define offset (if (= dir 1) 0 -1)) 24 | (define last (if (= dir 1) 25 | (send ed last-position) 26 | 0)) 27 | (or 28 | (for/or ([p (in-range pos last dir)]) 29 | (define ch (send ed get-text (+ p offset) (+ 1 p offset))) 30 | (and ch 31 | (memq (first (string->list ch)) non-word-chars) 32 | p)) 33 | last)) 34 | 35 | ;; Returns the string for the left- or right-hand-side of pos, depending on if dir=-1 or dir=1. 36 | (define (get-word ed pos dir) 37 | (let ([p (word-pos ed pos dir)]) 38 | (if p 39 | (send ed get-text (min p pos) (max p pos)) 40 | ""))) 41 | 42 | (define-script dabbrev 43 | #:label "D&ynamic completion" 44 | #:menu-path ("Re&factor") 45 | #:shortcut #\/ 46 | #:shortcut-prefix (alt) 47 | (λ (s #:editor ed) 48 | (define pos (send ed get-end-position)) 49 | (define left (get-word ed pos -1)) 50 | (define right (get-word ed pos 1)) 51 | (define txt (send ed get-text)) 52 | (define matches 53 | (remove-duplicates 54 | (regexp-match* (pregexp (string-append "\\b" (regexp-quote left) 55 | "[^" non-word-re "]*")) 56 | txt))) 57 | (when matches 58 | (define mems (member (string-append left right) matches)) 59 | (define str 60 | (if (and mems (not (empty? (rest mems)))) 61 | (second mems) 62 | (first matches))) 63 | (when str 64 | (send ed begin-edit-sequence) 65 | (send ed delete pos (+ pos (string-length right))) 66 | (send ed insert 67 | (substring str (string-length left))) 68 | (send ed set-position pos) 69 | (send ed end-edit-sequence))) 70 | #f)) 71 | -------------------------------------------------------------------------------- /scripts/complete-word.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/dict 4 | racket/list 5 | quickscript) 6 | 7 | (script-help-string "Word completion from a given user dictionary") 8 | ;;; Replaces the text abbreviation right before the caret by some expanded text 9 | 10 | ;;; *** How to customize this script *** 11 | ;;; 12 | ;;; 1. Click on Scripts|Manage|Library… 13 | ;;; 2. Select the ".../quickscript-extra/scripts" directory in the left panel 14 | ;;; 3. Select the "complete-word" scripts in the right panel 15 | ;;; 4. Click on Shadow (and read the message) 16 | ;;; 5. Customize the script by modifying the `words` parameters, for example 17 | #;(shadow:words '(("L" "(λ (" ") )") ; replace L with (λ () ) 18 | ("frame" "(define fr (new frame% [label \"" 19 | "\"]))\n(send fr show #true)"))) 20 | ;;; 6. Save the file, reload the menu (Scripts|Manage|Reload menu). 21 | ;;; 22 | ;;; Now try the script: In any tab, type `frame` (without quotes) followed 23 | ;;; by `c:s:/`. 24 | ;;; 25 | ;;; You can also customize the shortcut defined in the shadow script. 26 | 27 | 28 | 29 | (provide words 30 | default-words) 31 | 32 | (define default-words 33 | '(("dspr" "(define-syntax-parse-rule (" ")\n )") 34 | ("dsr" "(define-syntax-rule (" ")\n )") 35 | ("ds" "(define-syntax " "\n )") 36 | ("sr" "(syntax-rules ()\n [(_ " ")])") 37 | ("sc" "(syntax-case stx ()\n [(_ " ")])") 38 | ("dsm" "(define-simple-macro (" ")\n )") 39 | ("lbd" "(λ (" ") )") 40 | ("param" "(parameterize ([current-" "])\n )") 41 | ("wh" "(with-handlers ([exn:" "])\n )") 42 | ("wiff" "(with-input-from-file " "\n (λ _ ))") 43 | ("wotf" "(with-output-to-file " " #:exists 'replace\n (λ _ ))") 44 | 45 | ; slideshow: 46 | ("slide" "(slide #:title \"" "\"\n )") 47 | ("item" "@item{" "}") 48 | ("subitem" "@subitem{" "}") 49 | ("$" "@${" "}") 50 | ("$$" "@$${" "}") 51 | 52 | ; Qi: 53 | ("flow" "(☯ " ")") 54 | ("sep" "△ " "") 55 | ("collect" "▽ " "") 56 | ("ground" "⏚" "") 57 | )) 58 | 59 | (define words (make-parameter default-words)) 60 | 61 | (define-script complete-word 62 | #:label "Auto-complete" 63 | #:shortcut #\/ 64 | #:shortcut-prefix (ctl shift) 65 | (λ (s #:editor ed) 66 | (define pos (send ed get-end-position)) 67 | (define str 68 | (send ed get-text 69 | (send ed get-backward-sexp pos) 70 | pos)) 71 | (define str-ext (dict-ref (words) str #f)) 72 | (define left (if (list? str-ext) (first str-ext) str-ext)) 73 | (define right (and (list? str-ext) (second str-ext))) 74 | (when str-ext 75 | (send ed begin-edit-sequence) 76 | (send ed select-backward-sexp) 77 | (send ed insert left) 78 | (when right 79 | (define ipos (send ed get-start-position)) 80 | (send ed insert right) 81 | (send ed set-position ipos)) 82 | (send ed end-edit-sequence)) 83 | #f)) 84 | 85 | #;( 86 | item 87 | para 88 | wh 89 | $$ 90 | ) 91 | -------------------------------------------------------------------------------- /scripts/regexp-replace.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require framework/gui-utils 3 | racket/gui 4 | racket/help 5 | quickscript) 6 | 7 | (script-help-string "Replace patterns in the selected text using regular expressions.") 8 | 9 | (editor-set-x-selection-mode #t) 10 | 11 | (define str-out #f) 12 | (define str-in #f) 13 | (define f (new dialog% [label "Regexp Replace"] 14 | [min-width 500])) 15 | (define hp-help (new horizontal-panel% [parent f])) 16 | (define msg-help 17 | (new message% [parent hp-help] 18 | [label "Replace the selected text using an extended regular expression"])) 19 | (define bt-help (new button% [parent hp-help] [label "Regexp Help"] 20 | [callback (thunk* (help "Regular expressions N:Printing N:Reading"))])) 21 | (define templates 22 | '(("– Templates –" . #f) 23 | ; title from to protect-from protect-to 24 | ("Remove trailing spaces" "\\s*$" "" #f #f) 25 | ("Remove leading spaces" "^\\s*" "" #f #f) 26 | ("Comment out" "^" ";" #f #f) 27 | ("Uncomment" "^;" "" #f #f) 28 | ("Markdown quotes -> @racket[]" "`([^`]+)`" "@racket[\\1]" #f #f) 29 | ("Markdown item -> @item{}" "\\s*\\*\\s*(.*)\\s*" "@item{\\1}" #f #f) 30 | )) 31 | (define ch-templates 32 | (new choice% [parent f] 33 | [label #f #;"Templates:"] 34 | [choices (map car templates)] 35 | [callback (λ (ch ev) 36 | (define sel (send ch get-string-selection)) 37 | (define l (and sel (dict-ref templates sel))) 38 | (when l 39 | (send t1 set-value (first l)) 40 | (send t2 set-value (second l)) 41 | (send cb1 set-value (third l)) 42 | (send cb2 set-value (fourth l))))])) 43 | (define hp1 (new horizontal-panel% [parent f])) 44 | (define t1 (new text-field% [parent hp1] [label "Replace:"])) 45 | (define cb1 (new check-box% [parent hp1] [label "Not regexp"])) 46 | (define hp2 (new horizontal-panel% [parent f])) 47 | (define t2 (new text-field% [parent hp2] [label "Replace:"])) 48 | ; Hack: Setting the label afterwards ensures both fields have the same size. 49 | (send t2 set-label "With:") 50 | (define cb2 (new check-box% [parent hp2] [label "Not regexp"])) 51 | (define (ok-pressed b ev) 52 | (send f show #f) 53 | (define t1-re ((if (send cb1 get-value) regexp-quote pregexp) 54 | (send t1 get-value))) 55 | (define t2-re ((if (send cb2 get-value) regexp-replace-quote values) 56 | (send t2 get-value))) 57 | (define new-lines 58 | ; apply the regexes only per line 59 | (for/list ([line (regexp-split #rx"\n" str-in)]) 60 | (regexp-replace* t1-re line t2-re))) 61 | (set! str-out (string-join new-lines "\n")) 62 | ;(set! str-out (regexp-replace* t1-re str-in t2-re)) ; problems with that, e.g., with "\n" 63 | ) 64 | (define (cancel-pressed b ev) 65 | (send f show #f)) 66 | (define-values (bt-ok bt-cancel) 67 | (gui-utils:ok/cancel-buttons f ok-pressed cancel-pressed)) 68 | 69 | ;; Performs a (extended) regexp-replace* on the selection. 70 | ;; The "from" and "to" patterns are asked in a dialog box. 71 | ;; If protect? is checked, the "from" pattern is regexp-quoted. 72 | (define-script regexp-replace-selection 73 | #:label "Regex replace" 74 | #:menu-path ("Sele&ction") 75 | #:help-string "Replace patterns in the selection using regular expressions" 76 | #:shortcut #\h 77 | #:shortcut-prefix (ctl) 78 | #:persistent 79 | (λ (str) 80 | (set! str-in str) 81 | (set! str-out #f) 82 | (send t1 focus) 83 | (send (send t1 get-editor) select-all) 84 | (send f show #t) 85 | str-out)) 86 | 87 | #| 88 | (item-callback "See the manual in the Script/Help \s* menu for \nmore information.") 89 | ; for protect, test with \s* and \1 90 | ;|# 91 | -------------------------------------------------------------------------------- /scripts/color-theme.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require framework 3 | racket/class 4 | racket/contract 5 | racket/set 6 | racket/port 7 | racket/pretty 8 | racket/gui/base 9 | quickscript) 10 | 11 | (script-help-string "Display information about the current color theme.") 12 | 13 | (define-script show-theme 14 | #:label "Show color theme" 15 | #:menu-path ("&Utils") 16 | (λ (str) 17 | (theme->frame) 18 | #f)) 19 | 20 | ; Call (theme->frame) to open a frame with the current style as an info.rkt file 21 | 22 | (color-prefs:register-info-based-color-schemes) 23 | 24 | (define (obj->list o) 25 | (cond [(list? o) 26 | (map obj->list o)] 27 | [(is-a? o style-delta%) 28 | (style->list o)] 29 | [(is-a? o color%) 30 | (list (color->list o))] 31 | [(is-a? o add-color<%>) 32 | (vector (send o get-r) (send o get-g) (send o get-b))] 33 | [else o])) 34 | 35 | (define (color->list c [alpha? #t]) 36 | (vector (send c red) 37 | (send c green) 38 | (send c blue) 39 | #;(if alpha? 40 | (list (send c alpha)) 41 | '()))) 42 | 43 | (define (style->list s) 44 | (map obj->list 45 | (filter (not/c 'base) 46 | (list 47 | #;(send s get-alignment-off) 48 | #;(send s get-alignment-on) 49 | #;(send s get-background-add) 50 | #;(send s get-background-mult) 51 | #;(send s get-face) 52 | #;(send s get-family) 53 | (send s get-foreground-add) 54 | #;(send s get-foreground-mult) 55 | #;(send s get-size-add) 56 | #;(send s get-size-in-pixels-off) 57 | #;(send s get-size-in-pixels-on) 58 | #;(send s get-size-mult) 59 | #;(send s get-smoothing-off) 60 | #;(send s get-smoothing-on) 61 | #;(send s get-style-off) 62 | (send s get-style-on) 63 | #;(send s get-transparent-text-backing-off) 64 | #;(send s get-transparent-text-backing-on) 65 | #;(send s get-underlined-off) 66 | (if (send s get-underlined-on) 'underline 'base) 67 | #;(send s get-weight-off) 68 | (send s get-weight-on) 69 | )))) 70 | 71 | (define (get-current-theme) 72 | (define-values 73 | (color-names style-names) 74 | (color-prefs:get-color-scheme-names)) 75 | (set-union color-names style-names)) 76 | 77 | (define (theme->hash [theme (get-current-theme)]) 78 | `#hash((name . "My color theme") 79 | (colors 80 | . 81 | ,(for/list ([key theme]) 82 | (cons key (obj->list (color-prefs:lookup-in-color-scheme key))))))) 83 | 84 | (define (theme->file-string [theme (get-current-theme)]) 85 | (with-output-to-string 86 | (λ () (displayln "#lang info\n") 87 | (pretty-print 88 | `(define framework:color-schemes 89 | '(,(theme->hash theme))) 90 | (current-output-port) 91 | 1)))) 92 | 93 | ;; Like frame:text% but without exiting the app when closing the window 94 | (define no-exit-frame:text% 95 | (class frame:text% 96 | (super-new) 97 | (define/override (on-exit) 98 | (void)) 99 | (define/override (can-exit?) 100 | #f) 101 | (define/augment (on-close) 102 | (void)) 103 | (define/augment (can-close?) 104 | (send this show #f) 105 | #f) 106 | )) 107 | 108 | (define (theme->frame [theme (get-current-theme)]) 109 | (exit:set-exiting #f) 110 | (define f (new no-exit-frame:text% 111 | [width 800] 112 | [height 600])) 113 | (define ed (send f get-editor)) 114 | (send ed insert (theme->file-string theme)) 115 | (send f show #t)) 116 | -------------------------------------------------------------------------------- /scripts/tweet.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/list 3 | racket/string 4 | quickscript) 5 | 6 | (script-help-string "(Example) Tweet the current selection. See the script file for configuration details.") 7 | 8 | ;;; HOW TO USE 9 | ;;; to use this you need to 10 | ;;; 11 | ;;; 1. go to https://apps.twitter.com 12 | ;;; 2. create a new app (profile for your app) 13 | ;;; 3. create a new token 14 | ;;; 4. set the environment variables: 15 | (define env-keys '("OAUTH_CONS_KEY" "CONS_SEC" "OAUTH_TOKEN" "OAUTH_TOKEN_SEC")) 16 | 17 | (define-script tweet-selection 18 | #:label "Tweet" 19 | #:menu-path ("Sele&ction") 20 | #:output-to message-box 21 | (λ (str #:frame fr) 22 | (define keys (map getenv env-keys)) 23 | (if (member #f keys) 24 | (string-append "Please set the following environment variables\n" 25 | (string-join env-keys ", ") 26 | ".") 27 | (begin 28 | (tweet! str) 29 | #f)))) 30 | 31 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 32 | ; Code below by David Van Horn http://ter.ps/dvanhorn ; 33 | ; used with permission ; 34 | ; https://gist.github.com/dvanhorn/815bdda5cfcdee18d480cb6a5d1119f3 ; 35 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 36 | 37 | (require (only-in racket/random crypto-random-bytes) 38 | json 39 | net/url 40 | (only-in net/uri-codec [uri-unreserved-encode %]) 41 | web-server/stuffers/hmac-sha1 42 | (only-in net/base64 base64-encode)) 43 | 44 | ;; For description, see: 45 | ;; https://developer.twitter.com/en/docs/basics/authentication/guides/authorizing-a-request 46 | 47 | 48 | ;; tweet! : String -> JSON 49 | ;; Post a tweet!, return JSON response 50 | (define (tweet! status oauth-consumer-key consumer-sec oauth-token oauth-token-sec) 51 | (define url "https://api.twitter.com/1.1/statuses/update.json") 52 | (define oauth-nonce (nonce)) 53 | (define timestamp (number->string (current-seconds))) 54 | (define ++ string-append) 55 | (define (& s) (apply ++ (add-between s "&"))) 56 | 57 | (define (encode msg) 58 | (& (map (λ (e) (string-append (first e) "=" (second e))) 59 | (sort (map (λ (e) (list (% (first e)) (% (second e)))) msg) 60 | (λ (elem1 elem2) (string<=? (car elem1) (car elem2))))))) 61 | 62 | (define parameter-string 63 | (encode `(("status" ,status) 64 | ("include_entities" "true") 65 | ("oauth_consumer_key" ,oauth-consumer-key) 66 | ("oauth_nonce" ,oauth-nonce) 67 | ("oauth_signature_method" "HMAC-SHA1") 68 | ("oauth_timestamp" ,timestamp) 69 | ("oauth_token" ,oauth-token) 70 | ("oauth_version" "1.0")))) 71 | 72 | (define sig-base-string 73 | (++ "POST&" (% url) "&" (% parameter-string))) 74 | 75 | (define signing-key 76 | (++ (% consumer-sec) "&" (% oauth-token-sec))) 77 | 78 | (define oauth-signature 79 | (bytes->string/utf-8 80 | (base64-encode (HMAC-SHA1 (string->bytes/utf-8 signing-key) 81 | (string->bytes/utf-8 sig-base-string)) 82 | #""))) 83 | 84 | (define header 85 | (list "Accept: */*" 86 | "Connection: close" 87 | "Content-Type: application/x-www-form-urlencoded" 88 | (++ "Authorization: OAuth " 89 | "oauth_consumer_key=\"" (% oauth-consumer-key) "\", " 90 | "oauth_nonce=\"" oauth-nonce "\", " 91 | "oauth_signature=\"" (% oauth-signature) "\", " 92 | "oauth_signature_method=\"HMAC-SHA1\", " 93 | "oauth_timestamp=\"" timestamp "\", " 94 | "oauth_token=\"" (% oauth-token) "\", " 95 | "oauth_version=\"1.0\""))) 96 | 97 | (read-json 98 | (post-pure-port 99 | (string->url (++ url "?include_entities=true")) 100 | (string->bytes/utf-8 (++ "status=" (% status))) 101 | header))) 102 | 103 | 104 | 105 | ;; nonce : -> String 106 | ;; Creates 32 bytes of random alphabetic data 107 | (define (nonce) 108 | (define (int->alpha i) 109 | (define a (modulo i 52)) 110 | (integer->char 111 | (cond [(<= 0 a 25) (+ a 65)] 112 | [(<= 26 a 52) (+ a 97 -26)]))) 113 | (apply string 114 | (map int->alpha 115 | (bytes->list (crypto-random-bytes 32))))) 116 | -------------------------------------------------------------------------------- /scripts/bookmarks.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/gui 2 | (require quickscript 3 | search-list-box) 4 | 5 | (script-help-string "Quickly navigate between lines and headlines") 6 | 7 | #| 8 | Bookmarks are "anchors" as comments in the source code, and thus are part of the file 9 | (but they are very little invasive and can be used, for example, as section headers). 10 | 11 | Each time the user uses "Go to line" or "Save line number" or uses a bookmark, 12 | the current line position is saved. 13 | The user can use "Go to previous line" to go back to the latest saved position. 14 | The full history is saved, so the user can get back like in an undo list. 15 | 16 | |# 17 | 18 | (define saved-lines (make-hash)) 19 | 20 | #; 21 | (define-script view-hash 22 | #:label "view hash" 23 | #:menu-path ("Bookmarks") 24 | #:persistent 25 | (λ (str) 26 | (message-box "save-current-line!" (~a saved-lines)) 27 | #f)) 28 | 29 | ;; Saves the current line to be used with goto-previous 30 | (define-script temp-bookmark 31 | #:label "Save line number" 32 | #:menu-path ("Bookmarks") 33 | #:persistent 34 | (λ (str #:editor ed) 35 | (save-current-line! ed) 36 | #f)) 37 | 38 | ;; Saves the current line, and asks for the line to go to 39 | (define-script goto-line 40 | #:label "Go to line..." 41 | #:menu-path ("Bookmarks") 42 | #:shortcut f9 43 | #:shortcut-prefix (shift) 44 | #:persistent 45 | (λ (str #:editor ed) 46 | (define line (get-text-from-user "Go to line" "Line number:" 47 | #:validate string->number)) 48 | (define lnum (and line (string->number line))) 49 | (when lnum 50 | (save-current-line! ed) 51 | (ed-goto-line ed (sub1 lnum))) 52 | #f)) 53 | 54 | ;; Goes to the previous saved location 55 | (define-script goto-previous 56 | #:label "Go to previous line number" 57 | #:menu-path ("Bookmarks") 58 | #:shortcut f9 59 | #:shortcut-prefix (ctl shift) 60 | #:persistent 61 | (λ (str #:editor ed) 62 | (define ln (pop-saved-line! ed)) 63 | (when ln 64 | (ed-goto-line ed ln)) 65 | #f)) 66 | 67 | ;; Shows the list of bookmarks 68 | (define-script bookmarks 69 | #:label "Bookmarks" 70 | #:menu-path ("Bookmarks") 71 | #:shortcut f9 72 | #:shortcut-prefix () 73 | #:persistent 74 | (λ (str #:definitions ed) 75 | (bookmark-frame (get-marks ed) ed) 76 | #f)) 77 | 78 | (define (get-marks ed) 79 | (define txt (send ed get-text)) 80 | (filter values 81 | (for/list ([line (in-lines (open-input-string txt))] 82 | [i (in-naturals)]) 83 | ; To be usable with section headers: 84 | (define m (or (regexp-match #px";(?:@@*|==*|::*)\\s*(.*[\\w-].*?)[@=:;]*" line) 85 | (regexp-match #px"#:title \"(.*)\"" line))) ; for slideshow 86 | (and m (list i (second m)))))) 87 | 88 | ;; Adds a bookmark on the current line 89 | (define-script add-bookmark 90 | #:label "Add bookmark" 91 | #:menu-path ("Bookmarks") 92 | #:shortcut f9 93 | #:shortcut-prefix (ctl) 94 | (λ (str) 95 | (string-append ";@@ " (if (string=? str "") 96 | (format "bookmark name") 97 | str)))) 98 | 99 | ;@@ Here and now 100 | 101 | 102 | (define (save-current-line! ed) 103 | (define ln (send ed position-paragraph (send ed get-start-position))) 104 | (hash-update! saved-lines ed (λ (l) (cons ln l)) '())) 105 | 106 | (define (pop-saved-line! ed) 107 | (define lines (hash-ref! saved-lines ed '())) 108 | (if (empty? lines) 109 | #f 110 | (begin0 (first lines) 111 | (hash-set! saved-lines ed (rest lines))))) 112 | 113 | (define (ed-goto-line ed ln) 114 | (define l-start (box #f)) 115 | (define l-end (box #f)) 116 | (send ed get-visible-line-range l-start l-end) 117 | (send ed set-position (send ed paragraph-start-position ln)) 118 | (send ed scroll-to-position (send ed paragraph-start-position (- ln 5))) 119 | (send ed scroll-to-position (send ed paragraph-start-position 120 | (+ ln (- (unbox l-end) (unbox l-start) 5))))) 121 | 122 | (define (bookmark-frame marks ed) 123 | (define topwin (send ed get-top-level-window)) 124 | (define slbf 125 | (new search-list-box-frame% [parent topwin] 126 | [label "Bookmarks"] 127 | [contents (get-marks ed)] ; (list-of (list/c line-num label)) 128 | [key second] 129 | [filter word-filter] 130 | [callback (λ (idx label content) 131 | (save-current-line! ed) 132 | (ed-goto-line ed (first content)) 133 | (when (send cb get-value) 134 | (send slbf show #f)))] 135 | [show? #f])) 136 | (define cb (new check-box% [parent slbf] [label "Close on select?"] [value #t])) 137 | (send slbf center) 138 | (send slbf show #t)) 139 | -------------------------------------------------------------------------------- /scribblings/quickscript-extra.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @(require racket/runtime-path 3 | racket/dict 4 | racket/path 5 | racket/match 6 | quickscript/base) 7 | 8 | @(define-runtime-path scripts-path "../scripts") 9 | 10 | @;; If calling this function is slow, compile the scripts first. 11 | @(define (get-script-help-strings scripts-path) 12 | (filter 13 | values 14 | (for/list ([filename (in-list (directory-list scripts-path #:build? #f))]) 15 | (define filepath (build-path scripts-path filename)) 16 | (and (script-file? filepath) 17 | (cons (path->string (path-replace-extension filename #"")) 18 | (get-script-help-string filepath)))))) 19 | @(define help-strings (get-script-help-strings scripts-path)) 20 | 21 | 22 | @title{Quickscript Extra} 23 | 24 | Some scripts for @(hyperlink "https://github.com/Metaxal/quickscript" "Quickscript"). 25 | 26 | @section{Installation} 27 | 28 | In DrRacket, in @tt{File|Package manager|Source}, enter @tt{quickscript-extra}. 29 | 30 | Or, on the command line, type: @tt{raco pkg install quickscript-extra}. 31 | 32 | If DrRacket is already running, click on @tt{Scripts|Manage scripts|Compile scripts and reload menu}. 33 | 34 | @section{Scripts} 35 | 36 | 37 | @(itemlist 38 | (for/list ([(name str) (in-dict help-strings)]) 39 | (item (index name @(bold name)) ": " 40 | (let loop ([str str]) 41 | (match str 42 | ;; link 43 | [(regexp #px"^(.*)\\[([^]]+)\\]\\(([^)]+)\\)(.*)$" (list _ pre txt link post)) 44 | (list (loop pre) 45 | (hyperlink link txt) 46 | (loop post))] 47 | [else str]))))) 48 | 49 | @section{url2script} 50 | 51 | The @tt{url2script} script is special: it allows you to easily fetch single-file quickscripts from 52 | anywhere on the internet by providing the url to the raw code. 53 | It is actually a little smarter than that because it understands non-raw urls from 54 | @hyperlink["https://gist.github.com"]{github gists}, 55 | @hyperlink["https://gitlab.com/snippets"]{gitlab snippets}, 56 | @hyperlink["https://pastebin.com"]{pastebin} and 57 | @hyperlink["http://pasterack.org"]{pasterack}. 58 | 59 | Some single-file scripts can be found on the 60 | @hyperlink["https://github.com/racket/racket/wiki/Quickscript-Scripts-for-DrRacket"]{Racket wiki}. 61 | 62 | A script previously fetched with url2script can also be easily updated by first opening it via 63 | @tt{Scrits|Manage|Open script…} then clicking on @tt{Scripts|url2script|Update current script}. 64 | 65 | When a script is fetched by @tt{url2script}, a @racketid{url2script-info} submodule is 66 | automatically added (unless one already exists) with information about the filename in which the 67 | script is to be saved (or has been saved), and the original url of the script. 68 | The latter is used for updating the script as described above. 69 | The submodule looks like this: 70 | @racketblock[ 71 | (module url2script-info racket/base 72 | (provide url filename) 73 | (define filename "the-default-filename-to-save-the-script.rkt") 74 | (define url "https://url.of.the/script.rkt")) 75 | ] 76 | If you want to publish a single-file quickscript without making a package, consider adding this 77 | submodule so as to provide a default filename (otherwise the user who fetches your script will have to 78 | type one themselves, and may be unsure what name to pick). 79 | 80 | Also consider adding a permissive license. We recommend a dual license Apache 2.0 / MIT: 81 | @racketblock[ 82 | #,(elem ";;; Copyright ") 83 | #,(elem ";;; License: [Apache License, Version 2.0](http://www.apache.org/licenses/LICENSE-2.0) or") 84 | #,(elem ";;; [MIT license](http://opensource.org/licenses/MIT) at your option.") 85 | ] 86 | 87 | Scripts fetched by @tt{url2script} are added to the default script directory. 88 | They can be modified as desired (as long as the license permits it) 89 | 90 | @section{Customizing} 91 | 92 | Scripts can be selectively deactivated from the library 93 | (@tt{Scripts|Manage scripts|Library}). 94 | 95 | If you change the source code of a script installed from the @tt{quickscript-extra} package 96 | (or from any package containing quickscripts), you will lose all your modifications when the package 97 | is updated. 98 | To avoid this, you can use Quickscript's 99 | @hyperlink["https://docs.racket-lang.org/quickscript/index.html?q=quickscripts#%28part._.Shadow_scripts%29"]{shadow scripts}: 100 | The shadow script calls the original script without modifying it, and can be modified to your taste 101 | without being modified when the original script is updated. 102 | 103 | In particular, if you want to change the default label, menu path or keybinding of a script installed 104 | from @tt{quickscript-extra}, go to @tt{Scripts|Manage|Library…}, select the @tt{quickscript-extra} 105 | directory, then the script you want, and click on @tt{Shadow}. 106 | This opens a new (shadow) script that calls the original script where you can change what you want. 107 | 108 | Note that the shadowed script is deactivated so as to avoid duplicate menu entries and keybindings. 109 | -------------------------------------------------------------------------------- /scripts/indent-table.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require (only-in srfi/13 string-pad-right) 3 | racket/gui/base 4 | quickscript) 5 | 6 | (provide indent-table*) 7 | 8 | (script-help-string "Indent rows on double-space-separated columns 9 | [video](https://www.youtube.com/watch?v=KJjVREsgnvA)") 10 | 11 | #| 12 | Laurent Orseau -- 2012-04-19 13 | 14 | This script indents elements as in a left-aligned table. 15 | Left indentation is preserved. 16 | The column separator is the double-space (in fact a space longer than 1). 17 | 18 | For example (note the double-spaces): 19 | 20 | (let ([some-value '(some list of things)] 21 | [some-othe-value 2] 22 | [finally-some-value-again '(a list of items)]) 23 | 24 | Select the 3 lines, and apply the script. 25 | This will reformat as follows: 26 | 27 | (let ([some-value '(some list of things)] 28 | [some-othe-value 2] 29 | [finally-some-value-again '(a list of items)]) 30 | 31 | In case the number of columns does not match on each line, 32 | empty columns are added at the end of the shortest rows. 33 | 34 | |# 35 | 36 | (define (indent-table* str 37 | #:sep [sep " "] ; default separator: double space, which is innocuous for code (except python-like code) 38 | #:new-sep [new-sep sep]) 39 | ; split in lines, but don't remove empty lines: 40 | (define lines 41 | #;(regexp-split "\n" str) 42 | (string-split str "\n" #:trim? #f)) 43 | ;(pretty-write lines) 44 | (define px-splitter 45 | (pregexp (string-append " *" (regexp-quote sep) " *"))) 46 | ; split in columns, after removing all leading and trailing spaces: 47 | ; lens are the maximum lengths of the columns 48 | (define-values (llines2 lens) 49 | (for/fold ([llines2 '()] 50 | [rev-lens '()] 51 | #:result (values (reverse llines2) (reverse rev-lens))) 52 | ([l (in-list lines)]) 53 | (define items (regexp-split px-splitter (string-trim l))) 54 | (if (equal? items '("")) 55 | ; Whitespace line, return an empty line 56 | (values (cons '() llines2) rev-lens) 57 | ; Re-prepend the leading spaces to the first item to preserve indentation. 58 | ; items cannot be empty. 59 | (let ([items (cons (string-append (first (regexp-match #px"^ *" l)) (first items)) 60 | (rest items))]) 61 | #;(pretty-print items) 62 | 63 | (define diff-n-items (- (length items) (length rev-lens))) 64 | (define new-rev-lens 65 | (map max 66 | (append (make-list (max 0 diff-n-items) 0) 67 | rev-lens) 68 | (append (make-list (max 0 (- diff-n-items)) 0) 69 | (reverse (map string-length items))))) 70 | (values (cons items llines2) 71 | new-rev-lens))))) 72 | 73 | (string-join 74 | (for/list ([items (in-list llines2)]) 75 | (string-trim 76 | (string-join 77 | (for/list ([item (in-list items)] 78 | [len (in-list lens)]) 79 | (string-pad-right item len)) 80 | new-sep) 81 | #:left? #f)) 82 | "\n")) 83 | 84 | (define-script indent-table 85 | #:label "Table indent (on double spaces)" 86 | #:menu-path ("Sele&ction") 87 | #:shortcut #\I 88 | #:shortcut-prefix (ctl shift) 89 | (λ (str) 90 | (indent-table* str))) 91 | 92 | (define-script indent-table/gui 93 | #:label "Table indent… (&gui)" 94 | #:menu-path ("Sele&ction") 95 | (λ (str) 96 | (define sep (get-text-from-user "Table Indent" "Separator:")) 97 | (when (and sep (non-empty-string? sep)) 98 | (indent-table* str #:sep sep)))) 99 | 100 | 101 | (module+ drracket 102 | (define table1 103 | " 104 | a b c 105 | aa bb cc dd ee 106 | 107 | aaaa bbb ccccc dddd 108 | x y z 109 | ") 110 | (define table2 111 | "(let ([xxx (make me a sandwich)] 112 | [yy (make me an apple-pie)] 113 | [zzzzz 43])") 114 | (define table3 115 | "(define something 5) 116 | (define some-other-thing '(let me know)) 117 | ") 118 | (display (indent-table* table1)) 119 | (newline) 120 | (display (indent-table* table2)) 121 | (displayln " ; THIS SHOULD NOT BE ON ITS OWN LINE") 122 | (newline) 123 | (display (indent-table* table3)) 124 | (newline) 125 | (define table1b (indent-table* table1 #:new-sep " & ")) 126 | (displayln table1b) 127 | (newline) 128 | (displayln (indent-table* table1b #:sep "&" #:new-sep "|")) 129 | ) 130 | 131 | (module+ test 132 | (require rackunit) 133 | (let () 134 | (define from "\ 135 | (define immutable-string (string->immutable-string string)) 136 | (define start (string-replacement-start replacement)) 137 | (define end (string-replacement-original-end replacement)) 138 | (define new-end (string-replacement-new-end replacement)) 139 | (define contents (string-replacement-contents replacement)) 140 | (define required-length (string-replacement-required-length replacement)) 141 | (define original-length (string-length immutable-string)) 142 | ") 143 | (define to "\ 144 | (define immutable-string (string->immutable-string string)) 145 | (define start (string-replacement-start replacement)) 146 | (define end (string-replacement-original-end replacement)) 147 | (define new-end (string-replacement-new-end replacement)) 148 | (define contents (string-replacement-contents replacement)) 149 | (define required-length (string-replacement-required-length replacement)) 150 | (define original-length (string-length immutable-string)) 151 | ") 152 | (define str2 (indent-table* from #:sep " (")) 153 | (define str3 (indent-table* str2 #:sep " rep")) 154 | 155 | #;(displayln str3) 156 | (check-equal? str3 to)) 157 | 158 | (let () 159 | (define from "\ 160 | [union-into-string-replacement (reducer/c string-replacement? string-replacement?)] 161 | [string-replacement-render (-> string-replacement? string? immutable-string?)] 162 | [string-apply-replacement (-> string? string-replacement? immutable-string?)] 163 | [file-apply-string-replacement! (-> path-string? string-replacement? void?)] 164 | [inserted-string? predicate/c] 165 | [inserted-string (-> string? inserted-string?)] 166 | [inserted-string-contents (-> inserted-string? immutable-string?)] 167 | [copied-string? predicate/c] 168 | ") 169 | (define to 170 | "\ 171 | [union-into-string-replacement (reducer/c string-replacement? string-replacement?)] 172 | [string-replacement-render (-> string-replacement? string? immutable-string?)] 173 | [string-apply-replacement (-> string? string-replacement? immutable-string?)] 174 | [file-apply-string-replacement! (-> path-string? string-replacement? void?)] 175 | [inserted-string? predicate/c] 176 | [inserted-string (-> string? inserted-string?)] 177 | [inserted-string-contents (-> inserted-string? immutable-string?)] 178 | [copied-string? predicate/c] 179 | ") 180 | (define str2 (indent-table* from #:sep " ")) 181 | #;(displayln str2) 182 | (check-equal? str2 to)) 183 | 184 | 185 | ) 186 | 187 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Quickscript Extra 2 | 3 | Some scripts for [Quickscript](https://github.com/Metaxal/quickscript). 4 | 5 | ## 1. Installation 6 | 7 | In DrRacket, in `File|Package manager|Source`, enter 8 | `quickscript-extra`. 9 | 10 | Or, on the command line, type: `raco pkg install quickscript-extra`. 11 | 12 | If DrRacket is already running, click on `Scripts|Manage scripts|Compile 13 | scripts and reload menu`. 14 | 15 | ## 2. Scripts 16 | 17 | * **abstract-variable**: Create a variable from the selected expression 18 | [video](https://www.youtube.com/watch?v=qgjAZd4eBBY) 19 | 20 | * **add-menu**: \(Example\) Shows how to dynamically add a menu to 21 | DrRacket. 22 | 23 | * **all-tabs**: Have a menu that displays all open tabs in DrRacket. 24 | 25 | * **author-date**: Insert text snippets with author, date, time, and 26 | licence. 27 | 28 | * **backup-file**: Copies the current file in the ’backups’ subdirectory 29 | with a time stamp 30 | 31 | * **bookmarks**: Quickly navigate between lines and headlines 32 | 33 | * **color-chooser**: Pick a color in the palette and insert it in 34 | DrRacket’s current file. 35 | 36 | * **color-theme**: Display information about the current color theme. 37 | 38 | * **complete-word**: Word completion from a given user dictionary 39 | 40 | * **current-file-example**: \(Example\) Displays the current file and 41 | the current selected string in a message box. 42 | 43 | * **def-signatures**: Displays the signature of the procedure under the 44 | cursor (like DrRacket’s blue box but works also when the file does not 45 | compile). 46 | 47 | * **dynamic-abbrev**: Cyclic word completion using the words of the 48 | current file. 49 | 50 | * **enter-submod**: Easily enter a submodule (main, test, drracket, 51 | etc.) in the interaction window. 52 | 53 | * **extract-function**: Extracts a block of code out of its context and 54 | generates a function and a call 55 | [video](https://www.youtube.com/watch?v=XinMxDLZ7Zw) 56 | 57 | * **filepath-to-clipboard**: Write the path of the current file in the 58 | clipboard. 59 | 60 | * **git**: Some git commands (linux only). Currently meant as a demo. 61 | 62 | * **goto-line**: Jump to a given line number in the current editor. 63 | 64 | * **gui-tools**: Code snippets for racket/gui widgets. Meant as a demo. 65 | 66 | * **indent-table**: Indent rows on double-space-separated columns 67 | [video](https://www.youtube.com/watch?v=KJjVREsgnvA) 68 | 69 | * **insert-pict**: \(Example\) Insert a ‘pict‘ at the current position. 70 | 71 | * **number-tabs**: \(Example\) displays the number of opened tabs in a 72 | message box. 73 | 74 | * **open-collect-file**: Open a file in DrRacket, starting in racket’s 75 | collections base path. 76 | 77 | * **open-dir**: Open the system’s file browser in the current directory. 78 | 79 | * **open-terminal**: Open a terminal in the directory of the current 80 | file. 81 | 82 | * **pasterack**: Opens Pasterack in the browser. 83 | 84 | * **persistent-counter**: \(Example\) Shows how the ‘\#:persistent‘ 85 | property works. 86 | 87 | * **provided-by**: Displays a list of modules that ‘provide‘ the 88 | procedure under the cursor. 89 | 90 | * **regexp-replace**: Replace patterns in the selected text using 91 | regular expressions. 92 | 93 | * **reorder-tabs**: \(Example\) Move DrRacket’s tabs around. 94 | 95 | * **reverse-selection**: \(Example\) The simplest script example: 96 | reverse the selected string. 97 | 98 | * **sections**: Surrounds the selected text by comments ASCII frames. 99 | 100 | * **sort-lines**: Sorts the selected lines in (anti-)alphabetical order. 101 | 102 | * **surround-selection**: \(Example\) Surround the selected text with 103 | various characters. 104 | 105 | * **tweet**: \(Example\) Tweet the current selection. See the script 106 | file for configuration details. 107 | 108 | * **url2script**: Fetches a quickscript at a given url and adds it to 109 | the library. 110 | 111 | ## 3. url2script 112 | 113 | The `url2script` script is special: it allows you to easily fetch 114 | single-file quickscripts from anywhere on the internet by providing the 115 | url to the raw code. It is actually a little smarter than that because 116 | it understands non-raw urls from [github 117 | gists](https://gist.github.com), [gitlab 118 | snippets](https://gitlab.com/snippets), [pastebin](https://pastebin.com) 119 | and [pasterack](http://pasterack.org). 120 | 121 | Some single-file scripts can be found on the [Racket 122 | wiki](https://github.com/racket/racket/wiki/Quickscript-Scripts-for-DrRacket). 123 | 124 | A script previously fetched with url2script can also be easily updated 125 | by first opening it via `Scrits|Manage|Open script…` then clicking on 126 | `Scripts|url2script|Update current script`. 127 | 128 | When a script is fetched by `url2script`, a `"url2script-info"` 129 | submodule is automatically added (unless one already exists) with 130 | information about the filename in which the script is to be saved (or 131 | has been saved), and the original url of the script. The latter is used 132 | for updating the script as described above. The submodule looks like 133 | this: 134 | 135 | ```racket 136 | (module url2script-info racket/base 137 | (provide url filename) 138 | (define filename "the-default-filename-to-save-the-script.rkt") 139 | (define url "https://url.of.the/script.rkt")) 140 | ``` 141 | 142 | If you want to publish a single-file quickscript without making a 143 | package, consider adding this submodule so as to provide a default 144 | filename (otherwise the user who fetches your script will have to type 145 | one themselves, and may be unsure what name to pick). 146 | 147 | Also consider adding a permissive license. We recommend a dual license 148 | Apache 2.0 / MIT: 149 | 150 | ```racket 151 | ;;; Copyright 152 | ;;; License: [Apache License, Version 2.0](http://www.apache.org/licenses/LICENSE-2.0) or 153 | ;;; [MIT license](http://opensource.org/licenses/MIT) at your option. 154 | ``` 155 | 156 | Scripts fetched by `url2script` are added to the default script 157 | directory. They can be modified as desired (as long as the license 158 | permits it) 159 | 160 | ## 4. Customizing 161 | 162 | Scripts can be selectively deactivated from the library 163 | \(`Scripts|Manage scripts|Library`). 164 | 165 | If you change the source code of a script installed from the 166 | `quickscript-extra` package \(or from any package containing 167 | quickscripts\), you will lose all your modifications when the package is 168 | updated. To avoid this, you can use Quickscript’s [shadow 169 | scripts](https://docs.racket-lang.org/quickscript/index.html?q=quickscripts#%28part._.Shadow_scripts%29): 170 | The shadow script calls the original script without modifying it, and 171 | can be modified to your taste without being modified when the original 172 | script is updated. 173 | 174 | In particular, if you want to change the default label, menu path or 175 | keybinding of a script installed from `quickscript-extra`, go to 176 | `Scripts|Manage|Library…`, select the `quickscript-extra` directory, 177 | then the script you want, and click on `Shadow`. This opens a new 178 | (shadow) script that calls the original script where you can change what 179 | you want. 180 | 181 | Note that the shadowed script is deactivated so as to avoid duplicate 182 | menu entries and keybindings. 183 | -------------------------------------------------------------------------------- /scripts/url2script.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;;; License: [Apache License, Version 2.0](http://www.apache.org/licenses/LICENSE-2.0) or 4 | ;;; [MIT license](http://opensource.org/licenses/MIT) at your option. 5 | 6 | (require quickscript 7 | quickscript/base 8 | quickscript/utils 9 | racket/class 10 | racket/file 11 | racket/match 12 | racket/port 13 | racket/path 14 | racket/string 15 | racket/gui/base 16 | net/url 17 | browser/external) 18 | 19 | (script-help-string "Fetches a quickscript at a given url and adds it to the library.") 20 | 21 | (define dir user-script-dir) 22 | 23 | (define url2script-submod-name 'url2script-info) 24 | 25 | (define (parse-url str) 26 | ; Do not keep trailing anchors 27 | (set! str (regexp-replace #px"[#?].*" str "")) 28 | (match str 29 | ; We can extract the filename 30 | ; "https://gist.githubusercontent.com/Metaxal/4449e/raw/342e26/letterfall.rkt" 31 | [(regexp #px"^https://gist\\.github(?:usercontent|)\\.com/[^/]+/[0-9a-f]+/raw/[0-9a-f]+/([^/]+)$" 32 | (list _ filename)) 33 | (values str filename)] 34 | ; "https://gist.githubusercontent.com/Metaxal/4449e059959da9f344f83c7e628ad9af/raw" 35 | ; "https://pastebin.com/raw/EMfcc5zs" 36 | [(or (regexp #px"^https://gist\\.github(?:usercontent|).com/[^/]+/[0-9a-f]+/raw$") 37 | (regexp #px"^https://gitlab\\.com/snippets/[0-9]+/raw$") 38 | (regexp #px"^http://pasterack\\.org/pastes/[0-9]+/raw$") 39 | (regexp #px"^https://pastebin.com/raw/[0-9a-zA-Z]+$")) 40 | (values str #f)] 41 | ; "https://gist.githubusercontent.com/Metaxal/4449e059959da9f344f83c7e628ad9af" 42 | ; "https://gitlab.com/snippets/1997854" 43 | ; "http://pasterack.org/pastes/8953" 44 | [(or (regexp #px"^https://gist\\.github(?:usercontent|)\\.com/[^/]+/[0-9a-f]+$") 45 | (regexp #px"^https://gitlab\\.com/snippets/[0-9]+$") 46 | (regexp #px"^http://pasterack\\.org/pastes/[0-9]+$")) 47 | (values (string-append str "/raw") #f)] 48 | ; "https://pastebin.com/EMfcc5zs" 49 | [(regexp #px"^https://pastebin.com/([0-9a-zA-Z]+)$" (list _ name)) 50 | (values (string-append "https://pastebin.com/raw/" name) #f)] 51 | ; Any other kind of url, we assume a link to a raw file 52 | [else (values str #f)])) 53 | 54 | ;; TODO: check it is indeed a (valid?) quickscript 55 | ;; TODO: get-pure-port also handles files. This could be useful. 56 | ;; To prevent CDN caching, add "?cachebust=" at the end of the url 57 | ;; (or "&cachebust=..."), just to make sure the url is different. 58 | (define (get-text-at-url aurl) 59 | (port->string (get-pure-port (string->url aurl) 60 | #:redirections 10) 61 | #:close? #t)) 62 | 63 | ;; Notice: Does not ask to replace (should be done prior). 64 | ;; Doesn't add a submodule if one already exists. 65 | ;; Allows the designer to give the default file name to save the script. 66 | (define (write-script fout text aurl #:filename [filename (file-name-from-path fout)]) 67 | 68 | (display-to-file text fout #:exists 'replace) 69 | 70 | (unless (has-submod? fout) 71 | (display-to-file 72 | #:exists 'append 73 | (string-append 74 | "\n" 75 | "(module " (symbol->string url2script-submod-name) " racket/base\n" 76 | " (provide filename url)\n" 77 | " (define filename " (format "~s" (and filename (path->string filename))) ")\n" 78 | " (define url " (format "~s" aurl) "))\n") 79 | fout))) 80 | 81 | ;; Don't allow file or network access in the url2script submodule, 82 | ;; in particular because this module is `require`d right after downloading, 83 | ;; before the user has a chance to look at the file. 84 | ;; This prevents write and execute access, including calls to `system` and 85 | ;; `process` and friends. 86 | (define dynreq-security-guard 87 | (make-security-guard (current-security-guard) 88 | (λ (sym pth access) 89 | (unless (or (equal? access '(exists)) 90 | (equal? access '(read))) 91 | (error (format "File access disabled ~a" (list sym pth access))))) 92 | (λ _ (error "Network access disabled")))) 93 | 94 | ;; Get information from the url2script submodule. 95 | (define (get-submod f sym [fail-thunk (λ () #f)]) 96 | (parameterize ([current-security-guard dynreq-security-guard] 97 | [current-namespace (make-base-empty-namespace)] 98 | [current-environment-variables 99 | ; prevent writing to (actual) environment variables 100 | (environment-variables-copy (current-environment-variables))]) 101 | (dynamic-require `(submod (file ,(path->string f)) ,url2script-submod-name) 102 | sym 103 | fail-thunk))) 104 | 105 | ;; Does the file contain a url2script submodule? 106 | (define (has-submod? f) 107 | (with-handlers ([(λ (e) (and (exn:fail? e) 108 | (string-prefix? (exn-message e) "instantiate: unknown module"))) 109 | (λ (e) #f)]) 110 | (get-submod f (void)) 111 | #t)) 112 | 113 | ;====================; 114 | ;=== Quickscripts ===; 115 | ;====================; 116 | 117 | (define-script url2script 118 | #:label "Fetch script…" 119 | #:help-string "Asks for a URL and fetches the script" 120 | #:menu-path ("url2script") 121 | (λ (selection #:frame frame) 122 | (define str (get-text-from-user 123 | "url2script" 124 | (string-append 125 | "IMPORTANT:\nMake sure you trust the script before clicking on OK, " 126 | "It may run automatically.\n\n" 127 | "Enter a URL to gist, gitlab snippet or pasterack, or to a raw racket file:"))) 128 | (when str 129 | ; At a special commit, with the name at the end, which we could extract. 130 | (define-values (aurl maybe-filename) (parse-url str)) 131 | 132 | (define text (get-text-at-url aurl)) 133 | (define ftmp (make-temporary-file)) 134 | ; Write a first time to maybe-write and read the submod infos 135 | (write-script ftmp text aurl #:filename maybe-filename) 136 | (define filename (get-submod ftmp 'filename)) 137 | 138 | ; Ask the user for a filename and directory. 139 | ; Notice: If the directory is not in the Library's paths, Quickscript may not find the script. 140 | ; TODO: Check that it's in the Library's path and display a warning if not? 141 | (define fout (put-file "url2script: Save script as…" 142 | frame 143 | dir 144 | (or filename ".rkt") 145 | ".rkt" 146 | '() 147 | '(("Racket source" "*.rkt") 148 | ("Any" "*.*")))) 149 | 150 | (when fout 151 | (write-script fout text str) 152 | (smart-open-file frame fout)) 153 | #f))) 154 | 155 | (define-script update-script 156 | #:label "Update current script" 157 | #:help-string "Updates a script that was downloaded with url2script" 158 | #:menu-path ("url2script") 159 | (λ (selection #:file f #:frame drfr) 160 | (when f 161 | (define submod-url (get-submod f 'url)) 162 | 163 | (cond 164 | [submod-url 165 | (define-values (aurl _name) (parse-url submod-url)) 166 | (define text (get-text-at-url aurl)) 167 | (define res 168 | (message-box "Attention" 169 | "This will rewrite the current file. Continue?" 170 | #f 171 | '(ok-cancel caution))) 172 | (when (eq? res 'ok) 173 | (write-script f text aurl) 174 | (when drfr (send drfr revert)))] 175 | [else 176 | (message-box 177 | "Error" 178 | "Unable to find original url. Script may not have been downloaded with url2script." 179 | #f 180 | '(ok stop))])) 181 | #f)) 182 | 183 | (define-script visit-script-at-url 184 | #:label "Visit published script (browser)" 185 | #:menu-path ("url2script") 186 | (λ (selection #:file f) 187 | (when f 188 | (define submod-url (get-submod f 'url)) 189 | 190 | (cond 191 | [submod-url 192 | (send-url submod-url)] 193 | [else 194 | (message-box 195 | "Error" 196 | "Unable to find original url. Script may not have been downloaded with url2script." 197 | #f 198 | '(ok stop))])))) 199 | 200 | (define-script more-scripts 201 | #:label "Get more scripts (browser)" 202 | #:menu-path ("url2script") 203 | #:help-string "Opens the Racket wiki page for DrRacket Quickscript scripts." 204 | (λ (str) 205 | (send-url "https://github.com/racket/racket/wiki/Quickscript-Scripts-for-DrRacket") 206 | #f)) 207 | 208 | ;=============; 209 | ;=== Tests ===; 210 | ;=============; 211 | 212 | (module+ test 213 | (require rackunit) 214 | 215 | (let () 216 | (define f (make-temporary-file)) 217 | (define aurl "https://this.is.your/home/now") 218 | (write-script f "#lang racket/base\n" aurl) 219 | (check-equal? (has-submod? f) #t) 220 | (check-equal? (get-submod f 'url) 221 | aurl) 222 | 223 | (write-to-file '(module mymod racket/base (displayln "yop")) f #:exists 'replace) 224 | (check-equal? (has-submod? f) #f) 225 | ; syntax error 226 | (check-exn exn:fail? (λ () (write-script f "#lang racket/base\nraise-me-well!\n" aurl))) 227 | ) 228 | 229 | (define (test-parse-url url) 230 | (call-with-values (λ () (parse-url url)) list)) 231 | 232 | (check-equal? 233 | (test-parse-url "https://gist.github.com/Metaxal/f5ea8e94b802eac947fe9ea72870624b") 234 | '("https://gist.github.com/Metaxal/f5ea8e94b802eac947fe9ea72870624b/raw" 235 | #f)) 236 | (check-equal? 237 | (test-parse-url "https://gist.github.com/Metaxal/f5ea8e94b802eac947fe9ea72870624b/raw") 238 | '("https://gist.github.com/Metaxal/f5ea8e94b802eac947fe9ea72870624b/raw" 239 | #f)) 240 | 241 | (check-equal? 242 | (test-parse-url "https://gist.githubusercontent.com/Metaxal/4449e/raw/342e/letterfall.rkt") 243 | (list "https://gist.githubusercontent.com/Metaxal/4449e/raw/342e/letterfall.rkt" 244 | "letterfall.rkt")) 245 | 246 | (check-equal? 247 | (test-parse-url "https://gist.github.com/Metaxal/b2f6c446bded83962d3341bb79199734#file-upcase-rkt") 248 | ; Filename is a little annoying to parse 249 | (list "https://gist.github.com/Metaxal/b2f6c446bded83962d3341bb79199734/raw" 250 | #f)) 251 | (check-equal? 252 | (test-parse-url "https://gist.github.com/Metaxal/b2f6c446bded83962d3341bb79199734?path=something") 253 | (list "https://gist.github.com/Metaxal/b2f6c446bded83962d3341bb79199734/raw" 254 | #f)) 255 | 256 | (check-equal? 257 | (test-parse-url "https://pastebin.com/EMfcc5zs") 258 | (list "https://pastebin.com/raw/EMfcc5zs" #f)) 259 | 260 | (check-equal? 261 | (test-parse-url "https://pastebin.com/raw/EMfcc5zs") 262 | (list "https://pastebin.com/raw/EMfcc5zs" #f)) 263 | 264 | (check-equal? 265 | (test-parse-url "http://pasterack.org/pastes/8953") 266 | (list "http://pasterack.org/pastes/8953/raw" #f)) 267 | 268 | (check-equal? 269 | (test-parse-url "http://pasterack.org/pastes/8953/raw") 270 | (list "http://pasterack.org/pastes/8953/raw" #f)) 271 | 272 | (check-equal? 273 | (test-parse-url "https://gitlab.com/snippets/1997854") 274 | (list "https://gitlab.com/snippets/1997854/raw" #f)) 275 | 276 | (check-equal? 277 | (test-parse-url "https://gitlab.com/snippets/1997854/raw") 278 | (list "https://gitlab.com/snippets/1997854/raw" #f)) 279 | 280 | ;; TODO: Check that updating a script where the source does not have a url2script-info 281 | ;; submodule produces a script that still has the submodule 282 | 283 | 284 | ) 285 | -------------------------------------------------------------------------------- /scripts/extract-function.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require quickscript 4 | racket/format 5 | racket/class 6 | racket/path 7 | racket/gui/base) 8 | 9 | (script-help-string 10 | "Extracts a block of code out of its context and generates a function/macro and a call 11 | [video](https://www.youtube.com/watch?v=XinMxDLZ7Zw)") 12 | 13 | ;;;; How to use: 14 | ;;;; . Select a block of code 15 | ;;;; . Click on Scripts | extract-function (Ctrl-Shift-X) 16 | ;;;; . Enter a function name 17 | ;;;; . Move the cursor to the insertion point (don't edit the file!) 18 | ;;;; . Click on Scripts | put-function (Ctrl-Shift-Y) 19 | 20 | ;;;; This scripts aims at transforming the code while retaining its semantics, but 21 | ;;;; this is not perfect. 22 | ;;;; Some caveats: 23 | ;;;; . Don't trust this script too much, obviously. Check that the resulting code 24 | ;;;; suits you. 25 | ;;;; . If check-syntax doesn't have all the information, the resulting code 26 | ;;;; may not be semanticaly equivalent to the original. 27 | ;;;; . True lexical scoping via check-syntax is used for the original code, 28 | ;;;; but only estimated for the code after transformation: An identifier is 29 | ;;;; assumed to be in-scope if it is within the smallest common sexp of 30 | ;;;; its definition (see `smallest-common-scope`). 31 | ;;;; . This means that some identifiers may be considered out-of-scope when 32 | ;;;; they are not. 33 | ;;;; . Mutated variables can lead to inconsistent results, hence a warning 34 | ;;;; message is displayed for such cases. 35 | ;;;; . Currently the call site isn't checked to be in scope of the definition site. 36 | 37 | 38 | ;;; TODO: use `free-vars`: 39 | ;;; https://docs.racket-lang.org/syntax/syntax-helpers.html?q=free-vars#%28mod-path._syntax%2Ffree-vars%29 40 | ;;; This way we may avoid using check-syntax altogether! 41 | 42 | 43 | ;=================================; 44 | ;=== Function extraction tools ===; 45 | ;=================================; 46 | 47 | (require racket/dict 48 | racket/list 49 | racket/match 50 | racket/port 51 | syntax/modread 52 | drracket/check-syntax) 53 | 54 | (module+ test 55 | (require rackunit)) 56 | 57 | (struct scope (start end) 58 | #:transparent 59 | #:mutable) 60 | 61 | (define (scope-span scope) 62 | (- (scope-end scope) 63 | (scope-start scope))) 64 | 65 | ;; If strict is #t, then pos-or-scope must be strictly within scope, and not equal 66 | ;; (useful when scope is for a list and we want to check if something is inside the list, 67 | ;; and not on the opening parenthesis). 68 | (define (in-scope? pos-or-scope scope #:strict? [strict? #f]) 69 | (define start (+ (scope-start scope) (if strict? 1 0))) 70 | (define end (- (scope-end scope) 1)) ; unconditional 71 | (if (scope? pos-or-scope) 72 | (and (<= start (scope-start pos-or-scope) end) 73 | (<= start (- (scope-end pos-or-scope) 1) end)) 74 | (<= start pos-or-scope end))) 75 | 76 | (define (syntax-scope stx) 77 | ;; syncheck's first position is 0 (right before the # of #lang) 78 | ;; but syntax-position starts at 1. 79 | (define start (+ -1 (syntax-position stx))) ; -1 for syncheck 80 | (define span (syntax-span stx)) 81 | (define end (+ start span)) 82 | (scope start end)) 83 | 84 | ;; Symbols with occurrences start pos, end pos and span 85 | (define (id-scopes stx) 86 | (define sym+scopes '()) 87 | (let loop ([stx stx]) 88 | (define x (syntax-e stx)) 89 | (define sc (syntax-scope stx)) 90 | (cond [(list? x) 91 | (for-each loop x)] 92 | [(symbol? x) 93 | (set! sym+scopes (cons (list x sc) sym+scopes))])) ; else nothing 94 | (reverse sym+scopes)) 95 | 96 | ;; Returns a dict of scope -> source-scope 97 | ;; The only function that uses check-syntax (show-content). 98 | ;; We keep the last results to avoid recomputing them, but we don't use a memo hash to avoid 99 | ;; linear increase of memory. 100 | ;; TODO: implement annotation-mixin instead of calling show-content. 101 | (define syntax->source+mutation-dicts 102 | (let ([source-dict #f] 103 | [mutation-dict #f] 104 | [module-stx #f]) 105 | (λ (mod-stx) 106 | (unless (eq? module-stx mod-stx) 107 | (define hsource (make-hash)) 108 | (define hmutation (make-hash)) 109 | (for ([v (in-list (show-content mod-stx))]) 110 | (match v 111 | [(vector 'syncheck:add-arrow/name-dup/pxpy 112 | start-left start-right start-px start-py 113 | end-left end-right end-px end-py 114 | actual? 115 | phase-level 116 | require-arrow 117 | name-dup?) 118 | (define start-scope (scope start-left start-right)) 119 | (hash-set! hsource start-scope start-scope) 120 | (hash-set! hsource (scope end-left end-right) start-scope)] 121 | [(vector 'syncheck:add-mouse-over-status start end "mutated variable") 122 | (hash-set! hmutation (scope start end) #t)] 123 | [else (void)])) 124 | (set! source-dict hsource) 125 | (set! mutation-dict hmutation) 126 | (set! module-stx mod-stx)) 127 | (values source-dict mutation-dict)))) 128 | 129 | ;; Returns two lists: 130 | ;; The list of ids that are bound in from-scope but won't be bound in dest-pos, 131 | ;; and the list of ids outside of from-scope that are defined in from-scope 132 | ;; but will be undefined after moving the code to dest-pos. 133 | ;; Each list is made of an id an whether it is mutated. 134 | (define (unbound-ids mod-stx from-scope dest-pos) 135 | ;; if dest-pos is after the scope of the module, 136 | (set! dest-pos dest-pos) 137 | (define-values (source-dict mutation-dict) 138 | (syntax->source+mutation-dicts mod-stx)) 139 | (define sym+scopes (id-scopes mod-stx)) 140 | (define to-scope (smallest-common-scope mod-stx dest-pos)) 141 | ;; ids in from-scope that will become unbound at dest-pos 142 | (define ins '()) 143 | ;; ids outside of from-scope that will become unbound once 144 | ;; the code is moved to dest-pos 145 | (define outs '()) 146 | (for ([s (in-list sym+scopes)]) 147 | (define sym (first s)) 148 | (define sym-scope (second s)) 149 | (define sym-start (scope-start sym-scope)) 150 | (define src (dict-ref source-dict sym-scope #f)) 151 | (when (and (in-scope? sym-start from-scope) 152 | (and src 153 | (not (in-scope? (scope-start src) from-scope)) 154 | (let ([sym-def-scope (smallest-common-scope mod-stx sym-start (scope-start src))]) 155 | (not (in-scope? dest-pos sym-def-scope #:strict? #t))))) 156 | (define entry (list sym (dict-ref mutation-dict src #f))) 157 | (unless (member entry ins) 158 | (set! ins (cons entry ins)))) 159 | (when (and (not (in-scope? sym-start from-scope)) 160 | (and src 161 | (in-scope? (scope-start src) from-scope))) 162 | (define entry (list sym (dict-ref mutation-dict src #f))) 163 | (unless (member entry outs) 164 | (set! outs (cons entry outs))))) 165 | (values (reverse ins) 166 | (reverse outs))) 167 | 168 | ;; Returns the smallest scope of a list containing all positions of pos-or-scope-list. 169 | ;; If fix is not #f and the smallest common scope is the scope of the module, 170 | ;; then the end of the scope is set to +inf.0, to account for whitespaces at the end 171 | ;; of the file, which position may lie outside the module scope. 172 | (define (smallest-common-scope mod-stx 173 | #:fix-module-scope? [fix? #t] 174 | . pos-or-scope-list) 175 | (unless (syntax? mod-stx) 176 | (raise-argument-error 'smallest-common-scope "syntax?" mod-stx)) 177 | (define module-scope (syntax-scope mod-stx)) 178 | (define res 179 | (let loop ([stx mod-stx]) 180 | (define x (syntax-e stx)) 181 | (define sc (syntax-scope stx)) 182 | (and (list? x) 183 | (andmap (λ (p) (in-scope? p sc)) 184 | pos-or-scope-list) 185 | (or (ormap loop x) 186 | sc)))) 187 | (if (and fix? (or (equal? res module-scope) 188 | (not res))) 189 | (scope (scope-start module-scope) +inf.0) 190 | res)) 191 | 192 | (define (find-sexp stx from-scope) 193 | (let loop ([stx stx]) 194 | (define x (syntax-e stx)) 195 | (define sc (syntax-scope stx)) 196 | (cond [(equal? sc from-scope) 197 | (syntax->datum stx)] 198 | [(list? x) 199 | (ormap loop x)] 200 | [else #f]))) 201 | 202 | ;; TODO: some shadowing cases will not work such as 203 | #;(let ([a 5]) 204 | {+ a 5} 205 | (let ([a 'nowin]) 206 | 'TO)) 207 | 208 | ;; See def of `show-content`. 209 | (define (module-port->syntax port source) 210 | (port-count-lines! port) 211 | (with-module-reading-parameterization 212 | (λ () 213 | (read-syntax source port)))) 214 | 215 | (define (module-file->syntax f) 216 | (call-with-input-file f 217 | (λ (port) 218 | (module-port->syntax port f)))) 219 | 220 | ;; TODO: When require local file "file.rkt", it thinks it's in the wrong dir 221 | (define (module-string->syntax str [source #f]) 222 | (call-with-input-string str 223 | (λ (port) 224 | (module-port->syntax port (or source (build-path (current-directory) "dummy.rkt")))))) 225 | 226 | 227 | ;=============; 228 | ;=== Tests ===; 229 | ;=============; 230 | 231 | 232 | ; The 'position' script helps finding out the positions and scopes (copies into the clipboard, 233 | ; make sure to reload the menu). 234 | #| 235 | #lang racket/base 236 | 237 | (require quickscript 238 | racket/class) 239 | 240 | (define-script position 241 | #:label "position" 242 | #:output-to clipboard 243 | (λ (selection #:editor ed) 244 | (define start (send ed get-start-position)) 245 | (define end (send ed get-end-position)) 246 | (if (= start end) 247 | (format "~a" start) 248 | (format "~a ~a" start end)))) 249 | |# 250 | 251 | (module+ test 252 | (define test-prog 253 | (match-lambda* 254 | [(list txt 255 | (list from-scopes common-from-scopes 256 | dest-posss 257 | expected-inss expected-outss) 258 | ...) 259 | (define stx (module-string->syntax txt)) 260 | (define sym+scopes (id-scopes stx)) 261 | (define-values (source-dict mutation-dict) 262 | (syntax->source+mutation-dicts stx)) 263 | (let ([scopes-from-syncheck (map second sym+scopes)]) 264 | ; This doesn't pass anymore because syncheck now binds arrows 265 | ; to the invisible #%app 266 | #;(for ([(k v) (in-dict source-dict)]) 267 | (check member k scopes-from-syncheck (list k v)) 268 | (check member v scopes-from-syncheck)) 269 | (for ([from-scope (in-list from-scopes)] 270 | [common-from-scope (in-list common-from-scopes)] 271 | [expected-ins (in-list expected-inss)] 272 | [expected-outs (in-list expected-outss)] 273 | [dest-poss (in-list dest-posss)]) 274 | (define info1 275 | (format "from-scope: ~a common-from-scope:~a" 276 | from-scope 277 | common-from-scope)) 278 | (when common-from-scope 279 | (check-equal? (smallest-common-scope stx from-scope) 280 | common-from-scope 281 | info1)) 282 | (for ([dest-pos (in-list dest-poss)]) 283 | (define-values (in-ids out-ids) 284 | (unbound-ids stx from-scope dest-pos)) 285 | (define info2 286 | (format "~a dest-pos: ~a" info1 dest-pos)) 287 | (check-equal? in-ids expected-ins info2) 288 | (check-equal? out-ids expected-outs info2))))])) 289 | 290 | 291 | (test-prog 292 | "#lang racket 293 | 294 | (define a 1) 295 | 296 | (let ([e 4]) 297 | (define b (+ e 1)) 298 | (define c (+ a 3)) 299 | (displayln b) 300 | (define d 4) 301 | (+ b c d)) 302 | 303 | " 304 | (list (scope 41 99) ; from-scope 305 | (scope 28 126) ; common-from-scope 306 | '(13 26 126 128) ; dest-pos 307 | '([e #f]) '([b #f] [c #f])) ; expected-ins expected-outs, #f = not mutated 308 | (list (scope 41 99) 309 | (scope 28 126) 310 | '(28) 311 | '([e #f]) '([b #f] [c #f])) 312 | (list (scope 41 99) 313 | (scope 28 126) 314 | '(40) 315 | '() '([b #f] [c #f]))) 316 | 317 | (test-prog 318 | "#lang racket 319 | 320 | (λ (abc) 321 | (+ abc 3)) 322 | 323 | 324 | 325 | " 326 | (list (scope 25 34) 327 | (scope 25 34) 328 | '(13 35) 329 | '([abc #f]) '())) 330 | 331 | ; Failure case: the mutated variable is moved, changing the semantics of the program. 332 | 333 | (test-prog 334 | "#lang racket 335 | 336 | (let ([a 4]) 337 | (set! a 2) 338 | a) 339 | " 340 | (list (scope 29 39) 341 | (scope 29 39) 342 | '(13) 343 | '([a #t]) '())) 344 | ) 345 | 346 | ;===============; 347 | ;=== Scripts ===; 348 | ;===============; 349 | 350 | ;;; TODO: A script that displays the list of in and out ids for a selected block, 351 | ;;; independently of the dest-pos site? (or dest-pos = module?) 352 | 353 | ;; Returns the call-site and fun-sites strings. 354 | ;; Was created with this very script :) 355 | (define (make-call+fun-sites from-string fun-name in-ids out-ids) 356 | ;; The two common way to select text is either sexp-based or line based. 357 | ;; If the last charater of the selection is a newline (line-based), 358 | ;; put one back in. 359 | (define last-pos (- (string-length from-string) 1)) 360 | (define has-newline? 361 | (eqv? #\newline (string-ref from-string last-pos))) 362 | (when has-newline? 363 | (set! from-string (substring from-string 0 last-pos))) 364 | (define maybe-newline (if has-newline? "\n" "")) 365 | (define header 366 | (string-append "(" (apply ~a fun-name in-ids #:separator " ") ")")) 367 | (define call-site 368 | (cond [(empty? out-ids) (string-append header maybe-newline)] 369 | [(empty? (rest out-ids)) 370 | (string-append "(define " (~a (first out-ids)) 371 | " " header ")" maybe-newline)] 372 | [else 373 | (string-append "(define-values " (~a out-ids) 374 | "\n" header ")" maybe-newline)])) 375 | (define fun1 376 | (string-append "(define " header "\n" 377 | from-string)) 378 | (define fun-site 379 | (cond [(empty? out-ids) 380 | (string-append fun1 ")\n")] 381 | [(empty? (rest out-ids)) 382 | (string-append fun1 "\n" (~a (first out-ids)) ")\n")] 383 | [else 384 | (string-append fun1 "\n(values " (apply ~a #:separator " " out-ids) "))\n")])) 385 | (values call-site fun-site)) 386 | 387 | (define (make-call+syntax-sites from-string stx-name in-ids out-ids) 388 | ;; The two common way to select text is either sexp-based or line based. 389 | ;; If the last charater of the selection is a newline (line-based), 390 | ;; put one back in. 391 | (define last-pos (- (string-length from-string) 1)) 392 | (define has-newline? 393 | (eqv? #\newline (string-ref from-string last-pos))) 394 | (when has-newline? 395 | (set! from-string (substring from-string 0 last-pos))) 396 | (define maybe-newline (if has-newline? "\n" "")) 397 | (define header 398 | (string-append "(" (~a stx-name) " " 399 | (if (empty? in-ids) 400 | "" 401 | (string-append "(" (apply ~a in-ids #:separator " ") ")" 402 | (if (empty? out-ids) "" "\n"))) 403 | (if (empty? out-ids) 404 | "" 405 | (string-append "(" (apply ~a out-ids #:separator " ") ")")) 406 | ")")) 407 | (define call-site (string-append header maybe-newline)) 408 | (define stx-site 409 | (string-append "(define-syntax-rule " header "\n" 410 | "(begin\n" 411 | from-string 412 | "))\n")) ; warning: may be invalid if the last line is a comment 413 | (values call-site stx-site)) 414 | 415 | (define start #f) 416 | (define end #f) 417 | (define fun-name #f) 418 | (define txt-length #f) ; Can we use a string-hash instead? 419 | (define module-stx #f) 420 | (define fil #f) 421 | (define check-syntax-thread #f) 422 | 423 | (define (start-cs-thread fil fr txt) 424 | (set! module-stx #f) 425 | (set! check-syntax-thread 426 | (thread 427 | (λ () 428 | ;; Setting the current-directory to that of f; 429 | ;; ensures that read-syntax and syncheck have access to 430 | ;; local requires. 431 | (parameterize ([current-directory (if fil 432 | (path-only fil) 433 | (current-directory))]) 434 | (define mod-stx 435 | (with-handlers ([exn:fail:read? 436 | (λ (e) 437 | (string-append "Syntax error while reading file: " 438 | (exn-message e)))]) 439 | (module-string->syntax txt fil))) 440 | ; Trigger show-content, which is what takes the most time. 441 | (syntax->source+mutation-dicts mod-stx) 442 | ; When module-stx is set, we are ready. 443 | (set! module-stx mod-stx)))))) 444 | 445 | (define-script extract-function-to-module-level 446 | #:label "Extract function to to&p" 447 | #:menu-path ("Re&factor") 448 | (λ (selection #:file f #:editor ed #:frame fr #:as-syntax? [as-syntax? #f]) 449 | (extract-function selection #:file f #:editor ed #:frame fr) 450 | (define to-pos 451 | ; move up sexp as much as possible 452 | (let loop ([pos (send ed get-start-position)]) 453 | (define next-pos (send ed find-up-sexp pos)) 454 | (if next-pos (loop next-pos) pos))) 455 | (send ed set-position to-pos) 456 | (put-function "" #:file f #:editor ed #:frame fr #:as-syntax? as-syntax?) 457 | (send ed insert "\n"))) 458 | 459 | (define-script extract-syntax-to-module-level 460 | #:label "Extract s&yntax to top" 461 | #:menu-path ("Re&factor") 462 | (λ (selection #:file f #:editor ed #:frame fr) 463 | (extract-function-to-module-level selection #:file f #:editor ed #:frame fr #:as-syntax? #t))) 464 | 465 | (define-script extract-function 466 | #:label "E&xtract function" 467 | #:menu-path ("Re&factor") 468 | #:shortcut #\x 469 | #:shortcut-prefix (ctl shift) 470 | #:persistent 471 | (λ (selection #:file f #:editor ed #:frame fr) 472 | ; Start check-syntax early to be (more) ready on put-function 473 | (define txt (send ed get-text)) 474 | (start-cs-thread f fr txt) 475 | (define name (get-text-from-user "Function name" 476 | "Choose a name for the new function" 477 | fr 478 | "FOO" 479 | '(disallow-invalid) 480 | #:validate (λ (s) (not (regexp-match #px"\\s|^#|\"|'" s))))) 481 | (cond 482 | [name 483 | (set! fun-name name) 484 | (set! start (send ed get-start-position)) 485 | (set! end (send ed get-end-position)) 486 | (set! fil f) 487 | (set! txt-length (string-length txt))] 488 | [else 489 | (kill-thread check-syntax-thread) 490 | (set! check-syntax-thread #f)]) 491 | #f)) 492 | 493 | (define-script put-function 494 | #:label "P&ut function" 495 | #:menu-path ("Re&factor") 496 | #:shortcut #\y 497 | #:shortcut-prefix (ctl shift) 498 | #:persistent 499 | (λ (selection #:file f #:editor ed #:frame fr #:as-syntax? [as-syntax? #f]) 500 | ;; If module-stx, then the thread is irrelevant. 501 | ;; If not, then wait for the thread to produce module-stx. 502 | (when (or module-stx 503 | check-syntax-thread) 504 | (unless module-stx 505 | (thread-wait check-syntax-thread)) 506 | (set! check-syntax-thread #f) 507 | (define txt (send ed get-text)) 508 | (cond 509 | [(not (equal? fil f)) 510 | (message-box "extract-function: File error" 511 | "Cannot extract function to a different file" 512 | fr '(ok stop))] 513 | [(not (= (string-length txt) txt-length)) 514 | (message-box "extract-function: Buffer error" 515 | "Buffer has changed since extract-function" 516 | fr '(ok stop))] 517 | [(string? module-stx) 518 | (message-box "extract-function: Check-syntax error" 519 | module-stx 520 | fr '(ok stop))] 521 | [(not (syntax? module-stx)) 522 | (message-box "extract-function: Error" 523 | (format "Not syntax: ~a" module-stx) 524 | fr '(ok stop))] 525 | [else 526 | ;; Setting the current-directory to that of f 527 | ;; ensures that read-syntax and syncheck have access to 528 | ;; local requires. 529 | (parameterize ([current-directory (if f 530 | (path-only f) 531 | (current-directory))]) 532 | 533 | (define to-pos (send ed get-start-position)) 534 | 535 | ;; TODO: Prevent moving to a place where the definition is unreachable 536 | ;; from the call site. 537 | ;; We could check that the smallest enclosing scope of to-pos 538 | ;; also contains from-scope. 539 | ;; May fail with `begin`, but better to prevent some legal cases than 540 | ;; allow illegal ones? Or give a warning and the option? 541 | 542 | (define from-scope (scope start end)) 543 | 544 | (define-values (in-unbounds out-unbounds) 545 | ; min with module-scope as the whitespaces at the end of the module 546 | ; are considered out of scope otherwise. 547 | (unbound-ids module-stx from-scope to-pos)) 548 | 549 | (define mutated-ids (filter-map (λ (i) (and (second i) (first i))) in-unbounds)) 550 | (define ok-mutation? 551 | (or (empty? mutated-ids) 552 | (eq? 'yes 553 | (message-box "Mutated variable" 554 | (format "The following variables are mutated: 555 | ~a 556 | 557 | This may result in incorrect code. 558 | 559 | Do you want to continue?" 560 | (apply ~a mutated-ids #:separator "\n")) 561 | fr 562 | '(yes-no caution))))) 563 | (when ok-mutation? 564 | 565 | ;; TODO: remove-duplicates is slow, also unbound-ids returns too many things? 566 | (define in-ids (map first in-unbounds)) 567 | (define out-ids (map first out-unbounds)) 568 | 569 | (define from-string (send ed get-text start end)) 570 | (define-values (call-site fun-site) 571 | ((if as-syntax? make-call+syntax-sites make-call+fun-sites) 572 | from-string fun-name in-ids out-ids)) 573 | 574 | (send ed begin-edit-sequence) 575 | (send ed delete start end) 576 | (send ed insert call-site start) 577 | (send ed tabify-selection start (+ start (string-length call-site))) 578 | 579 | (define new-pos (send ed get-start-position)) 580 | (send ed insert fun-site) 581 | (send ed tabify-selection new-pos (+ new-pos (string-length fun-site))) 582 | (send ed end-edit-sequence)))])) 583 | #f)) 584 | 585 | -------------------------------------------------------------------------------- /scripts/def-signatures.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/gui 2 | (require (for-syntax racket/base) 3 | (prefix-in scrbl: scribble/reader) 4 | framework 5 | mrlib/close-icon 6 | quickscript 7 | racket/runtime-path 8 | setup/dirs ; for doc-dir 9 | srfi/13) 10 | 11 | (script-help-string 12 | "Displays the signature of the procedure under the cursor 13 | (like DrRacket's blue box but works also when the file does not compile).") 14 | 15 | ;;; *************************************** ;;; 16 | ;;; *** On-Screen Signature Display *** ;;; 17 | ;;; *************************************** ;;; 18 | 19 | ;;; Laurent Orseau -- 2012-04-26 20 | 21 | #| *** How it works *** 22 | 23 | Like DrRacket blue boxes, but works also when program does not compile. 24 | (Because it does not use lexical information, it is less accurate and can thus display 25 | multiple choices.) 26 | 27 | ** Usage: 28 | 29 | Put the cursor in the middle of a Racket function symbol, and 30 | press the keyboard shortcut for this script, or launch it from the menu. 31 | The signature of the function/form should appear in a frame, if it can find it. 32 | 33 | To hide the frame, press the shortcut again. 34 | 35 | The frame can be moved around by dragging it. 36 | 37 | The default shortcut is suitable for my keyboard, but probably not for yours; 38 | change it as you see fit. 39 | 40 | 41 | ** Notes: 42 | 43 | I could not figure how to use xref, so instead the script parses 44 | the .scrbl files in racket's scribblings directory. 45 | Since this can take a few seconds, the generated dict is saved to a file, 46 | so that the parsing is only done once (if you ever need to force reparsing, 47 | simply remove the file in the script subdirectory, it will regenerate it at the next call). 48 | 49 | The script does not use syntax information, and in particular 50 | from where the bindings are imported. 51 | 52 | Some scrbl files contain a #reader line that breaks `read-inside'. 53 | For such cases, the file is loaded as a string, the offending #reader is removed 54 | and the contents are read from the string again. 55 | In case the file cannot be read anyway, it is skipped. (none as of today) 56 | 57 | Not all definitions are parsed yet (e.g., no parameter), but the number should grow, 58 | and not all information is reported (e.g., no contract for forms yet). 59 | 60 | The code is a mess, and I did not bother much to make it better... 61 | 62 | |# 63 | 64 | 65 | #| TODO: 66 | - the 'function' identifier from 'plot' is not parsed. 67 | - get-text-from-user wrongly parsed for #:validate 68 | - the X button is very large on MacOS X and does not close the frame 69 | - curried procedures are not correctly recognized (e.g., in some framework's rkt files) 70 | - display module of the signature 71 | - use an editor instead of canvas? 72 | - warning: a "signature" seems to have a special meaning in Racket 73 | - instead of showing all definition forms, show only one and allow cycling with shortkey/mouse? 74 | - when a function name is not found, propose a list of similar names (edition distance) 75 | |# 76 | 77 | #| Testing procedure: 78 | 1) Delete the index-defs.rktd file 79 | 2) Restart DrRacket (from console for debugging), type with-output-to-file, and exec the script 80 | The index should be automatically built. 81 | 3) Touch the def-signatures.rktd file, and exec the script. 82 | It should ask for rebuilding the index-file. Say no and exec the script again. 83 | 4) Like 3) but say yes. 84 | 85 | |# 86 | 87 | ;;; Global variables that the user might want to change 88 | 89 | (define debug? #f) 90 | (define (set!-debug? d) 91 | (set! debug? d)) 92 | 93 | (define text-size 94 | ; relative to the user's preferences: 95 | (let ([size (preferences:get 'framework:standard-style-list:font-size)]) 96 | (- (cond [(number? size) size] 97 | [(vector? size) (vector-ref size 1)] 98 | [else 12]) 99 | 2))) 100 | 101 | (define srfi-files 102 | '("srfi-13.html" 103 | "srfi-14.html" 104 | )) 105 | 106 | (define rkt-files 107 | (list 108 | (build-path (collection-path "framework") "main.rkt") 109 | (build-path (collection-path "framework") "preferences.rkt") 110 | )) 111 | 112 | 113 | ;===========================; 114 | ;=== Parsing scribblings ===; 115 | ;===========================; 116 | 117 | ; for format 118 | (print-as-expression #f) 119 | (print-reader-abbreviations #t) 120 | 121 | 122 | (define (scribblings-path subdir) 123 | (collection-path "scribblings" subdir)) 124 | ;(build-path (find-system-path 'collects-dir) 125 | ; "scribblings" subdir)) 126 | 127 | 128 | ;; Returns the s-exp containing all s-exp in the input stream 129 | ;; in: input-stream? 130 | (define (read-scrbl in [file ""]) 131 | (scrbl:read-inside in)) 132 | ;(syntax->datum (scrbl:read-syntax-inside file in))) 133 | 134 | (define (read-rkt file) 135 | (with-input-from-file file 136 | (λ () 137 | (void (read-language)) ; don't care about the #lang line 138 | ; no need to reverse since we don't care about the top level order: 139 | (let loop ([l '()]) 140 | (define s (scrbl:read)) 141 | (if (eof-object? s) 142 | l 143 | (loop (cons s l))))))) 144 | 145 | 146 | (define (add-dict-entry dic key l) 147 | (hash-set! dic key 148 | (cons l (hash-ref dic key '())))) 149 | 150 | (read-accept-lang #t) 151 | (read-accept-reader #t) 152 | 153 | ;; Loads all the defproc forms from a given file into the dictionary. 154 | (define (index-defs dic file) 155 | (when debug? (printf "File ~a\n" file)) 156 | (define all 157 | (with-input-from-file file 158 | (λ () (read-scrbl (current-input-port) file)))) 159 | (parse-list dic all)) 160 | 161 | ;; takes a list of x-exprs, parses it, and add found form to the dictionary 162 | (define (parse-list dic all) 163 | 164 | (define (add-entry key l) 165 | (add-dict-entry dic key l)) 166 | 167 | (define (parse-class class-id subs) 168 | (for ([s subs]) 169 | (match s 170 | [(list-rest 'defconstructor args text) 171 | (add-entry class-id (list 'defconstructor class-id args))] 172 | [(list-rest 'defmethod '#:mode mode (list-rest id args) cont-out text) 173 | (add-entry id (list 'defmethod class-id id args cont-out))] 174 | [(list-rest 'defmethod (list-rest id args) cont-out text) 175 | (add-entry id (list 'defmethod class-id id args cont-out))] 176 | [(list-rest 'defmethod* (list (list (list-rest ids argss) cont-outs) ...) text) 177 | (for ([id ids][args argss][cont-out cont-outs]) 178 | (add-entry id (list 'defmethod class-id id args cont-out)))] 179 | [else #f]))) 180 | 181 | (define (add-doc/names id cont-args args args+vals cont-out) 182 | (add-entry id (list 'defproc id 183 | (map (λ (a c) 184 | (if (and (list? c) (keyword? (first c))) 185 | ; with keyword: 186 | (list* (first c) (first a) 187 | (second c) (rest a)) 188 | (list* (first a) c (rest a)))) 189 | (append (map list args) args+vals) 190 | cont-args) 191 | cont-out))) 192 | 193 | (define parse-cont-args 194 | (match-lambda 195 | [(list-rest (? keyword? k) c r) 196 | (cons (list k c) (parse-cont-args r))] 197 | [(list-rest c r) 198 | (cons c (parse-cont-args r))] 199 | [(list) 200 | '()])) 201 | 202 | (define (parse-doc subs) 203 | (for ([s subs]) 204 | (match s 205 | [(list 'proc-doc/names id 206 | (list '->* cont-args cont-opt-args cont-out) 207 | (list (list args ...) 208 | args+vals) 209 | text) 210 | (add-doc/names id 211 | (append (parse-cont-args cont-args) 212 | (parse-cont-args cont-opt-args)) 213 | args args+vals 214 | cont-out)] 215 | [(list 'proc-doc/names id 216 | (list '-> cont-args ... cont-out) 217 | (list args ...) text) 218 | (add-doc/names id (parse-cont-args cont-args) args '() cont-out)] 219 | [(list 'proc-doc id cont text) 220 | (add-entry id (list 'thing-doc id cont))] 221 | [(list thing-doc id cont text) 222 | (add-entry id (list 'thing-doc id cont))] 223 | [else #f]))) 224 | 225 | ; matches only the "top-level" forms, i.e. does not go into examples, etc. 226 | ; (hopefully there aren't many false positives/negatives) 227 | (define (parse-all subs) 228 | (for ([s subs]) 229 | (match s 230 | [(list-rest 'defproc (list-rest name args) cont-out text) 231 | (add-entry name (list 'defproc name args cont-out))] 232 | [(list-rest 'defproc* (list (list (list-rest names argss) cont-outs) ...) text) 233 | (for ([name names] [args argss] [cont-out cont-outs]) 234 | (add-entry name (list 'defproc name args cont-out)))] 235 | [(list-rest (or 'defclass 'defclass/title) id super intf-ids subs) 236 | (add-entry id (list 'defclass id super intf-ids)) 237 | (parse-class id subs)] 238 | [(list-rest (or 'definterface 'definterface/title) id intf-ids subs) 239 | (add-entry id (list 'definterface id intf-ids)) 240 | (parse-class id subs)] 241 | [(list-rest (or 'defform 'defform/subs) (list-rest id args) text) ; TODO: + contracts & literals + subs 242 | (add-entry id (list 'defform id args))] 243 | [(list-rest (or 'defform* 'defform*/subs) (list (list-rest ids argss) ...) text) 244 | (for ([id ids][args argss]) 245 | (add-entry id (list 'defform id args)))] 246 | [(list-rest 'deftogether subs text) 247 | (parse-all subs)] 248 | [(list-rest 'provide/doc subs) 249 | (parse-doc subs)] 250 | ; provide/doc has been changed to just 'provide recently: 251 | ; http://lists.racket-lang.org/dev/archive/2012-May/009500.html 252 | ; (this might make the parsing significantly longer...) 253 | ; (unless I specifically tell which files do that?) 254 | ; (looks ok though) 255 | [(list-rest 'provide subs) 256 | (parse-doc subs)] 257 | [else #f] 258 | ))) 259 | 260 | (parse-all all) 261 | ) 262 | 263 | (define replace-dict 264 | '((" " . " ") 265 | (">" . ">") 266 | ("<" . "<") 267 | ("&" . "&") 268 | ("" . "") 269 | ("" . "") 270 | )) 271 | 272 | (define (html-string->string str) 273 | (for/fold ([str str]) ([(k v) (in-dict replace-dict)]) 274 | (regexp-replace* (regexp-quote k) str (regexp-replace-quote v)))) 275 | 276 | (define (parse-srfi-file dic file) 277 | (define lines (file->lines file)) 278 | (for ([line lines]) 279 | (define l (regexp-match 280 | (pregexp 281 | (string-append 282 | "" 283 | "([^" (regexp-quote "([{}])\"'") "]*)" 284 | ;"(.*)" 285 | "\\s*" 286 | "(.*)" 287 | ;"(.*)" 288 | "")) 289 | line)) 290 | (when l 291 | (let ([id-str (string-trim-both (html-string->string (second l)))]) 292 | (add-dict-entry 293 | dic 294 | (string->symbol id-str) 295 | (list 'srfi id-str (string-trim-both (html-string->string (third l))))))))) 296 | 297 | ;==========================; 298 | ;=== Creating the Index ===; 299 | ;==========================; 300 | 301 | ;; Displays a message in a (non-modal) frame. 302 | (define (frame-message title message [show? #f] #:parent [parent #f]) 303 | (define fr (new frame% [parent parent] [label title])) 304 | (new message% [parent fr] [label message]) 305 | (when show? (send fr show #t)) 306 | fr) 307 | 308 | (define-runtime-path idx-file (build-path "def-index" "def-index.rktd")) 309 | (make-directory* (path-only idx-file)) 310 | 311 | (define-syntax-rule (with-parse-handler file body ...) 312 | (with-handlers ([exn:fail? (λ _ (when debug? 313 | (printf "Warning: Could not parse file ~a~n" file)))]) 314 | body ...)) 315 | 316 | ;(define-runtime-path this-file "def-signatures.rkt") 317 | (define-syntax (this-file stx) 318 | (with-syntax ([file (syntax-source stx)]) 319 | #'file)) 320 | 321 | ;; Constructs the index file if it does not exist, or load it, 322 | ;; and returns the generated index: 323 | (define (create-index) 324 | 325 | (when (file-exists? idx-file) 326 | (if (and 327 | (> (file-or-directory-modify-seconds (this-file)) 328 | (file-or-directory-modify-seconds idx-file)) 329 | (eq? 'yes 330 | (message-box "Recreate doc" 331 | "Script def-signatures: 332 | The documentation index looks older than the script file. 333 | Do you want to recreate the index?" 334 | #f '(caution yes-no)))) 335 | (delete-file idx-file) 336 | ; else touch the file to avoid asking the question again: 337 | (file-or-directory-modify-seconds idx-file (current-seconds)) 338 | )) 339 | 340 | (if (file-exists? idx-file) 341 | (with-input-from-file idx-file read) 342 | (let* ([dic (make-hash)] 343 | [fr (frame-message "Making index" "Constructing documentation index for the first time.\nPlease wait..." #t)] 344 | [read-scrbl-dir 345 | (λ (dir) 346 | (when (directory-exists? dir) 347 | (for ([f (in-directory dir)]) 348 | (when (equal? (filename-extension f) #"scrbl") 349 | (with-parse-handler f 350 | (index-defs dic f) 351 | )))))]) 352 | 353 | ; read all scrbl files in all collections: 354 | (for-each read-scrbl-dir 355 | (list (find-collects-dir) 356 | (find-user-collects-dir) 357 | (find-pkgs-dir) 358 | (find-user-pkgs-dir))) 359 | 360 | (for ([f rkt-files]) 361 | (with-parse-handler f 362 | (parse-list dic (read-rkt f)))) 363 | 364 | ; constructing index for srfi files: 365 | (for ([f srfi-files]) 366 | (let ([f (build-path (find-doc-dir) "srfi-std" f)]) 367 | (with-parse-handler f 368 | (parse-srfi-file dic f)))) 369 | 370 | (when debug? (printf "~a identifiers found\n" (dict-count dic))) 371 | 372 | ; write the generated dict to a file for speed up on next loadings: 373 | (with-output-to-file idx-file 374 | (λ () (write dic))) 375 | 376 | (send fr show #f) 377 | dic))) 378 | 379 | ;=====================================; 380 | ;=== Formatting entries as strings ===; 381 | ;=====================================; 382 | 383 | ;; Helpers for def-name->string-list 384 | (define (arg->head-string arg) 385 | (match arg 386 | [(list name cont) (symbol->string name)] 387 | [(list (? keyword? kw) name cont) (format "~v ~v" kw name)] 388 | [(list name cont val) (format "[~v]" name)] 389 | [(list (? keyword? kw) name cont val) (format "[~v ~v]" kw name)] 390 | ['... "..."] 391 | ['...+ "...+"] 392 | )) 393 | 394 | (define (arg->sig-string arg) 395 | (match arg 396 | [(list name cont) (format " ~v: ~v" name cont)] 397 | [(list (? keyword? kw) name cont) (format " ~v: ~v" name cont)] 398 | [(list name cont val) (format " ~v: ~v = ~v" name cont val)] 399 | [(list (? keyword? kw) name cont val) (format " ~v: ~v = ~v" name cont val)] 400 | ['... #f] 401 | ['...+ #f] 402 | )) 403 | 404 | (define NO_ENTRY_FOUND "No entry found") 405 | 406 | ;; Returns the list of signature in line-splitted string-format. 407 | ;; -> (list def-strings) 408 | ;; def-strings : (list string?) 409 | (define (def-name->string-list dic name) 410 | (define entries (dict-ref dic name #f)) 411 | (if entries 412 | (for/list ([entry entries]) 413 | (match entry 414 | [(list 'defclass id super intf-ids) 415 | (list (format "~v : class?" id) 416 | (format " superclass: ~v" super) 417 | (string-join (cons " extends:" 418 | (map symbol->string intf-ids)) 419 | " "))] 420 | [(list 'definterface id intf-ids) 421 | (list (format "~v : interface?" id) 422 | (string-join (cons " implements:" 423 | (map symbol->string intf-ids)) 424 | " "))] 425 | [(list 'defconstructor class-id args) 426 | (list* (string-append 427 | (format "(new ~v " class-id) 428 | (string-join (map arg->head-string args) " ") 429 | ")") 430 | (filter values (map arg->sig-string args)))] 431 | [(list 'defmethod class-id id args cont-out) 432 | (list* 433 | (string-append 434 | (format "(send a-~a ~a " class-id id) 435 | (string-join (map arg->head-string args) " ") 436 | ") -> " 437 | (format "~v" cont-out) 438 | ) 439 | (filter values (map arg->sig-string args)) 440 | )] 441 | [(list 'defproc id args cont-out) 442 | (list* 443 | (string-append 444 | "(" 445 | (string-join (cons (symbol->string name) 446 | (map arg->head-string args)) " ") 447 | ") -> " 448 | (format "~v" cont-out) 449 | ) 450 | (filter values (map arg->sig-string args)) 451 | )] 452 | [(list 'defform id args) 453 | (list (format "~v" (cons id args)))] 454 | [(list 'srfi id-str args) 455 | (list (string-append id-str " " args))] 456 | [(list 'doc-thing id cont) 457 | (list (format "~v : ~v" id cont))] 458 | [else (list (format "Unknown parsed form: ~a" entry))] 459 | )) 460 | `((,NO_ENTRY_FOUND)))) 461 | 462 | ; The definition index. Since the script is persitent, it is loaded only once 463 | (define def-index (create-index)) 464 | 465 | #| TESTS 466 | (dict-ref def-index 'list) 467 | (def-name->string-list def-index 'with-output-to-file) 468 | (def-name->string-list def-index 'string-pad) 469 | 470 | ;|# 471 | 472 | ;===========; 473 | ;=== GUI ===; 474 | ;===========; 475 | 476 | ;;; In the following, a 'text' is a list of strings. 477 | 478 | ; The font to use for the text 479 | (define label-font 480 | (send the-font-list find-or-create-font 481 | text-size 482 | 'modern 'normal 'normal #f)) 483 | 484 | (define inset 2) 485 | 486 | ; Calculate the minimum sizes of a string 487 | (define (calc-min-sizes dc str label-font) 488 | (send dc set-font label-font) 489 | (let-values ([(w h a d) (send dc get-text-extent str label-font)]) 490 | (let ([ans-w (max 0 (inexact->exact (ceiling w)))] 491 | [ans-h (max 0 (inexact->exact (ceiling h)))]) 492 | (values ans-w ans-h)))) 493 | 494 | ;; Calculate the total size of a text, with inset 495 | (define (dc-text-size dc text label-font) 496 | (define w-h 497 | (for/list ([str text]) 498 | (let-values ([(w h) (calc-min-sizes dc str label-font)]) 499 | (list w h)))) 500 | (values 501 | (+ inset inset (apply max (map car w-h))) 502 | (+ inset inset (apply + (map cadr w-h))))) 503 | 504 | ;; Draws the text (list of strings) in dc at x y, 505 | ;; each string on below the other, left-aligned. 506 | (define (draw-text dc x y text) 507 | 508 | (define black-color (make-object color% "black")) 509 | (define bg-color (make-object color% "wheat")) 510 | 511 | (define-values (w h) 512 | (dc-text-size dc text label-font)) 513 | 514 | ; background square 515 | (send dc set-pen (send the-pen-list find-or-create-pen 516 | bg-color 1 'solid)) 517 | (send dc set-brush (send the-brush-list find-or-create-brush 518 | bg-color 'solid)) 519 | (send dc draw-rectangle x y w h) 520 | 521 | ; boundaries 522 | (send dc set-pen (send the-pen-list find-or-create-pen 523 | black-color 1 'solid)) 524 | (send dc draw-line x y (+ x w) y) 525 | (send dc draw-line (+ x w) y (+ x w) (+ y h)) 526 | (send dc draw-line (+ x w) (+ y h) x (+ y h)) 527 | (send dc draw-line x (+ y h) x y) 528 | 529 | ; draw text into the square 530 | ; set colors, fonts, etc. 531 | (send dc set-text-foreground black-color) 532 | (send dc set-text-background bg-color) 533 | (send dc set-font label-font) 534 | (define ytot 535 | (for/fold ([ytot (+ y inset)]) 536 | ([str text]) 537 | (let-values ([(w h) (calc-min-sizes dc str label-font)]) 538 | (send dc draw-text str (+ x inset) ytot) 539 | (values (+ h ytot))))) 540 | ; return value: 541 | (values w h)) 542 | 543 | (define tooltip-frame% 544 | (class frame% 545 | (init-field [text '()]) 546 | (super-new [label ""] 547 | [style '(no-resize-border 548 | no-caption 549 | no-system-menu 550 | hide-menu-bar 551 | float)] 552 | ;[min-height 400] 553 | ;[min-width 400] 554 | [stretchable-width #f] 555 | [stretchable-height #f] 556 | ) 557 | 558 | (define/override (on-subwindow-char e k) 559 | (when (equal? (send k get-key-code) 'escape) 560 | (send this show #f)) 561 | #f) 562 | 563 | (define hp (new horizontal-panel% [parent this] 564 | [alignment '(left top)])) 565 | 566 | (new close-icon% [parent hp] 567 | [callback (λ _ (send (this-frame) show #f))]) 568 | 569 | (define (this-frame) this) 570 | 571 | ;; Internal canvas class 572 | (define tooltip-canvas% 573 | (class canvas% 574 | (define x-start #f) 575 | (define y-start #f) 576 | (define/override (on-event ev) 577 | (when (send ev get-left-down) 578 | (if (send ev moving?) 579 | (let ([x (send ev get-x)] [y (send ev get-y)]) 580 | (let-values ([(x y) (send this client->screen (round x) (round y))]) 581 | (send (this-frame) move (- x x-start) (- y y-start)))) 582 | (begin (set! x-start (send ev get-x)) 583 | (set! y-start (send ev get-y)))))) 584 | (super-new) 585 | )) 586 | 587 | (define cv (new tooltip-canvas% [parent hp] 588 | [paint-callback 589 | (λ (cv dc) (draw-text dc 0 0 text))])) 590 | 591 | (define/public (set-text t) 592 | (set! text t) 593 | (define-values (w h) (dc-text-size (send cv get-dc) text label-font)) 594 | (send cv min-width (+ w 1)) 595 | (send cv min-height (+ h 1)) 596 | (send this reflow-container) 597 | (send this stretchable-width #f) 598 | (send this stretchable-height #f) 599 | (send cv refresh)) 600 | 601 | (unless (empty? text) 602 | (set-text text)) 603 | )) 604 | 605 | ;::::::::::::::::; 606 | ;:: The script ::; 607 | ;::::::::::::::::; 608 | 609 | (define (def-name->text sym) 610 | (define defs (def-name->string-list def-index sym)) 611 | (append* (add-between defs '("")))) 612 | 613 | ;; persistent variables, to use always the same ones 614 | (define tooltip-frame #f) 615 | (define last-sym #f) 616 | 617 | (define-script def-signatures 618 | #:label "Signature" 619 | #:shortcut #\$ 620 | #:shortcut-prefix (ctl) 621 | #:persistent 622 | (λ (str #:editor ed) 623 | (define start-pos (send ed get-start-position)) 624 | (define end-pos (send ed get-end-position)) 625 | (define start-exp-pos 626 | (or (send ed get-backward-sexp start-pos) start-pos)) 627 | (define end-exp-pos 628 | (or (send ed get-forward-sexp (- end-pos 1)) end-pos)) 629 | (define str 630 | ;(send ed get-word-at (send ed get-forward-sexp (send ed get-start-position)))) 631 | (send ed get-text start-exp-pos end-exp-pos)) 632 | 633 | (define sym (string->symbol str)) 634 | (define text (def-name->text sym)) 635 | 636 | (define dc (send ed get-dc)) 637 | 638 | (unless tooltip-frame 639 | (set! tooltip-frame (new tooltip-frame%))) 640 | 641 | ; if the new sym is the same as the old one, 642 | ; or if it is an invalid one, hide the frame, 643 | ; otherwise show it for the new symbol. 644 | (if (and (eq? sym last-sym) (send tooltip-frame is-shown?)) 645 | (send tooltip-frame show #f) 646 | (let () 647 | (define &x (box #f)) 648 | (define &y (box #f)) 649 | (send ed position-location start-exp-pos &x &y #f #t) 650 | (define-values (x y) (send ed editor-location-to-dc-location 651 | (unbox &x) (unbox &y))) 652 | 653 | (let-values ([(x y) (send (send ed get-canvas) 654 | client->screen (round (inexact->exact x)) (round (inexact->exact y)))] 655 | [(left top) (get-display-left-top-inset)]) 656 | (send tooltip-frame move (- x left) (- y -2 top)) 657 | (send tooltip-frame set-text text) 658 | (send tooltip-frame show #t) 659 | (set! last-sym sym) 660 | ))) 661 | #f)) 662 | 663 | ; These tests are likely to fail within an automated tester if the docs are not installed, hence they are commented out. 664 | #; 665 | (module+ test 666 | (require rackunit) 667 | 668 | (set!-debug? #t) 669 | 670 | (define defs 671 | '(with-output-to-file list->string print error make-module-evaluator make-provide-transformer list->string open-input-output-file regexp-replace 672 | 673 | button% set-label class get-top-level-window min-height refresh on-move get-x get-cursor focus 674 | ; framework (complicated ones!): 675 | finder:common-put-file preferences:set-default 676 | )) 677 | (for ([d (in-list defs)]) 678 | (check-not-false (dict-ref def-index d #f))) 679 | ) 680 | --------------------------------------------------------------------------------