60 lines
2.1 KiB
Scheme
60 lines
2.1 KiB
Scheme
|
(library (ikarus.pretty-formats)
|
||
|
|
(export get-fmt pretty-format)
|
||
|
|
(import (except (ikarus) pretty-format))
|
||
|
|
|
||
|
|
(define *pretty-format* '*pretty-format*)
|
||
|
|
(define (get-fmt name)
|
||
|
|
(getprop name *pretty-format*))
|
||
|
|
(define (set-fmt! name fmt)
|
||
|
|
(putprop name *pretty-format* fmt))
|
||
|
|
|
||
|
|
|
||
|
|
(define pretty-format
|
||
|
|
(lambda (x)
|
||
|
|
(unless (symbol? x)
|
||
|
|
(die 'pretty-format "not a symbol" x))
|
||
|
|
(case-lambda
|
||
|
|
[() (getprop x *pretty-format*)]
|
||
|
|
[(v) (putprop x *pretty-format* v)])))
|
||
|
|
|
||
|
|
;;; standard formats
|
||
|
|
(set-fmt! 'quote '(read-macro . "'"))
|
||
|
|
(set-fmt! 'unquote '(read-macro . ","))
|
||
|
|
(set-fmt! 'unquote-splicing '(read-macro . ",@"))
|
||
|
|
(set-fmt! 'quasiquote '(read-macro . "`"))
|
||
|
|
(set-fmt! 'syntax '(read-macro . "#'"))
|
||
|
|
(set-fmt! 'quasisyntax '(read-macro . "#`"))
|
||
|
|
(set-fmt! 'unsyntax '(read-macro . "#,"))
|
||
|
|
(set-fmt! 'unsyntax-splicing '(read-macro . "#,@"))
|
||
|
|
;(set-fmt! '|#primitive| '(read-macro . "#%"))
|
||
|
|
(set-fmt! 'let '(alt
|
||
|
|
(_ (0 [e 0 e] ...) tab e ...)
|
||
|
|
(_ x (0 [e 0 e] ...) tab e ...)))
|
||
|
|
(set-fmt! 'letrec '(_ (0 [e 0 e] ...) tab e ...))
|
||
|
|
(set-fmt! 'letrec* '(_ (0 [e 0 e] ...) tab e ...))
|
||
|
|
(set-fmt! 'let-syntax '(_ (0 [e 0 e] ...) tab e ...))
|
||
|
|
(set-fmt! 'letrec-syntax '(_ (0 [e 0 e] ...) tab e ...))
|
||
|
|
(set-fmt! 'let* '(_ (0 [e 0 e] ...) tab e ...))
|
||
|
|
(set-fmt! 'let-values '(_ (0 [e 0 e] ...) tab e tab e* ...))
|
||
|
|
(set-fmt! 'cond '(_ tab [0 e ...] ...))
|
||
|
|
(set-fmt! 'define '(_ name tab e ...))
|
||
|
|
(set-fmt! 'case-lambda
|
||
|
|
'(_ tab [0 e ...] ...))
|
||
|
|
(set-fmt! 'struct-case
|
||
|
|
'(_ e tab [e 0 e ...] ...))
|
||
|
|
(set-fmt! 'if '(_ test 3 e ...))
|
||
|
|
(set-fmt! 'and '(and test 4 e ...))
|
||
|
|
(set-fmt! 'or '(or test 3 e ...))
|
||
|
|
(set-fmt! 'begin '(_ tab e ...))
|
||
|
|
(set-fmt! 'lambda '(_ fmls tab e tab e* ...))
|
||
|
|
(set-fmt! 'case '(_ e tab [e 0 e] ...))
|
||
|
|
(set-fmt! 'syntax-rules '(_ kwd* tab [e 0 e] ...))
|
||
|
|
(set-fmt! 'syntax-case '(_ expr kwd*
|
||
|
|
tab (e 0 e 0 e ...) ...))
|
||
|
|
(set-fmt! 'module '(alt (_ (fill ...) tab e ...)
|
||
|
|
(_ name (fill ...) tab e ...)))
|
||
|
|
(set-fmt! 'library '(_ name tab e ...))
|
||
|
|
(set-fmt! 'import '(_ tab e ...))
|
||
|
|
|
||
|
|
)
|