142 lines
3.3 KiB
Factor
142 lines
3.3 KiB
Factor
! Copyright (C) 2003, 2006 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
IN: prettyprint-internals
|
|
USING: alien arrays generic hashtables io kernel math
|
|
namespaces parser sequences strings styles vectors words
|
|
prettyprint ;
|
|
|
|
GENERIC: pprint* ( obj -- )
|
|
|
|
! Atoms
|
|
M: byte-array pprint* drop "( byte array )" text ;
|
|
|
|
: word-style ( word -- style )
|
|
[
|
|
dup presented set
|
|
parsing? [ bold font-style set ] when
|
|
] make-hash ;
|
|
|
|
: pprint-word ( word -- )
|
|
dup word-name swap word-style styled-text ;
|
|
|
|
M: word pprint*
|
|
dup parsing? [ \ POSTPONE: pprint-word ] when pprint-word ;
|
|
|
|
M: real pprint* number>string text ;
|
|
|
|
M: f pprint* drop \ f pprint-word ;
|
|
|
|
M: alien pprint*
|
|
dup expired? [
|
|
drop "( alien expired )"
|
|
] [
|
|
\ ALIEN: pprint-word alien-address number>string
|
|
] if text ;
|
|
|
|
! Strings
|
|
: ch>ascii-escape ( ch -- str )
|
|
H{
|
|
{ CHAR: \e "\\e" }
|
|
{ CHAR: \n "\\n" }
|
|
{ CHAR: \r "\\r" }
|
|
{ CHAR: \t "\\t" }
|
|
{ CHAR: \0 "\\0" }
|
|
{ CHAR: \\ "\\\\" }
|
|
{ CHAR: \" "\\\"" }
|
|
} hash ;
|
|
|
|
: ch>unicode-escape ( ch -- str )
|
|
>hex 4 CHAR: 0 pad-left "\\u" swap append ;
|
|
|
|
: unparse-ch ( ch -- )
|
|
dup quotable? [
|
|
,
|
|
] [
|
|
dup ch>ascii-escape [ ] [ ch>unicode-escape ] ?if %
|
|
] if ;
|
|
|
|
: do-string-limit ( str -- trimmed )
|
|
string-limit get [
|
|
dup length margin get > [
|
|
margin get 3 - head "..." append
|
|
] when
|
|
] when ;
|
|
|
|
: pprint-string ( str prefix -- )
|
|
[ % [ unparse-ch ] each CHAR: " , ] "" make
|
|
do-string-limit text ;
|
|
|
|
M: string pprint* "\"" pprint-string ;
|
|
|
|
M: sbuf pprint* "SBUF\" " pprint-string ;
|
|
|
|
M: dll pprint* dll-path "DLL\" " pprint-string ;
|
|
|
|
! Sequences
|
|
: nesting-limit? ( -- ? )
|
|
nesting-limit get dup [ pprinter-stack get length < ] when ;
|
|
|
|
: check-recursion ( obj quot -- )
|
|
nesting-limit? [
|
|
2drop "#" text
|
|
] [
|
|
over recursion-check get memq? [
|
|
2drop "&" text
|
|
] [
|
|
over recursion-check get push
|
|
call
|
|
recursion-check get pop*
|
|
] if
|
|
] if ; inline
|
|
|
|
: length-limit? ( seq -- trimmed ? )
|
|
length-limit get dup
|
|
[ over length over > [ head t ] [ drop f ] if ]
|
|
[ drop f ] if ;
|
|
|
|
: hilite-style ( -- hash )
|
|
H{
|
|
{ background { 0.9 0.9 0.9 1 } }
|
|
{ highlight t }
|
|
} ;
|
|
|
|
: pprint-hilite ( object n -- )
|
|
hilite-index get = [
|
|
hilite-style <flow pprint* block>
|
|
] [
|
|
pprint*
|
|
] if ;
|
|
|
|
: pprint-elements ( seq -- )
|
|
length-limit? >r dup hilite-quotation get eq? [
|
|
dup length [ pprint-hilite ] 2each
|
|
] [
|
|
[ pprint* ] each
|
|
] if r> [ "..." text ] when ;
|
|
|
|
GENERIC: >pprint-sequence ( obj -- seq start end narrow? )
|
|
|
|
M: complex >pprint-sequence >rect 2array \ C{ \ } f ;
|
|
|
|
M: quotation >pprint-sequence \ [ \ ] f ;
|
|
|
|
M: array >pprint-sequence \ { \ } t ;
|
|
|
|
M: vector >pprint-sequence \ V{ \ } t ;
|
|
|
|
M: hashtable >pprint-sequence hash>alist \ H{ \ } t ;
|
|
|
|
M: tuple >pprint-sequence tuple>array \ T{ \ } t ;
|
|
|
|
M: wrapper >pprint-sequence
|
|
wrapped dup 1array swap word? [ \ \ f ] [ \ W{ \ } ] if f ;
|
|
|
|
M: object pprint*
|
|
[
|
|
>pprint-sequence H{ } <flow
|
|
rot [ pprint-word ] when*
|
|
[ H{ } <narrow ] [ H{ } <inset ] if
|
|
swap pprint-elements
|
|
block> [ pprint-word ] when* block>
|
|
] check-recursion ;
|