suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

* Misc reformatting and improvements (using for loops now)

Browse Source 
* Removed (unused) toplevel op/oprintf, and switch to scheme/unit
  (=> code outdented, but remember `-x -w' for svn diff/blame/etc)
* Remove unused `get-module-name-prefix'

svn: r10289
This commit is contained in:
Eli Barzilay 2008-06-16 15:49:07 +00:00
parent 76b90e7947
commit 1386b63116
1 changed files with 504 additions and 579 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

305
collects/drscheme/private/module-language.ss
View File

@ -1,8 +1,8 @@
#lang scheme/base
#lang scheme/unit
(provide module-language@)
(require scheme/unit
scheme/class
scheme/list
mred
compiler/embed
launcher
@ -11,10 +11,6 @@
"drsig.ss"
scheme/contract)
(define op (current-output-port))
(define (oprintf . args) (apply fprintf op args))
(define-unit module-language@
(import [prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
[prefix drscheme:language: drscheme:language^]
[prefix drscheme:unit: drscheme:unit^]
@ -35,7 +31,7 @@
(drscheme:language:simple-module-based-language->module-based-language-mixin
drscheme:language:simple-module-based-language%)))))
(drscheme:language-configuration:add-language
(instantiate module-language% ())))
(new module-language%)))
;; collection-paths : (listof (union 'default string))
;; command-line-args : (vectorof string)
@ -50,22 +46,21 @@
(field [iteration-number 0])
(define/augment (capability-value key)
(cond
[(eq? key 'drscheme:autocomplete-words)
(drscheme:language-configuration:get-all-scheme-manual-keywords)]
[else (drscheme:language:get-capability-default key)]))
(if (eq? key 'drscheme:autocomplete-words)
(drscheme:language-configuration:get-all-scheme-manual-keywords)
(drscheme:language:get-capability-default key)))
;; config-panel : as in super class
;; uses drscheme:language:simple-module-based-language-config-panel
;; and adds a collection paths configuration to it.
;; uses drscheme:language:simple-module-based-language-config-panel and
;; adds a collection paths configuration to it.
(define/override (config-panel parent)
(module-language-config-panel parent))
(define/override (default-settings)
(let ([super-defaults (super default-settings)])
(apply make-module-language-settings
(append
(vector->list (drscheme:language:simple-settings->vector super-defaults))
(append (vector->list (drscheme:language:simple-settings->vector
super-defaults))
(list '(default)
#())))))
@ -106,15 +101,13 @@
(super on-execute settings run-in-user-thread)
(run-in-user-thread
(λ ()
(current-command-line-arguments (module-language-settings-command-line-args settings))
(current-command-line-arguments
(module-language-settings-command-line-args settings))
(let ([default (current-library-collection-paths)])
(current-library-collection-paths
(apply
append
(map (λ (x) (if (symbol? x)
default
(list x)))
(module-language-settings-collection-paths settings))))))))
(append-map
(λ (x) (if (symbol? x) default (list x)))
(module-language-settings-collection-paths settings)))))))
(define/override (get-one-line-summary)
(string-constant module-language-one-line-summary))
@ -122,8 +115,7 @@
(inherit get-reader)
(define/override (front-end/interaction port settings)
(if (thread-cell-ref hopeless-repl)
(begin
(display "Module Language: " (current-error-port))
(begin (display "Module Language: " (current-error-port))
(display hopeless-message (current-error-port))
(newline (current-error-port))
(λ x eof))
@ -133,8 +125,6 @@
(let* ([super-thunk (λ () ((get-reader) (object-name port) port))]
[path (get-filename port)]
[module-name #f]
[module-name-prefix (get-module-name-prefix path)]
[get-require-module-name
(λ ()
;; "clearing out" the module-name via datum->syntax ensures
@ -143,13 +133,13 @@
(datum->syntax #'here (syntax-e module-name)))])
(λ ()
(set! iteration-number (+ iteration-number 1))
(cond
[(= 1 iteration-number)
(case iteration-number
[(1)
#`(current-module-declare-name
(if #,path
(make-resolved-module-path '#,path)
#f))]
[(= 2 iteration-number)
[(2)
(let ([super-result (super-thunk)])
(if (eof-object? super-result)
(raise-syntax-error 'Module\ Language hopeless-message)
@ -157,7 +147,7 @@
(transform-module path super-result)])
(set! module-name name)
new-module)))]
[(= 3 iteration-number)
[(3)
(let ([super-result (super-thunk)])
(if (eof-object? super-result)
#`(begin
@ -173,25 +163,18 @@
'module-language
"there can only be one expression in the definitions window"
super-result)))]
[(= 4 iteration-number)
[(4)
(if path
#`(#%app current-namespace (#%app module->namespace #,path))
#`(#%app current-namespace
(#%app
module->namespace
#,path))
#`(#%app current-namespace
(#%app
module->namespace
(#%app module->namespace
''#,(get-require-module-name))))]
[else eof]))))
;; printer settings are just ignored here.
(define/override (create-executable setting parent program-filename)
(let* ([executable-specs (drscheme:language:create-executable-gui
parent
program-filename
#t
#t)])
parent program-filename #t #t)])
(when executable-specs
(let ([launcher? (eq? 'launcher (car executable-specs))]
[gui? (eq? 'mred (cadr executable-specs))]
@ -231,9 +214,9 @@
executable-filename))))))))
(super-new
(module #f)
(language-position (list "Module"))
(language-numbers (list -32768)))))
[module #f]
[language-position (list "Module")]
[language-numbers (list -32768)])))
(define hopeless-repl (make-thread-cell #t))
(define hopeless-message
@ -248,69 +231,70 @@
;; module-language-config-panel : panel -> (case-> (-> settings) (settings -> void))
(define (module-language-config-panel parent)
(define new-parent
(instantiate vertical-panel% ()
(parent parent)
(alignment '(center center))
(stretchable-height #f)
(stretchable-width #f)))
(define simple-case-lambda (drscheme:language:simple-module-based-language-config-panel new-parent))
(define cp-panel (instantiate group-box-panel% ()
(parent new-parent)
(label (string-constant ml-cp-collection-paths))))
(new vertical-panel%
[parent parent]
[alignment '(center center)]
[stretchable-height #f]
[stretchable-width #f]))
(define simple-case-lambda
(drscheme:language:simple-module-based-language-config-panel new-parent))
(define cp-panel (new group-box-panel%
[parent new-parent]
[label (string-constant ml-cp-collection-paths)]))
(define args-panel (instantiate group-box-panel% ()
(parent new-parent)
(label (string-constant ml-command-line-arguments))))
(define args-panel (new group-box-panel%
[parent new-parent]
[label (string-constant ml-command-line-arguments)]))
(define args-text-box (new text-field%
(parent args-panel)
(label #f)
(init-value "#()")
(callback void)))
[parent args-panel]
[label #f]
[init-value "#()"]
[callback void]))
;; data associated with each item in listbox : boolean
;; indicates if the entry is the default paths.
(define lb (instantiate list-box% ()
(parent cp-panel)
(choices '("a" "b" "c"))
(label #f)
(callback (λ (x y) (update-buttons)))))
(define button-panel (instantiate horizontal-panel% ()
(parent cp-panel)
(alignment '(center center))
(stretchable-height #f)))
(define add-button (make-object button% (string-constant ml-cp-add) button-panel
(define lb (new list-box%
[parent cp-panel]
[choices '("a" "b" "c")]
[label #f]
[callback (λ (x y) (update-buttons))]))
(define button-panel (new horizontal-panel%
[parent cp-panel]
[alignment '(center center)]
[stretchable-height #f]))
(define add-button
(make-object button% (string-constant ml-cp-add) button-panel
(λ (x y) (add-callback))))
(define add-default-button (make-object button% (string-constant ml-cp-add-default) button-panel
(define add-default-button
(make-object button% (string-constant ml-cp-add-default) button-panel
(λ (x y) (add-default-callback))))
(define remove-button (make-object button% (string-constant ml-cp-remove) button-panel
(define remove-button
(make-object button% (string-constant ml-cp-remove) button-panel
(λ (x y) (remove-callback))))
(define raise-button (make-object button% (string-constant ml-cp-raise) button-panel
(λ (x y) (raise-callback))))
(define lower-button (make-object button% (string-constant ml-cp-lower) button-panel
(λ (x y) (lower-callback))))
(define raise-button
(make-object button% (string-constant ml-cp-raise) button-panel
(λ (x y) (move-callback -1))))
(define lower-button
(make-object button% (string-constant ml-cp-lower) button-panel
(λ (x y) (move-callback +1))))
(define (update-buttons)
(let ([lb-selection (send lb get-selection)]
[lb-tot (send lb get-number)])
(send remove-button enable lb-selection)
(send raise-button enable
(and lb-selection
(not (= lb-selection 0))))
(send raise-button enable (and lb-selection (not (= lb-selection 0))))
(send lower-button enable
(and lb-selection
(not (= lb-selection (- lb-tot 1)))))))
(and lb-selection (not (= lb-selection (- lb-tot 1)))))))
(define (add-callback)
(let ([dir (get-directory
(string-constant ml-cp-choose-a-collection-path)
(let ([dir (get-directory (string-constant ml-cp-choose-a-collection-path)
(send parent get-top-level-window))])
(when dir
(send lb append (path->string dir) #f)
(update-buttons))))
(define (add-default-callback)
(cond
[(has-default?)
(cond [(has-default?)
(message-box (string-constant drscheme)
(string-constant ml-cp-default-already-present)
(send parent get-top-level-window))]
@ -322,8 +306,7 @@
;; returns #t if the `default' entry has already been added
(define (has-default?)
(let loop ([n (send lb get-number)])
(cond
[(= n 0) #f]
(cond [(= n 0) #f]
[(send lb get-data (- n 1)) #t]
[else (loop (- n 1))])))
@ -331,84 +314,54 @@
(let ([to-delete (send lb get-selection)])
(send lb delete to-delete)
(unless (zero? (send lb get-number))
(send lb set-selection (min to-delete
(- (send lb get-number) 1))))
(send lb set-selection (min to-delete (- (send lb get-number) 1))))
(update-buttons)))
(define (lower-callback)
(define (move-callback d)
(let* ([sel (send lb get-selection)]
[vec (get-lb-vector)]
[below (vector-ref vec (+ sel 1))])
(vector-set! vec (+ sel 1) (vector-ref vec sel))
(vector-set! vec sel below)
[new (+ sel d)]
[other (vector-ref vec new)])
(vector-set! vec new (vector-ref vec sel))
(vector-set! vec sel other)
(set-lb-vector vec)
(send lb set-selection (+ sel 1))
(update-buttons)))
(define (raise-callback)
(let* ([sel (send lb get-selection)]
[vec (get-lb-vector)]
[above (vector-ref vec (- sel 1))])
(vector-set! vec (- sel 1) (vector-ref vec sel))
(vector-set! vec sel above)
(set-lb-vector vec)
(send lb set-selection (- sel 1))
(send lb set-selection new)
(update-buttons)))
(define (get-lb-vector)
(list->vector
(let loop ([n 0])
(cond
[(= n (send lb get-number)) null]
[else (cons (cons (send lb get-string n)
(send lb get-data n))
(loop (+ n 1)))]))))
(list->vector (for/list ([n (in-range (send lb get-number))])
(cons (send lb get-string n) (send lb get-data n)))))
(define (set-lb-vector vec)
(send lb clear)
(let loop ([n 0])
(cond
[(= n (vector-length vec)) (void)]
[else (send lb append (car (vector-ref vec n)))
(send lb set-data n (cdr (vector-ref vec n)))
(loop (+ n 1))])))
(for ([x (in-vector vec)] [n (in-naturals)])
(send lb append (car x))
(send lb set-data n (cdr x))))
(define (get-collection-paths)
(let loop ([n 0])
(cond
[(= n (send lb get-number)) null]
[else
(for/list ([n (in-range (send lb get-number))])
(let ([data (send lb get-data n)])
(cons (if data
'default
(send lb get-string n))
(loop (+ n 1))))])))
(if data 'default (send lb get-string n)))))
(define (install-collection-paths paths)
(send lb clear)
(for-each (λ (cp)
(for ([cp paths])
(if (symbol? cp)
(send lb append
(string-constant ml-cp-default-collection-path)
#t)
(send lb append cp #f)))
paths))
(send lb append (string-constant ml-cp-default-collection-path) #t)
(send lb append cp #f))))
(define (get-command-line-args)
(let ([str (send args-text-box get-value)])
(let ([read-res (parameterize ([read-accept-graph #f])
(let* ([str (send args-text-box get-value)]
[read-res (parameterize ([read-accept-graph #f])
(with-handlers ([exn:fail:read? (λ (x) #())])
(read (open-input-string str))))])
(cond
[(and (vector? read-res)
(andmap string? (vector->list read-res)))
read-res]
[else #()]))))
(if (and (vector? read-res) (andmap string? (vector->list read-res)))
read-res
#())))
(define (install-command-line-args vec)
(send args-text-box set-value
(parameterize ([print-vector-length #f])
(format "~s" vec))))
(parameterize ([print-vector-length #f]) (format "~s" vec))))
(send lb set '())
(update-buttons)
@ -417,14 +370,16 @@
[()
(let ([simple-settings (simple-case-lambda)])
(apply make-module-language-settings
(append
(vector->list (drscheme:language:simple-settings->vector simple-settings))
(append (vector->list (drscheme:language:simple-settings->vector
simple-settings))
(list (get-collection-paths)
(get-command-line-args)))))]
[(settings)
(simple-case-lambda settings)
(install-collection-paths (module-language-settings-collection-paths settings))
(install-command-line-args (module-language-settings-command-line-args settings))
(install-collection-paths
(module-language-settings-collection-paths settings))
(install-command-line-args
(module-language-settings-command-line-args settings))
(update-buttons)]))
;; transform-module : (union #f string) syntax syntax -> (values symbol[name-of-module] syntax[module])
@ -440,13 +395,11 @@
(let ([v-name (syntax name)])
(when filename (check-filename-matches filename #'name stx))
(thread-cell-set! hopeless-repl #f)
(values v-name
(values
v-name
;; rewrite the module to use the scheme/base version of `module'
(datum->syntax stx
(cons (datum->syntax #'here
'module
#'form)
#'rest)
(cons (datum->syntax #'here 'module #'form) #'rest)
stx)))]
[_
(raise-syntax-error 'module-language
@ -460,26 +413,6 @@
"only module expressions are allowed"
stx)]))
;; get-module-name-prefix : path -> string
;; returns the symbol that gets passed the current-module-name-prefix
;; while evaluating/expanding the module.
(define (get-module-name-prefix path)
(and path
(let-values ([(base name dir)
(split-path (normal-case-path (simplify-path (expand-user-path path) #f)))])
(string->symbol (format ",~a" (bytes->string/latin-1 (path->bytes base)))))))
;; build-name : path -> symbol
(define (build-name pre-path)
(let ([path (normal-case-path (simplify-path (expand-user-path pre-path) #f))])
(let-values ([(base name dir) (split-path path)])
(string->symbol (format ",~a"
(bytes->string/latin-1
(path->bytes
(build-path
base
(path-replace-suffix name #"")))))))))
;; get-filename : port -> (union string #f)
;; extracts the file the definitions window is being saved in, if any.
(define (get-filename port)
@ -508,8 +441,8 @@
"bad syntax in name position of module"
unexpanded-stx name))
(let-values ([(base name dir?) (split-path filename)])
(let* ([expected (string->symbol (path->string
(path-replace-suffix name #"")))])
(let ([expected (string->symbol
(path->string (path-replace-suffix name #"")))])
(unless (equal? expected datum)
(raise-syntax-error
'module-language
@ -523,8 +456,7 @@
(inherit get-text last-position get-character get-top-level-window)
(define/override (put-file directory default-name)
(let ([tlw (get-top-level-window)])
(if (and tlw
(is-a? tlw drscheme:unit:frame<%>))
(if (and tlw (is-a? tlw drscheme:unit:frame<%>))
(let* ([definitions-text (send tlw get-definitions-text)]
[module-language?
(is-a? (drscheme:language-configuration:language-settings-language
@ -559,8 +491,7 @@
(define/private (matches start string)
(let ([last-pos (last-position)])
(let loop ([i 0])
(cond
[(and (i . < . (string-length string))
(cond [(and (i . < . (string-length string))
((+ i start) . < . last-pos))
(and (char=? (string-ref string i)
(get-character (+ i start)))
@ -571,24 +502,18 @@
(define/private (skip-whitespace start)
(let ([last-pos (last-position)])
(let loop ([pos start])
(cond
[(pos . >= . last-pos) last-pos]
[else
(if (pos . >= . last-pos)
last-pos
(let ([char (get-character pos)])
(cond
[(char-whitespace? char)
(loop (+ pos 1))]
[else pos]))]))))
(if (char-whitespace? char)
(loop (+ pos 1))
pos))))))
(define/private (skip-to-whitespace start)
(let ([last-pos (last-position)])
(let loop ([pos start])
(cond
[(pos . >= . last-pos)
last-pos]
[(char-whitespace? (get-character pos))
pos]
[else
(loop (+ pos 1))]))))
(cond [(pos . >= . last-pos) last-pos]
[(char-whitespace? (get-character pos)) pos]
[else (loop (+ pos 1))]))))
(super-new))))
(super-new)))