├── .gitignore ├── .travis.yml ├── LICENSE.txt ├── README.md ├── editor-test └── forge-identifier.rkt ├── editor ├── base.rkt ├── examples │ └── matrix.rkt ├── info.rkt ├── lang.rkt ├── main.rkt ├── private │ ├── background.rkt │ ├── context-text.rkt │ ├── context.rkt │ ├── editor.rkt │ ├── editselect.rkt │ ├── event.rkt │ ├── fallback.rkt │ ├── lang.rkt │ ├── list.rkt │ ├── log.rkt │ ├── read-editor.rkt │ ├── serialize.rkt │ ├── stdlib.rkt │ ├── surrogate-base.rkt │ └── surrogate.rkt ├── test.rkt └── test │ └── raco.rkt └── info.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.bak 3 | \#* 4 | .\#* 5 | .DS_Store 6 | compiled/ 7 | /doc/ 8 | -------------------------------------------------------------------------------- /.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.1 25 | - RACKET_VERSION=6.1.1 26 | - RACKET_VERSION=6.2 27 | - RACKET_VERSION=6.3 28 | - RACKET_VERSION=6.4 29 | - RACKET_VERSION=6.5 30 | - RACKET_VERSION=6.6 31 | - RACKET_VERSION=6.7 32 | - RACKET_VERSION=6.8 33 | - RACKET_VERSION=6.9 34 | - RACKET_VERSION=6.10 35 | - RACKET_VERSION=6.10.1 36 | - RACKET_VERSION=HEAD 37 | 38 | matrix: 39 | allow_failures: 40 | # - env: RACKET_VERSION=HEAD 41 | fast_finish: true 42 | 43 | before_install: 44 | - git clone https://github.com/greghendershott/travis-racket.git ~/travis-racket 45 | - cat ~/travis-racket/install-racket.sh | bash # pipe to bash not sh! 46 | - export PATH="${RACKET_DIR}/bin:${PATH}" #install-racket.sh can't set for us 47 | 48 | install: 49 | - raco pkg install --deps search-auto 50 | 51 | before_script: 52 | 53 | # Here supply steps such as raco make, raco test, etc. You can run 54 | # `raco pkg install --deps search-auto` to install any required 55 | # packages without it getting stuck on a confirmation prompt. 56 | script: 57 | - raco test -x -p idmt 58 | 59 | after_success: 60 | - raco setup --check-pkg-deps --pkgs idmt 61 | - raco pkg install --deps search-auto cover cover-coveralls 62 | - raco cover -b -f coveralls -d $TRAVIS_BUILD_DIR/coverage . 63 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | idmt 2 | Copyright (c) 2017 leif 3 | 4 | This package is distributed under the GNU Lesser General Public 5 | License (LGPL). This means that you can link idmt into proprietary 6 | applications, provided you follow the rules stated in the LGPL. You 7 | can also modify this package; if you distribute a modified version, 8 | you must distribute it under the terms of the LGPL, which in 9 | particular means that you must release the source code for the 10 | modified software. See http://www.gnu.org/copyleft/lesser.html 11 | for more information. 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Interactive Syntax 2 | ================== 3 | 4 | This repo is the `interactive-syntax` package. 5 | 6 | Paper 7 | ==== 8 | OOPSLA 2020 : Andersen, Ballantyne, Felleisen 9 | [Adding Interactive Visual Syntax to Textual Code](https://www2.ccs.neu.edu/racket/pubs/oopsla20-abf.pdf)(pdf) 10 | [conference presentation](https://youtu.be/8htgAxJuK5c)(YouTube) 11 | 12 | Install 13 | ======= 14 | 15 | `raco pkg install git://github.com/videolang/interactive-syntax` 16 | 17 | Examples 18 | ======== 19 | 20 | Examples can be found in the [artifact2020](https://github.com/LeifAndersen/artifact2020) repository. 21 | 22 | e.g. 23 | 1. install (as above) 24 | 2. download the artifact2020 repository 25 | 3. open artifact2020/rbtree/use.rkt 26 | 4. click the **Update Editors** button in the DrRacket toolbar 27 | -------------------------------------------------------------------------------- /editor-test/forge-identifier.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/load 2 | 3 | (require racket/match 4 | racket/dict 5 | syntax/modresolve 6 | rackunit) 7 | 8 | (define identifier->original-identifier 9 | (parameterize ([current-namespace (make-base-namespace)]) 10 | (namespace-require 'editor/private/editor) 11 | (parameterize ([current-namespace (module->namespace 'editor/private/editor)]) 12 | (eval '(let-syntax ([foo (λ (stx) #`'#,identifier->original-identifier)]) 13 | (foo)))))) 14 | 15 | (module direct racket 16 | (provide x) 17 | (define-syntax x 42)) 18 | (require 'direct) 19 | (check-equal? (identifier->original-identifier ''direct 'x) 20 | (cons ''direct 'x)) 21 | 22 | (module direct-rename racket 23 | (provide (rename-out [x y])) 24 | (define-syntax x 42)) 25 | (require 'direct-rename) 26 | (check-equal? (identifier->original-identifier ''direct-rename 'y) 27 | (cons ''direct-rename 'x)) 28 | 29 | (module indirect-reprovide racket 30 | (require 'direct-rename) 31 | (provide y)) 32 | (require 'indirect-reprovide) 33 | (check-equal? (identifier->original-identifier ''indirect-reprovide 'y) 34 | (cons (module-path-index-join ''direct-rename #f) 'x)) 35 | 36 | (module indirect-rename racket 37 | (require 'direct-rename) 38 | (provide (rename-out [y z]))) 39 | (require 'indirect-rename) 40 | (check-equal? (identifier->original-identifier ''indirect-rename 'z) 41 | (cons (module-path-index-join ''direct-rename #f) 'x)) 42 | 43 | (module for-syntax-reprovide racket 44 | (require (for-syntax 'direct-rename)) 45 | (provide (for-syntax y))) 46 | (require 'for-syntax-reprovide) 47 | (check-equal? (identifier->original-identifier ''for-syntax-reprovide 'y 1) 48 | (cons (module-path-index-join ''direct-rename #f) 'x)) 49 | -------------------------------------------------------------------------------- /editor/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "private/lang.rkt" 3 | "private/editor.rkt" 4 | racket/splicing 5 | (for-syntax racket/base)) 6 | 7 | (splicing-syntax-parameterize ([current-editor-lang 'racket/base] 8 | [current-editor-base "private/editor.rkt"] 9 | [current-editor-modpath-mode 'package]) 10 | (begin-for-interactive-syntax) ; <- because require happens too late... 11 | (require 12 | "private/stdlib.rkt" 13 | (for-editor "private/lang.rkt" 14 | "private/context.rkt" 15 | (from-editor "private/stdlib.rkt"))) 16 | 17 | (provide (~all-from-out "private/stdlib.rkt") 18 | (for-editor (~all-from-out (from-editor "private/stdlib.rkt")) 19 | define-state 20 | define-elaborator) 21 | define-state 22 | define-elaborator 23 | define-interactive-syntax 24 | define-interactive-syntax-mixin 25 | elaborator-parser 26 | begin-for-interactive-syntax 27 | define-for-interactive-syntax 28 | for-editor 29 | from-editor 30 | (rename-out [~require require] 31 | [~all-from-out all-from-out]))) 32 | -------------------------------------------------------------------------------- /editor/examples/matrix.rkt: -------------------------------------------------------------------------------- 1 | #lang editor editor/lang 2 | 3 | (require editor/base 4 | math/matrix 5 | racket/class 6 | data/gvector 7 | (for-syntax racket/base 8 | racket/syntax) 9 | (for-editor racket/gui/base 10 | racket/math 11 | racket/match 12 | data/gvector)) 13 | 14 | (define-interactive-syntax matrix-state$ base$ 15 | #:interfaces (receiver<$>) 16 | (super-new) 17 | (define-state width 0 18 | #:getter #t 19 | #:setter (λ (new-width) 20 | (set! width new-width) 21 | (resize-matrix))) 22 | (define-state height 0 23 | #:getter #t 24 | #:setter (λ (new-height) 25 | (set! height new-height) 26 | (resize-matrix))) 27 | (define-state values (make-gvector) 28 | #:getter #t) 29 | (define/private (resize-matrix) 30 | (define new-length (* width height)) 31 | (define old-length (gvector-count values)) 32 | (if (new-length . > . old-length) 33 | (for ([i (in-range (- new-length old-length))]) 34 | (gvector-add! values 0)) 35 | (for ([i (in-range (- old-length new-length))]) 36 | (gvector-remove-last! values)))) 37 | (define/public (set-cell! row col val) 38 | (gvector-set! values (+ (* row width) col) val)) 39 | (define/public (on-receive sender event) 40 | (cond 41 | [(is-a? event control-event%) 42 | (when (eq? (send event get-event-type) 'text-field) 43 | (set-cell! (send sender get-row) 44 | (send sender get-col) 45 | (string->number (send sender get-text))))]))) 46 | 47 | (define-interactive-syntax cell$ field$ 48 | (init [(ir row) 0] 49 | [(ic col) 0]) 50 | (define-state row ir 51 | #:getter #t 52 | #:persistence #f) 53 | (define-state col ic 54 | #:getter #t 55 | #:persistence #f) 56 | (super-new)) 57 | 58 | (define-interactive-syntax matrix-body$ vertical-block$ 59 | (inherit count 60 | remove-child 61 | in-children 62 | get-parent) 63 | (super-new) 64 | (define/public (resize-cells) 65 | (define-values (w h) 66 | (for/fold ([w 0] 67 | [h 0]) 68 | ([row (in-children)]) 69 | (for/fold ([w w] 70 | [h h]) 71 | ([cell (send row in-children)]) 72 | (match-define-values (w* h* _ _ _ _) 73 | (send cell get-extent 74 | (send cell get-x) 75 | (send cell get-y))) 76 | (values (max w w*) 77 | (max h h*))))) 78 | (send this set-uniform-child-size?! (list w h)) 79 | (for ([row (in-children)]) 80 | (send row set-uniform-child-size?! (list w h)))) 81 | (define/public (fill-cells cells width) 82 | (for ([row (in-children)] 83 | [i (in-naturals)]) 84 | (for ([cell (send row in-children)] 85 | [j (in-naturals)]) 86 | (send cell set-text! 87 | (number->string (gvector-ref cells (+ (* i width) j)))))) 88 | (resize-cells)) 89 | ;; Change the dimentions of the matrix to the new width/height. 90 | (define/public (change-dimensions width height) 91 | (define height-diff (abs (- height (count)))) 92 | ;; First grow rows 93 | (cond 94 | [(height . < . (count)) 95 | (for ([_ (in-range height-diff)]) 96 | (remove-child))] 97 | [(height . > . (count)) 98 | (for ([_ (in-range height-diff)]) 99 | (new horizontal-block$ [parent this] 100 | [uniform-child-size? #t]))]) 101 | ;; Then collumns in thos rows 102 | (for ([row (in-children)] 103 | [row-index (in-naturals)]) 104 | (define existing-width (send row count)) 105 | (define width-diff (abs (- width existing-width))) 106 | (cond 107 | [(width . < . existing-width) 108 | (for ([_ (in-range width-diff)]) 109 | (send row remove-child))] 110 | [(width . > . existing-width) 111 | (for ([_ (in-range width-diff)] 112 | [col-index (in-naturals existing-width)]) 113 | (new cell$ [parent row] 114 | [row row-index] 115 | [col col-index] 116 | [text "0"] 117 | [callback (send this get-parent)]))])) 118 | (resize-cells))) 119 | 120 | (define-interactive-syntax matrix$ (signaler$$ vertical-block$) 121 | #:interfaces (receiver<$>) 122 | (super-new) 123 | (define-state state (new matrix-state$) 124 | #:getter #t) 125 | (define-elaborator this 126 | #'(let () 127 | (define state (send this get-state)) 128 | (vector->matrix (send state get-height) 129 | (send state get-width) 130 | (gvector->vector (send state get-values))))) 131 | (define/public (on-receive sender message) 132 | (send state on-receive sender message) 133 | (send the-matrix resize-cells)) 134 | (define/override (on-state-changed) 135 | (super on-state-changed) 136 | (send w-str set-text! (number->string (send state get-width))) 137 | (send h-str set-text! (number->string (send state get-height))) 138 | (send the-matrix change-dimensions 139 | (send state get-width) 140 | (send state get-height)) 141 | (send the-matrix fill-cells 142 | (send state get-values) 143 | (send state get-width))) 144 | (define w-row (new horizontal-block$ [parent this])) 145 | (define h-row (new horizontal-block$ [parent this])) 146 | (new label$ [parent w-row] [text "Width: "]) 147 | (define/public (w-str-callback this event) 148 | (define w (string->number (send this get-text))) 149 | (when (and w (natural? w)) 150 | (send state set-width! w) 151 | (send the-matrix change-dimensions 152 | (send state get-width) 153 | (send state get-height)))) 154 | (define w-str (new field$ [parent w-row] 155 | [text (number->string (send state get-width))] 156 | [callback (list this 'w-str-callback)])) 157 | (new label$ [parent h-row] [text "Height: "]) 158 | (define/public (h-str-callback this event) 159 | (define h (string->number (send this get-text))) 160 | (when (and h (natural? h)) 161 | (send state set-height! h) 162 | (send the-matrix change-dimensions 163 | (send state get-width) 164 | (send state get-height)))) 165 | (define h-str (new field$ [parent h-row] 166 | [text (number->string (send state get-height))] 167 | [callback (list this 'h-str-callback)])) 168 | (define the-matrix (new matrix-body$ [parent this] 169 | [uniform-child-size? #t]))) 170 | 171 | (begin-for-interactive-syntax 172 | (module+ test 173 | (require editor/test) 174 | (test-window (new matrix$)))) 175 | 176 | -------------------------------------------------------------------------------- /editor/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "editor") 4 | ;(define scribblings '(("scribblings/idmt.scrbl" ()))) 5 | (define raco-commands '(("editor-test" 6 | (submod editor/test/raco main) 7 | "Run tests for edit-time" 8 | #f))) 9 | 10 | (define drracket-tools '(("private/surrogate.rkt"))) 11 | (define drracket-tool-name '("Editor")) 12 | (define drracket-tool-icons '(#f)) 13 | -------------------------------------------------------------------------------- /editor/lang.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "private/lang.rkt" 4 | "private/editor.rkt" 5 | "base.rkt" 6 | racket/splicing 7 | (for-syntax racket/base)) 8 | 9 | (splicing-syntax-parameterize ([current-editor-lang "private/editor.rkt"] 10 | [current-editor-base "base.rkt"] 11 | [current-editor-modpath-mode 'package]) 12 | (begin-for-interactive-syntax) ; <- because require happens too late... 13 | (require "base.rkt" 14 | racket/class 15 | (for-syntax racket/base 16 | "private/lang.rkt") 17 | (for-editor "private/lang.rkt" 18 | (from-editor "base.rkt") 19 | racket/class)) 20 | (provide (all-from-out "base.rkt") 21 | (for-editor (all-from-out (from-editor "base.rkt"))) 22 | (all-from-out racket/class) 23 | (all-from-out racket/base))) 24 | 25 | (module reader syntax/module-reader 26 | editor/lang 27 | #:read read 28 | #:read-syntax read-syntax) 29 | -------------------------------------------------------------------------------- /editor/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module reader racket/base 4 | 5 | (provide (rename-out [e:read read] 6 | [e:read-syntax read-syntax] 7 | [e:get-info get-info]) 8 | wrap-reader 9 | wrap-info) 10 | (require syntax/module-reader 11 | syntax/parse 12 | racket/match 13 | racket/pretty 14 | "private/read-editor.rkt") 15 | 16 | (define ((wrap-reader t) . args) 17 | (define outer-scope (make-syntax-introducer #t)) 18 | (parameterize ([current-readtable (make-editor-readtable #:outer-scope outer-scope)]) 19 | (define stx (apply t args)) 20 | (if (syntax? stx) 21 | (syntax-parse stx 22 | [(module name lang 23 | (~and mb 24 | (mod-beg (~optional (~seq #:headers (headers ...)) #:defaults ([(headers 1) '()])) 25 | body ...))) 26 | (outer-scope 27 | #`(module name lang 28 | #,(datum->syntax #'mb 29 | (append (list #'mod-beg) 30 | (syntax->list #'(headers ...)) 31 | (list (datum->syntax #f '(#%require (only editor/private/editor #%editor)))) 32 | ;#,(outer-scope #'(#%require (only editor/base))) 33 | (syntax->list #'(body ...))))))]) 34 | (match stx 35 | [`(module ,name ,lang 36 | (,mod-beg #:headers (,headers ...) 37 | ,body ...)) 38 | `(module ,name ,lang 39 | ,@headers 40 | ,@body)] 41 | [_ stx])))) 42 | 43 | (define ((wrap-info defproc) key default) 44 | (case key 45 | [(color-lexer) 46 | (lex-editor (defproc 'color-lexer default))] 47 | [(definitions-text-surrogate) 48 | 'editor/private/surrogate-base] 49 | [(definitions-text-surrogate-list) 50 | (define base-list 51 | (or (defproc key default) 52 | (let* ([alt (defproc 'definitions-text-surrogate default)]) 53 | (and alt (list alt))))) 54 | (if base-list 55 | (cons 'editor/private/surrogate base-list) 56 | (list 'editor/private/surrogate-base))] 57 | [(drracket:toolbar-buttons) 58 | (define others (defproc key default)) 59 | (list* (dynamic-require 'editor/private/surrogate 'toggle-button) 60 | (dynamic-require 'editor/private/editselect 'insert-button) 61 | (if (list? others) 62 | others 63 | '()))] 64 | [else (defproc key default)])) 65 | 66 | (define-values (e:read e:read-syntax e:get-info) 67 | (make-meta-reader 68 | 'editor 69 | "Embedded Editors" 70 | lang-reader-module-paths 71 | wrap-reader 72 | wrap-reader 73 | wrap-info))) 74 | -------------------------------------------------------------------------------- /editor/private/background.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (all-defined-out)) 4 | (require racket/match 5 | racket/fasl) 6 | 7 | (define (expansion-monitor callback directory source custodian) 8 | (define receiver (make-log-receiver (current-logger) 9 | 'info 10 | 'editor-lex-for-editors)) 11 | (thread 12 | (λ () 13 | (let loop () 14 | (define val (sync receiver)) 15 | (match val 16 | [(vector level message 17 | (vector elaborator editor src 18 | line col pos new-line new-col new-pos) 19 | name) 20 | (callback (vector (s-exp->fasl (syntax->datum elaborator)) 21 | (s-exp->fasl (syntax->datum editor)) 22 | pos new-pos))] 23 | [_ (void)]) 24 | (loop))))) 25 | -------------------------------------------------------------------------------- /editor/private/context-text.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (rename-out [editor-reader reader])) 4 | (require racket/class 5 | wxme) 6 | 7 | (define editor-reader% 8 | (class* object% (snip-reader<%>) 9 | (super-new) 10 | (define/public (read-header version stream) (void)) 11 | (define/public (read-snip text-only? version stream) 12 | (define text (send stream read-bytes 'editor)) 13 | (cond [text-only? text] 14 | [else text])))) ; <- fix? 15 | 16 | (define editor-reader (new editor-reader%)) 17 | -------------------------------------------------------------------------------- /editor/private/context.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (all-defined-out) 4 | (rename-out [editor-snip-class snip-class])) 5 | 6 | (require "lang.rkt" 7 | "editor.rkt" 8 | "read-editor.rkt" 9 | racket/pretty 10 | (prefix-in base: racket/base) 11 | racket/contract/base 12 | racket/class 13 | racket/gui/base 14 | racket/port 15 | file/convertible 16 | racket/match 17 | racket/list 18 | racket/serialize 19 | racket/format 20 | racket/math 21 | racket/path) 22 | 23 | (define editor-context<$> 24 | (interface () 25 | resize 26 | recount 27 | alert 28 | show 29 | get-path)) 30 | 31 | ;; =================================================================================================== 32 | 33 | (define editor-canvas% 34 | (class* canvas% (editor-context<$>) 35 | (init-field editor) 36 | (inherit min-height min-width refresh) 37 | (match-define-values (width height) 38 | (send editor get-extent)) 39 | (super-new [min-width (exact-ceiling width)] 40 | [min-height (exact-ceiling height)] 41 | [stretchable-width #f] 42 | [stretchable-height #f] 43 | [paint-callback (λ (c dc) 44 | (send editor draw dc 0 0) 45 | (match-define-values (width height) 46 | (send editor get-extent)) ;(send editor get-x) (send editor get-y))) 47 | (min-width (exact-ceiling width)) 48 | (min-height (exact-ceiling height)))]) 49 | (send editor set-context this) 50 | (define/public (resize w h) 51 | (void)) 52 | (define/public (recount . _) 53 | (void)) 54 | (define/public (alert . _) 55 | (error "TODO alert")) 56 | (define/override (on-event event) 57 | (send editor on-event event 0 0) 58 | (refresh)) 59 | (define/override (on-char event) 60 | (send editor on-event event 0 0) 61 | (refresh)) 62 | (define/public (get-path) 63 | #f))) 64 | 65 | ;; =================================================================================================== 66 | 67 | (define editor-read-as-snip? (make-parameter #f)) 68 | 69 | ;; Editor snip and snipclass implementations 70 | 71 | (define editor-snip% 72 | (class* snip% (editor-context<$> readable-snip<%>) 73 | (inherit get-flags set-flags set-snipclass get-admin) 74 | ;; editor contains the actual interactive editor. 75 | (init-field editor 76 | ;; Serial is only if it cannot yet be processed because 77 | ;; we need to first expand _this_ file. 78 | [serial-sexp #f] 79 | ;; The modname of the editor under edit in the current 80 | ;; namespace 81 | [mod-name #f] 82 | ;; The namespace for the editor under edit 83 | [namespace #f]) 84 | (when editor 85 | (send editor set-context this)) 86 | (super-new) 87 | (set-flags (list* 'handles-events 88 | 'uses-editor-path 89 | 'width-depends-on-x 90 | 'width-depends-on-y 91 | 'height-depends-on-x 92 | 'height-depends-on-y 93 | (get-flags))) 94 | (set-snipclass editor-snip-class) 95 | (send (get-the-snip-class-list) add editor-snip-class) 96 | (define/public (get-path) 97 | (define admin (get-admin)) 98 | (cond 99 | [admin 100 | (define ctx (send admin get-editor)) 101 | (define b (box #f)) 102 | (define filename (send ctx get-filename b)) 103 | (and (not (unbox b)) 104 | filename)] 105 | [else #f])) 106 | (define/public (get-editor) 107 | editor) 108 | (define/public (set-editor! e) 109 | (when editor 110 | (send editor set-context #f)) 111 | (set! editor e) 112 | (when e 113 | (send e set-context this)) 114 | (define admin (get-admin)) 115 | (when admin 116 | (send admin resized this #t))) 117 | (define/public (set-namespace! ns) 118 | (set! namespace ns)) 119 | (define/public (set-mod-name! m) 120 | (set! mod-name m)) 121 | (define/private (init-editor) 122 | (unless editor 123 | (parameterize ([current-namespace (or namespace (current-namespace))]) 124 | (set-editor! (deserialize serial-sexp))))) 125 | (define/override (get-extent dc x y [w #f] [h #f] [d #f] [s #f] [ls #f] [rs #f]) 126 | (init-editor) 127 | (define-values (w* h*) (send editor get-extent)) 128 | (define (wsb! x y) (when x (set-box! x y))) 129 | (wsb! w w*) 130 | (wsb! h h*) 131 | (wsb! ls 0) 132 | (wsb! s 0) 133 | (wsb! rs 0) 134 | (wsb! d 0)) 135 | (define/override (draw dc x y left top right bottom dx dy draw-caret) 136 | (init-editor) 137 | (send editor draw dc x y)) 138 | (define/override (on-char dc x y ex ey event) 139 | (init-editor) 140 | (send editor get-extent) ;; TODO, remove this 141 | (send editor on-event event x y) 142 | (define admin (get-admin)) 143 | (when admin 144 | (send admin resized this #t))) 145 | (define/override (on-event dc x y ex ey event) 146 | (init-editor) 147 | (send editor get-extent) ;; TODO, remove this 148 | (send editor on-event event x y) 149 | (define admin (get-admin)) 150 | (when admin 151 | (send admin resized this #t))) 152 | (define/override (copy) 153 | (init-editor) 154 | (define copy 155 | (with-handlers ([exn:fail? 156 | (λ (e) 157 | (log-warning "~s" e) 158 | #f)]) 159 | (send editor copy))) 160 | (define sexp (serialize editor)) 161 | (new editor-snip% 162 | [editor copy] 163 | [serial-sexp sexp])) 164 | (define/public (editor-binding) 165 | (init-editor) 166 | (match-define `((,edit-mod ,edit-name) (,des-mod ,des-id) (,elab-mod ,elab-name)) 167 | (editor->elaborator editor)) 168 | (define filename (maybe-get-filename)) 169 | (values 170 | (list (list edit-mod edit-name) 171 | (list des-mod des-id) 172 | (list elab-mod elab-name)) 173 | #f #;(equal? (car edit-mod) 174 | mod-name) 175 | des-id)) 176 | (define/private (serialize-data data des rel same-file?) 177 | (if same-file? 178 | (serialize+rehome data des #:relative-directory rel) 179 | (serialize data #:relative-directory rel))) 180 | (define/private (serialize-editor) 181 | (define-values (binding same-file? des-name) (editor-binding)) 182 | (define f (maybe-get-filename)) 183 | (values (serialize-data binding des-name (and f (cons f (build-path "/"))) same-file?) 184 | (serialize-data editor des-name (and f (cons f (build-path "/"))) same-file?))) 185 | (define/override (get-text offset num [flattened? #f]) 186 | (init-editor) 187 | (define-values (binding serial) (serialize-editor)) 188 | (define f (maybe-get-filename)) 189 | #| 190 | (writeln "start") 191 | (writeln serial) 192 | (define des-text 193 | (parameterize ([editor-deserialize-for-text #t] 194 | [current-load-relative-directory (or f (current-load-relative-directory))]) 195 | (writeln (editor-deserialize-for-text)) 196 | (deserialize serial))) 197 | (writeln des-text) 198 | (define clean-des-text 199 | (cons (vector-ref des-text 0) 200 | (let loop ([d (vector-ref des-text 1)]) 201 | (define sup (vector-ref d 0)) 202 | (list* 203 | (vector-ref d 0) 204 | (vector-ref d 2) 205 | (if sup 206 | (loop sup) 207 | '()))))) 208 | (pretty-write clean-des-text) 209 | (writeln "end") 210 | |# 211 | ;; Disregarding flattened? ... 212 | (format "#editor~a~a" 213 | (pretty-format binding #:mode 'write) 214 | (pretty-format serial #:mode 'write))) 215 | (define/private (maybe-get-filename) 216 | (define maybe-admin (get-admin)) 217 | (define maybe-filename 218 | (cond [maybe-admin 219 | (define editor (send maybe-admin get-editor)) 220 | (define tmp (box #f)) 221 | (define file (send editor get-filename)) 222 | (and (not (unbox tmp)) file)] 223 | [else #f])) 224 | #;(if (path-string? maybe-filename) 225 | (path-only maybe-filename) 226 | maybe-filename) 227 | maybe-filename) 228 | (define/public (read-special src line col pos) 229 | (cond [(editor-read-as-snip?) this] 230 | [else 231 | (define-values (binding serial) (serialize-editor)) 232 | (define editor-datum `(#%editor ,binding ,serial)) 233 | (datum->syntax #f ;#'#f 234 | editor-datum 235 | (vector src line col pos (string-length (format "~s" editor-datum))))])) 236 | (define/override (write f) 237 | (define text (string->bytes/utf-8 (get-text 0 #f))) 238 | (send f put text)) 239 | (define/public (alert . _) 240 | (error "TODO alert")) 241 | (define/override (resize w h) 242 | (super resize w h) 243 | (define a (get-admin)) 244 | (when a 245 | (send a resized this #t))) 246 | (define/public (recount . _) 247 | (log-editor-warning "TODO recount") 248 | (void)) 249 | (define/public (show show?) 250 | (void)))) 251 | 252 | (define editor-snip-class% 253 | (class snip-class% 254 | (inherit set-classname) 255 | (super-new) 256 | (set-classname (~s '((lib "context.rkt" "editor" "private") 257 | (lib "context-text.rkt" "editor" "private")))) 258 | (define/override (read f) 259 | (define text (send f get-bytes)) 260 | (match-define `(#%editor ,_ ,the-editor) 261 | (with-input-from-string (bytes->string/utf-8 text) 262 | (λ () 263 | (parameterize ([current-readtable (make-editor-readtable)]) 264 | (base:read))))) 265 | (define maybe-editor 266 | (with-handlers ([exn:fail? (λ (e) 267 | (log-warning "~s" e) 268 | #f)]) 269 | (deserialize the-editor))) 270 | (new editor-snip% 271 | [editor maybe-editor] 272 | [serial-sexp the-editor])))) 273 | 274 | (define editor-snip-class (new editor-snip-class%)) 275 | 276 | ;; =================================================================================================== 277 | -------------------------------------------------------------------------------- /editor/private/editor.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "lang.rkt" 4 | racket/list 5 | racket/stxparam 6 | racket/class 7 | racket/splicing 8 | syntax/location 9 | racket/serialize 10 | racket/dict 11 | syntax/parse 12 | syntax/parse/define 13 | racket/runtime-path 14 | racket/match 15 | racket/stxparam 16 | racket/pretty 17 | (for-syntax racket/base 18 | racket/dict 19 | racket/class 20 | (submod "lang.rkt" key-submod) 21 | "log.rkt" 22 | syntax/modresolve 23 | racket/match 24 | racket/serialize 25 | racket/function 26 | syntax/location 27 | racket/syntax 28 | racket/path 29 | racket/pretty 30 | syntax/parse)) 31 | (provide (all-defined-out) 32 | (all-from-out "lang.rkt") 33 | (for-syntax all-defined-out)) 34 | 35 | (define EDITOR-SERIALIZE-VERSION 0) 36 | 37 | ;; Keys for hidden methods. Only functions in 38 | ;; this module should access these methods directly. 39 | (define serial-key (generate-member-key)) 40 | (define deserial-key (generate-member-key)) 41 | (define deserial-binding-key (member-name-key deserialize-binding)) 42 | (define copy-key (generate-member-key)) 43 | (define elaborator-key (member-name-key elaborate)) 44 | (define modpath-key (member-name-key get-modpath)) 45 | (define equal?-key (generate-member-key)) 46 | (define hash-key (generate-member-key)) 47 | (define hash2-key (generate-member-key)) 48 | 49 | (define editor-deserialize-for-elaborator 50 | (make-parameter #f)) 51 | 52 | (define editor-deserialize-for-text 53 | (make-parameter #f)) 54 | 55 | (module m->r racket/base 56 | (provide (all-defined-out)) 57 | (require racket/path 58 | racket/match 59 | syntax/parse/define 60 | syntax/modresolve 61 | syntax/location 62 | (for-syntax racket/base)) 63 | (define (modpath->relpath modpath) 64 | (if (path-string? modpath) 65 | (path-only modpath) 66 | modpath)) 67 | (define-syntax (this-mod-dir stx) 68 | (syntax/loc stx 69 | (resolve-module-path-index 70 | (module-path-index-join "here.rkt" #f))))) 71 | (require 'm->r (for-syntax 'm->r)) 72 | 73 | ;; Placed in a sub module because the define-interactive-syntax 74 | ;; template uses these bindings in a begin-for-syntax 75 | ;; block and the deserializer-submod block. 76 | (module elaborator-keys racket/base 77 | (provide (all-defined-out)) 78 | (require racket/class) 79 | (define elaborator-deserialize-key (generate-member-key)) 80 | (define elaborator-copy-key (generate-member-key))) 81 | (require (for-syntax 'elaborator-keys)) 82 | 83 | 84 | ;; Runtime test for persistence. In case the syntax check did not work. 85 | (define (runtime-persist? persist this [other #f]) 86 | (cond 87 | [(procedure? persist) (persist this other)] 88 | [else persist])) 89 | 90 | (define-syntax-parameter current-editor-modpath-mode 'user) 91 | (begin-for-syntax 92 | (define (package/quote-module-path . submods) 93 | (define this-mod 94 | (case (syntax-parameter-value #'current-editor-modpath-mode) 95 | [(user) 'editor/private/editor] 96 | [(package) (quote-module-path)])) 97 | (if (null? submods) 98 | this-mod 99 | `(submod ,this-mod ,@submods)))) 100 | 101 | ;; Finds the original source of an identifier. Assumes that 102 | ;; the module chain has already been loaded. 103 | ;; ModulePath Symbol -> (Pair ModulePathIndex Symbol) 104 | (define-for-syntax (identifier->original-identifier module sym [phase 0]) 105 | (define-values (vals stxs) 106 | (module->exports module 'defined-names)) 107 | (define binding 108 | (let* ([acc (dict-ref stxs phase)]) 109 | (dict-ref acc sym))) 110 | (match binding 111 | [`(() ,orig-sym) 112 | (cons module orig-sym)] 113 | [`(((,mpi ,shift-phase ,orig-sym ,orig-phase) ,rest ...) ,eventual-sym) 114 | (identifier->original-identifier mpi orig-sym orig-phase)] 115 | [`((,mpi ,rest ...) ,orig-sym) 116 | (identifier->original-identifier mpi sym phase)])) 117 | 118 | ;; Because deserialized editors use a pseudo-identifier 119 | ;; to resolve to an elaborator, we need to reconstruct a 120 | ;; racket identifier out of their symbol and modpath. 121 | ;; Unless find-original? is set to #f, this function will use 122 | ;; identifier->original-identifier to forge the defining identifier, 123 | ;; and puts the given identifier in the nominal source fields. 124 | ;; NOTE THIS DOES NOT ACTUALLY REQUIRE THE MODPATH, USE 125 | ;; syntax-local-lift-require FOR THAT!!!! (Rather, this uses 126 | ;; whatever module exists in the registry under that name.) 127 | ;; resolved-module-path? symbol? boolean? -> identifier? 128 | (define-for-syntax (forge-identifier modpath sym [find-original? #t]) 129 | (parameterize ([current-namespace (make-base-namespace)] 130 | [current-load-relative-directory (build-path (this-mod-dir) "..")]) 131 | (when find-original? 132 | (namespace-require modpath)) 133 | (define real-id (if find-original? 134 | (identifier->original-identifier modpath sym) 135 | (cons #f #f))) 136 | (define real-modpath (or (car real-id) modpath)) 137 | (define real-sym (or (cdr real-id) sym)) 138 | (let* ([acc (syntax-binding-set)] 139 | [acc (syntax-binding-set-extend acc sym 0 real-modpath 140 | #:source-symbol real-sym 141 | #:nominal-symbol sym 142 | #:nominal-module modpath)]) 143 | (syntax-binding-set->syntax acc sym)))) 144 | 145 | ;; Only introduced by #editor reader macro. Handles deserializing 146 | ;; the editor. 147 | ;; It shouldn't need to be a stuct, because the logic _should_ be part 148 | ;; of the reader proper. 149 | (begin-for-syntax 150 | (define read-#%editor 151 | (syntax-parser 152 | [(_ binding-information body) 153 | (parameterize ([current-load-relative-directory (this-mod-dir)]) 154 | (match-define `((,editor-binding ,editor-name) 155 | (,deserialize-binding ,deserialize-name) 156 | (,elaborator-binding ,elaborator-name)) 157 | (deserialize (syntax->datum #'binding-information))) 158 | (define same-mod? (equal? (resolve-module-path-index elaborator-binding) 159 | (this-mod-dir))) 160 | ;; If the editor definition and use are from the same file, 161 | ;; then the current module is not yet named. 162 | ;; So eval variable-reference to get it. 163 | (define/syntax-parse elaborator 164 | (if same-mod? 165 | (forge-identifier 166 | (variable-reference->module-path-index (eval #'(#%variable-reference))) 167 | elaborator-name 168 | #f) 169 | (forge-identifier elaborator-binding elaborator-name))) 170 | (define/syntax-parse that-syntax (syntax-local-introduce #`#,this-syntax)) 171 | ;(pretty-write (identifier-binding #'elaborator)) 172 | ;(pretty-write (syntax-debug-info #'elaborator)) 173 | #'(elaborator body that-syntax))])) 174 | (struct #%editor-struct () 175 | #:property prop:procedure 176 | (λ (this stx) (read-#%editor stx)) 177 | #:property prop:match-expander 178 | read-#%editor)) 179 | (define-syntax #%editor (#%editor-struct)) 180 | 181 | ;; Returns an identifier that contains 182 | ;; the binding for an editor, elaborator, and deserializer. 183 | ;; To be put into the #editor()() form. 184 | ;; (is-a?/c editor$) -> (listof (list module-path-index? symbol?)) 185 | (define (editor->elaborator editor) 186 | (define-member-name elaborator elaborator-key) 187 | (define-member-name deserialize-binding deserial-binding-key) 188 | (define-member-name modpath modpath-key) 189 | (define binding ((send editor deserialize-binding))) 190 | (list (send editor modpath) 191 | (if (pair? binding) 192 | (list (cdr binding) (car binding)) 193 | (list #"???" #"???")) 194 | (send editor elaborator))) 195 | 196 | ;; Deserializes an editor, but giving a new modpath for its 197 | ;; deserialize id. 198 | ;; An optional dictionary of children can be provided to rehome 199 | ;; child elements in the editor as well. 200 | ;; editor : An editor instance 201 | ;; new-modpath : Any value given to prop:serialize's deserialize-id 202 | ;; children : (Dictof ) 203 | (define (serialize+rehome editor new-modpath 204 | #:deserialize-relative-directory [rel-to #f] 205 | #:children [children* #f]) 206 | (define-member-name deserial-binding deserial-binding-key) 207 | (define children (or children* (hash))) 208 | (let loop ([child# (dict-iterate-first children)]) 209 | (if child# 210 | (parameterize ([(send (dict-iterate-key children child#) deserial-binding) 211 | (dict-iterate-value children child#)]) 212 | (loop (dict-iterate-next children child#))) 213 | (parameterize ([(send editor deserial-binding) new-modpath]) 214 | (serialize editor #:deserialize-relative-directory rel-to))))) 215 | 216 | ;; Macros used by state variables (getter, setter, init) 217 | (module state-macros racket/base 218 | (provide (all-defined-out)) 219 | (require syntax/parse/define 220 | racket/class 221 | (for-syntax racket/base)) 222 | (define-syntax-parser define-init 223 | [(_ name:id default #f) 224 | (syntax/loc this-syntax 225 | (define name default))] 226 | [(_ name:id default #t) 227 | (syntax/loc this-syntax 228 | (define-init name default (λ (x) x)))] 229 | [(_ name:id default init-proc) 230 | (quasisyntax/loc this-syntax 231 | (begin 232 | (init [(ist name) default]) 233 | #,(syntax/loc this-syntax 234 | (define name (init-proc ist)))))]) 235 | 236 | (define-syntax-parser define-getter 237 | [(_ _:id _:id #f) 238 | (syntax/loc this-syntax (void))] 239 | [(_ state:id getter:id #t) 240 | (quasisyntax/loc this-syntax 241 | (define-getter state getter #,(syntax/loc this-syntax (λ () state))))] 242 | [(_ _:id getter:id body) 243 | (syntax/loc this-syntax (define/public getter body))]) 244 | 245 | (define-syntax-parser define-setter 246 | [(_ _:id _:id #f) 247 | (syntax/loc this-syntax (void))] 248 | [(_ state:id setter:id #t) 249 | (quasisyntax/loc this-syntax 250 | (define-setter state setter #,(syntax/loc this-syntax (λ (new-val) (set! state new-val)))))] 251 | [(_ _:id setter:id body) 252 | (syntax/loc this-syntax (define/public setter body))])) 253 | (require 'state-macros (for-syntax 'state-macros)) 254 | 255 | (begin-for-syntax 256 | (define-syntax-class defelaborate 257 | #:attributes (type 258 | data 259 | this-editor 260 | [body 1] 261 | struct) 262 | #:literals (define-elaborator) 263 | (pattern (define-elaborator data 264 | (~optional (~seq #:this-editor this-editor)) 265 | body ...+) 266 | #:attr struct #f 267 | #:attr type 'simple) 268 | (pattern (define-elaborator 269 | struct) 270 | #:attr data #f 271 | #:attr this-editor #f 272 | #:attr (body 1) (list #'#'#f) 273 | #:attr type 'struct)) 274 | (define-splicing-syntax-class defstate-options 275 | (pattern (~seq 276 | (~alt (~optional (~seq #:persistence persistence) #:defaults ([persistence #'#t])) 277 | (~optional (~seq #:getter getter) #:defaults ([getter #'#f])) 278 | (~optional (~seq #:setter setter) #:defaults ([setter #'#f])) 279 | (~optional (~seq #:serialize serialize) #:defaults ([serialize #'#f])) 280 | (~optional (~seq #:deserialize deserialize) #:defaults ([deserialize #'#f])) 281 | (~optional (~seq #:init init) #:defaults ([init #'#f])) 282 | (~optional (~seq #:elaborator elaborator) #:defaults ([elaborator #'#f])) 283 | (~optional (~seq #:elaborator-default elaborator-default) 284 | #:defaults ([elaborator-default #'#f])) 285 | (~optional (~seq #:elaborator-deserialize elaborator-deserialize) 286 | #:defaults ([elaborator-deserialize #'#f])) 287 | (~once default)) 288 | ...))) 289 | (define-syntax-class defstate 290 | #:literals (define-state) 291 | (pattern (define-state marked-name:id 292 | options:defstate-options) 293 | #:attr name (editor-syntax-introduce (attribute marked-name)) 294 | #:attr getter-name (format-id this-syntax "get-~a" #'name) 295 | #:attr setter-name (format-id this-syntax "set-~a!" #'name) 296 | #:attr default #'options.default 297 | #:attr init #'options.init 298 | #:attr persistence #'options.persistence 299 | #:attr getter #'options.getter 300 | #:attr setter #'options.setter 301 | #:attr serialize #'options.serialize 302 | #:attr deserialize #'options.deserialize 303 | #:attr elaborator #'options.elaborator 304 | #:attr elaborator-default #'options.elaborator-default 305 | #:attr elaborator-deserialize #'options.elaborator-deserialize))) 306 | 307 | (define-syntax-parameter define-elaborator 308 | (syntax-parser 309 | [de:defelaborate 310 | (raise-syntax-error 'define-elaborator "Use outside of define-interactive-syntax is an error" this-syntax)])) 311 | 312 | (define-syntax-parameter define-state 313 | (syntax-parser 314 | [x:defstate 315 | (raise-syntax-error 'define-state "Use outside of define-interactive-syntax is an error" this-syntax)])) 316 | 317 | ;; We don't want to get editor classes when 318 | ;; deserializing new editors. 319 | (define deserialize-editor-classes? 320 | (make-parameter #t)) 321 | 322 | ;; Each editor definition has three parts: 323 | ;; 1. A phase 1 elaboration 324 | ;; 2. A submodule with interaction code 325 | ;; 3. A deserializer submodule 326 | (define-syntax (~define-interactive-syntax stx) 327 | (syntax-parse stx 328 | [(_ orig-stx name:id supclass (interfaces ...) 329 | (~alt (~optional (~seq #:base? b?) #:defaults ([b? #'#f])) 330 | (~optional (~seq #:mixin mixin))) 331 | ... 332 | (~and 333 | (~seq (~alt plain-state:defstate 334 | (~optional elaborator:defelaborate 335 | #:defaults ([elaborator.type 'simple] 336 | [elaborator.data #'this-data] 337 | [elaborator.this-editor #'#f] 338 | [(elaborator.body 1) 339 | (list #'#'#f)])) ; ??? #'#'this-editor instead ??? 340 | internal-body) ...) 341 | (~seq body ...))) 342 | #:with marked-name (editor/user-syntax-introduce #'name) 343 | #:with marked-supclass (editor/user-syntax-introduce #'supclass) 344 | #:with elaborator-name (format-id #'orig-stx "~a:elaborate" #'name) 345 | #:with name-deserialize (format-id #'orig-stx "~a:deserialize" #'name) 346 | #:with (marked-interfaces ...) (editor/user-syntax-introduce #'(interfaces ...)) 347 | #:with (marked-body ...) (editor/user-syntax-introduce #'(body ...) 'add) 348 | #:with (state:defstate ...) (editor/user-syntax-introduce #'(plain-state ...)) 349 | #:with serialize-method (gensym 'serialize) 350 | #:with deserialize-method (gensym 'deserialize) 351 | #:with deserialize-binding-method (gensym 'deserialize-binding) 352 | #:with copy-method (gensym 'copy) 353 | #:with elaborator-method (gensym 'elaborator) 354 | #:with modpath-method (gensym 'get-modpath) 355 | #:with elaborator-deserialize-method (gensym 'deserialize) 356 | #:with elaborator-copy-method (gensym 'copy) 357 | #:with equal?-method (gensym 'equal?) 358 | #:with hash-method (gensym 'hash/) 359 | #:with hash2-method (gensym 'hash2/) 360 | #:with (state-methods ...) (for/list ([i (in-list (attribute state.getter-name))]) 361 | (gensym (syntax->datum i))) 362 | (unless (or (eq? 'module-begin (syntax-local-context)) (eq? 'module (syntax-local-context))) 363 | (raise-syntax-error #f "Must be defined at the module level" #'orig-stx)) 364 | (define m? (and (attribute mixin) #t)) 365 | (define base? (syntax-e (attribute b?))) 366 | (define/syntax-parse public/override 367 | (if base? #'public #'override)) 368 | (define (deserialize-proc rec for-editor?) 369 | #`(λ (data) 370 | (define sup (vector-ref data 0)) 371 | (define key (vector-ref data 1)) 372 | (define table (vector-ref data 2)) 373 | #,(if base? 374 | #`(void) 375 | #`(super #,rec (if (eq? 'name key) 376 | sup 377 | data))) 378 | (unless (eq? key 'name) 379 | (log-editor-warning "Missing data for key ~a, trying super" 380 | 'name)) 381 | (when (eq? key 'name) 382 | (void) 383 | #,@(for/list ([i (in-list (attribute state.marked-name))] 384 | [p? (in-list (attribute state.persistence))] 385 | [s? (in-list (attribute state.setter))] 386 | [d? (in-list (attribute state.deserialize))] 387 | [e? (in-list (attribute state.elaborator))]) 388 | (define key (syntax->datum i)) 389 | #`(when (hash-has-key? table '#,key) 390 | (define des-proc #,(if for-editor? d? #f)) 391 | (define maybe-other-val (hash-ref table '#,key)) 392 | (define other-val (if des-proc 393 | (des-proc maybe-other-val) 394 | maybe-other-val)) 395 | #,(if for-editor? 396 | #`(let ([p* #,p?]) 397 | (case p* 398 | [(#t) (set! #,i other-val)] 399 | [(#f) (void)] 400 | [else (set! #,i (p* #,i other-val))])) 401 | #`(set! #,i other-val))))))) 402 | (define (copy-proc rec) 403 | #`(λ (other) 404 | #,(if base? 405 | #`(void) 406 | #`(super #,rec other)) 407 | (set! state.marked-name (send other state-methods)) ...)) 408 | (define (equal?-proc rec) 409 | #`(λ (other equal?/rec) 410 | (and #,(if base? 411 | #'#t 412 | #`(super #,rec other equal?/rec)) 413 | (let () 414 | (define left (state-methods)) 415 | (define right (send other state-methods)) 416 | (or (not (runtime-persist? state.persistence left other)) 417 | (equal?/rec left right))) ...))) 418 | (define (hash-proc rec) 419 | #`(λ (hash/rec) 420 | (+ #,(if base? 421 | #'0 422 | #`(super #,rec hash/rec)) 423 | (let () 424 | (define left (state-methods)) 425 | (if (runtime-persist? state.persistence left) 426 | (hash/rec left) 427 | 0)) ...))) 428 | (define (hash2-proc rec) 429 | #`(λ (hash2/rec) 430 | (* #,(if base? 431 | #'1 432 | #`(super #,rec hash2/rec)) 433 | (let () 434 | (define left (state-methods)) 435 | (if (runtime-persist? state.persistence left) 436 | (hash2/rec left) 437 | 1)) ...))) 438 | #`(begin 439 | #,@(if m? 440 | (list) 441 | (list #'(provide elaborator-name) 442 | #'(begin-for-syntax 443 | (let () 444 | (define b (continuation-mark-set-first #f editor-list-key)) 445 | (when (and b (box? b)) 446 | (set-box! b (cons #'name (unbox b)))))))) 447 | ;; Submodule for deserialization, used by both editor submodule 448 | ;; and begin-for-syntax elaborator. 449 | (deserializer-submod 450 | (provide name-deserialize) 451 | (#%require racket/class 452 | #,(package/quote-module-path) 453 | #,(package/quote-module-path 'elaborator-keys)) 454 | (define-member-name serialize-method serial-key) 455 | (define-member-name deserialize-method deserial-key) 456 | (define-member-name deserialize-binding-method deserial-binding-key) 457 | (define-member-name copy-method copy-key) 458 | (define-member-name elaborator-method elaborator-key) 459 | (define-member-name modpath-method modpath-key) 460 | (define-member-name elaborator-deserialize-method elaborator-deserialize-key) 461 | (define-member-name elaborator-copy-method elaborator-copy-key) 462 | (define (get-name) 463 | (cond [(editor-deserialize-for-elaborator) 464 | (namespace-require `(for-template ,(quote-module-path ".."))) 465 | (namespace-variable-value 'name)] 466 | [else 467 | (dynamic-require (quote-module-path ".." editor) 468 | 'name)])) 469 | (define name-deserialize 470 | (make-deserialize-info 471 | (λ (version args) 472 | (cond [(editor-deserialize-for-text) 473 | (vector version args)] 474 | [else 475 | (define this (new (get-name))) 476 | (cond [(editor-deserialize-for-elaborator) 477 | (send this elaborator-deserialize-method args)] 478 | [else 479 | (send this deserialize-method args)]) 480 | this])) 481 | (λ () 482 | (cond [(editor-deserialize-for-text) 483 | (define vec (make-vector #f)) 484 | (values vec 485 | (λ (other) 486 | (vector-set! vec 0 other)))] 487 | [else 488 | (define pattern (new (get-name))) 489 | (values pattern 490 | (λ (other) 491 | (cond [(editor-deserialize-for-elaborator) 492 | (send pattern elaborator-copy-method other)] 493 | [else 494 | (send pattern copy-method other)])))]))))) 495 | ;; Main editor class 496 | (editor-submod 497 | (provide name) 498 | (#%require #,(package/quote-module-path)) 499 | (define this-modpath 500 | (variable-reference->module-path-index (#%variable-reference))) 501 | (define-runtime-module-path-index this-filepath ".") 502 | (define-member-name serialize-method serial-key) 503 | (define-member-name deserialize-method deserial-key) 504 | (define-member-name deserialize-binding-method deserial-binding-key) 505 | (define-member-name copy-method copy-key) 506 | (define-member-name elaborator-method elaborator-key) 507 | (define-member-name modpath-method modpath-key) 508 | (define-member-name equal?-method equal?-key) 509 | (define-member-name hash-method hash-key) 510 | (define-member-name hash2-method hash2-key) 511 | (splicing-syntax-parameterize 512 | ([define-state 513 | (syntax-parser 514 | [st:defstate 515 | #`(begin 516 | #,(syntax/loc #'st 517 | (define-init st.marked-name st.default st.init)) 518 | #,(syntax/loc #'st 519 | (define-getter st.marked-name st.getter-name st.getter)) 520 | #,(syntax/loc #'st 521 | (define-setter st.marked-name st.setter-name st.setter)))])] 522 | [define-elaborator 523 | (syntax-parser 524 | [de:defelaborate 525 | #'(begin)])]) 526 | (define deserialize-binding 527 | (make-parameter 528 | (cons 'name-deserialize 529 | (module-path-index-join '(submod ".." deserializer) this-modpath)))) 530 | (define-syntax marked-name (make-rename-transformer #'name)) 531 | (define #,(if m? #'(name mixin) #'name) 532 | (let () 533 | (define-local-member-name state-methods) ... 534 | (class/derived 535 | orig-stx 536 | (name 537 | #,(if m? #'(supclass mixin) #'marked-supclass) 538 | ((interface* () ([prop:serializable 539 | (make-serialize-info 540 | (λ (this) 541 | (define ret 542 | (vector 543 | EDITOR-SERIALIZE-VERSION 544 | (send this serialize-method))) 545 | ret) 546 | deserialize-binding 547 | #t 548 | (or (current-load-relative-directory) (current-directory)))] 549 | [prop:equal+hash 550 | (list (λ (this other rec) 551 | (send this equal?-method other rec)) 552 | (λ (this rec) 553 | (send this hash-method rec)) 554 | (λ (this rec) 555 | (send this hash2-method rec)))])) 556 | marked-interfaces ...) 557 | #f) 558 | (define (elaborator-method) 559 | #,(if m? 560 | #'(list this-modpath #f) 561 | #'(list (module-path-index-join '(submod "..") this-modpath) 562 | 'elaborator-name))) 563 | (public/override elaborator-method) 564 | (define (serialize-method) 565 | (vector #,(if base? 566 | #'#f 567 | #`(super serialize-method)) 568 | 'name 569 | (let () 570 | (define state-vars 571 | `((state.marked-name 572 | ,state.marked-name 573 | ,state.persistence 574 | ,state.serialize) 575 | ...)) 576 | (for/hash ([var (in-list state-vars)] 577 | #:when (third var)) 578 | (define val (second var)) 579 | (define serial-proc (fourth var)) 580 | (values (first var) (if serial-proc 581 | (serial-proc val) 582 | val)))))) 583 | (public/override serialize-method) 584 | (define deserialize-method 585 | #,(deserialize-proc #'deserialize-method #t)) 586 | (public/override deserialize-method) 587 | (define copy-method 588 | #,(copy-proc #'copy-method)) 589 | (public/override copy-method) 590 | (define (deserialize-binding-method) 591 | deserialize-binding) 592 | (public/override deserialize-binding-method) 593 | (define (modpath-method) 594 | (list this-modpath 'name)) 595 | (public/override modpath-method) 596 | (define equal?-method 597 | #,(equal?-proc #'equal?-method)) 598 | (public/override equal?-method) 599 | (define hash-method 600 | #,(hash-proc #'hash-method)) 601 | (public/override hash-method) 602 | (define hash2-method 603 | #,(hash2-proc #'hash2-method)) 604 | (public/override hash2-method) 605 | (define/public (state-methods) state.marked-name) ... 606 | marked-body ...))))) 607 | ;; Special class used by elaborator for deserialization. 608 | ;; Because can't init racket/gui/base twice in one process... 609 | (begin-for-syntax 610 | (provide name) 611 | (define-member-name elaborator-deserialize-method elaborator-deserialize-key) 612 | (define-member-name elaborator-copy-method elaborator-copy-key) 613 | (define #,(if m? #'(name $) #'name) 614 | (let () 615 | (define-local-member-name state-methods) ... 616 | (class #,(cond [base? #'object%] 617 | [m? #'(supclass $)] 618 | [else #'marked-supclass]) 619 | (super-new) 620 | (define elaborator-deserialize-method 621 | #,(deserialize-proc #'elaborator-deserialize-method #f)) 622 | (public/override elaborator-deserialize-method) 623 | (define elaborator-copy-method 624 | #,(copy-proc #'elaborator-copy-method)) 625 | (public/override elaborator-copy-method) 626 | (define/public (state-methods) state.marked-name) ... 627 | (define state.marked-name state.elaborator-default) ... 628 | (define-getter state.marked-name state.getter-name state.elaborator) ...)))) 629 | ;; Elaborator must be split into two parts to bind the 630 | ;; elaborator.this-editor in the template. 631 | (define-syntax-parser elaborator-inside 632 | [(_ data-id:id data orig) 633 | (syntax-parse #'orig 634 | [_ 635 | #:do [(define elaborator.data 636 | (parameterize ([(dynamic-require 637 | '#,(package/quote-module-path) 638 | 'editor-deserialize-for-elaborator) #t] 639 | [current-load-relative-directory (this-mod-dir)]) 640 | (deserialize (syntax->datum #'data)))) 641 | (define/syntax-parse 642 | #,(if (syntax->datum #'elaborator.this-editor) 643 | #'elaborator.this-editor 644 | #'ignored-binding) 645 | #'data-id)] 646 | elaborator.body ...])]) 647 | (define-syntax elaborator-name 648 | #,(case (attribute elaborator.type) 649 | [(struct) 650 | #'elaborator.struct] 651 | [(simple) 652 | #`(elaborator-transformer #'elaborator-inside elaborator.this-editor)])))])) 653 | 654 | 655 | ;; When `use-elaborate-this? is true, it corresponds to `#:this-editor _id`, and _id gets bound 656 | ;; to the editor object at phase 0. Otherwise no run-time deserialization is needed. 657 | (define-for-syntax (elaborator-transformer inside use-elaborator-this?) 658 | (syntax-parser 659 | [(_ data orig) 660 | #:with elaborator-inside inside 661 | (if use-elaborator-this? 662 | #`(splicing-let ([data-id 663 | (parameterize ([current-load-relative-directory (this-mod-dir)]) 664 | (deserialize 'data))]) 665 | (elaborator-inside data-id data orig)) 666 | #'(elaborator-inside data-id data orig))])) 667 | 668 | (define-syntax (define-base-editor* stx) 669 | (syntax-parse stx 670 | [(_ name:id super (interfaces ...) body ...) 671 | #`(~define-interactive-syntax #,stx name super (interfaces ...) #:base? #t body ...)])) 672 | 673 | (define-syntax (define-interactive-syntax stx) 674 | (syntax-parse stx 675 | [(_ name:id super 676 | (~or (~optional (~seq #:interfaces (interfaces ...)) #:defaults ([(interfaces 1) '()]))) 677 | ... 678 | body ...) 679 | #`(~define-interactive-syntax #,stx name super (interfaces ...) body ...)])) 680 | 681 | ;; Mixin-editors are not at module level, and thus are not 682 | ;; implicetly provided by the ~define-interactive-syntax helper macro. 683 | (define-syntax (define-interactive-syntax-mixin stx) 684 | (syntax-parse stx 685 | [(_ name:id 686 | (~or (~optional (~seq #:interfaces (interfaces ...)) #:defaults ([(interfaces 1) '()])) 687 | (~optional (~seq #:mixins (mixins ...)) #:defaults ([(mixins 1) '()])) 688 | (~optional (~seq #:super $) #:defaults ([$ #'super]))) 689 | ... 690 | body ...) 691 | #:with (marked-mixins ...) (editor/user-syntax-introduce #'(mixins ...) 'add) 692 | #`(begin 693 | (begin-for-syntax 694 | (let () 695 | (define b (continuation-mark-set-first #f editor-mixin-list-key)) 696 | (when (and b (box? b)) 697 | (set-box! b (cons #'name (unbox b)))))) 698 | (~define-interactive-syntax #,stx 699 | name 700 | (compose #,@(reverse (attribute marked-mixins))) 701 | (interfaces ...) 702 | #:mixin $ 703 | body ...))])) 704 | 705 | 706 | ;; Helper macro for struct-style macros in define-elaborator 707 | ;; Auto deserializes the editor 708 | (define-syntax-parser elaborator-parser 709 | [(_ data body ...+) 710 | #'(syntax-parser 711 | [(_ data-stx orig) 712 | (syntax-parse #'orig 713 | [_ 714 | #:do [(define data 715 | (parameterize ([editor-deserialize-for-elaborator #t] 716 | [current-load-relative-directory (this-mod-dir)]) 717 | (deserialize (syntax->datum #'data-stx))))] 718 | body ...])])]) 719 | -------------------------------------------------------------------------------- /editor/private/editselect.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (all-defined-out)) 4 | (require racket/splicing 5 | "editor.rkt" 6 | (for-syntax racket/base)) 7 | 8 | (splicing-syntax-parameterize ([current-editor-lang "../lang.rkt"] 9 | [current-editor-base '(submod "../base.rkt" editor)] 10 | [current-editor-modpath-mode 'package]) 11 | (begin-for-interactive-syntax) ; <--- TODO...WHY!!! 12 | (require syntax/location 13 | "context.rkt" 14 | syntax/parse 15 | (prefix-in gui: racket/gui/base) 16 | racket/class 17 | racket/serialize 18 | racket/port 19 | images/icons/style 20 | images/icons/control 21 | (prefix-in gui: racket/gui/base) 22 | syntax/modread 23 | "stdlib.rkt" 24 | (for-editor "context.rkt" 25 | racket/class 26 | (prefix-in gui: racket/gui/base) 27 | racket/async-channel)) 28 | 29 | (define-interactive-syntax picker$ dialog$ 30 | (inherit get-frame 31 | set-result! 32 | show) 33 | (super-new) 34 | (new label$ [parent this] 35 | [text "Select Interactive-Syntax Extension"]) 36 | 37 | (new blank$ [parent this] 38 | [height 3]) 39 | (define items-row (new horizontal-block$ [parent this])) 40 | (define label-col (new vertical-block$ [parent items-row])) 41 | (define field-col (new vertical-block$ [parent items-row])) 42 | (new blank$ [parent this] 43 | [height 3]) 44 | (define confirm-row (new horizontal-block$ [parent this])) 45 | 46 | (new label$ [parent label-col] 47 | [text "Module:"]) 48 | (new blank$ [parent label-col] 49 | [height 1]) 50 | (new label$ [parent label-col] 51 | [text "Interactive Syntax:"]) 52 | (new button$ [parent confirm-row] 53 | [label (new label$ [text "Cancel"])] 54 | [callback (λ (button event) 55 | (show #f))]) 56 | (define ok-space (new blank$ [parent confirm-row] 57 | [width 5])) 58 | (define ok-button 59 | (new button$ [parent confirm-row] 60 | [label (new label$ [text "Insert"])] 61 | [callback (λ (b event) 62 | (set-result! 63 | (cons (send mod-name get-text) 64 | (send editor-name get-text))) 65 | (show #f))])) 66 | 67 | (define mod-name (new field$ [parent field-col] 68 | [callback (λ (t e) 69 | (update-width!))])) 70 | (new blank$ [parent field-col] 71 | [height 1]) 72 | (define editor-name (new field$ [parent field-col] 73 | [callback (λ (t e) 74 | (update-width!))])) 75 | 76 | (define (update-width!) 77 | (define-values (mw mh) (send mod-name get-extent)) 78 | (define-values (ew eh) (send editor-name get-extent)) 79 | (define-values (ow oh) (send ok-button get-extent)) 80 | (define width (max mw ew)) 81 | (send ok-space set-width! (max 0 (+ width 40)))) 82 | (update-width!)) 83 | 84 | (begin-for-interactive-syntax 85 | (provide get-module) 86 | (define (get-module [parent #f]) 87 | (define f (new gui:dialog% [parent parent] 88 | [label "Interactive Syntax Selector"])) 89 | (define p (new picker$ 90 | [frame f])) 91 | (send p show #t) 92 | (send p get-result))) 93 | 94 | (define insert-button 95 | (list "Insert Editor" 96 | (record-icon #:color "red" 97 | #:height (toolbar-icon-height)) 98 | (λ (this) 99 | (define get-module (dynamic-require (from-editor (quote-module-path)) 'get-module)) 100 | (define text (send this get-definitions-text)) 101 | (define text-surrogate (send text get-surrogate)) 102 | (define the-editor (get-module this)) 103 | (writeln the-editor) 104 | (when (and the-editor (pair? the-editor)) 105 | (define editor-class$ 106 | (cond 107 | [(equal? (car the-editor) "") 108 | (define out (open-output-bytes)) 109 | (define mod-name (send text-surrogate get-mod-name)) 110 | (parameterize* ([current-namespace (send text-surrogate get-editor-namespace)] 111 | #;[current-namespace (module->namespace (from-editor `',mod-name))]) 112 | (namespace-require (from-editor mod-name)) 113 | (namespace-variable-value (with-input-from-string (cdr the-editor) read)))] 114 | [else 115 | (define directory (send (send this get-current-tab) get-directory)) 116 | (unless directory 117 | (error 'editor "Could not determine the current dirrectory")) 118 | (define read-path (with-input-from-string (car the-editor) read)) 119 | (define full-path 120 | (if (or (not (path-string? read-path)) 121 | (and (path-string? read-path) 122 | (absolute-path? read-path))) 123 | read-path 124 | (build-path directory read-path))) 125 | (with-handlers ([exn:fail? (λ (e) 126 | (error 'editor "Could not load ~a in ~a got ~s" 127 | (cdr the-editor) 128 | full-path 129 | e))]) 130 | (parameterize* ([current-namespace (send text-surrogate get-editor-namespace)] 131 | #;[current-namespace (module->namespace (from-editor full-path))]) 132 | (namespace-require (from-editor full-path)) 133 | (namespace-variable-value 134 | (with-input-from-string (cdr the-editor) read))))])) 135 | (send text insert (new editor-snip% 136 | [editor (new editor-class$)] 137 | [namespace (send text-surrogate get-editor-namespace)] 138 | [mod-name (send text-surrogate get-mod-name)])))) 139 | #f))) 140 | -------------------------------------------------------------------------------- /editor/private/event.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (all-defined-out)) 4 | (require racket/gui/base 5 | racket/class) 6 | 7 | #| Use control-event% 8 | (define text-change-event% 9 | (class event% 10 | (super-new) 11 | (init-field [text ""]) 12 | (define/public (get-text) 13 | text) 14 | (define/public (set-text! t) 15 | (set! text t)))) 16 | |# -------------------------------------------------------------------------------- /editor/private/fallback.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/splicing 4 | "editor.rkt" 5 | (for-syntax racket/base)) 6 | 7 | (splicing-syntax-parameterize ([current-editor-lang "../lang.rkt"] 8 | [current-editor-base '(submod "../base.rkt" editor)] 9 | [current-editor-modpath-mode 'package]) 10 | (require "stdlib.rkt") 11 | 12 | (define-interactive-syntax fallback$ base$ 13 | (super-new))) 14 | -------------------------------------------------------------------------------- /editor/private/lang.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (all-defined-out) 4 | (all-from-out "log.rkt") 5 | (for-syntax (all-defined-out))) 6 | 7 | (require racket/class 8 | racket/serialize 9 | racket/stxparam 10 | racket/splicing 11 | racket/match 12 | syntax/location 13 | syntax/parse/define 14 | "log.rkt" 15 | (for-syntax racket/base 16 | racket/list 17 | racket/match 18 | racket/function 19 | racket/require-transform 20 | racket/provide-transform 21 | racket/syntax 22 | syntax/parse 23 | syntax/parse/lib/function-header 24 | syntax/location 25 | racket/serialize)) 26 | 27 | ;; To be able to instantiate the found editors, we need each 28 | ;; module to be able to track the editors created in its 29 | ;; (partially defined) file. 30 | (module key-submod racket/base 31 | ;(#%declare #:cross-phase-persistent) 32 | (provide editor-list-key editor-mixin-list-key) 33 | (define editor-list-key 'editor-list-cmark-key) 34 | (define editor-mixin-list-key 'editor-mixin-list-cmark-key)) 35 | (require (for-syntax 'key-submod)) 36 | 37 | ;; =================================================================================================== 38 | 39 | ;; Because we use lang in building the stdlib, which is exported 40 | ;; as part of the lang, we want to use racket/base to bootstrap 41 | ;; that language. 42 | (define-syntax-parameter current-editor-lang 'editor/lang) 43 | (define-syntax-parameter current-editor-base '(submod editor/base editor)) 44 | 45 | (define-for-syntax editor-syntax-introduce (make-syntax-introducer #t)) 46 | (define-for-syntax user-syntax-introduce (make-syntax-introducer #t)) 47 | (define-for-syntax (editor/user-syntax-introduce stx [type 'add]) 48 | (user-syntax-introduce (editor-syntax-introduce stx type) type)) 49 | 50 | ;; Creates a box for storing submodule syntax pieces. 51 | ;; Note that this box is newly instantiated for every module 52 | ;; that defines new editor types. 53 | (begin-for-syntax 54 | (struct submod-data (forms 55 | lifted) 56 | #:transparent 57 | #:mutable) 58 | (define the-submod-data (submod-data '() #f)) 59 | (define deserializer-submod-data (submod-data '() #f)) 60 | (define (add-syntax-to-submod! stx submod submod-name 61 | #:lang-submod [lang-submod #f] 62 | #:base-submod [base-submod #f] 63 | #:scopes [scp #f] 64 | #:required? [req? #t]) 65 | (define existing (submod-data-forms submod)) 66 | (when (and (not (submod-data-lifted submod)) req?) 67 | (syntax-local-lift-module-end-declaration 68 | #`(#,submod-name 69 | #,@(if base-submod (list base-submod) '()) 70 | #,@(if lang-submod (list lang-submod) '()))) 71 | (set-submod-data-lifted! submod #t)) 72 | (set-submod-data-forms! submod (append (reverse (syntax->list stx)) existing))) 73 | (define (add-syntax-to-editor! stx 74 | #:scopes [scp #f] 75 | #:required? [req? #t]) 76 | (add-syntax-to-submod! stx the-submod-data 77 | #'define-interactive-syntax-submodule 78 | #:base-submod (syntax-parameter-value #'current-editor-base) 79 | #:lang-submod (syntax-parameter-value #'current-editor-lang) 80 | #:scopes scp 81 | #:required? req?)) 82 | (define (add-syntax-to-deserializer! stx 83 | #:scopes [scp #f] 84 | #:required? [req? #t]) 85 | (add-syntax-to-submod! stx deserializer-submod-data 86 | #'define-deserializer-submodule 87 | #:base-submod 'racket/base 88 | #:scopes scp 89 | #:required? req?))) 90 | 91 | (define-syntax (editor-submod stx) 92 | (syntax-parse stx 93 | [(_ (~or (~optional (~seq #:required? req?:boolean) #:defaults ([req? #'#t]))) 94 | body ...) 95 | (case (syntax-local-context) 96 | [(module) 97 | (add-syntax-to-editor! (syntax-local-introduce #'(body ...)) 98 | #:scopes (let ([_ (attribute body)]) 99 | (if (pair? _) (car _) #f)) 100 | #:required? (syntax-e #'req?)) 101 | #'(begin)] 102 | [else #`(begin #,stx)])])) 103 | 104 | (define-syntax (deserializer-submod stx) 105 | (syntax-parse stx 106 | [(_ body ...) 107 | (case (syntax-local-context) 108 | [(module) 109 | (add-syntax-to-deserializer! (syntax-local-introduce #'(body ...)) 110 | #:scopes (let ([_ (attribute body)]) 111 | (if (pair? _) (car _) #f))) 112 | #'(begin)] 113 | [else #'(begin #,stx)])])) 114 | 115 | (define-for-syntax (wrap-scope scopes stx) 116 | (datum->syntax scopes (syntax-e stx))) 117 | 118 | (define-syntax-parser define-interactive-syntax-submodule 119 | [(_ base lang) 120 | (define base-scope 121 | (editor-syntax-introduce (syntax-local-introduce (datum->syntax #f #f)))) 122 | #`(module* editor racket/base 123 | (require #,(wrap-scope base-scope #'base) 124 | #,(wrap-scope base-scope #'lang) 125 | racket/serialize 126 | racket/class) 127 | #,@(map syntax-local-introduce (reverse (submod-data-forms the-submod-data))))]) 128 | 129 | (define-syntax-parser define-deserializer-submodule 130 | [(_ base) 131 | (define base-scope 132 | (editor-syntax-introduce (syntax-local-introduce (datum->syntax #f #f)))) 133 | #`(module* deserializer racket/base 134 | (require #,(wrap-scope base-scope #'base) 135 | racket/serialize 136 | racket/class) 137 | #,@(map syntax-local-introduce (reverse (submod-data-forms deserializer-submod-data))))]) 138 | 139 | ;; =================================================================================================== 140 | 141 | ;; Expand for-editor to a recognized module path 142 | ;; editor-module-path? -> module-path? 143 | (define-for-syntax (expand-editor-req-path path) 144 | (match path 145 | [`(from-editor ',mod) 146 | `(submod ".." mod editor)] 147 | [`(from-editor (submod ".." ,subpath ...)) 148 | `(submod ".." ".." ,@subpath editor)] 149 | [`(from-editor (submod "." ,subpath ...)) 150 | `(submod ".." ,@subpath editor)] 151 | [`(from-editor (submod ,subpath ...)) 152 | `(submod ,@subpath editor)] 153 | [`(from-editor ,mod) 154 | `(submod ,mod editor)] 155 | [_ path])) 156 | 157 | ;; Test to see if the given submodule exists. 158 | ;; If it does, then require it, otherwise `(begin)`. 159 | ;; Must only be used at top/module level. 160 | (define-syntax-parser maybe-require-submod 161 | [(_ phase mod-path) 162 | (define expanded-modpath (expand-editor-req-path `(from-editor ,(syntax->datum #'mod-path)))) 163 | (when (or (with-handlers* ([exn:fail? (λ (e) #f)]) 164 | (module-declared? 165 | (convert-relative-module-path expanded-modpath) 166 | #t)) 167 | (with-handlers* ([exn:fail? (λ (e) #f)]) 168 | (expand-import #'(from-editor mod-path)) 169 | #t)) 170 | (define expanded-modpath-stx (datum->syntax #'#f expanded-modpath)) 171 | (define scopes (editor/user-syntax-introduce #'mod-path)) 172 | (add-syntax-to-editor! 173 | (syntax-local-introduce 174 | #`((~require (for-meta phase #,(wrap-scope scopes expanded-modpath-stx))))) 175 | #:required? #f)) 176 | #'(begin)]) 177 | 178 | ;; We want to require edit-time code into the modules editor submod. 179 | (define-syntax (~require stx) 180 | ;(printf "req:~s~n" stx) 181 | (syntax-parse stx 182 | [(_ body ...) 183 | (define/syntax-parse (maybe-reqs ...) 184 | (append* 185 | (for/list ([i (in-list (attribute body))]) 186 | (define-values (imports import-sources) (expand-import i)) 187 | (for/list ([s (in-list import-sources)]) 188 | (match-define (struct* import-source ([mod-path-stx mod-path] 189 | [mode phase])) 190 | s) 191 | #`(maybe-require-submod #,phase #,mod-path))))) 192 | ;(printf "mreq:~s~n" #'(maybe-reqs ...)) 193 | #'(begin (require body ...) 194 | maybe-reqs ...)])) 195 | 196 | ;; We also want all-from-out to respect `from-editor`. 197 | (define-syntax ~all-from-out 198 | (make-provide-pre-transformer 199 | (λ (stx mode) 200 | ;(printf "afo-pre: ~s~n" stx) 201 | (syntax-parse stx 202 | [(_ paths ...) 203 | #:with (expanded-paths ...) (for/list ([i (in-list (attribute paths))]) 204 | (editor/user-syntax-introduce (pre-expand-export i mode) 'add)) 205 | ;(printf "afo-post: ~s~n" #'(expanded-paths ...)) 206 | #'(all-from-out expanded-paths ...)])))) 207 | 208 | (define-syntax provide-key #'provide-key) 209 | 210 | ;; Since the editor submodule is a language detail, we want 211 | ;; a dedicated for-editor require subform. 212 | (begin-for-syntax 213 | (struct for-editor-struct () 214 | #:property prop:require-transformer 215 | (λ (str) 216 | (λ (stx) 217 | (syntax-parse stx 218 | [(_ name ...) 219 | #:with (marked-name ...) (editor/user-syntax-introduce #'(name ...) 'add) 220 | #:with r/b (editor-syntax-introduce 221 | (datum->syntax stx (syntax-parameter-value #'current-editor-lang))) 222 | (add-syntax-to-editor! (syntax-local-introduce #'((require r/b marked-name ...)))) 223 | (values '() '())]))) 224 | #:property prop:provide-pre-transformer 225 | (λ (str) 226 | (λ (stx mode) 227 | (syntax-parse stx 228 | [(_ name ...) 229 | #:with (marked-name ...) (editor/user-syntax-introduce #'(name ...) 'add) 230 | ;(printf "for-editor: ~s~n" stx) 231 | (add-syntax-to-editor! (syntax-local-introduce #'((provide marked-name ...)))) 232 | #'(for-editor provide-key name ...)]))) 233 | #:property prop:provide-transformer 234 | (λ (str) 235 | (λ (stx mode) 236 | (syntax-parse stx 237 | [(_ (~literal provide-key) name ...) 238 | '()] 239 | [else 240 | (raise-syntax-error 'for-editor "Not a provide sub-form" stx)]))))) 241 | 242 | (define-syntax for-editor (for-editor-struct)) 243 | 244 | (define-for-syntax (expand-editorpath path) 245 | (syntax-parse path 246 | #:literals (from-editor submod) 247 | [(from-editor (submod subpath ...)) 248 | #'(submod subpath ... editor)] 249 | [(from-editor mod) 250 | #'(submod mod editor)] 251 | [_ path])) 252 | 253 | ;; Just as for-editor is similar to for-syntax, for-elaborator 254 | ;; is similar to for-template. It lets helper modules bring in 255 | ;; editor components from another module. 256 | (begin-for-syntax 257 | (struct from-editor-struct () 258 | #:property prop:procedure 259 | (λ (f stx) 260 | (syntax-parse stx 261 | [(_ mod) 262 | #'(let ([m mod]) 263 | (match m 264 | [`(submod ,x ,rest (... ...)) `(submod ,x ,@rest editor)] 265 | [x `(submod ,x editor)]))])) 266 | #:property prop:require-transformer 267 | (λ (str) 268 | (λ (stx) 269 | (syntax-parse stx 270 | [(_ name ...) 271 | (for/fold ([i-list '()] 272 | [is-list '()]) 273 | ([n (in-list (attribute name))]) 274 | ;; XXX This NEEDS a proper from-editor implementation. 275 | (define-values (imports is) 276 | (expand-import (expand-editorpath #`(from-editor #,n)))) 277 | (define new-imports 278 | (for/list ([i (in-list imports)]) 279 | (struct-copy import i 280 | [local-id (format-id n "~a" (import-local-id i))]))) 281 | (values (append new-imports i-list) 282 | (append is is-list)))]))) 283 | #:property prop:provide-pre-transformer 284 | (λ (str) 285 | (λ (stx mode) 286 | (syntax-parse stx 287 | [(_ name) 288 | ;(printf "from-editor: ~s~n" stx) 289 | (datum->syntax stx `(submod ,#'name editor))] 290 | [(_ name ...) 291 | #:with (subnames ...) (for/list ([i (in-list (attribute name))]) 292 | (datum->syntax stx `(submod i editor))) 293 | #`(combine-out subnames ...)]))))) 294 | 295 | (define-syntax from-editor (from-editor-struct)) 296 | 297 | (define-syntax (begin-for-interactive-syntax stx) 298 | (syntax-parse stx 299 | [(_ code ...) 300 | #:with (marked-code ...) (editor/user-syntax-introduce #'(code ...)) 301 | (syntax/loc stx 302 | (editor-submod 303 | marked-code ...))])) 304 | 305 | (define-syntax (define-for-interactive-syntax stx) 306 | (syntax-parse stx 307 | [(_ name:id body) 308 | (syntax/loc stx 309 | (begin-for-interactive-syntax 310 | (define name body)))] 311 | [(_ name:function-header body) 312 | (syntax/loc stx 313 | (begin-for-interactive-syntax 314 | (define name body)))])) 315 | 316 | -------------------------------------------------------------------------------- /editor/private/list.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (all-defined-out)) 4 | (require (submod "lang.rkt" key-submod)) 5 | 6 | (define ((mk-editor-list-proc key) modpath [ns #f]) 7 | (define the-list (box '())) 8 | (with-continuation-mark key the-list 9 | (parameterize ([current-namespace (make-base-namespace)]) 10 | (when ns 11 | (namespace-attach-module-declaration ns modpath)) 12 | (with-handlers ([exn:fail? (λ (e) (void))]) 13 | (dynamic-require modpath (void))))) 14 | (unbox the-list)) 15 | 16 | (define list-editors 17 | (mk-editor-list-proc editor-list-key)) 18 | 19 | (define list-editor-mixins 20 | (mk-editor-list-proc editor-mixin-list-key)) 21 | -------------------------------------------------------------------------------- /editor/private/log.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (all-defined-out)) 4 | (define-logger editor) 5 | -------------------------------------------------------------------------------- /editor/private/read-editor.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (all-defined-out)) 4 | 5 | (require racket/serialize 6 | racket/port 7 | racket/list 8 | racket/set 9 | syntax/srcloc 10 | syntax/readerr 11 | syntax-color/module-lexer 12 | "editor.rkt" 13 | (for-template "editor.rkt")) 14 | 15 | (define paren-table 16 | (hash "(" ")" 17 | "{" "}" 18 | "[" "]")) 19 | 20 | (define (open-paren-char? par) 21 | (case par 22 | [(\( #\( "(" \[ #\[ "[" \{ #\{ "{") #t] 23 | [else #f])) 24 | 25 | (define (close-paren-char? par) 26 | (case par 27 | [(\) #\) ")" \] #\] "]" \} #\} "}") #t] 28 | [else #f])) 29 | 30 | (define (close->open-paren par) 31 | (case par 32 | [(#\) ")" \)) '|(|] 33 | [(#\] "]" \]) '|[|] 34 | [(#\} "}" \}) '|{|])) 35 | 36 | (define editor-finish "ditor") 37 | (define editor-str (string-append "#e" "ditor")) 38 | 39 | (define (make-editor-readtable #:readtable [base-readtable (current-readtable)] 40 | #:outer-scope [user-outer-scope #f]) 41 | (define outer-scope values);(or user-outer-scope (make-syntax-introducer #t))) 42 | (define (read-editor ch port src line col pos) 43 | (define next (peek-string (string-length editor-finish) 0 port)) 44 | (cond [(equal? next "ditor") 45 | (read-string (string-length editor-finish) port) 46 | (define span (add1 (string-length editor-str))) 47 | (define next (peek-char port)) 48 | (unless (open-paren-char? (peek-char port)) 49 | (raise-read-error "bad syntax" src line col pos span)) 50 | (define the-elaborator (read-syntax/recursive src port #f #f)) 51 | (unless (open-paren-char? (peek-char port)) 52 | (raise-read-error "bad syntax" src line col pos span)) 53 | (define the-editor (read-syntax/recursive src port #f #f)) 54 | (define stx (build-source-location-syntax (make-srcloc src line col pos span))) 55 | (define inner-scope values #;(make-syntax-introducer)) 56 | (define-values (new-line new-col new-pos) 57 | (port-next-location port)) 58 | (log-message (current-logger) 59 | 'info 60 | 'editor-lex-for-editors 61 | "" 62 | (vector the-elaborator 63 | the-editor 64 | src line col pos 65 | new-line new-col new-pos)) 66 | (outer-scope 67 | (inner-scope 68 | (datum->syntax 69 | the-elaborator 70 | `(#%editor ,the-elaborator ,the-editor) 71 | stx)))] 72 | [else 73 | (define-values (in out) (make-pipe)) 74 | (write-string "#e" out) 75 | (close-output-port out) 76 | (port-count-lines! in) 77 | (set-port-next-location! in line col pos) 78 | (with-handlers ([exn:fail:read? 79 | (λ (e) 80 | (raise-read-error 81 | "bad syntax" 82 | src 83 | line 84 | col 85 | pos 86 | (srcloc-span (first (exn:fail:read-srclocs e)))))]) 87 | (read-syntax/recursive src (input-port-append #f in port) #f base-readtable))])) 88 | (make-readtable base-readtable 89 | #\e 90 | 'dispatch-macro 91 | read-editor)) 92 | 93 | (module+ test 94 | (define (test-reader str) 95 | (parameterize ([current-readtable (make-editor-readtable)]) 96 | (with-input-from-string str 97 | (λ () 98 | (read))))) 99 | 100 | (test-reader "#e#d42.1") 101 | (test-reader "#d#e42.1") 102 | (test-reader "#editor(1 2)()") 103 | (test-reader "(+ 1 #editor(1 2 #editor(3 4)())())") 104 | (test-reader "(+ 1 #editor(1 #e2 3 4 5)())") 105 | (test-reader "(+ 1 #editor(1 #e2)())")) 106 | 107 | (define ((lex-editor base-lexer* #:fill-matches [matches #f]) 108 | in [offset 0] [mode #f]) 109 | (define base-lexer 110 | (cond 111 | [(not base-lexer*) 112 | module-lexer] 113 | [(procedure-arity-includes? base-lexer* 3) 114 | base-lexer*] 115 | [else (λ (in offset mode) 116 | (apply values 117 | (append (call-with-values (λ () (base-lexer* in)) list) 118 | (list 0 #f))))])) 119 | (define-values (text type paren start end backup new-mode) 120 | (base-lexer in offset mode)) 121 | (cond 122 | [(and (equal? text editor-str) 123 | (open-paren-char? (peek-char in))) 124 | (let loop ([cur-text text] 125 | [par-stack '()] 126 | [end end] 127 | [read-elaborator? #f] 128 | [mode new-mode]) 129 | (define-values (text* type* p s e b n) 130 | (base-lexer in offset mode)) 131 | (define new-backup 132 | (if (= backup 0) 133 | 0 134 | (+ backup (- end start)))) 135 | (define new-text (if (string? text*) 136 | (string-append cur-text text*) 137 | cur-text)) 138 | (cond 139 | [(eof-object? text*) 140 | (values new-text 'error #f start end new-backup n)] 141 | [(open-paren-char? p) 142 | (define new-table (cons p par-stack)) 143 | (loop new-text new-table e read-elaborator? n)] 144 | [(close-paren-char? p) 145 | (define open-par (close->open-paren p)) 146 | (cond 147 | [(and (not (empty? par-stack)) 148 | (equal? open-par (car par-stack))) 149 | (define new-stack (cdr par-stack)) 150 | (if (empty? new-stack) 151 | (cond 152 | [read-elaborator? 153 | (when matches 154 | (set-add! matches (list new-text start e))) 155 | (values new-text 'parenthesis #f start e new-backup n)] 156 | [else (loop new-text new-stack e #t n)]) 157 | (loop new-text new-stack e read-elaborator? n))] 158 | [else 159 | (values new-text 'error #f start end new-backup new-mode)])] 160 | [else (loop new-text par-stack e read-elaborator? n)]))] 161 | [else 162 | (values text type paren start end backup new-mode)])) 163 | 164 | (module+ test 165 | (define (test-color-lexer str) 166 | (with-input-from-string str 167 | (λ () 168 | (lex-editor (current-input-port))))) 169 | (test-color-lexer "#editor(1)(2)") 170 | (test-color-lexer "#editor(") 171 | (test-color-lexer "#editor({)")) 172 | 173 | -------------------------------------------------------------------------------- /editor/private/serialize.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide deserialize-editor/vector) 4 | (require racket/serialize) 5 | 6 | (define deserialize-editor/vector 7 | (make-deserialize-info 8 | (λ (sup table) 9 | (vector sup table)) 10 | (λ () 11 | (define vec (vector #f #f)) 12 | (values 13 | vec 14 | (λ (other) 15 | (vector-copy! vec 0 other)))))) 16 | -------------------------------------------------------------------------------- /editor/private/stdlib.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "lang.rkt" 4 | "editor.rkt" 5 | racket/splicing 6 | (for-syntax racket/base 7 | racket/syntax 8 | syntax/parse)) 9 | 10 | ;; Because this module is part of the editor language, 11 | ;; its base lang needs to be something more like racket/base 12 | ;; rather than editor 13 | (splicing-syntax-parameterize ([current-editor-lang 'racket/base] 14 | [current-editor-base "editor.rkt"] 15 | [current-editor-modpath-mode 'package]) 16 | 17 | (require (for-editor "context.rkt" 18 | "event.rkt" 19 | racket/match 20 | racket/set 21 | racket/list 22 | racket/class 23 | racket/serialize 24 | racket/contract/base 25 | racket/string 26 | racket/dict 27 | file/convertible 28 | racket/math 29 | racket/draw 30 | racket/gui/event 31 | racket/pretty 32 | #;(except-in racket/gui/base 33 | editor-snip% 34 | editor-canvas%)) 35 | racket/contract/base 36 | file/convertible 37 | racket/set 38 | racket/list 39 | racket/math 40 | racket/draw 41 | racket/class 42 | racket/serialize 43 | racket/match 44 | racket/string 45 | racket/format) 46 | 47 | (provide (all-defined-out) 48 | (for-editor (all-defined-out) 49 | (all-from-out "event.rkt"))) 50 | 51 | (begin-for-interactive-syntax 52 | (define editor<$> 53 | (interface* 54 | () 55 | ([prop:convertible 56 | (λ (this format default) 57 | (case format 58 | [(png-bytes) 59 | (define-values (w* h*) (send this get-extent)) 60 | (define w (exact-ceiling (max w* 1))) 61 | (define h (exact-ceiling (max h* 1))) 62 | (define bit (make-object bitmap% w h)) 63 | (send this draw (new bitmap-dc% [bitmap bit]) 0 0) 64 | (define s (open-output-bytes)) 65 | (send bit save-file s 'png) 66 | (get-output-bytes s)] 67 | [else default]))]) 68 | partial-extent 69 | (get-extent (->m (values real? real?))) 70 | (resize (->m real? real? any/c)) 71 | (draw (->m (is-a?/c dc<%>) real? real? any)) 72 | (get-count (->m integer?)) 73 | (on-event (->m (is-a?/c event%) real? real? any)) 74 | (set-context (->m any/c #;(or/c #f (is-a?/c editor-context<$>)) void?)) 75 | (get-context (->m any/c #;(or/c #f (is-a?/c editor-context<$>)))))) 76 | 77 | (define current-system-font (make-parameter #f)) 78 | 79 | ;; DC used internally for measuring text size. 80 | (define text-size-dc 81 | (new bitmap-dc% [bitmap (make-object bitmap% 1 1)]))) 82 | 83 | (define-base-editor* base$ object% (editor<$>) 84 | (super-new) 85 | (define context #f) 86 | (define/public (copy) 87 | (deserialize (serialize this))) 88 | (define/pubment (draw dc x y) 89 | (dynamic-wind 90 | (λ () (send dc translate x y)) 91 | (λ () (inner (void) draw dc)) 92 | (λ () (send dc translate (- x) (- y))))) 93 | (define/public (partial-extent x y len) 94 | (values 0 0)) 95 | (define/pubment (get-extent) 96 | (inner (values 0 0) get-extent)) 97 | (define/public (get-count) 98 | 1) 99 | (define/pubment (on-event event x y) 100 | (define x* (inexact->exact (round x))) 101 | (define y* (inexact->exact (round y))) 102 | (define old-x (send event get-x)) 103 | (define old-y (send event get-y)) 104 | (dynamic-wind 105 | (λ () 106 | (send event set-x (- old-x x*)) 107 | (send event set-y (- old-y y*))) 108 | (λ () (inner (void) on-event event)) 109 | (λ () 110 | (send event set-x old-x) 111 | (send event set-y old-y)))) 112 | (define/public (description) 113 | "Empty Editor") 114 | (define/public (set-context c) 115 | (log-editor-debug "Setting context to ~a" c) 116 | (set! context c)) 117 | (define/public (resize w h) 118 | #f) 119 | (define/public (get-context) 120 | context)) 121 | 122 | (define-interactive-syntax-mixin get-path$$ 123 | (inherit get-context) 124 | (super-new) 125 | (define/public (get-path) 126 | (define ctx (get-context)) 127 | (and ctx 128 | (send ctx get-path)))) 129 | 130 | (begin-for-interactive-syntax 131 | (define callable<$> 132 | (interface* () 133 | ([prop:procedure 134 | (λ (this . args) 135 | (send/apply this apply args))]) 136 | apply))) 137 | 138 | (define-interactive-syntax-mixin signaler$$ 139 | #:interfaces (signaler<$>) 140 | (inherit get-persistence) 141 | (init [(ir receiver) '()]) 142 | (define-state receivers (mutable-set)) 143 | (define-state callback #f 144 | #:persistence (get-persistence) 145 | #:init #t) 146 | (super-new) 147 | (define/public (signal event) 148 | (cond 149 | [(procedure? callback) 150 | (callback this event)] 151 | [(is-a? callback receiver<$>) 152 | (send callback on-receive this event)] 153 | [(pair? callback) 154 | (dynamic-send (car callback) (cadr callback) this event)] 155 | [(not callback) (void)] 156 | [else (error 'signaler "Invalid Callback ~a" callback)]) 157 | (for ([r (in-set receivers)]) 158 | (send r on-receive this event))) 159 | (define/public (register-receiver x) 160 | (set-add! receivers x)) 161 | (define/public (unregister-receiver x) 162 | (set-remove! receivers x)) 163 | (cond 164 | [(is-a? ir receiver<$>) 165 | (register-receiver ir)] 166 | [(list? ir) 167 | (for ([i (in-list ir)]) 168 | (register-receiver i))])) 169 | 170 | (begin-for-interactive-syntax 171 | (define signaler<$> 172 | (interface () 173 | [signal (->m any/c void?)] 174 | [register-receiver (->m (recursive-contract (is-a?/c receiver<$>)) void?)] 175 | [unregister-receiver (->m (recursive-contract (is-a?/c receiver<$>)) void?)])) 176 | (define receiver<$> 177 | (interface () 178 | (on-receive (->m (is-a?/c signaler<$>) any/c void?))))) 179 | 180 | (define-interactive-syntax widget$ (get-path$$ base$) 181 | (super-new) 182 | (init [(ip persistence) #f]) 183 | (define persist ip) 184 | (define/public (get-persistence) persist) 185 | (define-state parent #f 186 | #:init #t 187 | #:persistence (get-persistence) 188 | #:getter #t) 189 | (define-state top-margin 1 190 | #:init #t 191 | #:persistence (get-persistence)) 192 | (define-state bottom-margin 1 193 | #:init #t 194 | #:persistence (get-persistence)) 195 | (define-state left-margin 1 196 | #:init #t 197 | #:persistence (get-persistence)) 198 | (define-state right-margin 1 199 | #:init #t 200 | #:persistence (get-persistence)) 201 | (define/public (get-margin) 202 | (values top-margin bottom-margin left-margin right-margin)) 203 | (define/public (set-margin l t r b) 204 | (set! left-margin l) 205 | (set! right-margin r) 206 | (set! top-margin t) 207 | (set! bottom-margin b)) 208 | (define-state background '("Gainsboro" solid #f #f #f) 209 | #:persistence (get-persistence) 210 | #:getter (λ () 211 | (define color 212 | (match (first background) 213 | [(list r g b a) (make-object color% r g b a)] 214 | [str str])) 215 | (new brush% 216 | [color color] 217 | [style (or (second background) 'solid)] 218 | [stipple (third background)] 219 | ;[gradient (fourth background)] 220 | [transformation (fifth background)]))) 221 | (define/public (set-background brush/color [style #f]) 222 | (define (color->quad c) 223 | (cond 224 | [(is-a? c color%) 225 | (list (send c red) (send c green) (send c blue) (send c alpha))] 226 | [else c])) 227 | (set! background 228 | (cond 229 | [(is-a? brush/color brush%) 230 | (list (color->quad (send brush/color get-color)) 231 | (send brush/color get-style) 232 | (send brush/color get-stipple) 233 | #f ;(send brush/color get-gradient) 234 | (send brush/color get-transformation))] 235 | [else (list (color->quad brush/color) (or style 'solid) #f #f #f)]))) 236 | (define-state count 1 237 | #:persistence (get-persistence) 238 | #:setter (λ (c) 239 | (define con (send this get-context)) 240 | (set! count c) 241 | (when con 242 | (send con recount)))) 243 | (define/override (get-count) 244 | count) 245 | (define/augment (draw dc) 246 | (define-values (width height) (get-extent)) 247 | (define old-pen (send dc get-pen)) 248 | (define old-brush (send dc get-brush)) 249 | (send dc set-pen 250 | (new pen% 251 | [style 'transparent])) 252 | (send dc set-brush (send this get-background)) 253 | (send dc draw-rectangle 0 0 width height) 254 | (send dc set-pen old-pen) 255 | (send dc set-brush old-brush) 256 | (dynamic-wind 257 | (λ () (send dc translate left-margin top-margin)) 258 | (λ () (inner (void) draw dc)) 259 | (λ () (send dc translate (- left-margin) (- top-margin))))) 260 | (define/public (get-content-extent) 261 | (inner (values 0 0) get-extent)) 262 | (define/augment (get-extent) 263 | (define-values (iw ih) 264 | (inner (values 0 0) get-extent)) 265 | (values (+ iw left-margin right-margin) 266 | (+ ih top-margin bottom-margin))) 267 | (define/override (resize w h) 268 | ;(define c (send this get-context)) 269 | ;(when c 270 | ; (send c resize content-width content-height)) 271 | ;(when parent 272 | ; (send parent resized-child this))) 273 | #f) 274 | (define/public (register-parent other) 275 | (set! parent other)) 276 | (define/public (in-bounds? event) 277 | (define-values (width height) (get-extent)) 278 | (define mouse-x (send event get-x)) 279 | (define mouse-y (send event get-y)) 280 | (and (<= 0 mouse-x width) 281 | (<= 0 mouse-y height))) 282 | (when parent 283 | (send parent add-child this))) 284 | 285 | (begin-for-interactive-syntax 286 | ;; An interface for widgets that can be resized, like a maximized window. 287 | (define stretchable<$> 288 | (interface () 289 | ;; Get's the minimum possible extent for this widget. 290 | ;; The input arguments are (x, y) coordinates. They are the coordinates 291 | ;; where the widget will be drawn. 292 | ;; A return value of (0, 0) means the window can have no size. 293 | (get-min-extent (->m real? real? (values real? real?))) 294 | ;; Like get-min-extent, but for maximum possible widget size. 295 | ;; A return value of (+inf.0, +inf.0) means the window has no 296 | ;; maximum size. 297 | (get-max-extent (->m real? real? (values real? real?))) 298 | ;; A specialized draw function to render the widget at a specific size. 299 | ;; The dc<%> is the context that its being drawn onto. 300 | ;; The remaining `real?`s are the (x, y) values to place the widget, 301 | ;; as well as the (w, h) of the widget drawing. (These values are 302 | ;; expected to be between the minimum and maximum extent for the widget) 303 | (draw-stretched (->m (is-a?/c dc<%>) real? real? real? real? any)))) 304 | 305 | ;; A focusable widget is one that directly can take focus on the screen. 306 | ;; Such as a button/text box/etc. 307 | (define focus<$> 308 | (interface () 309 | ;; Returns #t if the current widget has focus, #f otherwise. 310 | (has-focus? (->m boolean?)) 311 | ;; Manually sets the focus for the widget. 312 | (set-focus (->m boolean? any)))) 313 | 314 | ;; A parent can be any type of widget that contains children. 315 | ;; Such as a list-block$$. This interface assumes that there is some 316 | ;; sort of order for the `next-child-focus` and `previous-child-focus`, 317 | ;; but not particular semantic meaning is otherwise required 318 | (define parent<$> 319 | (interface () 320 | ;; Adds a new child to the collection 321 | (add-child (or/c (->m (is-a?/c editor<$>) any) 322 | any/c)) 323 | ;; Remove an existing child from the collection 324 | (remove-child (or/c (->*m () ((is-a?/c editor<$>)) any) 325 | any/c)) 326 | ;; Clear all children from the parent 327 | (clear (or/c (->*m () () any) 328 | any/c)) 329 | ;; Call (generally from a child) when they have been resized. 330 | ;; This gives the parent a chance to adjust its other children. 331 | (resized-child (->m (is-a?/c editor<$>) any)) 332 | ;; Sets the given child as the editor's current focus. 333 | ;; Such as a highlighted button or current text field. 334 | ;; Returns #f if no existing child could be (possibly transitively) 335 | ;; found. 336 | (set-child-focus (->*m () ((or/c (is-a?/c editor<$>) #f)) boolean?)) 337 | ;; Like set-child-focus, but does not inform the child of its focus change. 338 | ;; To be called by the child itself. 339 | ;; As a side effect, all other children loose focus. 340 | (child-focus-changed (->m (or (is-a?/c editor<$>) #f) any)) 341 | ;; Move focus to the next child (button/text field) that can have focus. 342 | ;; This operation is also transitive accross parents. 343 | ;; If #:wrap is true and when there is no next child, than the widget wraps around and 344 | ;; focuses on the first child. 345 | ;; If #:wrap is false, then no child gets focus. 346 | ;; Returns the child that got focus, #f otherwise. 347 | (next-child-focus (->*m () (#:wrap boolean?) (or/c (is-a?/c editor<$>) #f))) 348 | ;; Like next-child-focus, but goes to the previous focusable child instead. 349 | (previous-child-focus (->*m () (#:wrap boolean?) (or/c (is-a?/c editor<$>) #f)))))) 350 | 351 | (define-interactive-syntax blank$ widget$ 352 | (super-new) 353 | (define-state width 0 354 | #:getter #t 355 | #:setter #t 356 | #:persistence #f 357 | #:init #t) 358 | (define-state height 0 359 | #:getter #t 360 | #:setter #t 361 | #:persistence #f 362 | #:init #t) 363 | (define/augride (get-extent) 364 | (values width height))) 365 | 366 | (define-interactive-syntax pasteboard$ widget$ 367 | #:interfaces (parent<$>) 368 | (inherit in-bounds? get-persistence) 369 | (define-state extra-width 100 370 | #:persistence #f 371 | #:init #t) 372 | (define-state extra-height 100 373 | #:persistence #f 374 | #:init #t) 375 | (define-state min-height 0 376 | #:persistence #f 377 | #:init #t) 378 | (define-state min-width 0 379 | #:persistence #f 380 | #:init #t) 381 | (define-state children (hash) 382 | #:persistence (get-persistence) 383 | #:getter #t) 384 | (define-state focus #f 385 | #:persistence #f 386 | #:getter #t 387 | #:setter (λ ([child #f]) 388 | (set! focus child))) 389 | (super-new) 390 | (define/public (add-child child [x 0] [y 0]) 391 | (set! children (dict-set children child (cons x y)))) 392 | (define/public (remove-child [child #f]) 393 | (define elem 394 | (or child (let ([k (dict-iterate-first children)]) 395 | (and k (dict-iterate-key children k))))) 396 | (when elem 397 | (set! children (dict-remove children elem)) 398 | (when (equal? focus elem) 399 | (set! focus #f)))) 400 | (define/public (clear) 401 | (set! children (hash)) 402 | (set! focus #f)) 403 | (define/public (move-child child new-x new-y) 404 | (set! children 405 | (dict-update children child (cons new-x new-y)))) 406 | (define/public (set-child-focus [child #f]) 407 | (set-focus! child) 408 | (and focus #t)) 409 | (define/public (get-child-position child) 410 | (define coords (dict-ref children child 411 | (λ () 412 | (error 'pasteboard$ "Couldn't find editor ~a" child)))) 413 | (values (car coords) (cdr coords))) 414 | (define/public (next-child-focus #:wrap [wrap #f]) 415 | (error "TODO")) 416 | (define/public (previous-child-focus #:wrap [wrap #f]) 417 | (error "TODO")) 418 | (define/public (child-focus-changed child) 419 | (error "TODO")) 420 | (define/public (resized-child child) 421 | (error "TODO")) 422 | (define/augment (on-event event) 423 | (cond [(is-a? event mouse-event%) 424 | (when (in-bounds? event) 425 | (match (send event get-event-type) 426 | ;; Set focus or move child 427 | ['left-down 428 | (define old-x (send event get-x)) 429 | (define old-y (send event get-y)) 430 | (define maybe-new-focus 431 | (for/fold ([focus #f]) 432 | ([(child pos) (in-dict children)]) 433 | ;(printf "~a~a~a~a~n" child pos old-x old-y) 434 | (dynamic-wind 435 | (λ () 436 | (send event set-x (- old-x (car pos))) 437 | (send event set-y (- old-y (cdr pos)))) 438 | (λ () 439 | (or (and (send child in-bounds? event) 440 | child) 441 | focus)) 442 | (λ () 443 | (send event set-x old-x) 444 | (send event set-y old-y))))) 445 | (cond 446 | [maybe-new-focus (set! focus maybe-new-focus)] 447 | [else 448 | (when focus 449 | (set! children (dict-set children focus 450 | (cons (send event get-x) 451 | (send event get-y)))))])] 452 | [_ (void)]))])) 453 | (define/augride (get-extent) 454 | (for/fold ([min-width min-width] 455 | [min-height min-height] 456 | #:result (values (+ min-width extra-width) 457 | (+ min-height extra-height))) 458 | ([(child pos) (in-dict children)]) 459 | (define x (car pos)) 460 | (define y (cdr pos)) 461 | (define-values (w h) (send child get-extent)) 462 | (values (max min-width (+ x w)) 463 | (max min-height (+ y h))))) 464 | (define/augride (draw dc) 465 | (for ([(child pos) (in-dict children)]) 466 | (send child draw dc (car pos) (cdr pos))))) 467 | 468 | ;; Generic list collection, used by other editors such as vertical-block$ 469 | ;; and horizontal-block$. 470 | (define-interactive-syntax-mixin list-block$$ 471 | #:interfaces (parent<$> stretchable<$>) 472 | (inherit get-persistence) 473 | (init [(ixe x-extent)] 474 | [(iye y-extent)] 475 | [(ixd x-draw)] 476 | [(iyd y-draw)] 477 | [(ixo x-offset)] 478 | [(iyo y-offset)]) 479 | (define x-extent ixe) 480 | (define y-extent iye) 481 | (define x-draw ixd) 482 | (define y-draw iyd) 483 | (define x-offset ixo) 484 | (define y-offset iyo) 485 | (define-state editor-list '() 486 | #:getter #t 487 | #:persistence (get-persistence)) 488 | (define-state focus #f) 489 | (super-new) 490 | (define/public (add-child editor [index #f]) 491 | (cond [index 492 | (define-values (head tail) (split-at editor-list index)) 493 | (set! editor-list (append head (list editor) tail)) 494 | (send editor register-parent this) 495 | (resized-child editor)] 496 | [else 497 | (set! editor-list (append editor-list (list editor)))])) 498 | (define/public (update-child index proc) 499 | (define removed-editor (list-ref editor-list index)) 500 | (set! editor-list (list-update editor-list index proc)) 501 | (define new-editor (list-ref editor-list index)) 502 | (send removed-editor register-parent #f) 503 | (send new-editor register-parent this) 504 | (resized-child removed-editor) 505 | (resized-child new-editor)) 506 | (define/public (remove-child [editor #f]) 507 | (when editor 508 | (writeln editor-list) 509 | (writeln editor) 510 | (writeln (index-of editor-list editor))) 511 | (when (empty? editor-list) 512 | (error 'remove-editor "List widget already empty")) 513 | (define index (if editor 514 | (index-of editor-list editor) 515 | (sub1 (length editor-list)))) 516 | (remove-child/index index)) 517 | (define/public (remove-child/index index) 518 | (define removed-editor (list-ref editor-list index)) 519 | (send removed-editor register-parent #f) 520 | (set! editor-list (remq removed-editor editor-list)) 521 | (resized-child removed-editor)) 522 | (define/public (clear) 523 | (for ([child (in-list editor-list)]) 524 | (send child register-parent #f) 525 | (resized-child child)) 526 | (set! editor-list '())) 527 | (define/public (count) 528 | (length editor-list)) 529 | (define/public (in-children) 530 | (in-list editor-list)) 531 | (define/public (resized-child child) 532 | (match-define-values (_ w h) (get-child-extents)) 533 | (send this resize w h) 534 | (send this set-count! (length editor-list))) 535 | (define/public (child-focus-changed child) 536 | (when (send this get-parent) 537 | (send (send this get-parent) child-focus-changed this)) 538 | (for/list ([i (in-list editor-list)] 539 | #:unless (eq? i child)) 540 | (when (is-a? i parent<$>) 541 | (send i set-child-focus #f)) 542 | (when (is-a? i focus<$>) 543 | (send i set-focus #f)))) 544 | (define/public (set-child-focus [child #f]) 545 | (define ret 546 | (for/fold ([child child] 547 | #:result (not child)) 548 | ([i (in-list editor-list)] 549 | [index (in-naturals)]) 550 | (define maybe-child 551 | (and (is-a? i parent<$>) 552 | (send i set-child-focus child))) 553 | (cond [maybe-child 554 | (set! focus index) 555 | #f] 556 | [(eq? child i) 557 | (set! focus index) 558 | (send child set-focus #t) 559 | #f] 560 | [(is-a? i focus<$>) 561 | (send i set-focus #f) 562 | child] 563 | [else child]))) 564 | ret) 565 | (define/public (next-child-focus #:wrap [wrap? #t]) 566 | (define start (or focus 0)) 567 | ;; If direct child has focus, switch it off. 568 | (define start-editor (and (not (empty? editor-list)) 569 | (list-ref editor-list start))) 570 | (when (and start-editor (is-a? start-editor focus<$>)) 571 | (send start-editor set-focus #f)) 572 | ;; Update focus 573 | (let loop ([i start] 574 | [looped-back? #f]) 575 | (cond 576 | [(and looped-back? (= (add1 start) i)) #f] 577 | [((length editor-list) . <= . i) 578 | (cond 579 | [(empty? editor-list) #f] 580 | [wrap? (loop 0 #t)] 581 | [else #f])] 582 | [else 583 | (define editor-i (list-ref editor-list i)) 584 | (cond 585 | [(is-a? editor-i parent<$>) 586 | (or (send editor-i next-child-focus #:wrap #f) 587 | (loop (add1 i) looped-back?))] 588 | [(and (is-a? editor-i focus<$>) 589 | (or (not (= i start)) 590 | looped-back?)) 591 | (set! focus i) 592 | (send editor-i set-focus #t) 593 | editor-i] 594 | [else (loop (add1 i) looped-back?)])]))) 595 | (define/public (previous-child-focus #:wrap [wrap? #t]) 596 | (define start (or focus (length editor-list))) 597 | (error "prev-child-focus, TODO")) 598 | (define/public (get-min-extent x y) 599 | (error "min-extent TODO")) 600 | (define/public (get-max-extent x y) 601 | (error "max-extent TODO")) 602 | (define/augride (get-extent) 603 | (define-values (extents w h) 604 | (send this get-child-extents)) 605 | (log-editor-debug "List Extent: ~a" (list extents w h)) 606 | (values w h)) 607 | (define/public (get-child-extents) 608 | (get-fixed-child-extents)) 609 | (define/private (get-fixed-child-extents #:stretchable? [stretchable? #f]) 610 | (for/fold ([res '()] 611 | [w 0] 612 | [h 0] 613 | #:result (values (reverse res) 614 | w h)) 615 | ([i (in-list editor-list)]) 616 | (cond 617 | [(and stretchable? (is-a? i stretchable<$>)) 618 | (define-values (w* h*) 619 | (send i get-min-extent 0 0)) 620 | (values (cons (list w* h*) res) 621 | (x-extent w w*) 622 | (y-extent h h*))] 623 | [else 624 | (define-values (w* h*) (send i get-extent)) 625 | (values (cons (list w* h*) res) 626 | (x-extent w w*) 627 | (y-extent h h*))]))) 628 | (define child-locs (make-hasheq)) 629 | (define/augment (draw dc) 630 | (hash-clear! child-locs) 631 | (define-values (extents w h) (get-child-extents)) 632 | (for/fold ([x 0] 633 | [y 0]) 634 | ([i (in-list editor-list)] 635 | [e (in-list extents)]) 636 | (define w* (first e)) 637 | (define h* (second e)) 638 | (define x* (x-offset x w* w)) 639 | (define y* (y-offset y h* h)) 640 | (hash-set! child-locs i (cons x* y*)) 641 | (send i draw dc x* y*) 642 | (values (x-draw x w*) 643 | (y-draw y h*))) 644 | (inner (void) draw dc) 645 | (void)) 646 | (define/public (draw-stretched dc x y w h) 647 | (send this draw dc x y)) 648 | (define/augment (on-event event) 649 | (cond [(and (is-a? event key-event%) 650 | (eq? #\tab (send event get-key-code))) 651 | (next-child-focus)] 652 | [else (for/list ([i (in-list editor-list)]) 653 | (define loc (hash-ref child-locs i (cons 0 0))) 654 | (send i on-event event (car loc) (cdr loc)))]))) 655 | 656 | ;; A style is: 'left, 'right, 'center 657 | (define-interactive-syntax vertical-block$ (list-block$$ widget$) 658 | (init [alignment 'left]) 659 | (super-new [x-extent max] 660 | [y-extent +] 661 | [x-draw (λ (acc new) acc)] 662 | [y-draw +] 663 | [x-offset (λ (x cw w) 664 | (case alignment 665 | [(left) x] 666 | [(center) (+ x (/ (- w cw) 2))] 667 | [(right) (+ x (- w cw))] 668 | [else x]))] 669 | [y-offset (λ (y ch h) 670 | y)])) 671 | 672 | ;; A style is: 'top, 'botton, 'center 673 | (define-interactive-syntax horizontal-block$ (list-block$$ widget$) 674 | (init [alignment 'top]) 675 | (super-new [x-extent +] 676 | [y-extent max] 677 | [x-draw +] 678 | [y-draw (λ (acc new) acc)] 679 | [x-offset (λ (x cw w) 680 | x)] 681 | [y-offset (λ (y ch h) 682 | (case alignment 683 | [(top) y] 684 | [(center) (+ y (/ (- h ch) 2))] 685 | [(bottom) (+ y (- h ch))] 686 | [else y]))])) 687 | 688 | (define-interactive-syntax grid-block$ widget$ 689 | #:interfaces (parent<$>) 690 | (super-new) 691 | (define children (make-hasheq)) 692 | (define grid (make-hasheq)) 693 | (define child-locs (make-hasheq)) ;; (for events) 694 | (define (find-by-pos x y) 695 | (hash-ref grid (cons x y) #f)) 696 | (define/public (add-child child [x 0] [y 0] [width 1] [height 1]) 697 | (hash-set! children child (list x y width height)) 698 | (for ([x* (in-range x (+ x width))] 699 | [y* (in-range y (+ y height))]) 700 | (hash-set! grid (cons x* y*) child))) 701 | (define/public (remove-child [child* #f]) 702 | (define child (or child* (hash-iterate-key children (hash-iterate-first children)))) 703 | (define loc (hash-ref children child)) 704 | (hash-remove! children child) 705 | (define x (first loc)) 706 | (define y (second loc)) 707 | (define w (third loc)) 708 | (define h (fourth loc)) 709 | (for ([x* (in-range x (+ x w))] 710 | [y* (in-range y (+ y h))]) 711 | (hash-remove! grid (cons x* y*)))) 712 | (define/public (clear) 713 | (set! children (make-hasheq)) 714 | (set! grid (make-hasheq))) 715 | (define (get-child-extents) 716 | (define row-extents (make-hash)) 717 | (define col-extents (make-hash)) 718 | (define size-w 0) 719 | (define size-h 0) 720 | (for ([(child size) children]) 721 | (define-values (child-w child-h) (send child get-extent)) 722 | (define x (first size)) 723 | (define y (second size)) 724 | (define w (third size)) 725 | (define h (fourth size)) 726 | (define cell-w (/ child-w w)) 727 | (define cell-h (/ child-h h)) 728 | (set! size-w (max size-w (+ x w))) 729 | (set! size-h (max size-h (+ y h))) 730 | (for ([x* (in-range x (+ x w))] 731 | [y* (in-range y (+ y h))]) 732 | (hash-update! col-extents x* (λ (old) 733 | (max old cell-w)) 734 | cell-h) 735 | (hash-update! row-extents y* (λ (old) 736 | (max old cell-h)) 737 | cell-w))) 738 | (define-values (width col-pos) 739 | (for/fold ([acc 0] 740 | [pos '()] 741 | #:result (values acc (reverse pos))) 742 | ([i (in-range size-w)]) 743 | (values 744 | (+ acc (hash-ref col-extents i 0)) 745 | (cons acc pos)))) 746 | (define-values (height row-pos) 747 | (for/fold ([acc 0] 748 | [pos '()] 749 | #:result (values acc (reverse pos))) 750 | ([i (in-range size-h)]) 751 | (values 752 | (+ acc (hash-ref row-extents i 0)) 753 | (cons acc pos)))) 754 | (values width height row-pos col-pos)) 755 | (define/augride (get-extent) 756 | (match-define-values (w h _ _) (get-child-extents)) 757 | (values w h)) 758 | (define/augride (draw dc) 759 | (match-define-values (_ _ rows cols) (get-child-extents)) 760 | (set! child-locs (make-hasheq)) 761 | (for ([(child size) children]) 762 | (define x (first size)) 763 | (define y (second size)) 764 | (hash-set! child-locs child (cons (list-ref cols x) (list-ref rows y))) 765 | (send child draw dc (list-ref cols x) (list-ref rows y)))) 766 | (define/public (resized-child . args) 767 | (error "TODO")) 768 | (define/public (set-child-focus . args) 769 | (error "TODO")) 770 | (define/public (child-focus-changed . args) 771 | (error "TODO")) 772 | (define/public (next-child-focus #:wrap [wrap #f] . args) 773 | (error "TODO")) 774 | (define/public (previous-child-focus #:wrap [wrap #f] . args) 775 | (error "TODO")) 776 | (define/augment (on-event event) 777 | (for ([(child loc) child-locs]) 778 | (send child on-event event (car loc) (cdr loc))))) 779 | 780 | (define-interactive-syntax-mixin text$$ 781 | #:mixins (signaler$$) 782 | (inherit get-persistence) 783 | (init [(internal-text text) ""]) 784 | (define-state text-width 0) 785 | (define-state text-height 0) 786 | (define-state font #f 787 | #:getter (λ () 788 | (or font (current-system-font))) 789 | #:setter #t 790 | #:init (λ (i) 791 | (or i 792 | (current-system-font) 793 | (dynamic-require 'racket/gui/base 'normal-control-font))) 794 | #:deserialize (λ (lst) 795 | (and lst 796 | (apply make-object font% lst))) 797 | #:serialize (λ (f) 798 | (and f 799 | (list (send f get-size) 800 | (send f get-face) 801 | (send f get-family) 802 | (send f get-style) 803 | (send f get-weight) 804 | (send f get-underlined) 805 | (send f get-smoothing) 806 | (send f get-size-in-pixels) 807 | (send f get-hinting)))) 808 | #:persistence (get-persistence)) 809 | (define-state scale? #f) 810 | (define-state text "" 811 | #:setter (λ (t #:signal? [signal? #f]) 812 | (define text-size-str (if (non-empty-string? t) t " ")) 813 | (match-define-values (w h _ _) 814 | (send text-size-dc get-text-extent text-size-str (send this get-font))) 815 | (set! text t) 816 | (set! text-width w) 817 | (set! text-height h) 818 | (when signal? 819 | (send this signal (new control-event% [event-type 'text-field])))) 820 | #:getter #t 821 | #:persistence (get-persistence)) 822 | (super-new) 823 | (define/augment (get-extent) 824 | (define-values (w h) (inner (values 0 0) get-extent)) 825 | (values (max w text-width) (max h text-height))) 826 | (define/augride (draw dc) 827 | (define-values (l t r b) (send this get-margin)) 828 | (define old-font (send dc get-font)) 829 | (send dc set-font (send this get-font)) 830 | (send dc draw-text text l t) 831 | (send dc set-font old-font)) 832 | (send this set-background "white" 'transparent) 833 | (set-text! internal-text)) 834 | 835 | (define-interactive-syntax label$ (text$$ widget$) 836 | (super-new) 837 | (init [(internal-text text) ""]) 838 | (send this set-text! internal-text)) 839 | 840 | (define-interactive-syntax-mixin focus$$ 841 | #:interfaces (focus<$>) 842 | (define-state focus? #f) 843 | (define mouse-state 'up) 844 | (super-new) 845 | (define/public (has-focus?) 846 | focus?) 847 | (define/public (set-focus f) 848 | (set! focus? f)) 849 | (define/augment (on-event event) 850 | (cond 851 | [(is-a? event mouse-event%) 852 | (define in-button? (send this in-bounds? event)) 853 | (match (send event get-event-type) 854 | ['left-down 855 | (set! focus? in-button?) 856 | (when (and focus? (send this get-parent)) 857 | (send (send this get-parent) child-focus-changed this))] 858 | [_ (void)])]) 859 | (inner (void) on-event event))) 860 | 861 | (define-interactive-syntax button$ (signaler$$ (focus$$ widget$)) 862 | (inherit has-focus? 863 | get-persistence) 864 | (super-new) 865 | (init [(il label) #f]) 866 | (define mouse-state 'up) 867 | (define-state label #f 868 | #:persistence (get-persistence) 869 | #:getter #t 870 | #:setter (λ (l) 871 | (set! label l))) 872 | (define up-color "Silver") 873 | (define hover-color "DarkGray") 874 | (define down-color "DimGray") 875 | (define/override (set-focus f) 876 | (super set-focus f) 877 | (set! mouse-state (if f 'hover 'up))) 878 | (define/augment (on-event event) 879 | (cond 880 | [(is-a? event mouse-event%) 881 | (define in-button? 882 | (send this in-bounds? event)) 883 | (match (send event get-event-type) 884 | ['left-down 885 | (when (and in-button? (eq? mouse-state 'hover)) 886 | (set! mouse-state 'down))] 887 | ['left-up 888 | (when (and in-button? (eq? mouse-state 'down)) 889 | (if in-button? 890 | (set! mouse-state 'hover) 891 | (set! mouse-state 'up)) 892 | (define control-event (new control-event% [event-type 'button])) 893 | (send this signal control-event))] 894 | ['motion 895 | (match mouse-state 896 | [(or 'up 'hover) 897 | (if in-button? 898 | (set! mouse-state 'hover) 899 | (set! mouse-state 'up))] 900 | ['down 901 | (unless in-button? 902 | (set! mouse-state 'up))])] 903 | [_ (void)])])) 904 | (define/augment (get-extent) 905 | (send label get-extent)) 906 | (define/augment (draw dc) 907 | (define-values (w h) (get-extent)) 908 | (define old-pen (send dc get-pen)) 909 | (define old-brush (send dc get-brush)) 910 | (send dc set-pen 911 | (new pen% [width 1])) 912 | (send dc set-brush 913 | (new brush% [color (make-object color% 914 | (match mouse-state 915 | ['up up-color] 916 | ['hover hover-color] 917 | ['down down-color]))])) 918 | (send dc draw-rounded-rectangle 0 0 (sub1 w) (sub1 h)) 919 | (send dc set-pen old-pen) 920 | (send dc set-brush old-brush) 921 | (if label 922 | (send label draw dc 0 0) 923 | (error 'button$ "Missing label")) 924 | (inner (void) draw dc)) 925 | (cond 926 | [(string? il) 927 | (set-label! (new label$ [text il]))] 928 | [(eq? il #f) (void)] 929 | [else (set-label! il)])) 930 | 931 | (define-interactive-syntax toggle$ (signaler$$ (focus$$ widget$)) 932 | (inherit has-focus? 933 | get-persistence) 934 | (super-new) 935 | (define-state value #f 936 | #:persistence (get-persistence) 937 | #:getter #t 938 | #:setter #t) 939 | (define-state mouse-state 'up) 940 | (define-state up-color "Silver") 941 | (define-state focus-color "LightSkyBlue") 942 | (define-state down-color "DeepSkyBlue") 943 | (define/augment (on-event event) 944 | (cond 945 | [(is-a? event mouse-event%) 946 | (define in-button? 947 | (send this in-bounds? event)) 948 | (match (send event get-event-type) 949 | ['left-down 950 | (when in-button? 951 | (set! mouse-state 'down))] 952 | ['left-up 953 | (when (and in-button? (eq? mouse-state 'down)) 954 | (set! value (not value)) 955 | (define control-event (new control-event% [event-type 'check-box])) 956 | (send this signal control-event)) 957 | (set! mouse-state 'up)] 958 | [_ (void)])])) 959 | (define/augment (draw dc) 960 | (define-values (cw ch) (send this get-extent)) 961 | (define old-pen (send dc get-pen)) 962 | (define old-brush (send dc get-brush)) 963 | (send dc set-pen 964 | (new pen% [width 1])) 965 | (send dc set-brush 966 | (new brush% [color (make-object color% 967 | (cond 968 | ;[(has-focus?) focus-color] 969 | [value down-color] 970 | [else up-color]))])) 971 | (send dc draw-rectangle 0 0 cw ch) 972 | ;(send label draw dc (+ mx pl) (+ my pt)) 973 | (send dc set-pen old-pen) 974 | (send dc set-brush old-brush) 975 | (inner (void) draw dc))) 976 | 977 | ;; Will be lifted into racket/list 978 | (begin-for-interactive-syntax 979 | (define (remove-index ls index) 980 | (unless (list? ls) 981 | (raise-argument-error 'remove-index "list?" 0 ls index)) 982 | (unless (exact-nonnegative-integer? index) 983 | (raise-argument-error 'remove-index "exact-nonnegative-integer?" 1 ls index)) 984 | (let loop ([count 0] 985 | [lst ls]) 986 | (cond [(null? lst) '()] 987 | [(= count index) 988 | (loop (add1 count) 989 | (cdr lst))] 990 | [else 991 | (cons (car lst) 992 | (loop (add1 count) 993 | (cdr lst)))])))) 994 | 995 | (define-interactive-syntax radio$ (list-block$$ widget$) 996 | (inherit get-persistence 997 | get-editor-list) 998 | (define-state selected #f 999 | #:persistence (get-persistence)) 1000 | (define-state children '() 1001 | #:persistence (get-persistence)) 1002 | (super-new) 1003 | (define/override (add-child child) 1004 | (define option (new horizontal-block$)) 1005 | (define toggle (new toggle$ [parent option])) 1006 | (send toggle add-child child) 1007 | (set! children (append children option)) 1008 | (super add-child toggle)) 1009 | (define/override (remove-child child) 1010 | (define index (index-where children 1011 | (λ (c) (eq? child (car c))))) 1012 | (when index 1013 | (define option (list-ref (get-editor-list) index)) 1014 | (set! children (remove-index children index)) 1015 | (super remove-child option)))) 1016 | 1017 | (define-interactive-syntax-mixin pickable$$ 1018 | (super-new) 1019 | (init-field [(in normal) (void)] 1020 | [(ih hover) (void)] 1021 | [(ip picked) (void)]) 1022 | (define-state normal-style in) 1023 | (define-state hover-style ih) 1024 | (define-state picked-style ip) 1025 | ; states can be one of: normal, hover, or picked 1026 | (define-state state 'normal) 1027 | (define (get-state state) 1028 | state) 1029 | (define (set-state! s) 1030 | (set! state s))) 1031 | 1032 | (define-interactive-syntax field$ (focus$$ (text$$ widget$)) 1033 | #:interfaces (stretchable<$>) 1034 | (inherit get-extent 1035 | get-text 1036 | set-text! 1037 | get-persistence) 1038 | (super-new) 1039 | (define-state background #f 1040 | #:init #t) 1041 | (send this set-background (or background "white")) 1042 | (define/public (get-max-extent x y) 1043 | (match-define-values (w h) (get-extent)) 1044 | (values +inf.0 h)) 1045 | (define/public (get-min-extent x y) 1046 | (match-define-values (w h) (get-extent)) 1047 | (values 0 h)) 1048 | (define-state caret 0 1049 | #:persistence (get-persistence)) 1050 | (define/override (draw dc) 1051 | (super draw dc) 1052 | (when (send this has-focus?) 1053 | (define t (get-text)) 1054 | (define car-str (substring t 0 caret)) 1055 | (match-define-values (cx cy _ _) 1056 | (send text-size-dc get-text-extent car-str (send this get-font))) 1057 | (match-define-values (w h) (send this get-content-extent)) 1058 | (send dc draw-line cx 0 cx h))) 1059 | (define/public (draw-stretched dc x y w h) 1060 | (draw dc x y)) 1061 | (define/augment (on-event event) 1062 | (define text (get-text)) 1063 | (cond 1064 | [(is-a? event key-event%) 1065 | (when (send this has-focus?) 1066 | (define char (send event get-key-code)) 1067 | (match char 1068 | ['left 1069 | (set! caret (max 0 (sub1 caret)))] 1070 | ['right 1071 | (set! caret (min (string-length text) (add1 caret)))] 1072 | [(or #\newline #\return) 1073 | (void)] 1074 | [#\backspace 1075 | (define old-caret caret) 1076 | (set! caret (max 0 (sub1 caret))) 1077 | (set-text! (format "~a~a" 1078 | (substring text 0 (max 0 (sub1 old-caret))) 1079 | (substring text old-caret)) 1080 | #:signal? #t) 1081 | ] 1082 | [#\rubout 1083 | (error "Delete key: TODO") 1084 | #;(set! text 1085 | (format "~a~a" 1086 | (substring text 0 caret) 1087 | (substring text (min (length text) (add1 caret))))) 1088 | #;(set! caret (min (sub1 (length text)) caret))] 1089 | [(? char?) 1090 | (send this set-text! (format "~a~a~a" 1091 | (substring text 0 caret) 1092 | char 1093 | (substring text caret)) 1094 | #:signal? #t) 1095 | (set! caret (add1 caret))] 1096 | [_ (void)]))])) 1097 | (let ([t (get-text)]) 1098 | (when t 1099 | (set! caret (string-length t))))) 1100 | 1101 | (define-interactive-syntax window$ vertical-block$ 1102 | (inherit get-context) 1103 | (super-new) 1104 | (define-state frame #f 1105 | #:init #t 1106 | #:setter #t 1107 | #:getter #t) 1108 | (define/public (show [show? #t]) 1109 | (when (get-context) 1110 | (send (get-context) show show?)) 1111 | (when frame 1112 | (cond 1113 | [show? 1114 | (new editor-canvas% [parent frame] 1115 | [editor this]) 1116 | (send frame show #t)] 1117 | [else 1118 | (send frame show #f)])))) 1119 | 1120 | (define-interactive-syntax dialog$ window$ 1121 | (inherit set-frame! get-frame) 1122 | (init [title "Dialog"]) 1123 | (super-new) 1124 | (define dialog% (dynamic-require 'racket/gui/base 'dialog%)) 1125 | (unless (get-frame) 1126 | (set-frame! (new dialog% 1127 | [label title]))) 1128 | (define result #f) 1129 | (define/public (get-result) 1130 | result) 1131 | (define/public (set-result! new) 1132 | (set! result new))) 1133 | 1134 | (begin-for-interactive-syntax 1135 | (define option-bundle$ 1136 | (class object% 1137 | (super-new) 1138 | (define finalized? #f) 1139 | (define options (hash)) 1140 | (define/public (add-option label setter) 1141 | (when finalized? 1142 | (error 'option-bundle$ "Options already finalized")) 1143 | (set! options (dict-set options label setter))) 1144 | (define/public (finalize-options) 1145 | (when finalized? 1146 | (error 'option-bundle$ "Options already finalized")) 1147 | (set! finalized? #t) 1148 | (set! options 1149 | (for/hash ([(option setter) (in-dict options)]) 1150 | (values option (setter))))) 1151 | (define/public (get-options) 1152 | (unless finalized? 1153 | (log-editor-warning 'option-bundle "Finalizing Options") 1154 | (finalize-options)) 1155 | options)))) 1156 | 1157 | (define-interactive-syntax labeled-option$ horizontal-block$ 1158 | (super-new) 1159 | (init [option values]) 1160 | (define/public (get-option) 1161 | opt) 1162 | (define-state font #f 1163 | #:init #t) 1164 | (define-state label #f 1165 | #:init #t) 1166 | (define-state bundle #f 1167 | #:init #t) 1168 | (define-state bundle-finalizer #f 1169 | #:init #t) 1170 | (define-state bundle-label label 1171 | #:init #t) 1172 | (new label$ [parent this] 1173 | [font font] 1174 | [text label]) 1175 | (define opt (option this)) 1176 | (when bundle 1177 | (send bundle add-option 1178 | bundle-label 1179 | (λ () 1180 | ((or bundle-finalizer values) opt)))))) 1181 | -------------------------------------------------------------------------------- /editor/private/surrogate-base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide surrogate%) 4 | (require framework 5 | (prefix-in s: "surrogate.rkt")) 6 | 7 | (define surrogate% 8 | (s:surrogate% racket:text-mode%)) 9 | -------------------------------------------------------------------------------- /editor/private/surrogate.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (all-defined-out)) 4 | (require racket/class 5 | (prefix-in gui: racket/gui/base) 6 | racket/unit 7 | racket/runtime-path 8 | racket/list 9 | racket/fasl 10 | racket/path 11 | racket/pretty 12 | syntax/modread 13 | drracket/tool 14 | framework 15 | (only-in racket/gui/base 16 | open-input-text-editor 17 | make-gui-empty-namespace) 18 | images/icons/style 19 | images/icons/control 20 | syntax-color/module-lexer 21 | syntax/modresolve 22 | racket/match 23 | racket/set 24 | racket/port 25 | racket/serialize 26 | syntax/parse 27 | "../lang.rkt" 28 | "context.rkt" 29 | "editor.rkt" 30 | "stdlib.rkt" 31 | "read-editor.rkt") 32 | 33 | (define-namespace-anchor anchor) 34 | 35 | (define (make-editor-namespace) 36 | (define ns (make-gui-empty-namespace)) 37 | (namespace-attach-module (namespace-anchor->empty-namespace anchor) 38 | 'editor/lang 39 | ns) 40 | (namespace-require 'racket/base ns) 41 | (namespace-require 'editor/base ns) 42 | (namespace-require 'editor/lang ns) 43 | (namespace-require 'racket/serialize ns) 44 | ns) 45 | 46 | (define (surrogate% %) 47 | (class* % (racket:text-mode<%>) 48 | (super-new) 49 | ;; Need the text object when enabled 50 | (define text #f) 51 | (define/override (on-enable-surrogate t) 52 | (super on-enable-surrogate t) 53 | (set! text t) 54 | (reset-editor-namespace)) 55 | ;; Ensure all editors in a buffer use the same namespace 56 | (define editor-namespace (make-editor-namespace)) 57 | (define stored-mod-stx #f) 58 | (define stored-mod-name #f) 59 | (define/public (get-mod-name) 60 | stored-mod-name) 61 | (define/public (get-editor-namespace) 62 | editor-namespace) 63 | (define/private (maybe-get-filename) 64 | (define tmp (box #f)) 65 | (define filename (send text get-filename tmp)) 66 | (and (not (unbox tmp)) 67 | filename 68 | (let* ([_ (if (string? filename) 69 | (string->path filename) 70 | filename)] 71 | [_ (resolve-module-path _)]) 72 | _))) 73 | (define/private (maybe-path-only path) 74 | (if (path-string? path) 75 | (path-only path) 76 | path)) 77 | (define/public (reset-editor-namespace) 78 | (define maybe-filename (maybe-get-filename)) 79 | (parameterize ([editor-read-as-snip? #t]) 80 | (define new-ns (make-editor-namespace)) 81 | (parameterize ([current-namespace new-ns]) 82 | (with-handlers ([exn:fail? 83 | (λ (e) 84 | (log-warning "~a" e) 85 | ;(define frame (send (send text get-tab) get-frame)) 86 | #;(send frame show-editor-error-panel (exn-message e)))]) 87 | (define-values (mod-stx mod-name) 88 | (let ([stx (try-read-editor)]) 89 | (values stx 90 | (or maybe-filename 91 | (list 'quote 92 | (syntax-parse stx 93 | [(mod name lang body ...) 94 | (syntax->datum #'name)])))))) 95 | (parameterize ([current-directory 96 | (or (maybe-path-only maybe-filename) (current-directory))] 97 | [current-module-declare-name 98 | (and maybe-filename (make-resolved-module-path maybe-filename))] 99 | [current-load-relative-directory 100 | (or maybe-filename (current-load-relative-directory))]) 101 | (eval mod-stx)) 102 | (namespace-require/expansion-time mod-name) 103 | (namespace-require (from-editor mod-name)) 104 | (namespace-require `(submod ,mod-name deserializer)) 105 | (set! stored-mod-name mod-name) 106 | (set! stored-mod-stx mod-stx) 107 | (set! editor-namespace new-ns))))) 108 | (define/public (try-read-editor) 109 | (parameterize ([editor-read-as-snip? #t]) 110 | (define out (open-output-bytes)) 111 | (define mod-text (send text save-port out 'standard)) 112 | (with-input-from-bytes (get-output-bytes out) 113 | (λ () 114 | (with-module-reading-parameterization 115 | read-syntax))))) 116 | ;; Ensure that #editor()() format is used 117 | (define prev-format #f) 118 | (define/override (after-save-file orig inner success?) 119 | (super after-save-file orig inner success?) 120 | (when prev-format 121 | (send orig set-file-format prev-format))) 122 | (define/override (on-save-file orig inner filename format) 123 | (set! prev-format (send orig get-file-format)) 124 | (send orig set-file-format 'text) 125 | (super on-save-file orig inner filename 'text)))) 126 | 127 | (define editor-icon 128 | (fast-forward-icon #:color "green" 129 | #:height (toolbar-icon-height))) 130 | 131 | (define (update-editors! text editors) 132 | (define filename (send text get-filename)) 133 | (parameterize ([editor-read-as-snip? #t] 134 | [current-directory (if filename (path-only filename) (current-directory))]) 135 | (define text-surrogate (send text get-surrogate)) 136 | (send text-surrogate reset-editor-namespace) 137 | (define editor-namespace (send text-surrogate get-editor-namespace)) 138 | (define editor-mod-name (send text-surrogate get-mod-name)) 139 | ;; First, update all editor-snips already in use. 140 | (let loop ([last-editor #f]) 141 | (define current-editor (send text find-next-non-string-snip last-editor)) 142 | (cond 143 | [(not current-editor) (void)] 144 | [else 145 | (when (is-a? current-editor editor-snip%) 146 | (define-values (binding is-same-file des-name) 147 | (send current-editor editor-binding)) 148 | (define serial 149 | (if is-same-file 150 | (serialize+rehome (send current-editor get-editor) des-name) 151 | (serialize (send current-editor get-editor)))) 152 | (send current-editor set-editor! (eval `(deserialize ',serial) editor-namespace)) 153 | (send current-editor set-namespace! editor-namespace) 154 | (send current-editor set-mod-name! editor-mod-name)) 155 | (loop current-editor)])) 156 | ;; Finally, replace their text with an actual editor snip 157 | ;; Go from end of file to start to ensure the placements haven't changed. 158 | (send text set-file-format 'standard) 159 | (define sorted-editors 160 | (sort (set->list editors) > #:key second)) 161 | (for ([e (in-list sorted-editors)]) 162 | (with-handlers ([exn:fail? (λ (e) 163 | (raise e) 164 | (void))]) 165 | (match-define `(#%editor ,elaborator ,editor) 166 | (let ([edi (first e)]) 167 | (cond [(string? edi) 168 | (with-input-from-string edi 169 | (λ () 170 | (parameterize ([current-readtable (make-editor-readtable)]) 171 | (read))))] 172 | [else edi]))) 173 | (define des 174 | (parameterize ([current-load-relative-directory 175 | (or filename (current-load-relative-directory))]) 176 | (eval `(deserialize ',editor) editor-namespace))) 177 | (send text delete (sub1 (second e)) (sub1 (third e)) #f) 178 | (send text insert (new editor-snip% 179 | [editor des] 180 | [namespace editor-namespace] 181 | [mod-name editor-mod-name]) (sub1 (second e))))))) 182 | 183 | (define toggle-button 184 | (list "Update Editors" 185 | editor-icon 186 | (λ (this) 187 | (parameterize ([editor-read-as-snip? #t] 188 | [port-count-lines-enabled #t]) 189 | (define text (send this get-definitions-text)) 190 | (define port #f) 191 | (define data (mutable-set)) 192 | ;; First, grab the location of every editor in text 193 | (dynamic-wind 194 | (λ () 195 | (set! port (open-input-text-editor text 0 'end values text #t #:lock-while-reading? #t)) 196 | (port-count-lines! port)) 197 | (λ () 198 | (match-define-values (_ _ _ _ _ _ out) 199 | (module-lexer port 0 #f)) 200 | ;; This button 'should' only get clicked 201 | ;; when the language is editor. 202 | (when #t ;(eq? out lex-editor) 203 | (define lex (lex-editor #f #:fill-matches data)) 204 | (let loop () 205 | (match-define-values (_ _ _ start end _ _) 206 | (lex port)) 207 | (when (and start end) 208 | (loop))))) 209 | (λ () 210 | (close-input-port port))) 211 | ;; Finally, update the editors 212 | (update-editors! text data))) 213 | #f)) 214 | 215 | (define (editor-status-mixin super%) 216 | (class super% 217 | (define status-panel-parent #f) 218 | (define status-panel #f) 219 | (define status-editor #f) 220 | (define d/i-p-p #f) 221 | (define showing? #f) 222 | (super-new) 223 | (define/override (get-definitions/interactions-panel-parent) 224 | (unless status-panel-parent 225 | (set! status-panel-parent (new panel:vertical-dragable% 226 | [parent (super get-definitions/interactions-panel-parent)])) 227 | (set! status-panel (new gui:vertical-panel% [parent status-panel-parent] 228 | [style '(border)] 229 | [stretchable-width #f] 230 | [stretchable-height #f])) 231 | (send status-panel-parent change-children (λ (l) '())) 232 | (define horiz-row (new gui:horizontal-pane% [parent status-panel])) 233 | (set! status-editor (new gui:text%)) 234 | (new gui:editor-canvas% [parent horiz-row] 235 | [editor status-editor] 236 | [line-count 3]) 237 | (new gui:button% [parent horiz-row] 238 | [label "Close"] 239 | [callback (λ (b e) 240 | (hide-editor-error-panel))]) 241 | (set! d/i-p-p (make-object gui:vertical-panel% status-panel-parent))) 242 | d/i-p-p) 243 | (define/public (show-editor-error-panel [msg ""]) 244 | (unless showing? 245 | (send status-panel-parent change-children (λ (l) (cons status-panel l))) 246 | (send status-panel-parent set-percentages 247 | '(1/10 9/10)) 248 | (set! showing? #t)) 249 | (send status-editor begin-edit-sequence) 250 | (send status-editor select-all) 251 | (send status-editor clear) 252 | (send status-editor insert msg) 253 | (send status-editor end-edit-sequence)) 254 | (define/public (hide-editor-error-panel) 255 | (when showing? 256 | (send status-panel-parent change-children (λ (l) (rest l))) 257 | (set! showing? #f))))) 258 | 259 | (define-runtime-path background.rkt "background.rkt") 260 | 261 | (define tool@ 262 | (unit 263 | (import drracket:tool^) 264 | (export drracket:tool-exports^) 265 | 266 | (define (phase1) (void)) 267 | (define (phase2) (void)) 268 | 269 | (drracket:get/extend:extend-unit-frame editor-status-mixin) 270 | (drracket:module-language-tools:add-online-expansion-monitor 271 | background.rkt 'expansion-monitor 272 | (λ (text data) 273 | (match data 274 | #;[(vector elaborator editor start end) 275 | (update-editors! text `(((#%editor ,(fasl->s-exp elaborator) 276 | ,(fasl->s-exp editor)) ,start ,end)))] 277 | [_ (void)]))))) 278 | -------------------------------------------------------------------------------- /editor/test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide test-window 4 | editor-canvas% 5 | editor->string 6 | editor->sexp) 7 | (require racket/class 8 | racket/port 9 | (prefix-in gui: racket/gui/base) 10 | "private/context.rkt" 11 | "private/read-editor.rkt") 12 | 13 | (define (test-window editor) 14 | (define f (new gui:frame% [label "Test Window"])) 15 | (new editor-canvas% [parent f] 16 | [editor editor]) 17 | (send f show #t)) 18 | 19 | (define (editor->string editor) 20 | (define f (new editor-snip% [editor editor])) 21 | (send f get-text 0 #f)) 22 | 23 | (define (editor->sexp editor) 24 | (parameterize ([current-readtable (make-editor-readtable)]) 25 | (with-input-from-string (editor->string editor) read))) 26 | -------------------------------------------------------------------------------- /editor/test/raco.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module+ main 4 | (require racket/cmdline 5 | syntax/location) 6 | (define the-file 7 | (command-line 8 | #:args (file) 9 | file)) 10 | 11 | (with-handlers* ([exn:fail? (λ (e) (dynamic-require `(submod ,the-file editor) #f))]) 12 | (dynamic-require `(submod ,the-file editor test) #f))) 13 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '(("base" "7.6") 6 | "draw-lib" 7 | "data-lib" 8 | "drracket-plugin-lib" 9 | "gui-lib" 10 | "images-lib" 11 | "math-lib" 12 | "syntax-color-lib" 13 | "wxme-lib")) 14 | (define build-deps '("scribble-lib" 15 | "racket-doc")) 16 | (define version "0.0.9") 17 | (define pkg-authors '(leif)) 18 | (define pkg-desc "Interactive Syntax") 19 | --------------------------------------------------------------------------------