347 lines
16 KiB
Scheme
347 lines
16 KiB
Scheme
(module tool mzscheme
|
|
(require (lib "tool.ss" "drscheme")
|
|
(lib "mred.ss" "mred")
|
|
(lib "framework.ss" "framework")
|
|
(lib "unitsig.ss")
|
|
(lib "etc.ss")
|
|
(lib "class.ss")
|
|
(lib "list.ss" "srfi" "1")
|
|
"parsers/lex.ss"
|
|
"parsers/parse.ss"
|
|
"private/typechecker/type-utils.ss"
|
|
(only "base.ss" null%)
|
|
"tenv.ss"
|
|
"compile.ss"
|
|
(lib "string-constant.ss" "string-constants"))
|
|
|
|
(provide tool@)
|
|
|
|
(define tool@
|
|
(unit/sig drscheme:tool-exports^
|
|
(import drscheme:tool^)
|
|
|
|
(define (phase1) (void))
|
|
(define (phase2)
|
|
(drscheme:language-configuration:add-language
|
|
(make-object ((drscheme:language:get-default-mixin) (honu-lang-mixin 'normal)))))
|
|
|
|
(define-struct honu-settings (display-style) #f)
|
|
|
|
(define (honu-lang-mixin level)
|
|
(class* object% (drscheme:language:language<%>)
|
|
(define/public (first-opened) (void))
|
|
(define/public (get-comment-character) (values "//" #\*))
|
|
|
|
(define/public (default-settings)
|
|
(make-honu-settings 'field))
|
|
(define/public (default-settings? s)
|
|
(equal? s (default-settings)))
|
|
(define/public (marshall-settings s)
|
|
(list (list (honu-settings-display-style s))))
|
|
(define/public (unmarshall-settings s)
|
|
(if (and (pair? s) (= (length s) 1)
|
|
(pair? (car s)) (= (length (car s)) 1))
|
|
(make-honu-settings (caar s))
|
|
#f))
|
|
|
|
(define/public (config-panel _parent)
|
|
(letrec ([parent (instantiate vertical-panel% ()
|
|
(parent _parent)
|
|
(alignment '(center center))
|
|
(stretchable-height #f)
|
|
(stretchable-width #f))]
|
|
|
|
[output-panel (instantiate group-box-panel% ()
|
|
(label "Display Preferences")
|
|
(parent parent)
|
|
(alignment '(left center)))]
|
|
[display-style (make-object radio-box%
|
|
"Display style"
|
|
(list "Class" "Class+Fields" )
|
|
output-panel
|
|
(lambda (x y) (update-ps)))]
|
|
|
|
[update-ps (lambda () (void))])
|
|
|
|
(case-lambda
|
|
[()
|
|
(make-honu-settings (case (send display-style get-selection)
|
|
[(0) 'class]
|
|
[(1) 'field]))]
|
|
[(settings)
|
|
(send display-style set-selection
|
|
(case (honu-settings-display-style settings)
|
|
((class) 0)
|
|
((field) 1)))])))
|
|
|
|
(define tenv (empty-tenv))
|
|
(define lenv (get-builtin-lenv))
|
|
(define level-parser
|
|
(case level
|
|
[(normal) parse-port]))
|
|
(define/public (front-end/complete-program port settings teachpack-cache)
|
|
(set! tenv (empty-tenv))
|
|
(set! lenv (get-builtin-lenv))
|
|
(let ([name (object-name port)])
|
|
(lambda ()
|
|
(if (eof-object? (peek-char-or-special port))
|
|
eof
|
|
(let* ([parsed (level-parser port name)])
|
|
(let-values
|
|
([(cruft-for-stx compiled-defns) (compile/defns tenv lenv parsed)])
|
|
;; if we wrap this in something special for the syntax-case below, then
|
|
;; Check Syntax breaks (unsurprisingly), so we'll just do special
|
|
;; wrappers for the interaction stuff.
|
|
(datum->syntax-object
|
|
#f
|
|
(list 'begin cruft-for-stx
|
|
(datum->syntax-object #f (cons 'begin compiled-defns) #f))
|
|
#f)))))))
|
|
(define/public (front-end/interaction port settings teachpack-cache)
|
|
(let ([name (object-name port)])
|
|
(lambda ()
|
|
(if (eof-object? (peek-char-or-special port))
|
|
eof
|
|
(let ([parsed (parse-interaction port name)])
|
|
(let-values ([(compiled-expr type) (compile/interaction tenv lenv parsed)])
|
|
(if type
|
|
(datum->syntax-object #f `(compiled-expression ,compiled-expr ,type) #f)
|
|
(datum->syntax-object #f `(compiled-binding ,compiled-expr) #f))))))))
|
|
(define/public (get-style-delta) #f)
|
|
(define/public (get-language-position)
|
|
(list (string-constant experimental-languages)
|
|
"Honu"))
|
|
(define/public (order-manuals x)
|
|
(values
|
|
(list #"drscheme" #"tour" #"help")
|
|
#f))
|
|
(define/public (get-language-name)
|
|
(case level
|
|
[(normal) "Honu"]))
|
|
(define/public (get-language-url) #f)
|
|
(define/public (get-language-numbers)
|
|
(case level
|
|
[(normal) (list 1000 10)]))
|
|
(define/public (get-teachpack-names) null)
|
|
(define/private (syntax-as-top s)
|
|
(if (syntax? s) (namespace-syntax-introduce s) s))
|
|
(define/public (on-execute settings run-in-user-thread)
|
|
(dynamic-require '(lib "base.ss" "honu") #f)
|
|
(let ([path ((current-module-name-resolver) '(lib "base.ss" "honu") #f #f)]
|
|
[n (current-namespace)])
|
|
(run-in-user-thread
|
|
(lambda ()
|
|
(error-display-handler
|
|
(drscheme:debug:make-debug-error-display-handler (error-display-handler)))
|
|
(let ([old-current-eval (drscheme:debug:make-debug-eval-handler (current-eval))])
|
|
(current-eval
|
|
(lambda (exp)
|
|
(syntax-case exp (compiled-binding compiled-expression)
|
|
[(compiled-binding binding)
|
|
(old-current-eval (syntax-as-top #'binding))]
|
|
[(compiled-expression ex type)
|
|
(cons (old-current-eval (syntax-as-top #'ex))
|
|
(syntax-e #'type))]
|
|
;; if it wasn't either of those, this must have been from the definitions
|
|
;; window, so just eval it.
|
|
;;
|
|
;; well, remove the cruft I added to get Check Syntax to work first.
|
|
[(_ type-cruft real-stx)
|
|
(old-current-eval (syntax-as-top #'real-stx))]))))
|
|
(namespace-attach-module n path)
|
|
(namespace-require path)))))
|
|
(define/public (render-value value settings port)
|
|
(display (format-honu value settings) port))
|
|
(define/public (render-value/format value settings port width)
|
|
(render-value value settings port)
|
|
(if (not (null? (car value))) (newline port)))
|
|
(define/public (create-executable settings parent src-file teachpacks)
|
|
(message-box "Unsupported"
|
|
"Sorry - executables are not supported for Honu at this time"
|
|
parent))
|
|
(define/public (get-one-line-summary)
|
|
(case level
|
|
[(normal) "Honu (also not Scheme at all!)"]))
|
|
|
|
(super-instantiate ())))
|
|
|
|
;; The following copies the Java mode to make one for Honu, but it's better right now than
|
|
;; using the Scheme mode. Ugh.
|
|
|
|
;; matches-language : (union #f (listof string)) -> boolean
|
|
(define (matches-language l)
|
|
(and l (pair? l) (pair? (cdr l)) (equal? (cadr l) "Honu")))
|
|
|
|
(define (format-honu result settings)
|
|
(cond
|
|
;; if we have a pair, then we evaluated an expression (the car)
|
|
;; and we also have its type (the cdr).
|
|
[(pair? result)
|
|
(if (null? (car result))
|
|
;; Don't print out anything for void values.
|
|
""
|
|
(format "~a : ~a"
|
|
(format-honu-value (car result) settings 0)
|
|
(printable-type (cdr result))))]
|
|
;; If we got here, then who knows what we got -- just print it out.
|
|
[else (format "~a" result)]))
|
|
|
|
(define (format-honu-value value settings indent)
|
|
(cond
|
|
[(number? value) (format "~a" value)]
|
|
[(char? value) (format "'~a'" value)]
|
|
[(string? value) (format "~v" value)]
|
|
[(boolean? value) (if value "true" "false")]
|
|
[(procedure? value) "procedure"]
|
|
;; tuples -- first the zero tuple, then the non-empty tuples
|
|
;;
|
|
;; if you want void values to be printed out, uncomment
|
|
;; the following:
|
|
;; [(null? value) "()"]
|
|
[(null? value)
|
|
;; the following makes it so that nothing is printed out
|
|
;; for a void value, but if a zero-tuple is part of a tuple
|
|
;; or structure, then it is printed out.
|
|
(if (= indent 0) "" "()")]
|
|
[(list? value)
|
|
(if (and (eqv? (honu-settings-display-style settings) 'field)
|
|
(any (lambda (v)
|
|
;; checking to see if it's a non-null object
|
|
(and (object? v) (not (is-a? v null%))))
|
|
value))
|
|
(string-append "("
|
|
(fold (lambda (v s)
|
|
;; if there are objects in the list, then we'll
|
|
;; print each value on its own line.
|
|
(string-append s ",\n" (make-string (+ indent 1) #\space)
|
|
(format-honu-value v settings (+ indent 1))))
|
|
(format-honu-value (car value) settings (+ indent 1))
|
|
(cdr value))
|
|
")")
|
|
(string-append "("
|
|
(fold (lambda (v s)
|
|
;; if there are no objects, then we'll just print out
|
|
;; the list on the same line.
|
|
(string-append s ", "
|
|
(format-honu-value v settings (+ indent 1))))
|
|
(format-honu-value (car value) settings (+ indent 1))
|
|
(cdr value))
|
|
")"))]
|
|
[(is-a? value null%) "null"]
|
|
[(object? value) (if (eqv? (honu-settings-display-style settings) 'field)
|
|
(send value format-class
|
|
(lambda (value at-top?)
|
|
(format-honu-value value settings at-top?))
|
|
indent)
|
|
(send value format-class-name))]
|
|
[else (format "~a" value)]))
|
|
|
|
;Set the Honu editing colors
|
|
(define color-prefs-table
|
|
`((keyword ,(make-object color% "black") "keyword")
|
|
(parenthesis ,(make-object color% 132 60 36) "parenthesis")
|
|
(string ,(make-object color% "forestgreen") "string")
|
|
(literal ,(make-object color% "forestgreen") "literal")
|
|
(comment ,(make-object color% 194 116 31) "comment")
|
|
(error ,(make-object color% "red") "error")
|
|
(identifier ,(make-object color% 38 38 128) "identifer")
|
|
(default ,(make-object color% "black") "default")))
|
|
|
|
;; short-sym->pref-name : symbol -> symbol
|
|
;; returns the preference name for the color prefs
|
|
(define (short-sym->pref-name sym) (string->symbol (short-sym->style-name sym)))
|
|
|
|
;; short-sym->style-name : symbol->string
|
|
;; converts the short name (from the table above) into a name in the editor list
|
|
;; (they are added in by `color-prefs:register-color-pref', called below)
|
|
(define (short-sym->style-name sym) (format "honu:syntax-coloring:scheme:~a" sym))
|
|
|
|
;; extend-preferences-panel : vertical-panel -> void
|
|
;; adds in the configuration for the Honu colors to the prefs panel
|
|
(define (extend-preferences-panel parent)
|
|
(for-each
|
|
(lambda (line)
|
|
(let ([sym (car line)])
|
|
(color-prefs:build-color-selection-panel
|
|
parent
|
|
(short-sym->pref-name sym)
|
|
(short-sym->style-name sym)
|
|
(format "~a" sym))))
|
|
color-prefs-table))
|
|
|
|
;Create the Honu editing mode
|
|
(define mode-surrogate
|
|
(new color:text-mode%
|
|
(matches (list (list '|{| '|}|)
|
|
(list '|(| '|)|)
|
|
(list '|[| '|]|)))
|
|
(get-token get-syntax-token)
|
|
(token-sym->style short-sym->style-name)))
|
|
|
|
;repl-submit: text int -> bool
|
|
;Determines if the reple should submit or not
|
|
(define (repl-submit text prompt-position)
|
|
(let ((is-empty? #t)
|
|
(is-string? #f)
|
|
(open-parens 0)
|
|
(open-braces 0)
|
|
(open-curlies 0))
|
|
(let loop ((index 1) (char (send text get-character prompt-position)))
|
|
(unless (eq? char #\nul)
|
|
(cond
|
|
((eq? char #\()
|
|
(set! is-empty? #f)
|
|
(unless is-string? (set! open-parens (add1 open-parens)))
|
|
(loop (add1 index) (send text get-character (+ index prompt-position))))
|
|
((eq? char #\))
|
|
(set! is-empty? #f)
|
|
(unless is-string? (set! open-parens (sub1 open-parens)))
|
|
(loop (add1 index) (send text get-character (+ index prompt-position))))
|
|
((eq? char #\{)
|
|
(set! is-empty? #f)
|
|
(unless is-string? (set! open-curlies (add1 open-curlies)))
|
|
(loop (add1 index) (send text get-character (+ index prompt-position))))
|
|
((eq? char #\})
|
|
(set! is-empty? #f)
|
|
(unless is-string? (set! open-curlies (sub1 open-curlies)))
|
|
(loop (add1 index) (send text get-character (+ index prompt-position))))
|
|
((eq? char #\[)
|
|
(set! is-empty? #f)
|
|
(unless is-string? (set! open-braces (add1 open-braces)))
|
|
(loop (add1 index) (send text get-character (+ index prompt-position))))
|
|
((eq? char #\])
|
|
(set! is-empty? #f)
|
|
(unless is-string? (set! open-braces (sub1 open-braces)))
|
|
(loop (add1 index) (send text get-character (+ index prompt-position))))
|
|
;beginning of string
|
|
((eq? char #\")
|
|
(set! is-empty? #f)
|
|
(set! is-string? (not is-string?))
|
|
(loop (add1 index) (send text get-character (+ index prompt-position))))
|
|
((char-whitespace? char)
|
|
(loop (add1 index) (send text get-character (+ index prompt-position))))
|
|
(else
|
|
(set! is-empty? #f)
|
|
(loop (add1 index) (send text get-character (+ index prompt-position)))))))
|
|
(not (or (not (= open-parens 0))
|
|
(not (= open-braces 0))
|
|
(not (= open-curlies 0))
|
|
is-empty?))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Wire up to DrScheme
|
|
;;
|
|
|
|
(drscheme:modes:add-mode "Honu mode" mode-surrogate repl-submit matches-language)
|
|
(color-prefs:add-to-preferences-panel "Honu" extend-preferences-panel)
|
|
|
|
(for-each (lambda (line)
|
|
(let ([sym (car line)]
|
|
[color (cadr line)])
|
|
(color-prefs:register-color-pref (short-sym->pref-name sym)
|
|
(short-sym->style-name sym)
|
|
color)))
|
|
color-prefs-table)
|
|
)))
|