! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: prettyprint
-USING: errors generic kernel lists math namespaces stdio strings
-presentation unparser vectors words hashtables ;
+
+! This using kernel-internals is pretty bad. Remove the
+! kernel-internals usage as soon as the tuple class is moved
+! to the generic vocabulary.
+USING: errors generic kernel kernel-internals lists math
+namespaces stdio strings presentation unparser vectors words
+hashtables ;
SYMBOL: prettyprint-limit
+SYMBOL: one-line
+SYMBOL: tab-size
GENERIC: prettyprint* ( indent obj -- indent )
M: object prettyprint* ( indent obj -- indent )
unparse write ;
-: tab-size
- #! Change this to suit your tastes.
- 4 ;
-
: indent ( indent -- )
#! Print the given number of spaces.
" " fill write ;
] ifte " " write ;
: <prettyprint ( indent -- indent )
- tab-size +
- "prettyprint-single-line" get [
+ tab-size get + one-line get [
" " write
] [
dup prettyprint-newline
] ifte ;
: prettyprint> ( indent -- indent )
- tab-size -
- "prettyprint-single-line" get [
- dup prettyprint-newline
- ] unless ;
+ tab-size get - one-line get
+ [ dup prettyprint-newline ] unless ;
: word-link ( word -- link )
[
swap dup word-attrs swap word-style append
write-attr ;
-: prettyprint-[ ( indent -- indent )
- \ [ prettyprint* <prettyprint ;
-
-: prettyprint-] ( indent -- indent )
- prettyprint> \ ] prettyprint* ;
-
-: prettyprint-list ( indent list -- indent )
- #! Pretty-print a list, without [ and ].
- [ prettyprint-element ] each ;
+: prettyprint-sequence ( indent start list end -- indent )
+ #! Prettyprint a list, with start/end delimiters; eg, [ ],
+ #! or { }, or << >>. The body of the list is indented,
+ #! unless the list is empty.
+ over [
+ >r
+ >r prettyprint* <prettyprint
+ r> [ prettyprint-element ] each
+ prettyprint> r> prettyprint*
+ ] [
+ >r >r prettyprint* " " write r> drop r> prettyprint*
+ ] ifte ;
M: list prettyprint* ( indent list -- indent )
- [
- swap prettyprint-[ swap prettyprint-list prettyprint-]
- ] [
- f unparse write
- ] ifte* ;
+ \ [ swap \ ] prettyprint-sequence ;
M: cons prettyprint* ( indent cons -- indent )
- \ [[ prettyprint* " " write
- uncons >r prettyprint-element r> prettyprint-element
- \ ]] prettyprint* ;
-
-: prettyprint-{ ( indent -- indent )
- \ { prettyprint* <prettyprint ;
-
-: prettyprint-} ( indent -- indent )
- prettyprint> \ } prettyprint* ;
-
-: prettyprint-vector ( indent list -- indent )
- #! Pretty-print a vector, without { and }.
- [ prettyprint-element ] vector-each ;
+ #! Here we turn the cons into a list of two elements.
+ \ [[ swap uncons 2list \ ]] prettyprint-sequence ;
M: vector prettyprint* ( indent vector -- indent )
- dup vector-length 0 = [
- drop
- \ { prettyprint*
- " " write
- \ } prettyprint*
- ] [
- swap prettyprint-{ swap prettyprint-vector prettyprint-}
- ] ifte ;
-
-: prettyprint-{{ ( indent -- indent )
- \ {{ prettyprint* <prettyprint ;
-
-: prettyprint-}} ( indent -- indent )
- prettyprint> \ }} prettyprint* ;
+ \ { swap vector>list \ } prettyprint-sequence ;
M: hashtable prettyprint* ( indent hashtable -- indent )
- hash>alist dup length 0 = [
- drop
- \ {{ prettyprint*
- " " write
- \ }} prettyprint*
- ] [
- swap prettyprint-{{ swap prettyprint-list prettyprint-}}
- ] ifte ;
+ \ {{ swap hash>alist \ }} prettyprint-sequence ;
M: tuple prettyprint* ( indent tuple -- indent )
- \ << prettyprint*
- " " write
- tuple>list [ prettyprint-element ] each
- \ >> prettyprint* ;
+ \ << swap tuple>list \ >> prettyprint-sequence ;
: prettyprint-1 ( obj -- )
0 swap prettyprint* drop ;
: . ( obj -- )
[
- "prettyprint-single-line" on
+ one-line on
16 prettyprint-limit set
prettyprint
] with-scope ;
: .o >oct print ;
: .h >hex print ;
-global [ 40 prettyprint-limit set ] bind
+global [ 40 prettyprint-limit set 4 tab-size set ] bind
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2003, 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
+! Copyright (C) 2003, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
IN: prettyprint
-USE: generic
-USE: kernel
-USE: lists
-USE: math
-USE: namespaces
-USE: stdio
-USE: strings
-USE: presentation
-USE: unparser
-USE: words
+USING: generic kernel lists math namespaces stdio strings
+presentation unparser words ;
! Prettyprinting words
: vocab-actions ( search -- list )
: prettyprint-: ( indent -- indent )
\ : prettyprint* " " write
- tab-size + ;
+ tab-size get + ;
: prettyprint-; ( indent -- indent )
\ ; prettyprint*
- tab-size - ;
+ tab-size get - ;
: prettyprint-prop ( word prop -- )
tuck word-name word-property [
] keep documentation. ;
: prettyprint-M: ( indent -- indent )
- \ M: prettyprint-1 " " write tab-size + ;
+ \ M: prettyprint-1 " " write tab-size get + ;
GENERIC: see ( word -- )
0 prettyprint-: swap
[ prettyprint-1 ] keep
[ prettyprint-docs ] keep
- [ word-parameter prettyprint-list prettyprint-; ] keep
+ [
+ word-parameter [ prettyprint-element ] each
+ prettyprint-;
+ ] keep
prettyprint-plist prettyprint-newline ;
: see-method ( indent word class method -- indent )
r> r> prettyprint-1 " " write
prettyprint-1 " " write
dup prettyprint-newline
- r> prettyprint-list
+ r> [ prettyprint-element ] each
prettyprint-;
terpri ;
projects / factor.git / commitdiff