"/library/presentation.factor"
"/library/vocabulary-style.factor"
"/library/syntax/prettyprint.factor"
+ "/library/syntax/see.factor"
"/library/platform/native/debugger.factor"
"/library/tools/debugger.factor"
"/library/platform/native/init.factor"
parsing
! Comments
-: ( ")" until parsed-stack-effect ; parsing
+: (
+ #! Stack comment.
+ ")" until parsed-stack-effect ; parsing
-: ! until-eol drop ; parsing
+: !
+ #! EOL comment.
+ until-eol drop ; parsing
-: #! until-eol parsed-documentation ; parsing
+: #!
+ #! Documentation comment.
+ until-eol parsed-documentation ; parsing
! Reading numbers in other bases
dup prettyprint-newline
] unless ;
+: word-link ( word -- link )
+ [
+ "vocabularies'" ,
+ dup word-vocabulary ,
+ "'" ,
+ word-name ,
+ ] make-string ;
+
+: word-actions ( -- list )
+ [
+ [ "Describe" | "describe-path" ]
+ [ "Push" | "lookup" ]
+ [ "Execute" | "lookup execute" ]
+ [ "jEdit" | "lookup jedit" ]
+ [ "Usages" | "lookup usages." ]
+ ] ;
+
+: word-attrs ( word -- attrs )
+ #! Words without a vocabulary do not get a link or an action
+ #! popup.
+ dup word-vocabulary [
+ word-link [ "object-link" swons ] keep
+ word-actions <actions> "actions" swons
+ t "underline" swons
+ 3list
+ ] [
+ drop [ ]
+ ] ifte ;
+
+: prettyprint-word ( word -- )
+ dup word-name
+ swap dup word-attrs swap word-style append
+ write-attr ;
+
: prettyprint-[ ( indent -- indent )
\ [ prettyprint-word <prettyprint ;
prettyprint-list
] [
[
- "|" write prettyprint-space prettyprint-element
+ \ | prettyprint-word
+ prettyprint-space prettyprint-element
] when*
] ifte
] when* ;
swap prettyprint-{{ swap prettyprint-list prettyprint-}}
] ifte ;
-: trim-newline ( str -- str )
- dup ends-with-newline? dup [ nip ] [ drop ] ifte ;
-
-: prettyprint-comment ( comment -- )
- trim-newline "comments" style write-attr ;
-
-: word-link ( word -- link )
- [
- "vocabularies'" ,
- dup word-vocabulary ,
- "'" ,
- word-name ,
- ] make-string ;
-
-: word-actions ( -- list )
- [
- [ "Describe" | "describe-path" ]
- [ "Push" | "lookup" ]
- [ "Execute" | "lookup execute" ]
- [ "jEdit" | "lookup jedit" ]
- [ "Usages" | "lookup usages." ]
- ] ;
-
-: word-attrs ( word -- attrs )
- #! Words without a vocabulary do not get a link or an action
- #! popup.
- dup word-vocabulary [
- word-link [ "object-link" swons ] keep
- word-actions <actions> "actions" swons
- t "underline" swons
- 3list
- ] [
- drop [ ]
- ] ifte ;
-
-: prettyprint-word ( word -- )
- dup word-name
- swap dup word-attrs swap word-style append
- write-attr ;
-
: prettyprint-object ( indent obj -- indent )
unparse write ;
: prettyprint* ( indent obj -- indent )
over prettyprint-limit >= [
- unparse write
+ prettyprint-object
] [
[
[ f = ] [ prettyprint-object ]
: vocab-link ( vocab -- link )
"vocabularies'" swap cat2 ;
-: vocab-attrs ( word -- attrs )
- vocab-link "object-link" default-style acons ;
-
-: prettyprint-vocab ( vocab -- )
- dup vocab-attrs write-attr ;
-
-: prettyprint-IN: ( indent word -- )
- \ IN: prettyprint-word prettyprint-space
- word-vocabulary prettyprint-vocab prettyprint-newline ;
-
-: prettyprint-: ( indent -- indent )
- \ : prettyprint-word prettyprint-space
- tab-size + ;
-
-: prettyprint-; ( indent -- indent )
- \ ; prettyprint-word
- tab-size - ;
-
-: prettyprint-plist ( word -- )
- dup "parsing" word-property [ " parsing" write ] when
- "inline" word-property [ " inline" write ] when ;
-
: . ( obj -- )
[
"prettyprint-single-line" on
: .b >bin print ;
: .o >oct print ;
: .h >hex print ;
-
-: stack-effect. ( word -- )
- stack-effect [
- " " write
- [ CHAR: ( , , CHAR: ) , ] make-string prettyprint-comment
- ] when* ;
-
-: documentation. ( indent word -- indent )
- documentation [
- "\n" split [
- "#!" swap cat2 prettyprint-comment
- dup prettyprint-newline
- ] each
- ] when* ;
-
-: prettyprint-docs ( indent word -- indent )
- [
- stack-effect. dup prettyprint-newline
- ] keep documentation. ;
-
-: see-compound ( word -- )
- 0 swap
- [ dupd prettyprint-IN: prettyprint-: ] keep
- [ prettyprint-word ] keep
- [ prettyprint-docs ] keep
- [ word-parameter prettyprint-list prettyprint-; ] keep
- prettyprint-plist prettyprint-newline ;
-
-: see-primitive ( word -- )
- "PRIMITIVE: " write dup unparse write stack-effect. terpri ;
-
-: see-symbol ( word -- )
- "SYMBOL: " write . ;
-
-: see-undefined ( word -- )
- drop "Not defined" print ;
-
-: see ( name -- )
- #! Show a word definition.
- [
- [ compound? ] [ see-compound ]
- [ symbol? ] [ see-symbol ]
- [ primitive? ] [ see-primitive ]
- [ word? ] [ see-undefined ]
- [ drop t ] [ "Not a word: " write . ]
- ] cond ;
--- /dev/null
+! :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.
+
+IN: prettyprint
+USE: combinators
+USE: lists
+USE: math
+USE: stack
+USE: stdio
+USE: strings
+USE: presentation
+USE: unparser
+USE: words
+
+! Prettyprinting words
+: vocab-attrs ( word -- attrs )
+ vocab-link "object-link" default-style acons ;
+
+: prettyprint-vocab ( vocab -- )
+ dup vocab-attrs write-attr ;
+
+: prettyprint-IN: ( indent word -- )
+ \ IN: prettyprint-word prettyprint-space
+ word-vocabulary prettyprint-vocab prettyprint-newline ;
+
+: prettyprint-: ( indent -- indent )
+ \ : prettyprint-word prettyprint-space
+ tab-size + ;
+
+: prettyprint-; ( indent -- indent )
+ \ ; prettyprint-word
+ tab-size - ;
+
+: prettyprint-prop ( word prop -- )
+ tuck word-name word-property [
+ prettyprint-space prettyprint-word
+ ] [
+ drop
+ ] ifte ;
+
+: prettyprint-plist ( word -- )
+ dup
+ \ parsing prettyprint-prop
+ \ inline prettyprint-prop ;
+
+: prettyprint-comment ( comment -- )
+ "comments" style write-attr ;
+
+: stack-effect. ( word -- )
+ stack-effect [
+ " " write
+ [ CHAR: ( , , CHAR: ) , ] make-string prettyprint-comment
+ ] when* ;
+
+: documentation. ( indent word -- indent )
+ documentation [
+ "\n" split [
+ "#!" swap cat2 prettyprint-comment
+ dup prettyprint-newline
+ ] each
+ ] when* ;
+
+: prettyprint-docs ( indent word -- indent )
+ [
+ stack-effect. dup prettyprint-newline
+ ] keep documentation. ;
+
+: see-compound ( word -- )
+ 0 swap
+ [ dupd prettyprint-IN: prettyprint-: ] keep
+ [ prettyprint-word ] keep
+ [ prettyprint-docs ] keep
+ [ word-parameter prettyprint-list prettyprint-; ] keep
+ prettyprint-plist prettyprint-newline ;
+
+: see-primitive ( word -- )
+ "PRIMITIVE: " write dup unparse write stack-effect. terpri ;
+
+: see-symbol ( word -- )
+ \ SYMBOL: prettyprint-word . ;
+
+: see-undefined ( word -- )
+ drop "Not defined" print ;
+
+: see ( name -- )
+ #! Show a word definition.
+ [
+ [ compound? ] [ see-compound ]
+ [ symbol? ] [ see-symbol ]
+ [ primitive? ] [ see-primitive ]
+ [ word? ] [ see-undefined ]
+ [ drop t ] [ "Not a word: " write . ]
+ ] cond ;
[ "ansi-fg" | "3" ]
[ "fg" | [ 2 185 2 ] ]
] "vectors" set-vocab-style
+[
+ [ "fg" | [ 128 128 128 ] ]
+] "syntax" set-vocab-style
projects / factor.git / commitdiff