439c1ecd24
of a supertype and subtype, where the subtype was not yet added to the tenv. Had to hack to get around that one. Also little problems like the fact that list can be captured by the user program, so we can't use that -- used list* (with a null at the end) and null (for empty lists) instead. Since the power was down and I couldn't get the earlier stuff committed, I have even more changes. Bug-fixes, mostly, though now top-level functions that are defined consecutively are mutually recursive as they should be. svn: r300
246 lines
11 KiB
Scheme
246 lines
11 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"
|
|
"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 (honu-lang-mixin level)
|
|
(class* object% (drscheme:language:language<%>)
|
|
(define/public (config-panel parent)
|
|
(case-lambda
|
|
[() null]
|
|
[(x) (void)]))
|
|
(define/public (get-comment-character) (values "//" #\*))
|
|
(define/public (default-settings) null)
|
|
(define/public (default-settings? x) #t)
|
|
(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 ([compiled-defns (compile/defns tenv lenv parsed)])
|
|
(datum->syntax-object #f (cons 'begin compiled-defns) #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 ([compiled-expr (compile/interaction tenv lenv parsed)])
|
|
(datum->syntax-object #f 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/public (marshall-settings x) x)
|
|
(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)
|
|
(old-current-eval (syntax-as-top exp)))))
|
|
(namespace-attach-module n path)
|
|
(namespace-require path)))))
|
|
(define/public (render-value value settings port) (display (format-honu value settings #t) port))
|
|
(define/public (render-value/format value settings port width) (render-value value settings port) (if (not (null? value)) (newline port)))
|
|
(define/public (unmarshall-settings x) x)
|
|
(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 value settings at-top?)
|
|
(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 at-top? "" "()")]
|
|
[(list? value)
|
|
(string-append "("
|
|
(fold (lambda (v s)
|
|
(string-append s ", " (format-honu v settings #f)))
|
|
(format-honu (car value) settings #f)
|
|
(cdr value))
|
|
")")]
|
|
[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)
|
|
)))
|