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

merging 314:317 from branches/sstrickl

Browse Source 
This adds the ability to configure whether to print out just the class
name or class + fields for objects.  This also adds the feature of
printing out the type of expressions evaluated at the REPL as well as
their value.

svn: r318
This commit is contained in:
Stevie Strickland 2005-07-04 04:33:41 +00:00
parent 50a7859893
commit 62d631998b
3 changed files with 124 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/honu/compile.ss
View File

@ -21,11 +21,12 @@
. -> . . -> .
(listof (syntax/c any/c)))] (listof (syntax/c any/c)))]
[compile/interaction [compile/interaction
(tenv? ((tenv?
tenv? tenv?
(union honu:bind-top? honu:expr?) (union honu:bind-top? honu:expr?))
. -> . . ->* .
(syntax/c any/c))]) ((syntax/c any/c)
(union honu:type? false/c)))])
(define (compile/defns tenv lenv pgm) (define (compile/defns tenv lenv pgm)
(let ([pgm (post-parse-program tenv (add-defns-to-tenv pgm tenv))]) (let ([pgm (post-parse-program tenv (add-defns-to-tenv pgm tenv))])
(let ([checked (typecheck tenv lenv pgm)]) (let ([checked (typecheck tenv lenv pgm)])
@ -46,11 +47,11 @@
(check-bound-names lenv names) (check-bound-names lenv names)
(let ([checked (typecheck-defn tenv lenv ast)]) (let ([checked (typecheck-defn tenv lenv ast)])
(parameterize ([current-compile-context honu-compile-context]) (parameterize ([current-compile-context honu-compile-context])
(translate-defn tenv checked)))] (values (translate-defn tenv checked) #f)))]
[else [else
(let-values ([(checked type) (typecheck-expression tenv (lambda (n) #f) (let-values ([(checked type) (typecheck-expression tenv (lambda (n) #f)
(wrap-as-function lenv) (make-top-type #f) #f ast)]) (wrap-as-function lenv) (make-top-type #f) #f ast)])
(parameterize ([current-compile-context honu-compile-context]) (parameterize ([current-compile-context honu-compile-context])
(translate-expression tenv #f checked)))])) (values (translate-expression tenv #f checked) type)))]))
) )

54
collects/honu/private/compiler/translate.ss
View File

@ -98,32 +98,34 @@
(define (translate-formatter tenv name members arg-type) (define (translate-formatter tenv name members arg-type)
(let ([right-define (if arg-type 'define/override 'define/public)]) (let ([right-define (if arg-type 'define/override 'define/public)])
`(,right-define (format-class renderer indent) `(,right-define (format-class renderer indent print-fields?)
(format "~a {~a}" (if print-fields?
(quote ,(syntax-e name)) (format "~a {~a}"
,(cons 'string-append (quote ,(syntax-e name))
(let ([printable-members (filter (lambda (m) ,(cons 'string-append
(not (honu:method? m))) (let ([printable-members (filter (lambda (m)
members)] (not (honu:method? m)))
[printable-smembers (if arg-type members)]
(filter-map (lambda (m) [printable-smembers (if arg-type
(if (not (honu:type-disp? (tenv:member-type m))) (filter-map (lambda (m)
(tenv:member-name m) (if (not (honu:type-disp? (tenv:member-type m)))
#f)) (tenv:member-name m)
(tenv:type-members (get-type-entry tenv arg-type))) #f))
'())] (tenv:type-members (get-type-entry tenv arg-type)))
;; how much more do we want the members indented? Let's try 2 spaces more. '())]
[indent-delta 2]) ;; how much more do we want the members indented? Let's try 2 spaces more.
(if (and (null? printable-members) [indent-delta 2])
(null? printable-smembers)) (if (and (null? printable-members)
'("") (null? printable-smembers))
(fold-right (lambda (m l) '("")
(list* "\n" (translate-super-member-formatter tenv arg-type m indent-delta) l)) (fold-right (lambda (m l)
(fold-right (lambda (m l) (list* "\n" (translate-super-member-formatter tenv arg-type m indent-delta) l))
(list* "\n" (translate-member-formatter m indent-delta) l)) (fold-right (lambda (m l)
'("\n" (make-string indent #\space)) (list* "\n" (translate-member-formatter m indent-delta) l))
printable-members) '("\n" (make-string indent #\space))
printable-smembers)))))))) printable-members)
printable-smembers)))))
(format "~a" (quote ,(syntax-e name)))))))
(define (translate-member-formatter member indent-delta) (define (translate-member-formatter member indent-delta)
(let ([name (if (honu:field? member) (let ([name (if (honu:field? member)

114
collects/honu/tool.ss
View File

@ -8,6 +8,7 @@
(lib "list.ss" "srfi" "1") (lib "list.ss" "srfi" "1")
"parsers/lex.ss" "parsers/lex.ss"
"parsers/parse.ss" "parsers/parse.ss"
"private/typechecker/type-utils.ss"
(only "base.ss" null%) (only "base.ss" null%)
"tenv.ss" "tenv.ss"
"compile.ss" "compile.ss"
@ -24,15 +25,54 @@
(drscheme:language-configuration:add-language (drscheme:language-configuration:add-language
(make-object ((drscheme:language:get-default-mixin) (honu-lang-mixin 'normal))))) (make-object ((drscheme:language:get-default-mixin) (honu-lang-mixin 'normal)))))
(define-struct honu-settings (display-style) #f)
(define (honu-lang-mixin level) (define (honu-lang-mixin level)
(class* object% (drscheme:language:language<%>) (class* object% (drscheme:language:language<%>)
(define/public (config-panel parent)
(case-lambda
[() null]
[(x) (void)]))
(define/public (get-comment-character) (values "//" #\*)) (define/public (get-comment-character) (values "//" #\*))
(define/public (default-settings) null)
(define/public (default-settings? x) #t) (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 tenv (empty-tenv))
(define lenv (get-builtin-lenv)) (define lenv (get-builtin-lenv))
(define level-parser (define level-parser
@ -47,15 +87,17 @@
eof eof
(let* ([parsed (level-parser port name)]) (let* ([parsed (level-parser port name)])
(let ([compiled-defns (compile/defns tenv lenv parsed)]) (let ([compiled-defns (compile/defns tenv lenv parsed)])
(datum->syntax-object #f (cons 'begin compiled-defns) #f))))))) (datum->syntax-object #f `(compiled-program ,(cons 'begin compiled-defns)) #f)))))))
(define/public (front-end/interaction port settings teachpack-cache) (define/public (front-end/interaction port settings teachpack-cache)
(let ([name (object-name port)]) (let ([name (object-name port)])
(lambda () (lambda ()
(if (eof-object? (peek-char-or-special port)) (if (eof-object? (peek-char-or-special port))
eof eof
(let ([parsed (parse-interaction port name)]) (let ([parsed (parse-interaction port name)])
(let ([compiled-expr (compile/interaction tenv lenv parsed)]) (let-values ([(compiled-expr type) (compile/interaction tenv lenv parsed)])
(datum->syntax-object #f compiled-expr #f))))))) (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-style-delta) #f)
(define/public (get-language-position) (define/public (get-language-position)
(list (string-constant experimental-languages) (list (string-constant experimental-languages)
@ -72,7 +114,6 @@
(case level (case level
[(normal) (list 1000 10)])) [(normal) (list 1000 10)]))
(define/public (get-teachpack-names) null) (define/public (get-teachpack-names) null)
(define/public (marshall-settings x) x)
(define/private (syntax-as-top s) (define/private (syntax-as-top s)
(if (syntax? s) (namespace-syntax-introduce s) s)) (if (syntax? s) (namespace-syntax-introduce s) s))
(define/public (on-execute settings run-in-user-thread) (define/public (on-execute settings run-in-user-thread)
@ -86,12 +127,21 @@
(let ([old-current-eval (drscheme:debug:make-debug-eval-handler (current-eval))]) (let ([old-current-eval (drscheme:debug:make-debug-eval-handler (current-eval))])
(current-eval (current-eval
(lambda (exp) (lambda (exp)
(old-current-eval (syntax-as-top exp))))) (syntax-case exp (compiled-program compiled-binding compiled-expression)
[(compiled-program pgm)
(old-current-eval (syntax-as-top #'pgm))]
[(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))]))))
(namespace-attach-module n path) (namespace-attach-module n path)
(namespace-require path))))) (namespace-require path)))))
(define/public (render-value value settings port) (display (format-honu value settings 0) port)) (define/public (render-value value settings port)
(define/public (render-value/format value settings port width) (render-value value settings port) (if (not (null? value)) (newline port))) (display (format-honu value settings) port))
(define/public (unmarshall-settings x) x) (define/public (render-value/format value settings port width)
(render-value value settings port)
(if (not (null? value)) (newline port)))
(define/public (create-executable settings parent src-file teachpacks) (define/public (create-executable settings parent src-file teachpacks)
(message-box "Unsupported" (message-box "Unsupported"
"Sorry - executables are not supported for Honu at this time" "Sorry - executables are not supported for Honu at this time"
@ -109,7 +159,18 @@
(define (matches-language l) (define (matches-language l)
(and l (pair? l) (pair? (cdr l)) (equal? (cadr l) "Honu"))) (and l (pair? l) (pair? (cdr l)) (equal? (cadr l) "Honu")))
(define (format-honu value settings indent) (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)
(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 (cond
[(number? value) (format "~a" value)] [(number? value) (format "~a" value)]
[(char? value) (format "'~a'" value)] [(char? value) (format "'~a'" value)]
@ -127,34 +188,35 @@
;; or structure, then it is printed out. ;; or structure, then it is printed out.
(if (= indent 0) "" "()")] (if (= indent 0) "" "()")]
[(list? value) [(list? value)
(if (any (lambda (v) (if (and (eqv? (honu-settings-display-style settings) 'field)
;; checking to see if it's a non-null object (any (lambda (v)
(and (object? v) (not (is-a? v null%)))) ;; checking to see if it's a non-null object
value) (and (object? v) (not (is-a? v null%))))
value))
(string-append "(" (string-append "("
(fold (lambda (v s) (fold (lambda (v s)
;; if there are objects in the list, then we'll ;; if there are objects in the list, then we'll
;; print each value on its own line. ;; print each value on its own line.
(string-append s ",\n" (make-string (+ indent 1) #\space) (string-append s ",\n" (make-string (+ indent 1) #\space)
(format-honu v settings (+ indent 1)))) (format-honu-value v settings (+ indent 1))))
(format-honu (car value) settings (+ indent 1)) (format-honu-value (car value) settings (+ indent 1))
(cdr value)) (cdr value))
")") ")")
(string-append "(" (string-append "("
(fold (lambda (v s) (fold (lambda (v s)
;; if there are no objects, then we'll just print out ;; if there are no objects, then we'll just print out
;; the list on the same line. ;; the list on the same line.
(string-append s ", " (format-honu v settings (+ indent 1)))) (string-append s ", " (format-honu-value v settings (+ indent 1))))
(format-honu (car value) settings (+ indent 1)) (format-honu-value (car value) settings (+ indent 1))
(cdr value)) (cdr value))
")"))] ")"))]
[(is-a? value null%) "null"] [(is-a? value null%) "null"]
[(object? value) (send value format-class [(object? value) (send value format-class
(lambda (value at-top?) (lambda (value at-top?)
(format-honu value settings at-top?)) (format-honu-value value settings at-top?))
indent)] indent
(eqv? (honu-settings-display-style settings) 'field))]
[else (format "~a" value)])) [else (format "~a" value)]))
;Set the Honu editing colors ;Set the Honu editing colors
(define color-prefs-table (define color-prefs-table