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

Honu

Browse Source 
tool.ss
- Added comments and contracts to all functions/methods
- Moved all definitions inside Honu language class
- Simplified some functions
- Removed Honu "configuration" option
format.ss
- Started new module for text formatting of Honu values

svn: r1964
This commit is contained in:
Carl Eastlund 2006-01-25 18:33:24 +00:00
parent 252304b43c
commit f1b37e9793
2 changed files with 372 additions and 297 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
collects/honu/format.ss Normal file
View File

@ -0,0 +1,75 @@
(module format mzscheme
(require (lib "contract.ss")
(lib "list.ss")
(lib "class.ss")
(lib "plt-match.ss")
(only "base.ss" null%)
"ast.ss"
)
(provide/contract
[honu-value->string (any/c . -> . string?)]
[honu-type->string (ast:type? . -> . string?)]
)
(define (string-append-delimited pre mid post strings)
(string-append
pre
(if (null? strings)
""
(foldl (lambda (str prefix)
(string-append prefix mid str))
(car strings)
(cdr strings)))
post))
(define (honu-value->string value)
(cond
[(number? value) (format "~a" value)]
[(char? value) (format "'~a'" value)]
[(string? value) (format "~s" value)]
[(boolean? value) (if value "true" "false")]
[(procedure? value) "procedure"]
[(null? value) "()"]
[(list? value) ; Always non-empty
(honu-tuple->string value)]
[(is-a? value null%) "null"]
[(object? value) ; Always non-null
(honu-object->string value)]
[else (error 'honu-value->string "Unknown value ~s" value)]))
(define (honu-tuple->string tuple)
(string-append-delimited "(" ", " ")" (map honu-value->string tuple)))
(define (honu-object->string value)
(send value format-class-name))
(define (honu-type->string t)
(match t
[(struct ast:type:top (_))
"(top type / any value)"]
[(struct ast:type:bot (_))
"(bottom type / no value)"]
[(struct ast:type:primitive (_ name))
(symbol->string name)]
[(struct ast:type:tuple (_ args))
(string-append-delimited "tuple(" ", " ")" (map honu-type->string args))]
[(struct ast:type:partial/tuple (_ slot type))
(format "tuple of size >= ~a where the type in position ~a is ~a"
slot slot (honu-type->string type))]
[(struct ast:type:function (_ arg ret))
(if (ast:type:function? arg)
(string-append "(" (honu-type->string arg) ") -> " (honu-type->string ret))
(string-append (honu-type->string arg) " -> " (honu-type->string ret)))]
[(struct ast:type:method (_ disp arg ret))
(string-append "[" (honu-type->string disp) "] "
(honu-type->string arg) " -> " (honu-type->string ret))]
[(struct ast:type:object:iface (_ name))
(symbol->string (syntax-e name))]
[(struct ast:type:object:any (_))
"Any"]
[(struct ast:type:object:null (_))
"null"]))
)

374
collects/honu/tool.ss
View File

@ -6,237 +6,252 @@
(lib "etc.ss")
(lib "class.ss")
(lib "list.ss" "srfi" "1")
(lib "match.ss")
"parsers/lex.ss"
"parsers/parse.ss"
"private/typechecker/type-utils.ss"
(only "base.ss" null%)
"tenv.ss"
"compile.ss"
"format.ss"
(lib "string-constant.ss" "string-constants"))
(provide tool@)
;; tool@ : Unit/Sig[drscheme:tool^ -> drscheme:tool-exports^]
;; Implements Honu as a DrScheme language
(define tool@
(unit/sig drscheme:tool-exports^
(import drscheme:tool^)
;; phase1 : -> Void
;; Performs general language extensions to DrScheme for Honu.
;; Currently none exist.
(define (phase1) (void))
;; phase2 : -> Void
;; Adds the Honu language to DrScheme.
(define (phase2)
(drscheme:language-configuration:add-language
(make-object ((drscheme:language:get-default-mixin) (honu-lang-mixin 'normal)))))
(define honu (new ((drscheme:language:get-default-mixin) honu-lang%)))
(drscheme:language-configuration:add-language honu)
(send honu pre-initialize))
(define-struct honu-settings (display-style) #f)
(define (honu-lang-mixin level)
;; honu-lang% : Class[drscheme:language:language<%>]
;; Honu implementation as a class.
(define honu-lang%
(class* object% (drscheme:language:language<%>)
(define/public (first-opened) (void))
;; tenv : TypeEnvironment
;; The current type environment for evaluation.
(define tenv #f)
;; lenv : LexicalEnvironment
;; The current lexical environment for evaluation.
(define lenv #f)
;; pre-initialize : -> Void
;; Hooks Honu up to DrScheme after being added as a language.
(define/public (pre-initialize)
(drscheme:modes:add-mode "Honu mode" mode-surrogate repl-submit matches-language)
(color-prefs:add-to-preferences-panel "Honu" extend-preferences-panel)
(for-each register-color-pref color-prefs-table))
;; first-opened : -> Void
;; Sets Honu state to initial values.
(define/public (first-opened)
(reset-evaluation!))
;; get-comment-character : -> String Character
;; Provides prefix and filler character for comments
;; for use in "Insert Large Letters"
(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))
;; default-settings : -> HonuSetting
;; Provides default global Honu configuration
(define/public (default-settings) #f)
(define/public (config-panel _parent)
(letrec ([parent (instantiate vertical-panel% ()
(parent _parent)
(alignment '(center center))
(stretchable-height #f)
(stretchable-width #f))]
;; default-settings? : HonuSetting -> Boolean
;; Reports whether Honu configuration is set to defaults
(define/public (default-settings? s) #t)
[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)))]
;; marshall-settings : HonuSetting -> Writable
;; Converts a Honu configuration to a value which can be
;; written to a port.
(define/public (marshall-settings s) s)
[update-ps (lambda () (void))])
;; unmarshall-settings : Writable -> HonuSetting
;; Converts the result of a previous marshall-settings to
;; a Honu configuration.
(define/public (unmarshall-settings s) s)
;; config-panel : panel% -> [Case (-> HonuSetting) (HonuSetting -> Void)]
;; Assembles a language configuration dialog for Honu
;; and produces a get/set function for the displayed configuration.
(define/public (config-panel parent)
(letrec ([output-panel (new group-box-panel%
[label "Honu Preferences (Currently Empty)"]
[parent parent]
[alignment '(left center)])])
(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)))])))
[() (default-settings)]
[(settings) (void)])))
(define tenv (empty-tenv))
(define lenv (get-builtin-lenv))
(define level-parser
(case level
[(normal) parse-port]))
;; front-end/complete-program :
;; InputPort HonuSetting TeachpackCache -> (-> (Union Syntax EOF))
;; Produces a thunk which compiles and returns a Honu definition when one
;; is available on the input port, or EOF when none are left.
(define/public (front-end/complete-program port settings teachpack-cache)
(set! tenv (empty-tenv))
(set! lenv (get-builtin-lenv))
(let ([name (object-name port)])
(reset-evaluation!)
(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.
(let*-values
([(syntax-annotation compiled-defns)
(compile/defns tenv lenv (parse-port port (object-name port)))])
;; This particular syntax construction is compatible with Check Syntax
;; and can be distinguished from compiled Interactions.
(datum->syntax-object
#f
(list 'begin cruft-for-stx
(datum->syntax-object #f (cons 'begin compiled-defns) #f))
#f)))))))
(list 'begin
syntax-annotation
(datum->syntax-object
#f
(cons 'begin compiled-defns)
#f))
#f)))))
;; front-end/interaction :
;; InputPort HonuSetting TeachpackCache -> (-> (Union Syntax EOF))
;; Produces a thunk which compiles and returns a Honu expression or definition
;; when one is available on the input port, or EOF when none are left.
(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)])
(let*-values ([(compiled-expr type)
(compile/interaction
tenv lenv
(parse-interaction port (object-name port)))])
(datum->syntax-object
#f
(if type
(datum->syntax-object #f `(compiled-expression ,compiled-expr ,type) #f)
(datum->syntax-object #f `(compiled-binding ,compiled-expr) #f))))))))
`(compiled-expression ,compiled-expr ,type)
`(compiled-binding ,compiled-expr))
#f)))))
;; get-style-delta : -> #f
;; Reports that the name Honu has no specific text style.
(define/public (get-style-delta) #f)
;; order-manuals : [Listof ByteString] -> (values [Listof ByteString] Boolean)
;; Reports which manuals from the input contain Honu documentation
;; and whether to search doc.txt files for Honu documentation.
;; Currently lists no manuals, but includes doc.txt.
(define/public (order-manuals manuals)
(values '() #t))
;; get-language-name : -> String
;; Produces Honu's name.
(define/public (get-language-name) "Honu")
;; get-language-url : -> (Union String #f)
;; Reports that Honu has no URL.
(define/public (get-language-url) #f)
;; get-language-position : -> [NonEmptyListof String]
;; Reports Honu's place in the language hierarchy.
(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))
;; get-language-numbers : -> [NonEmptyListof String]
;; Reports Honu's sort order in the language hierarchy.
(define/public (get-language-numbers) (list 1000 10))
;; get-one-line-summary : -> String
;; Produces a short description of Honu.
(define/public (get-one-line-summary) "Honu (not a Scheme dialect)")
;; on-execute : HonuSetting ((-> Void) -> Void) -> Void
;; Sets parameters for Honu execution.
(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)])
[namespace (current-namespace)])
(run-in-user-thread
(lambda ()
(define base-eval (drscheme:debug:make-debug-eval-handler (current-eval)))
(define (eval stx)
(syntax-case stx (compiled-binding compiled-expression)
[(compiled-binding BINDING)
(base-eval (namespace-syntax-introduce #'BINDING))]
[(compiled-expression EXPR TYPE)
(cons (base-eval (namespace-syntax-introduce #'EXPR))
(syntax-e #'TYPE))]
[(_ ANNOTATION PROGRAM)
(base-eval (namespace-syntax-introduce #'PROGRAM))]))
(current-eval eval)
(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-attach-module namespace path)
(namespace-require path)))))
;; render-value : Value HonuSetting OutputPort -> Void
;; Writes value to port as a single line with no newline.
(define/public (render-value value settings port)
(display (format-honu value settings) port))
;; render-value/format : Value HonuSetting OutputPort (Union Integer #f) -> Void
;; Writes value to port as lines of length no greater than width.
;; Terminates all lines with newline.
;; Currently fails to actually account for width.
(define/public (render-value/format value settings port width)
(render-value value settings port)
(if (not (null? (car value))) (newline port)))
(newline port))
;; create-executable : HonuSetting (Union Dialog Frame) String TeachpackCache -> Void
;; Raises an error reporting that Honu programs cannot be made into executables.
(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 ())))
;; Finish the class instantiation
(super-new)
;; The following copies the Java mode to make one for Honu, but it's better right now than
;; using the Scheme mode. Ugh.
;; ------------------------------------------------------------
;; BEGIN PRIVATE FUNCTIONS
;; matches-language : (union #f (listof string)) -> boolean
(define (matches-language l)
(and l (pair? l) (pair? (cdr l)) (equal? (cadr l) "Honu")))
;; reset-evaluation! : -> Void
;; Restore Honu state to initial values.
(define (reset-evaluation!)
(set! tenv (empty-tenv))
(set! lenv (get-builtin-lenv)))
;; format-honu : (cons Value Ast:Type) HonuSetting -> String
;; Formats the result of Honu evaluation for printing.
(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)]))
(honu-value->string (car result))
(honu-type->string (cdr 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)]))
;; matches-language : [NonEmptyListof String] -> Boolean
;; Reports whether a language dialog choice matches Honu.
(define (matches-language l)
(equal? l (get-language-position)))
;Set the Honu editing colors
;; register-color-pref : (list Symbol Color String) -> Void
;; Registers a single color preference setting in the correct menu.
(define (register-color-pref pref)
(let ([sym (car pref)]
[color (cadr pref)])
(color-prefs:register-color-pref (short-sym->pref-name sym)
(short-sym->style-name sym)
color)))
;; color-prefs-table : [Listof (list Symbol Color String)]
;; Lists the Honu color preference entries
(define color-prefs-table
`((keyword ,(make-object color% "black") "keyword")
(parenthesis ,(make-object color% 132 60 36) "parenthesis")
@ -269,7 +284,8 @@
(format "~a" sym))))
color-prefs-table))
;Create the Honu editing mode
;; mode-surrogate : TextMode
;; Create the Honu editing mode
(define mode-surrogate
(new color:text-mode%
(matches (list (list '|{| '|}|)
@ -278,8 +294,8 @@
(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
;; 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)
@ -313,7 +329,7 @@
(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
;; beginning of string
((eq? char #\")
(set! is-empty? #f)
(set! is-string? (not is-string?))
@ -327,20 +343,4 @@
(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)
)))
)))))