5 line-limit set
[ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
[ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
- ] tabular-output ;
+ ] tabular-output nl ;
M: immutable summary drop "Sequence is immutable" ;
USING: help.markup help.syntax io kernel math namespaces parser
prettyprint sequences vocabs.loader namespaces stack-checker
-help command-line multiline ;
+help command-line multiline see ;
IN: help.cookbook
ARTICLE: "cookbook-syntax" "Basic syntax cookbook"
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors definitions help help.topics help.syntax
prettyprint.backend prettyprint.custom prettyprint words kernel
-effects ;
+effects see ;
IN: help.definitions
! Definition protocol implementation
ARTICLE: "tools" "Developer tools"
{ $subsection "tools.vocabs" }
"Exploratory tools:"
+{ $subsection "see" }
{ $subsection "editor" }
{ $subsection "listener" }
{ $subsection "tools.crossref" }
USING: help.markup help.crossref help.stylesheet help.topics
help.syntax definitions io prettyprint summary arrays math
-sequences vocabs strings ;
+sequences vocabs strings see ;
IN: help
ARTICLE: "printing-elements" "Printing markup elements"
hashtables namespaces make parser prettyprint sequences strings
io.styles vectors words math sorting splitting classes slots fry
sets vocabs help.stylesheet help.topics vocabs.loader quotations
-combinators call ;
+combinators call see ;
IN: help.markup
PREDICATE: simple-element < array
SYMBOL: last-element
SYMBOL: span
SYMBOL: block
-SYMBOL: table
: last-span? ( -- ? ) last-element get span eq? ;
: last-block? ( -- ? ) last-element get block eq? ;
[ print-element ] with-default-style ;
: ($block) ( quot -- )
- last-element get { f table } member? [ nl ] unless
+ last-element get [ nl ] when
span last-element set
call
block last-element set ; inline
table-content-style get [
swap [ last-element off call ] tabular-output
] with-style
- ] ($block) table last-element set ; inline
+ ] ($block) ; inline
: $list ( element -- )
list-style get [
] with-style
] ($block) ; inline
-: $see ( element -- ) first [ see ] ($see) ;
+: $see ( element -- ) first [ see* ] ($see) ;
: $synopsis ( element -- ) first [ synopsis write ] ($see) ;
drop
"Throws an error if the I/O operation fails." $errors ;
+FROM: prettyprint.private => with-pprint ;
+
: $prettyprinting-note ( children -- )
drop {
"This word should only be called from inside the "
SYMBOL: +number-rows+
-: summary. ( obj -- ) [ summary ] keep write-object nl ;
+: print-summary ( obj -- ) [ summary ] keep write-object ;
<PRIVATE
: (describe) ( obj assoc -- keys )
t pprint-string-cells? [
- [ summary. ] [
+ [ print-summary nl ] [
dup hashtable? [ sort-unparsed-keys ] when
[ fix-slot-names add-numbers simple-table. ] [ keys ] bi
] bi*
nip <ignore-close-stream> ;
M: plain-writer stream-write-table
- [ drop format-table [ print ] each ] with-output-stream* ;
+ [ drop format-table [ nl ] [ write ] interleave ] with-output-stream* ;
M: plain-writer make-cell-stream 2drop <string-writer> ;
bi
] with-row
] each
- ] tabular-output
+ ] tabular-output nl
] unless-empty ;
: trimmed-stack. ( seq -- )
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors definitions effects generic kernel locals
-macros memoize prettyprint prettyprint.backend words ;
+macros memoize prettyprint prettyprint.backend see words ;
IN: locals.definitions
PREDICATE: lambda-word < word "lambda" word-prop >boolean ;
USING: help.syntax help.markup kernel macros prettyprint
-memoize combinators arrays generalizations ;
+memoize combinators arrays generalizations see ;
IN: locals
HELP: [|
USING: prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections prettyprint.private help.markup help.syntax
-io kernel words definitions quotations strings generic classes ;
+io kernel words definitions quotations strings generic classes
+prettyprint.private ;
IN: prettyprint
ARTICLE: "prettyprint-numbers" "Prettyprinting numbers"
{ $subsection unparse-use }
"Utility for tabular output:"
{ $subsection pprint-cell }
-"Printing a definition (see " { $link "definitions" } "):"
-{ $subsection see }
-"Printing the methods defined on a generic word or class (see " { $link "objects" } "):"
-{ $subsection see-methods }
"More prettyprinter usage:"
{ $subsection "prettyprint-numbers" }
{ $subsection "prettyprint-stacks" }
{ $subsection "prettyprint-variables" }
{ $subsection "prettyprint-extension" }
{ $subsection "prettyprint-limitations" }
-{ $see-also "number-strings" } ;
+{ $see-also "number-strings" "see" } ;
ABOUT: "prettyprint"
HELP: in.
{ $values { "vocab" "a vocabulary specifier" } }
{ $description "Prettyprints a " { $snippet "IN:" } " declaration." }
-$prettyprinting-note ;
-
-HELP: synopsis
-{ $values { "defspec" "a definition specifier" } { "str" string } }
-{ $contract "Prettyprints the prologue of a definition." } ;
-
-HELP: synopsis*
-{ $values { "defspec" "a definition specifier" } }
-{ $contract "Adds sections to the current block corresponding to a the prologue of a definition, in source code-like form." }
-{ $notes "This word should only be called from inside the " { $link with-pprint } " combinator. Client code should call " { $link synopsis } " instead." } ;
-
-HELP: comment.
-{ $values { "string" "a string" } }
-{ $description "Prettyprints some text with the comment style." }
-$prettyprinting-note ;
-
-HELP: see
-{ $values { "defspec" "a definition specifier" } }
-{ $contract "Prettyprints a definition." } ;
-
-HELP: see-methods
-{ $values { "word" "a " { $link generic } " or a " { $link class } } }
-{ $contract "Prettyprints the methods defined on a generic word or class." } ;
-
-HELP: definer
-{ $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } }
-{ $contract "Outputs the parsing words which delimit the definition." }
-{ $examples
- { $example "USING: definitions prettyprint ;"
- "IN: scratchpad"
- ": foo ; \\ foo definer . ."
- ";\nPOSTPONE: :"
- }
- { $example "USING: definitions prettyprint ;"
- "IN: scratchpad"
- "SYMBOL: foo \\ foo definer . ."
- "f\nPOSTPONE: SYMBOL:"
- }
-}
-{ $notes "This word is used in the implementation of " { $link see } "." } ;
-
-HELP: definition
-{ $values { "defspec" "a definition specifier" } { "seq" "a sequence" } }
-{ $contract "Outputs the body of a definition." }
-{ $examples
- { $example "USING: definitions math prettyprint ;" "\\ sq definition ." "[ dup * ]" }
-}
-{ $notes "This word is used in the implementation of " { $link see } "." } ;
+$prettyprinting-note ;
\ No newline at end of file
prettyprint.sections sequences tools.test vectors words
effects splitting generic.standard prettyprint.private
continuations generic compiler.units tools.walker eval
-accessors make vocabs.parser ;
+accessors make vocabs.parser see ;
IN: prettyprint.tests
[ "4" ] [ 4 unparse ] unit-test
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic generic.standard assocs io kernel math
-namespaces make sequences strings io.styles io.streams.string
-vectors words words.symbol prettyprint.backend prettyprint.custom
-prettyprint.sections prettyprint.config sorting splitting
-grouping math.parser vocabs definitions effects classes.builtin
-classes.tuple io.pathnames classes continuations hashtables
-classes.mixin classes.union classes.intersection
-classes.predicate classes.singleton combinators quotations sets
-accessors colors parser summary vocabs.parser ;
+USING: accessors assocs colors combinators grouping io
+io.streams.string io.styles kernel make math math.parser namespaces
+parser prettyprint.backend prettyprint.config prettyprint.custom
+prettyprint.sections quotations sequences sorting strings vocabs
+vocabs.parser words ;
IN: prettyprint
+<PRIVATE
+
: make-pprint ( obj quot -- block in use )
[
0 position set
nl
] print-use-hook set-global
+PRIVATE>
+
: with-use ( obj quot -- )
make-pprint use/in. do-pprint ; inline
] each
] with-row
] each
- ] tabular-output ;
-
-GENERIC: see ( defspec -- )
-
-: comment. ( string -- )
- [ H{ { font-style italic } } styled-text ] when* ;
-
-: seeing-word ( word -- )
- vocabulary>> pprinter-in set ;
-
-: definer. ( defspec -- )
- definer drop pprint-word ;
-
-: stack-effect. ( word -- )
- [ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and
- [ effect>string comment. ] when* ;
-
-: word-synopsis ( word -- )
- {
- [ seeing-word ]
- [ definer. ]
- [ pprint-word ]
- [ stack-effect. ]
- } cleave ;
-
-M: word synopsis* word-synopsis ;
-
-M: simple-generic synopsis* word-synopsis ;
-
-M: standard-generic synopsis*
- {
- [ definer. ]
- [ seeing-word ]
- [ pprint-word ]
- [ dispatch# pprint* ]
- [ stack-effect. ]
- } cleave ;
-
-M: hook-generic synopsis*
- {
- [ definer. ]
- [ seeing-word ]
- [ pprint-word ]
- [ "combination" word-prop var>> pprint* ]
- [ stack-effect. ]
- } cleave ;
-
-M: method-spec synopsis*
- first2 method synopsis* ;
-
-M: method-body synopsis*
- [ definer. ]
- [ "method-class" word-prop pprint-word ]
- [ "method-generic" word-prop pprint-word ] tri ;
-
-M: mixin-instance synopsis*
- [ definer. ]
- [ class>> pprint-word ]
- [ mixin>> pprint-word ] tri ;
-
-M: pathname synopsis* pprint* ;
-
-: synopsis ( defspec -- str )
- [
- 0 margin set
- 1 line-limit set
- [ synopsis* ] with-in
- ] with-string-writer ;
-
-M: word summary synopsis ;
-
-GENERIC: declarations. ( obj -- )
-
-M: object declarations. drop ;
-
-: declaration. ( word prop -- )
- [ nip ] [ name>> word-prop ] 2bi
- [ pprint-word ] [ drop ] if ;
-
-M: word declarations.
- {
- POSTPONE: parsing
- POSTPONE: delimiter
- POSTPONE: inline
- POSTPONE: recursive
- POSTPONE: foldable
- POSTPONE: flushable
- } [ declaration. ] with each ;
-
-: pprint-; ( -- ) \ ; pprint-word ;
-
-M: object see
- [
- 12 nesting-limit set
- 100 length-limit set
- <colon dup synopsis*
- <block dup definition pprint-elements block>
- dup definer nip [ pprint-word ] when* declarations.
- block>
- ] with-use nl ;
-
-M: method-spec see
- first2 method see ;
-
-GENERIC: see-class* ( word -- )
-
-M: union-class see-class*
- <colon \ UNION: pprint-word
- dup pprint-word
- members pprint-elements pprint-; block> ;
-
-M: intersection-class see-class*
- <colon \ INTERSECTION: pprint-word
- dup pprint-word
- participants pprint-elements pprint-; block> ;
-
-M: mixin-class see-class*
- <block \ MIXIN: pprint-word
- dup pprint-word <block
- dup members [
- hard line-break
- \ INSTANCE: pprint-word pprint-word pprint-word
- ] with each block> block> ;
-
-M: predicate-class see-class*
- <colon \ PREDICATE: pprint-word
- dup pprint-word
- "<" text
- dup superclass pprint-word
- <block
- "predicate-definition" word-prop pprint-elements
- pprint-; block> block> ;
-
-M: singleton-class see-class* ( class -- )
- \ SINGLETON: pprint-word pprint-word ;
-
-GENERIC: pprint-slot-name ( object -- )
-
-M: string pprint-slot-name text ;
-
-M: array pprint-slot-name
- <flow \ { pprint-word
- f <inset unclip text pprint-elements block>
- \ } pprint-word block> ;
-
-: unparse-slot ( slot-spec -- array )
- [
- dup name>> ,
- dup class>> object eq? [
- dup class>> ,
- initial: ,
- dup initial>> ,
- ] unless
- dup read-only>> [
- read-only ,
- ] when
- drop
- ] { } make ;
-
-: pprint-slot ( slot-spec -- )
- unparse-slot
- dup length 1 = [ first ] when
- pprint-slot-name ;
-
-M: tuple-class see-class*
- <colon \ TUPLE: pprint-word
- dup pprint-word
- dup superclass tuple eq? [
- "<" text dup superclass pprint-word
- ] unless
- <block "slots" word-prop [ pprint-slot ] each block>
- pprint-; block> ;
-
-M: word see-class* drop ;
-
-M: builtin-class see-class*
- drop "! Built-in class" comment. ;
-
-: see-class ( class -- )
- dup class? [
- [
- dup seeing-word dup see-class*
- ] with-use nl
- ] when drop ;
-
-M: word see
- [ see-class ]
- [ [ class? ] [ symbol? not ] bi and [ nl ] when ]
- [
- dup [ class? ] [ symbol? ] bi and
- [ drop ] [ call-next-method ] if
- ] tri ;
-
-: see-all ( seq -- )
- natural-sort [ nl ] [ see ] interleave ;
-
-: (see-implementors) ( class -- seq )
- dup implementors [ method ] with map natural-sort ;
-
-: (see-methods) ( generic -- seq )
- "methods" word-prop values natural-sort ;
-
-: methods ( word -- seq )
- [
- dup class? [ dup (see-implementors) % ] when
- dup generic? [ dup (see-methods) % ] when
- drop
- ] { } make prune ;
-
-: see-methods ( word -- )
- methods see-all ;
+ ] tabular-output nl ;
\ No newline at end of file
HELP: colon
{ $class-description "A " { $link block } " section. When printed as a " { $link long-section } ", indents every line except the first." }
-{ $notes "Colon sections are used to enclose word definitions printed by " { $link see } "." } ;
+{ $notes "Colon sections are used to enclose word definitions when " { $link "see" } "." } ;
HELP: <colon
{ $description "Begins a " { $link colon } " section." } ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: see
+USING: help.markup help.syntax strings prettyprint.private
+definitions generic words classes ;
+
+HELP: synopsis
+{ $values { "defspec" "a definition specifier" } { "str" string } }
+{ $contract "Prettyprints the prologue of a definition." } ;
+
+HELP: synopsis*
+{ $values { "defspec" "a definition specifier" } }
+{ $contract "Adds sections to the current block corresponding to a the prologue of a definition, in source code-like form." }
+{ $notes "This word should only be called from inside the " { $link with-pprint } " combinator. Client code should call " { $link synopsis } " instead." } ;
+
+HELP: see
+{ $values { "defspec" "a definition specifier" } }
+{ $contract "Prettyprints a definition." } ;
+
+HELP: see-methods
+{ $values { "word" "a " { $link generic } " or a " { $link class } } }
+{ $contract "Prettyprints the methods defined on a generic word or class." } ;
+
+HELP: definer
+{ $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } }
+{ $contract "Outputs the parsing words which delimit the definition." }
+{ $examples
+ { $example "USING: definitions prettyprint ;"
+ "IN: scratchpad"
+ ": foo ; \\ foo definer . ."
+ ";\nPOSTPONE: :"
+ }
+ { $example "USING: definitions prettyprint ;"
+ "IN: scratchpad"
+ "SYMBOL: foo \\ foo definer . ."
+ "f\nPOSTPONE: SYMBOL:"
+ }
+}
+{ $notes "This word is used in the implementation of " { $link see } "." } ;
+
+HELP: definition
+{ $values { "defspec" "a definition specifier" } { "seq" "a sequence" } }
+{ $contract "Outputs the body of a definition." }
+{ $examples
+ { $example "USING: definitions math prettyprint ;" "\\ sq definition ." "[ dup * ]" }
+}
+{ $notes "This word is used in the implementation of " { $link see } "." } ;
+
+ARTICLE: "see" "Printing definitions"
+"The " { $vocab-link "see" } " vocabulary implements support for printing out " { $link "definitions" } " in the image."
+$nl
+"Printing a definition:"
+{ $subsection see }
+"Printing the methods defined on a generic word or class (see " { $link "objects" } "):"
+{ $subsection see-methods } ;
+
+ABOUT: "see"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes classes.builtin
+classes.intersection classes.mixin classes.predicate
+classes.singleton classes.tuple classes.union combinators
+definitions effects generic generic.standard io io.pathnames
+io.streams.string io.styles kernel make namespaces prettyprint
+prettyprint.backend prettyprint.config prettyprint.custom
+prettyprint.sections sequences sets sorting strings summary
+words words.symbol ;
+IN: see
+
+GENERIC: see* ( defspec -- )
+
+: see ( defspec -- ) see* nl ;
+
+: synopsis ( defspec -- str )
+ [
+ 0 margin set
+ 1 line-limit set
+ [ synopsis* ] with-in
+ ] with-string-writer ;
+
+: definer. ( defspec -- )
+ definer drop pprint-word ;
+
+: comment. ( text -- )
+ H{ { font-style italic } } styled-text ;
+
+: stack-effect. ( word -- )
+ [ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and
+ [ effect>string comment. ] when* ;
+
+<PRIVATE
+
+: seeing-word ( word -- )
+ vocabulary>> pprinter-in set ;
+
+: word-synopsis ( word -- )
+ {
+ [ seeing-word ]
+ [ definer. ]
+ [ pprint-word ]
+ [ stack-effect. ]
+ } cleave ;
+
+M: word synopsis* word-synopsis ;
+
+M: simple-generic synopsis* word-synopsis ;
+
+M: standard-generic synopsis*
+ {
+ [ definer. ]
+ [ seeing-word ]
+ [ pprint-word ]
+ [ dispatch# pprint* ]
+ [ stack-effect. ]
+ } cleave ;
+
+M: hook-generic synopsis*
+ {
+ [ definer. ]
+ [ seeing-word ]
+ [ pprint-word ]
+ [ "combination" word-prop var>> pprint* ]
+ [ stack-effect. ]
+ } cleave ;
+
+M: method-spec synopsis*
+ first2 method synopsis* ;
+
+M: method-body synopsis*
+ [ definer. ]
+ [ "method-class" word-prop pprint-word ]
+ [ "method-generic" word-prop pprint-word ] tri ;
+
+M: mixin-instance synopsis*
+ [ definer. ]
+ [ class>> pprint-word ]
+ [ mixin>> pprint-word ] tri ;
+
+M: pathname synopsis* pprint* ;
+
+M: word summary synopsis ;
+
+GENERIC: declarations. ( obj -- )
+
+M: object declarations. drop ;
+
+: declaration. ( word prop -- )
+ [ nip ] [ name>> word-prop ] 2bi
+ [ pprint-word ] [ drop ] if ;
+
+M: word declarations.
+ {
+ POSTPONE: parsing
+ POSTPONE: delimiter
+ POSTPONE: inline
+ POSTPONE: recursive
+ POSTPONE: foldable
+ POSTPONE: flushable
+ } [ declaration. ] with each ;
+
+: pprint-; ( -- ) \ ; pprint-word ;
+
+M: object see*
+ [
+ 12 nesting-limit set
+ 100 length-limit set
+ <colon dup synopsis*
+ <block dup definition pprint-elements block>
+ dup definer nip [ pprint-word ] when* declarations.
+ block>
+ ] with-use ;
+
+M: method-spec see*
+ first2 method see* ;
+
+GENERIC: see-class* ( word -- )
+
+M: union-class see-class*
+ <colon \ UNION: pprint-word
+ dup pprint-word
+ members pprint-elements pprint-; block> ;
+
+M: intersection-class see-class*
+ <colon \ INTERSECTION: pprint-word
+ dup pprint-word
+ participants pprint-elements pprint-; block> ;
+
+M: mixin-class see-class*
+ <block \ MIXIN: pprint-word
+ dup pprint-word <block
+ dup members [
+ hard line-break
+ \ INSTANCE: pprint-word pprint-word pprint-word
+ ] with each block> block> ;
+
+M: predicate-class see-class*
+ <colon \ PREDICATE: pprint-word
+ dup pprint-word
+ "<" text
+ dup superclass pprint-word
+ <block
+ "predicate-definition" word-prop pprint-elements
+ pprint-; block> block> ;
+
+M: singleton-class see-class* ( class -- )
+ \ SINGLETON: pprint-word pprint-word ;
+
+GENERIC: pprint-slot-name ( object -- )
+
+M: string pprint-slot-name text ;
+
+M: array pprint-slot-name
+ <flow \ { pprint-word
+ f <inset unclip text pprint-elements block>
+ \ } pprint-word block> ;
+
+: unparse-slot ( slot-spec -- array )
+ [
+ dup name>> ,
+ dup class>> object eq? [
+ dup class>> ,
+ initial: ,
+ dup initial>> ,
+ ] unless
+ dup read-only>> [
+ read-only ,
+ ] when
+ drop
+ ] { } make ;
+
+: pprint-slot ( slot-spec -- )
+ unparse-slot
+ dup length 1 = [ first ] when
+ pprint-slot-name ;
+
+M: tuple-class see-class*
+ <colon \ TUPLE: pprint-word
+ dup pprint-word
+ dup superclass tuple eq? [
+ "<" text dup superclass pprint-word
+ ] unless
+ <block "slots" word-prop [ pprint-slot ] each block>
+ pprint-; block> ;
+
+M: word see-class* drop ;
+
+M: builtin-class see-class*
+ drop "! Built-in class" comment. ;
+
+: see-class ( class -- )
+ dup class? [
+ [
+ [ seeing-word ] [ see-class* ] bi
+ ] with-use
+ ] [ drop ] if ;
+
+M: word see*
+ [ see-class ]
+ [ [ class? ] [ symbol? not ] bi and [ nl nl ] when ]
+ [
+ dup [ class? ] [ symbol? ] bi and
+ [ drop ] [ call-next-method ] if
+ ] tri ;
+
+: seeing-implementors ( class -- seq )
+ dup implementors [ method ] with map natural-sort ;
+
+: seeing-methods ( generic -- seq )
+ "methods" word-prop values natural-sort ;
+
+PRIVATE>
+
+: see-all ( seq -- )
+ natural-sort [ nl nl ] [ see* ] interleave ;
+
+: methods ( word -- seq )
+ [
+ dup class? [ dup seeing-implementors % ] when
+ dup generic? [ dup seeing-methods % ] when
+ drop
+ ] { } make prune ;
+
+: see-methods ( word -- )
+ methods see-all nl ;
\ No newline at end of file
--- /dev/null
+Printing loaded definitions as source code
"cannot-infer" word-prop rethrow ;
: maybe-cannot-infer ( word quot -- )
- [ [ "cannot-infer" set-word-prop ] keep throw ] recover ; inline
+ [ [ "cannot-infer" set-word-prop ] keep rethrow ] recover ; inline
: infer-word ( word -- effect )
[
ARTICLE: "tools.crossref" "Cross-referencing tools"
{ $subsection usage. }
-{ $see-also "definitions" "words" see see-methods } ;
+{ $see-also "definitions" "words" "see" } ;
ABOUT: "tools.crossref"
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs definitions io io.styles kernel prettyprint
-sorting ;
+sorting see ;
IN: tools.crossref
: synopsis-alist ( definitions -- alist )
- [ dup synopsis swap ] { } map>assoc ;
+ [ [ synopsis ] keep ] { } map>assoc ;
: definitions. ( alist -- )
[ write-object nl ] assoc-each ;
{ "" "Total" "Used" "Free" } write-headings
(data-room.)
] tabular-output
- nl
+ nl nl
"==== CODE HEAP" print
standard-table-style [
(code-room.)
- ] tabular-output ;
+ ] tabular-output
+ nl ;
: heap-stats ( -- counts sizes )
[ ] instances H{ } clone H{ } clone
pick at pprint-cell
] with-row
] each 2drop
- ] tabular-output ;
+ ] tabular-output nl ;
profiler-usage counters ;
: counters. ( assoc -- )
- standard-table-style [
- sort-values simple-table.
- ] tabular-output ;
+ sort-values simple-table. ;
: profile. ( -- )
"Call counts for all words:" print
threads >alist sort-keys values [\r
[ thread. ] with-row\r
] each\r
- ] tabular-output ;\r
+ ] tabular-output nl ;\r
: describe-children ( vocab -- )
vocab-name all-child-vocabs $vocab-roots ;
+: files. ( seq -- )
+ snippet-style get [
+ code-style get [
+ [ nl ] [ [ string>> ] keep write-object ] interleave
+ ] with-nesting
+ ] with-style ;
+
: describe-files ( vocab -- )
vocab-files [ <pathname> ] map [
"Files" $heading
[
- snippet-style get [
- code-style get [
- stack.
- ] with-nesting
- ] with-style
+ files.
] ($block)
] unless-empty ;
{ $description "Writes a gadget followed by a newline to " { $link output-stream } "." }
{ $notes "Not all streams support this operation." } ;
-HELP: ?nl
-{ $values { "stream" pane-stream } }
-{ $description "Inserts a line break in the pane unless the current line is empty." } ;
-
HELP: with-pane
{ $values { "pane" pane } { "quot" quotation } }
{ $description "Clears the pane and calls the quotation in a new scope where " { $link output-stream } " is rebound to a " { $link pane-stream } " writing to the pane." } ;
: test-gadget-text ( quot -- ? )
dup make-pane gadget-text dup print "======" print
- swap with-string-writer dup print "\n" ?tail drop "\n" ?tail drop = ;
+ swap with-string-writer dup print = ;
[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
] test-gadget-text
] unit-test
+[ t ] [
+ [
+ last-element off
+ \ = >link title-style get [
+ $navigation-table
+ ] with-nesting
+ "Hello world" print-content
+ ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [ { { "a\n" } } simple-table. ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [ { { "a" } } simple-table. "x" write ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [ H{ } [ { { "a" } } simple-table. ] with-nesting "x" write ] test-gadget-text
+] unit-test
+
ARTICLE: "test-article-1" "This is a test article"
"Hello world, how are you today." ;
output current input last-line prototype scrolls?
selection-color caret mark selecting? ;
+TUPLE: pane-stream pane ;
+
+C: <pane-stream> pane-stream
+
+<PRIVATE
+
: clear-selection ( pane -- pane )
f >>caret f >>mark ; inline
M: pane gadget-selection ( pane -- string/f )
selected-children gadget-text ;
-: pane-clear ( pane -- )
- clear-selection
- [ output>> clear-incremental ]
- [ current>> clear-gadget ]
- bi ;
-
: init-prototype ( pane -- pane )
<shelf> +baseline+ >>align >>prototype ; inline
[ >>last-line ] [ 1 track-add ] bi
dup prepare-last-line ; inline
-: new-pane ( input class -- pane )
- [ vertical ] dip new-track
- swap >>input
- pane-theme
- init-prototype
- init-output
- init-current
- init-last-line ; inline
-
-: <pane> ( -- pane ) f pane new-pane ;
-
GENERIC: draw-selection ( loc obj -- )
: if-fits ( rect quot -- )
: scroll-pane ( pane -- )
dup scrolls?>> [ scroll>bottom ] [ drop ] if ;
-TUPLE: pane-stream pane ;
-
-C: <pane-stream> pane-stream
-
: smash-line ( current -- gadget )
dup children>> {
{ [ dup empty? ] [ 2drop "" <label> ] }
[ drop ]
} cond ;
-: smash-pane ( pane -- gadget ) output>> smash-line ;
-
: pane-nl ( pane -- )
[
[ current>> [ unparent ] [ smash-line ] bi ] [ output>> ] bi
add-incremental
] [ next-line ] bi ;
+: ?pane-nl ( pane -- )
+ [ dup current>> children>> empty? [ pane-nl ] [ drop ] if ]
+ [ pane-nl ] bi ;
+
+: smash-pane ( pane -- gadget ) [ pane-nl ] [ output>> smash-line ] bi ;
+
: pane-write ( seq pane -- )
[ pane-nl ] [ current>> stream-write ]
bi-curry interleave ;
[ nip pane-nl ] [ current>> stream-format ]
bi-curry bi-curry interleave ;
+: do-pane-stream ( pane-stream quot -- )
+ [ pane>> ] dip keep scroll-pane ; inline
+
+M: pane-stream stream-nl
+ [ pane-nl ] do-pane-stream ;
+
+M: pane-stream stream-write1
+ [ current>> stream-write1 ] do-pane-stream ;
+
+M: pane-stream stream-write
+ [ [ string-lines ] dip pane-write ] do-pane-stream ;
+
+M: pane-stream stream-format
+ [ [ string-lines ] 2dip pane-format ] do-pane-stream ;
+
+M: pane-stream dispose drop ;
+
+M: pane-stream stream-flush drop ;
+
+M: pane-stream make-span-stream
+ swap <style-stream> <ignore-close-stream> ;
+
+PRIVATE>
+
+: new-pane ( input class -- pane )
+ [ vertical ] dip new-track
+ swap >>input
+ pane-theme
+ init-prototype
+ init-output
+ init-current
+ init-last-line ; inline
+
+: <pane> ( -- pane ) f pane new-pane ;
+
GENERIC: write-gadget ( gadget stream -- )
M: pane-stream write-gadget ( gadget pane-stream -- )
: gadget. ( gadget -- )
output-stream get print-gadget ;
-: ?nl ( stream -- )
- dup pane>> current>> children>> empty?
- [ dup stream-nl ] unless drop ;
+: pane-clear ( pane -- )
+ clear-selection
+ [ output>> clear-incremental ]
+ [ current>> clear-gadget ]
+ bi ;
: with-pane ( pane quot -- )
- over scroll>top
- over pane-clear [ <pane-stream> ] dip
- over [ with-output-stream* ] dip ?nl ; inline
+ [ [ scroll>top ] [ pane-clear ] [ <pane-stream> ] tri ] dip
+ with-output-stream* ; inline
: make-pane ( quot -- gadget )
- <pane> [ swap with-pane ] keep smash-pane ; inline
+ [ <pane> ] dip [ with-pane ] [ drop smash-pane ] 2bi ; inline
TUPLE: pane-control < pane quot ;
swap >>quot
swap >>model ;
-: do-pane-stream ( pane-stream quot -- )
- [ pane>> ] dip keep scroll-pane ; inline
-
-M: pane-stream stream-nl
- [ pane-nl ] do-pane-stream ;
-
-M: pane-stream stream-write1
- [ current>> stream-write1 ] do-pane-stream ;
-
-M: pane-stream stream-write
- [ [ string-lines ] dip pane-write ] do-pane-stream ;
-
-M: pane-stream stream-format
- [ [ string-lines ] 2dip pane-format ] do-pane-stream ;
-
-M: pane-stream dispose drop ;
-
-M: pane-stream stream-flush drop ;
-
-M: pane-stream make-span-stream
- swap <style-stream> <ignore-close-stream> ;
-
! Character styles
+<PRIVATE
MEMO: specified-font ( assoc -- font )
#! We memoize here to avoid creating lots of duplicate font objects.
inline
: unnest-pane-stream ( stream -- child parent )
- dup ?nl
- dup style>>
- over pane>> smash-pane style-pane
- swap parent>> ;
+ [ [ style>> ] [ pane>> smash-pane ] bi style-pane ] [ parent>> ] bi ;
TUPLE: pane-block-stream < nested-pane-stream ;
TUPLE: pane-cell-stream < nested-pane-stream ;
-M: pane-cell-stream dispose ?nl ;
+M: pane-cell-stream dispose drop ;
M: pane-stream make-cell-stream
pane-cell-stream new-nested-pane-stream ;
[
swap [ [ pane>> smash-pane ] map ] map
styled-grid
- ] dip print-gadget ;
+ ] dip write-gadget ;
! Stream utilities
M: pack dispose drop ;
: pane-menu ( pane -- ) { com-copy } show-commands-menu ;
+PRIVATE>
+
pane H{
{ T{ button-down } [ begin-selection ] }
{ T{ button-down f { S+ } 1 } [ select-to-caret ] }
[
[
[ "Class:" write ] with-cell
- [ class . ] with-cell
+ [ class pprint ] with-cell
] with-row
]
[
[
[ "Object:" write ] with-cell
- [ short. ] with-cell
+ [ pprint-short ] with-cell
] with-row
]
[
[
[ "Summary:" write ] with-cell
- [ summary. ] with-cell
+ [ print-summary ] with-cell
] with-row
] tri
] tabular-output
[ listener-gadget? ] find-parent ;
: listener-streams ( listener -- input output )
- [ input>> ] [ output>> ] bi <pane-stream> ;
+ [ input>> ] [ output>> <pane-stream> ] bi ;
: init-listener ( listener -- listener )
<interactor>
USING: kernel quotations accessors fry assocs present math.order
math.vectors arrays locals models.search models.sort models sequences
vocabs tools.profiler words prettyprint combinators.smart
-definitions.icons ui ui.commands ui.gadgets ui.gadgets.panes
+definitions.icons see ui ui.commands ui.gadgets ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons
ui.gadgets.tables ui.gadgets.search-tables ui.gadgets.labeled
ui.gadgets.buttons ui.gadgets.packs ui.gadgets.labels
USING: editors help.markup help.syntax summary inspector io io.styles
listener parser prettyprint tools.profiler tools.walker ui.commands
ui.gadgets.panes ui.gadgets.presentations ui.operations
-ui.tools.operations ui.tools.profiler ui.tools.common vocabs ;
+ui.tools.operations ui.tools.profiler ui.tools.common vocabs see ;
IN: ui.tools
ARTICLE: "starting-ui-tools" "Starting the UI tools"
{ $subsection redefine-error } ;
ARTICLE: "definitions" "Definitions"
-"A " { $emphasis "definition" } " is an artifact read from a source file. This includes words, methods, and help articles. Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary. Implementations of the definition protocol include pathnames, words, methods, and help articles."
+"A " { $emphasis "definition" } " is an artifact read from a source file. This includes words, methods, help articles, and path names (which represent the source file at that location). Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary."
{ $subsection "definition-protocol" }
{ $subsection "definition-crossref" }
{ $subsection "definition-checking" }
{ $subsection "compilation-units" }
-{ $see-also "parser" "source-files" "words" "generic" "help-impl" } ;
+{ $see-also "see" "parser" "source-files" "words" "generic" "help-impl" } ;
ABOUT: "definitions"
{ $subsection <method> }
"A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":"
{ $subsection method-spec }
-{ $see-also see see-methods } ;
+{ $see-also "see" } ;
ARTICLE: "method-combination" "Custom method combination"
"Abstractly, a generic word can be thought of as a big chain of type conditional tests applied to the top of the stack, with methods as the bodies of each test. The " { $emphasis "method combination" } " is this control flow glue between the set of methods, and several aspects of it can be customized:"
{ $subsection "word-definition" }
{ $subsection "word-props" }
{ $subsection "word.private" }
-{ $see-also "vocabularies" "vocabs.loader" "definitions" } ;
+{ $see-also "vocabularies" "vocabs.loader" "definitions" "see" } ;
ABOUT: "words"
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel math math.functions tools.test combinators.cleave ;
-
-IN: combinators.cleave.tests
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: unit-test* ( input output -- ) swap unit-test ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[ { [ 1 ] [ 2 ] [ 3 ] [ 4 ] } 0arr ] [ { 1 2 3 4 } ] unit-test*
-
-[ 3 { 1+ 1- 2^ } 1arr ] [ { 4 2 8 } ] unit-test*
-
-[ 3 4 { [ + ] [ - ] [ ^ ] } 2arr ] [ { 7 -1 81 } ] unit-test*
-
-[ 1 2 3 { [ + + ] [ - - ] [ * * ] } 3arr ] [ { 6 2 6 } ] unit-test*
-
+++ /dev/null
-
-USING: kernel combinators words quotations arrays sequences locals macros
- shuffle generalizations fry ;
-
-IN: combinators.cleave
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: >quot ( obj -- quot ) dup word? [ 1quotation ] when ;
-
-: >quots ( seq -- seq ) [ >quot ] map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: [ncleave] ( SEQ N -- quot )
- SEQ >quots [ [ N nkeep ] curry ] map concat [ N ndrop ] append >quotation ;
-
-MACRO: ncleave ( seq n -- quot ) [ncleave] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Cleave into array
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: [narr] ( seq n -- quot ) over length '[ _ _ ncleave _ narray ] ;
-
-MACRO: narr ( seq n -- array ) [narr] ;
-
-MACRO: 0arr ( seq -- array ) 0 [narr] ;
-MACRO: 1arr ( seq -- array ) 1 [narr] ;
-MACRO: 2arr ( seq -- array ) 2 [narr] ;
-MACRO: 3arr ( seq -- array ) 3 [narr] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: <arr> ( seq -- )
- [ >quots ] [ length ] bi
- '[ _ cleave _ narray ] ;
-
-MACRO: <2arr> ( seq -- )
- [ >quots ] [ length ] bi
- '[ _ 2cleave _ narray ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: {1} ( x -- {x} ) 1array ; inline
-: {2} ( x y -- {x,y} ) 2array ; inline
-: {3} ( x y z -- {x,y,z} ) 3array ; inline
-
-: {n} narray ;
-
-: {bi} ( x p q -- {p(x),q(x)} ) bi {2} ; inline
-
-: {tri} ( x p q r -- {p(x),q(x),r(x)} ) tri {3} ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Spread into array
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: <arr*> ( seq -- )
- [ >quots ] [ length ] bi
- '[ _ spread _ narray ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: {bi*} ( x y p q -- {p(x),q(y)} ) bi* {2} ; inline
-: {tri*} ( x y z p q r -- {p(x),q(y),r(z)} ) tri* {3} ; inline
+++ /dev/null
-
-USING: combinators.cleave fry kernel macros parser quotations ;
-
-IN: combinators.cleave.enhanced
-
-: \\
- scan-word literalize parsed
- scan-word literalize parsed ; parsing
-
-MACRO: bi ( p q -- quot )
- [ >quot ] dip
- >quot
- '[ _ _ [ keep ] dip call ] ;
-
-MACRO: tri ( p q r -- quot )
- [ >quot ] 2dip
- [ >quot ] dip
- >quot
- '[ _ _ _ [ [ keep ] dip keep ] dip call ] ;
-
-MACRO: bi* ( p q -- quot )
- [ >quot ] dip
- >quot
- '[ _ _ [ dip ] dip call ] ;
-
-MACRO: tri* ( p q r -- quot )
- [ >quot ] 2dip
- [ >quot ] dip
- >quot
- '[ _ _ _ [ [ 2dip ] dip dip ] dip call ] ;
-
+++ /dev/null
-
-USING: kernel combinators sequences macros fry newfx combinators.cleave ;
-
-IN: combinators.conditional
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: 1if ( test then else -- ) '[ dup @ _ _ if ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: 1cond ( tbl -- )
- [ [ 1st [ dup ] prepend ] [ 2nd ] bi {2} ] map
- [ cond ] prefix-on ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
USING: kernel sequences assocs sets locals combinators
accessors system math math.functions unicode.case prettyprint
- combinators.cleave dns ;
+ combinators.smart dns ;
IN: dns.cache.rr
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-cache-key ( obj -- key )
- { [ name>> >lower ] [ type>> unparse ] [ class>> unparse ] } 1arr " " join ;
+ [ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
destructors
io io.binary io.sockets io.encodings.binary
accessors
- combinators.cleave
+ combinators.smart
newfx
;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: query->ba ( query -- ba )
+ [
{
[ name>> dn->ba ]
[ type>> type-table of uint16->ba ]
[ class>> class-table of uint16->ba ]
- }
- <arr> concat ;
+ } cleave
+ ] output>array concat ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: soa->ba ( rdata -- ba )
+ [
{
[ mname>> dn->ba ]
[ rname>> dn->ba ]
[ retry>> uint32->ba ]
[ expire>> uint32->ba ]
[ minimum>> uint32->ba ]
- }
- <arr> concat ;
+ } cleave
+ ] output>array concat ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rr->ba ( rr -- ba )
+ [
{
[ name>> dn->ba ]
[ type>> type-table of uint16->ba ]
[ type>> ] [ rdata>> ] bi rdata->ba
[ length uint16->ba ] [ ] bi append
]
- }
- <arr> concat ;
+ } cleave
+ ] output>array concat ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: header-bits-ba ( message -- ba )
+ [
{
[ qr>> 15 shift ]
[ opcode>> opcode-table of 11 shift ]
[ ra>> 7 shift ]
[ z>> 4 shift ]
[ rcode>> rcode-table of 0 shift ]
- }
- <arr> sum uint16->ba ;
+ } cleave
+ ] sum-outputs uint16->ba ;
: message->ba ( message -- ba )
+ [
{
[ id>> uint16->ba ]
[ header-bits-ba ]
[ answer-section>> [ rr->ba ] map concat ]
[ authority-section>> [ rr->ba ] map concat ]
[ additional-section>> [ rr->ba ] map concat ]
- }
- <arr> concat ;
+ } cleave
+ ] output>array concat ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ask ( message -- message ) dns-server ask-server ;
-: query->message ( query -- message ) <message> swap {1} >>question-section ;
+: query->message ( query -- message ) <message> swap 1array >>question-section ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: kernel combinators sequences sets math threads namespaces continuations
debugger io io.sockets unicode.case accessors destructors
- combinators.cleave combinators.short-circuit
- newfx fry
+ combinators.short-circuit combinators.smart
+ newfx fry arrays
dns dns.util dns.misc ;
IN: dns.server
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: {name-type-class} ( obj -- array )
- { [ name>> >lower ] [ type>> ] [ class>> ] } <arr> ;
+ [ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ;
: rr=query? ( obj obj -- ? ) [ {name-type-class} ] bi@ = ;
: rr->rdata-names ( rr -- names/f )
{
- { [ dup type>> NS = ] [ rdata>> {1} ] }
- { [ dup type>> MX = ] [ rdata>> exchange>> {1} ] }
- { [ dup type>> CNAME = ] [ rdata>> {1} ] }
+ { [ dup type>> NS = ] [ rdata>> 1array ] }
+ { [ dup type>> MX = ] [ rdata>> exchange>> 1array ] }
+ { [ dup type>> CNAME = ] [ rdata>> 1array ] }
{ [ t ] [ drop f ] }
}
cond ;
USING: accessors arrays assocs combinators help help.crossref
help.markup help.topics io io.streams.string kernel make namespaces
parser prettyprint sequences summary tools.vocabs tools.vocabs.browser
-vocabs vocabs.loader words ;
+vocabs vocabs.loader words see ;
IN: fuel.help
+++ /dev/null
-
-USING: kernel sequences multi-methods accessors math.vectors ;
-
-IN: math.physics.pos
-
-TUPLE: pos pos ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: distance ( a b -- c )
-
-METHOD: distance { sequence sequence } v- norm ;
-
-METHOD: distance { pos pos } [ pos>> ] bi@ distance ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: math.physics.pos ;
-
-IN: math.physics.vel
-
-TUPLE: vel < pos vel ;
-
+++ /dev/null
-
-USING: accessors effects.parser kernel lexer multi-methods
- parser sequences words ;
-
-IN: multi-method-syntax
-
-! A nicer specializer syntax to hold us over till multi-methods go in
-! officially.
-!
-! Use both 'multi-methods' and 'multi-method-syntax' in that order.
-
-: scan-specializer ( -- specializer )
-
- scan drop ! eat opening parenthesis
-
- ")" parse-effect in>> [ search ] map ;
-
-: CREATE-METHOD ( -- method )
- scan-word scan-specializer swap create-method-in ;
-
-: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
-
-: METHOD: (METHOD:) define ; parsing
\ No newline at end of file
definitions prettyprint prettyprint.backend prettyprint.custom
quotations generalizations debugger io compiler.units
kernel.private effects accessors hashtables sorting shuffle
-math.order sets ;
+math.order sets see ;
IN: multi-methods
! PART I: Converting hook specializers
USING: kernel classes strings quotations words math math.parser arrays
- combinators.cleave
+ combinators.smart
accessors
system prettyprint splitting
sequences combinators sequences.deep
: datestamp ( -- string )
now
- { year>> month>> day>> hour>> minute>> } <arr>
+ [ { [ year>> ] [ month>> ] [ day>> ] [ hour>> ] [ minute>> ] } cleave ] output>array
[ pad-00 ] map "-" join ;
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel math math.functions tools.test combinators.cleave ;
+
+IN: combinators.cleave.tests
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: unit-test* ( input output -- ) swap unit-test ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+[ { [ 1 ] [ 2 ] [ 3 ] [ 4 ] } 0arr ] [ { 1 2 3 4 } ] unit-test*
+
+[ 3 { 1+ 1- 2^ } 1arr ] [ { 4 2 8 } ] unit-test*
+
+[ 3 4 { [ + ] [ - ] [ ^ ] } 2arr ] [ { 7 -1 81 } ] unit-test*
+
+[ 1 2 3 { [ + + ] [ - - ] [ * * ] } 3arr ] [ { 6 2 6 } ] unit-test*
+
--- /dev/null
+
+USING: kernel combinators words quotations arrays sequences locals macros
+ shuffle generalizations fry ;
+
+IN: combinators.cleave
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: >quot ( obj -- quot ) dup word? [ 1quotation ] when ;
+
+: >quots ( seq -- seq ) [ >quot ] map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: [ncleave] ( SEQ N -- quot )
+ SEQ >quots [ [ N nkeep ] curry ] map concat [ N ndrop ] append >quotation ;
+
+MACRO: ncleave ( seq n -- quot ) [ncleave] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Cleave into array
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: [narr] ( seq n -- quot ) over length '[ _ _ ncleave _ narray ] ;
+
+MACRO: narr ( seq n -- array ) [narr] ;
+
+MACRO: 0arr ( seq -- array ) 0 [narr] ;
+MACRO: 1arr ( seq -- array ) 1 [narr] ;
+MACRO: 2arr ( seq -- array ) 2 [narr] ;
+MACRO: 3arr ( seq -- array ) 3 [narr] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MACRO: <arr> ( seq -- )
+ [ >quots ] [ length ] bi
+ '[ _ cleave _ narray ] ;
+
+MACRO: <2arr> ( seq -- )
+ [ >quots ] [ length ] bi
+ '[ _ 2cleave _ narray ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {1} ( x -- {x} ) 1array ; inline
+: {2} ( x y -- {x,y} ) 2array ; inline
+: {3} ( x y z -- {x,y,z} ) 3array ; inline
+
+: {n} narray ;
+
+: {bi} ( x p q -- {p(x),q(x)} ) bi {2} ; inline
+
+: {tri} ( x p q r -- {p(x),q(x),r(x)} ) tri {3} ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Spread into array
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MACRO: <arr*> ( seq -- )
+ [ >quots ] [ length ] bi
+ '[ _ spread _ narray ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {bi*} ( x y p q -- {p(x),q(y)} ) bi* {2} ; inline
+: {tri*} ( x y z p q r -- {p(x),q(y),r(z)} ) tri* {3} ; inline
--- /dev/null
+
+USING: combinators.cleave fry kernel macros parser quotations ;
+
+IN: combinators.cleave.enhanced
+
+: \\
+ scan-word literalize parsed
+ scan-word literalize parsed ; parsing
+
+MACRO: bi ( p q -- quot )
+ [ >quot ] dip
+ >quot
+ '[ _ _ [ keep ] dip call ] ;
+
+MACRO: tri ( p q r -- quot )
+ [ >quot ] 2dip
+ [ >quot ] dip
+ >quot
+ '[ _ _ _ [ [ keep ] dip keep ] dip call ] ;
+
+MACRO: bi* ( p q -- quot )
+ [ >quot ] dip
+ >quot
+ '[ _ _ [ dip ] dip call ] ;
+
+MACRO: tri* ( p q r -- quot )
+ [ >quot ] 2dip
+ [ >quot ] dip
+ >quot
+ '[ _ _ _ [ [ 2dip ] dip dip ] dip call ] ;
+
--- /dev/null
+
+USING: kernel combinators sequences macros fry newfx combinators.cleave ;
+
+IN: combinators.conditional
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MACRO: 1if ( test then else -- ) '[ dup @ _ _ if ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MACRO: 1cond ( tbl -- )
+ [ [ 1st [ dup ] prepend ] [ 2nd ] bi {2} ] map
+ [ cond ] prefix-on ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: accessors effects.parser kernel lexer multi-methods
+ parser sequences words ;
+
+IN: multi-method-syntax
+
+! A nicer specializer syntax to hold us over till multi-methods go in
+! officially.
+!
+! Use both 'multi-methods' and 'multi-method-syntax' in that order.
+
+: scan-specializer ( -- specializer )
+
+ scan drop ! eat opening parenthesis
+
+ ")" parse-effect in>> [ search ] map ;
+
+: CREATE-METHOD ( -- method )
+ scan-word scan-specializer swap create-method-in ;
+
+: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
+
+: METHOD: (METHOD:) define ; parsing
\ No newline at end of file
--- /dev/null
+
+USING: kernel sequences multi-methods accessors math.vectors ;
+
+IN: math.physics.pos
+
+TUPLE: pos pos ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: distance ( a b -- c )
+
+METHOD: distance { sequence sequence } v- norm ;
+
+METHOD: distance { pos pos } [ pos>> ] bi@ distance ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: math.physics.pos ;
+
+IN: math.physics.vel
+
+TUPLE: vel < pos vel ;
+