moved pretty-printing formats to their own library.
This commit is contained in:
parent
f05f171f28
commit
4acf71d6d2
|
@ -0,0 +1,59 @@
|
||||||
|
(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 ...))
|
||||||
|
|
||||||
|
)
|
|
@ -15,10 +15,11 @@
|
||||||
|
|
||||||
|
|
||||||
(library (ikarus pretty-print)
|
(library (ikarus pretty-print)
|
||||||
(export pretty-print pretty-width pretty-format)
|
(export pretty-print pretty-width)
|
||||||
(import
|
(import
|
||||||
(rnrs hashtables)
|
(rnrs hashtables)
|
||||||
(except (ikarus) pretty-print pretty-width pretty-format))
|
(only (ikarus.pretty-formats) get-fmt)
|
||||||
|
(except (ikarus) pretty-print pretty-width))
|
||||||
(define (map1ltr f ls)
|
(define (map1ltr f ls)
|
||||||
;;; ltr so that gensym counts get assigned properly
|
;;; ltr so that gensym counts get assigned properly
|
||||||
(cond
|
(cond
|
||||||
|
@ -98,7 +99,7 @@
|
||||||
alt-fmt*))
|
alt-fmt*))
|
||||||
(define (applicable-formats a alt-fmt*)
|
(define (applicable-formats a alt-fmt*)
|
||||||
(cond
|
(cond
|
||||||
[(and (symbol? a) (getprop a *pretty-format*)) =>
|
[(and (symbol? a) (get-fmt a)) =>
|
||||||
(lambda (fmt)
|
(lambda (fmt)
|
||||||
(cond
|
(cond
|
||||||
[(and (pair? fmt) (eq? (car fmt) 'alt))
|
[(and (pair? fmt) (eq? (car fmt) 'alt))
|
||||||
|
@ -599,9 +600,6 @@
|
||||||
(define (pretty x p)
|
(define (pretty x p)
|
||||||
(output (boxify (unshare x)) p))
|
(output (boxify (unshare x)) p))
|
||||||
;;;
|
;;;
|
||||||
(define *pretty-format* '*pretty-format*)
|
|
||||||
(define (set-fmt! name fmt)
|
|
||||||
(putprop name *pretty-format* fmt))
|
|
||||||
(define pretty-print
|
(define pretty-print
|
||||||
(case-lambda
|
(case-lambda
|
||||||
[(x) (pretty x (current-output-port))]
|
[(x) (pretty x (current-output-port))]
|
||||||
|
@ -610,53 +608,6 @@
|
||||||
(pretty x p)
|
(pretty x p)
|
||||||
(die 'pretty-print "not an output port" p))]))
|
(die 'pretty-print "not an output port" p))]))
|
||||||
|
|
||||||
(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 ...))
|
|
||||||
|
|
||||||
)
|
)
|
||||||
|
|
||||||
#!eof
|
#!eof
|
||||||
|
|
|
@ -27,6 +27,7 @@
|
||||||
(ikarus system $symbols)
|
(ikarus system $symbols)
|
||||||
(ikarus system $bytevectors)
|
(ikarus system $bytevectors)
|
||||||
(ikarus system $transcoders)
|
(ikarus system $transcoders)
|
||||||
|
(only (ikarus.pretty-formats) get-fmt)
|
||||||
(only (ikarus unicode-data) unicode-printable-char?)
|
(only (ikarus unicode-data) unicode-printable-char?)
|
||||||
(except (ikarus)
|
(except (ikarus)
|
||||||
write display format printf fprintf print-error print-unicode print-graph
|
write display format printf fprintf print-error print-unicode print-graph
|
||||||
|
@ -458,7 +459,7 @@
|
||||||
(and (pair? d)
|
(and (pair? d)
|
||||||
(null? ($cdr d))
|
(null? ($cdr d))
|
||||||
(not (hashtable-ref h x #f))))
|
(not (hashtable-ref h x #f))))
|
||||||
(let ([p ((pretty-format a))])
|
(let ([p (get-fmt a)])
|
||||||
(and (pair? p)
|
(and (pair? p)
|
||||||
(eq? (car p) 'read-macro)
|
(eq? (car p) 'read-macro)
|
||||||
(string? (cdr p)))
|
(string? (cdr p)))
|
||||||
|
|
|
@ -1 +1 @@
|
||||||
1472
|
1473
|
||||||
|
|
|
@ -72,6 +72,7 @@
|
||||||
"ikarus.bytevectors.ss"
|
"ikarus.bytevectors.ss"
|
||||||
"ikarus.io.ss"
|
"ikarus.io.ss"
|
||||||
"ikarus.hash-tables.ss"
|
"ikarus.hash-tables.ss"
|
||||||
|
"ikarus.pretty-formats.ss"
|
||||||
"ikarus.writer.ss"
|
"ikarus.writer.ss"
|
||||||
"ikarus.reader.ss"
|
"ikarus.reader.ss"
|
||||||
"ikarus.code-objects.ss"
|
"ikarus.code-objects.ss"
|
||||||
|
|
Loading…
Reference in New Issue