[ t ] [
[ { fixnum fixnum } declare = ]
\ both-fixnums? inlined?
+] unit-test
+
+[ t ] [
+ [ { integer integer } declare + drop ]
+ { + +-integer-integer } inlined?
] unit-test
\ No newline at end of file
USING: delegate kernel arrays tools.test words math definitions
compiler.units parser generic prettyprint io.streams.string
accessors eval multiline generic.standard delegate.protocols
-delegate.private assocs ;
+delegate.private assocs see ;
IN: delegate.tests
TUPLE: hello this that ;
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"
USING: math definitions help.topics help tools.test
prettyprint parser io.streams.string kernel source-files
-assocs namespaces words io sequences eval accessors ;
+assocs namespaces words io sequences eval accessors see ;
IN: help.definitions.tests
[ ] [ \ + >link see ] unit-test
-! 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
] 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 "
html.components html.forms namespaces
xml.writer ;
+\ render must-infer
+
[ ] [ begin-form ] unit-test
[ ] [ 3 "hi" set-value ] unit-test
H{ } describe
H{ } describe
-[ "fixnum instance\n" ] [ [ 3 describe ] with-string-writer ] unit-test
+[ "fixnum instance\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test
[ ] [ H{ } clone inspect ] unit-test
! 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: [|
namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit
combinators.short-circuit.smart math.order math.functions
-definitions compiler.units fry lexer words.symbol ;
+definitions compiler.units fry lexer words.symbol see ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
IN: macros.tests
USING: tools.test macros math kernel arrays
-vectors io.streams.string prettyprint parser eval ;
+vectors io.streams.string prettyprint parser eval see ;
MACRO: see-test ( a b -- c ) + ;
: define-integer-op-word ( fix-word big-word triple -- )
[
- [ 2nip integer-op-word ] [ integer-op-quot ] 3bi
+ [ 2nip integer-op-word dup make-foldable ] [ integer-op-quot ] 3bi
(( x y -- z )) define-declared
] [
2nip
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel memoize tools.test parser generalizations
-prettyprint io.streams.string sequences eval namespaces ;
+prettyprint io.streams.string sequences eval namespaces see ;
IN: memoize.tests
MEMO: fib ( m -- n )
IN: opengl.textures.tests
[ ] [
- { 3 5 }
- RGB
- B{
- 1 2 3 4 5 6 7 8 9
- 10 11 12 13 14 15 16 17 18
- 19 20 21 22 23 24 25 26 27
- 28 29 30 31 32 33 34 35 36
- 37 38 39 40 41 42 43 44 45
- } image boa "image" set
+ T{ image
+ { dim { 3 5 } }
+ { component-order RGB }
+ { bitmap
+ B{
+ 1 2 3 4 5 6 7 8 9
+ 10 11 12 13 14 15 16 17 18
+ 19 20 21 22 23 24 25 26 27
+ 28 29 30 31 32 33 34 35 36
+ 37 38 39 40 41 42 43 44 45
+ }
+ }
+ } "image" set
] unit-test
[
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 nl ;
-
-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." } ;
: char-class ( ranges ? -- term )
[ <or-class> ] dip [ <not-class> ] when ;
-TUPLE: lookahead term positive? ;
+TUPLE: lookahead term ;
C: <lookahead> lookahead
-TUPLE: lookbehind term positive? ;
+TUPLE: lookbehind term ;
C: <lookbehind> lookbehind
! Class algebra
[ f ] [ { 1 2 } <and-class> ] unit-test
-[ T{ or-class f { 2 1 } } ] [ { 1 2 } <or-class> ] unit-test
+[ T{ or-class f { 1 2 } } ] [ { 1 2 } <or-class> ] unit-test
[ 3 ] [ { 1 2 } <and-class> 3 2array <or-class> ] unit-test
[ CHAR: A ] [ CHAR: A LETTER-class <primitive-class> 2array <and-class> ] unit-test
[ CHAR: A ] [ LETTER-class <primitive-class> CHAR: A 2array <and-class> ] unit-test
[ t ] [ { t t } <or-class> ] unit-test
[ T{ primitive-class { class letter-class } } ] [ letter-class <primitive-class> dup 2array <and-class> ] unit-test
[ T{ primitive-class { class letter-class } } ] [ letter-class <primitive-class> dup 2array <or-class> ] unit-test
-[ T{ or-class { seq { 2 3 1 } } } ] [ { 1 2 } <or-class> { 2 3 } <or-class> 2array <or-class> ] unit-test
-[ T{ or-class { seq {
3 2 } } } ] [ { 2 3 } <or-class> 1 <not-class> 2array <and-class> ] unit-test
+[ T{ or-class { seq { 1 2 3 } } } ] [ { 1 2 } <or-class> { 2 3 } <or-class> 2array <or-class> ] unit-test
+[ T{ or-class { seq {
2 3 } } } ] [ { 2 3 } <or-class> 1 <not-class> 2array <and-class> ] unit-test
[ f ] [ t <not-class> ] unit-test
[ t ] [ f <not-class> ] unit-test
[ f ] [ 1 <not-class> 1 t answer ] unit-test
+[ t ] [ { 1 2 } <or-class> <not-class> 1 2 3array <or-class> ] unit-test
+[ f ] [ { 1 2 } <and-class> <not-class> 1 2 3array <and-class> ] unit-test
! Making classes into nested conditionals
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math math.order words combinators locals
ascii unicode.categories combinators.short-circuit sequences
-fry macros arrays assocs sets classes ;
+fry macros arrays assocs sets classes mirrors ;
IN: regexp.classes
SINGLETONS: any-char any-char-no-nl
control-character-class hex-digit-class java-blank-class c-identifier-class
unmatchable-class terminator-class word-boundary-class ;
-SINGLETONS: beginning-of-input ^ end-of-input $ end-of-file ;
+SINGLETONS: beginning-of-input ^ end-of-input $ end-of-file word-break ;
TUPLE: range from to ;
C: <range> range
TUPLE: primitive-class class ;
C: <primitive-class> primitive-class
-TUPLE: or-class seq ;
-
TUPLE: not-class class ;
-TUPLE: and-class seq ;
-
-GENERIC: combine-and ( class1 class2 -- combined ? )
-
-: replace-if-= ( object object -- object ? )
- over = ;
-
-M: object combine-and replace-if-= ;
+PREDICATE: not-integer < not-class class>> integer? ;
+PREDICATE: not-primitive < not-class class>> primitive-class? ;
-M: t combine-and
- drop t ;
-
-M: f combine-and
- nip t ;
-
-M: not-class combine-and
- class>> 2dup = [ 2drop f t ] [
- dup integer? [
- 2dup swap class-member?
- [ 2drop f f ]
- [ drop t ] if
- ] [ 2drop f f ] if
- ] if ;
-
-M: integer combine-and
- swap 2dup class-member? [ drop t ] [ 2drop f t ] if ;
-
-GENERIC: combine-or ( class1 class2 -- combined ? )
+M: not-class class-member?
+ class>> class-member? not ;
-M: object combine-or replace-if-= ;
+TUPLE: or-class seq ;
-M: t combine-or
- nip t ;
+M: or-class class-member?
+ seq>> [ class-member? ] with any? ;
-M: f combine-or
- drop t ;
+TUPLE: and-class seq ;
-M: not-class combine-or
- class>> = [ t t ] [ f f ] if ;
+M: and-class class-member?
+ seq>> [ class-member? ] with all? ;
-M: integer combine-or
- 2dup swap class-member? [ drop t ] [ 2drop f f ] if ;
+DEFER: substitute
: flatten ( seq class -- newseq )
'[ dup _ instance? [ seq>> ] [ 1array ] if ] map concat ; inline
-: try-combine ( elt1 elt2 quot -- combined/f ? )
- 3dup call [ [ 3drop ] dip t ] [ drop swapd call ] if ; inline
-
-DEFER: answer
-
-:: try-cancel ( elt1 elt2 empty -- combined/f ? )
- [ elt1 elt2 empty answer dup elt1 = not ] try-combine ;
-
-:: prefix-combining ( seq elt quot: ( elt1 elt2 -- combined/f ? ) -- newseq )
- f :> combined!
- seq [ elt quot call swap combined! ] find drop
- [ seq remove-nth combined prefix ]
- [ seq elt prefix ] if* ; inline
-
-: combine-by ( seq quot -- new-seq )
- { } swap '[ _ prefix-combining ] reduce ; inline
-
:: seq>instance ( seq empty class -- instance )
seq length {
{ 0 [ empty ] }
{ 1 [ seq first ] }
- [ drop class new seq >>seq ]
+ [ drop class new seq { } like >>seq ]
} case ; inline
-:: combine ( seq quot: ( elt1 elt2 -- combined/f ? ) empty class -- newseq )
- seq class flatten
- [ quot try-combine ] combine-by
- ! [ empty try-cancel ] combine-by ! This makes the algorithm O(n^4)
- empty class seq>instance ; inline
+TUPLE: class-partition integers not-integers primitives not-primitives and or other ;
+
+: partition-classes ( seq -- class-partition )
+ prune
+ [ integer? ] partition
+ [ not-integer? ] partition
+ [ primitive-class? ] partition ! extend primitive-class to epsilon tags
+ [ not-primitive? ] partition
+ [ and-class? ] partition
+ [ or-class? ] partition
+ class-partition boa ;
+
+: class-partition>seq ( class-partition -- seq )
+ make-mirror values concat ;
+
+: repartition ( partition -- partition' )
+ ! This could be made more efficient; only and and or are effected
+ class-partition>seq partition-classes ;
+
+: filter-not-integers ( partition -- partition' )
+ dup
+ [ primitives>> ] [ not-primitives>> ] [ or>> ] tri
+ 3append and-class boa
+ '[ [ class>> _ class-member? ] filter ] change-not-integers ;
+
+: answer-ors ( partition -- partition' )
+ dup [ not-integers>> ] [ not-primitives>> ] [ primitives>> ] tri 3append
+ '[ [ _ [ t substitute ] each ] map ] change-or ;
+
+: contradiction? ( partition -- ? )
+ {
+ [ [ primitives>> ] [ not-primitives>> ] bi intersects? ]
+ [ other>> f swap member? ]
+ } 1|| ;
+
+: make-and-class ( partition -- and-class )
+ answer-ors repartition
+ [ t swap remove ] change-other
+ dup contradiction?
+ [ drop f ]
+ [ filter-not-integers class-partition>seq prune t and-class seq>instance ] if ;
: <and-class> ( seq -- class )
- [ combine-and ] t and-class combine ;
+ dup and-class flatten partition-classes
+ dup integers>> length {
+ { 0 [ nip make-and-class ] }
+ { 1 [ integers>> first [ '[ _ swap class-member? ] all? ] keep and ] }
+ [ 3drop f ]
+ } case ;
+
+: filter-integers ( partition -- partition' )
+ dup
+ [ primitives>> ] [ not-primitives>> ] [ and>> ] tri
+ 3append or-class boa
+ '[ [ _ class-member? not ] filter ] change-integers ;
+
+: answer-ands ( partition -- partition' )
+ dup [ integers>> ] [ not-primitives>> ] [ primitives>> ] tri 3append
+ '[ [ _ [ f substitute ] each ] map ] change-and ;
+
+: tautology? ( partition -- ? )
+ {
+ [ [ primitives>> ] [ not-primitives>> ] bi intersects? ]
+ [ other>> t swap member? ]
+ } 1|| ;
-M: and-class class-member?
- seq>> [ class-member? ] with all? ;
+: make-or-class ( partition -- and-class )
+ answer-ands repartition
+ [ f swap remove ] change-other
+ dup tautology?
+ [ drop t ]
+ [ filter-integers class-partition>seq prune f or-class seq>instance ] if ;
: <or-class> ( seq -- class )
- [ combine-or ] f or-class combine ;
-
-M: or-class class-member?
- seq>> [ class-member? ] with any? ;
+ dup or-class flatten partition-classes
+ dup not-integers>> length {
+ { 0 [ nip make-or-class ] }
+ { 1 [ not-integers>> first [ class>> '[ _ swap class-member? ] any? ] keep or ] }
+ [ 3drop t ]
+ } case ;
GENERIC: <not-class> ( class -- inverse )
M: t <not-class> drop f ;
M: f <not-class> drop t ;
-M: not-class class-member?
- class>> class-member? not ;
-
M: primitive-class class-member?
class>> class-member? ;
M: not-class answer
[ class>> ] 2dip answer <not-class> ;
+GENERIC# substitute 1 ( class from to -- new-class )
+M: object substitute answer ;
+M: not-class substitute [ <not-class> ] bi@ answer ;
+
: assoc-answer ( table question answer -- new-table )
- '[ _ _ answer ] assoc-map
+ '[ _ _ substitute ] assoc-map
[ nip ] assoc-filter ;
: assoc-answers ( table questions answer -- new-table )
[ t t t ] [ "foo" "bar" "baz" [ strings matches? ] tri@ ] unit-test
[ f f f ] [ "food" "ibar" "ba" [ strings matches? ] tri@ ] unit-test
-USE: multiline
-/*
-! Why is conjuction broken?
: conj ( -- regexp )
{ R' .*a' R' b.*' } <and> ;
[ f ] [ "bljhasflsda" conj <not> matches? ] unit-test
[ t ] [ "bsdfdfs" conj <not> matches? ] unit-test
[ t ] [ "fsfa" conj <not> matches? ] unit-test
-*/
[ f f ] [ "" "hi" [ <nothing> matches? ] bi@ ] unit-test
[ t t ] [ "" "hi" [ <nothing> <not> matches? ] bi@ ] unit-test
USING: regexp.classes kernel sequences regexp.negation
quotations assocs fry math locals combinators
accessors words compiler.units kernel.private strings
-sequences.private arrays call namespaces
+sequences.private arrays call namespaces unicode.breaks
regexp.transition-tables combinators.short-circuit ;
IN: regexp.compiler
<PRIVATE
M: t question>quot drop [ 2drop t ] ;
+M: f question>quot drop [ 2drop f ] ;
+
+M: not-class question>quot
+ class>> question>quot [ not ] compose ;
M: beginning-of-input question>quot
drop [ drop zero? ] ;
M: ^ question>quot
drop [ { [ drop zero? ] [ [ 1- ] dip ?nth "\r\n" member? ] } 2|| ] ;
+M: word-break question>quot
+ drop [ word-break-at? ] ;
+
: (execution-quot) ( next-state -- quot )
! The conditions here are for lookaround and anchors, etc
dup condition? [
: literals>cases ( literal-transitions -- case-body )
[ execution-quot ] assoc-map ;
-: expand-one-or ( or-class transition -- alist )
- [ seq>> ] dip '[ _ 2array ] map ;
-
-: expand-or ( alist -- new-alist )
- [
- first2 over or-class?
- [ expand-one-or ] [ 2array 1array ] if
- ] map concat ;
-
: split-literals ( transitions -- case default )
- >alist expand-or [ first integer? ] partition
+ { } assoc-like [ first integer? ] partition
[ [ literals>cases ] keep ] dip non-literals>dispatch ;
:: step ( last-match index str quot final? direction -- last-index/f )
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors regexp.classes math.bits assocs sequences
-arrays sets regexp.dfa math fry regexp.minimize regexp.ast ;
+arrays sets regexp.dfa math fry regexp.minimize regexp.ast regexp.transition-tables ;
IN: regexp.disambiguate
TUPLE: parts in out ;
: preserving-epsilon ( state-transitions quot -- new-state-transitions )
[ [ drop tagged-epsilon? ] assoc-filter ] bi
assoc-union H{ } assoc-like ; inline
-
: disambiguate ( nfa -- nfa )
- [
+ expand-ors [
dup new-transitions '[
[
_ swap '[ _ get-transitions ] assoc-map
+++ /dev/null
-! Copyright (C) 2008, 2009 Daniel Ehrenberg, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences math splitting make fry locals math.ranges
-accessors arrays ;
-IN: regexp.matchers
-
-! For now, a matcher is just something with a method to do the
-! equivalent of match.
-
-GENERIC: match-index-from ( i string matcher -- index/f )
-
-: match-index-head ( string matcher -- index/f )
- [ 0 ] 2dip match-index-from ;
-
-: match-slice ( i string matcher -- slice/f )
- [ 2dup ] dip match-index-from
- [ swap <slice> ] [ 2drop f ] if* ;
-
-: matches? ( string matcher -- ? )
- dupd match-index-head
- [ swap length = ] [ drop f ] if* ;
-
-: match-from ( i string matcher -- slice/f )
- [ [ length [a,b) ] keep ] dip
- '[ _ _ match-slice ] map-find drop ;
-
-: match-head ( str matcher -- slice/f )
- [ 0 ] 2dip match-from ;
-
-<PRIVATE
-
-: next-match ( i string matcher -- i match/f )
- match-from [ dup [ to>> ] when ] keep ;
-
-PRIVATE>
-
-:: all-matches ( string matcher -- seq )
- 0 [ dup ] [ string matcher next-match ] produce nip but-last ;
-
-: count-matches ( string matcher -- n )
- all-matches length ;
-
-<PRIVATE
-
-:: split-slices ( string slices -- new-slices )
- slices [ to>> ] map 0 prefix
- slices [ from>> ] map string length suffix
- [ string <slice> ] 2map ;
-
-PRIVATE>
-
-: re-split1 ( string matcher -- before after/f )
- dupd match-head [ 1array split-slices first2 ] [ f ] if* ;
-
-: re-split ( string matcher -- seq )
- dupd all-matches split-slices ;
-
-: re-replace ( string matcher replacement -- result )
- [ re-split ] dip join ;
[ [ ] [ ] while-changes ] must-infer
-[ H{ { T{ or-class f { 1 2 } } 3 } { 4 5 } } ]
+[ H{ { T{ or-class f { 2 1 } } 3 } { 4 5 } } ]
[ H{ { 1 3 } { 2 3 } { 4 5 } } combine-state-transitions ] unit-test
clone
number-states
combine-states
- combine-transitions ;
+ combine-transitions
+ expand-ors ;
{ CHAR: z [ end-of-input <tagged-epsilon> ] }
{ CHAR: Z [ end-of-file <tagged-epsilon> ] }
{ CHAR: A [ beginning-of-input <tagged-epsilon> ] }
+ { CHAR: b [ word-break <tagged-epsilon> ] }
+ { CHAR: B [ word-break <not-class> <tagged-epsilon> ] }
[ ]
} case ;
=> [[ a on off parse-options <with-options> ]]
| "?#" [^)]* => [[ f ]]
| "?~" Alternation:a => [[ a <negation> ]]
- | "?=" Alternation:a => [[ a t <lookahead> <tagged-epsilon> ]]
- | "?!" Alternation:a => [[ a f <lookahead> <tagged-epsilon> ]]
- | "?<=" Alternation:a => [[ a t <lookbehind> <tagged-epsilon> ]]
- | "?<!" Alternation:a => [[ a f <lookbehind> <tagged-epsilon> ]]
+ | "?=" Alternation:a => [[ a <lookahead> <tagged-epsilon> ]]
+ | "?!" Alternation:a => [[ a <lookahead> <not-class> <tagged-epsilon> ]]
+ | "?<=" Alternation:a => [[ a <lookbehind> <tagged-epsilon> ]]
+ | "?<!" Alternation:a => [[ a <lookbehind> <not-class> <tagged-epsilon> ]]
| Alternation
Element = "(" Parenthized:p ")" => [[ p ]]
{ $vocab-link "regexp.combinators" } ;
ARTICLE: { "regexp" "syntax" } "Regular expression syntax"
-"Regexp syntax is largely compatible with Perl, Java and extended POSTFIX regexps, but not completely." $nl
+"Regexp syntax is largely compatible with Perl, Java and extended POSIX regexps, but not completely." $nl
"A new addition is the inclusion of a negation operator, with the syntax " { $snippet "(?~foo)" } " to match everything that does not match " { $snippet "foo" } "." $nl
"One missing feature is backreferences. This is because of a design decision to allow only regular expressions following the formal theory of regular languages. For more information, see " { $link { "regexp" "theory" } } ". You can create a new regular expression to match a particular string using " { $vocab-link "regexp.combinators" } " and group capture is available to extract parts of a regular expression match." $nl
"A distinction from Perl is that " { $snippet "\\G" } ", which references the previous match, is not included. This is because that sequence is inherently stateful, and Factor regexps don't hold state." $nl
{ $subsection matches? }
{ $subsection re-contains? }
{ $subsection first-match }
-{ $subsection all-matches }
-{ $subsection re-split1 }
+{ $subsection all-matching-slices }
+{ $subsection all-matching-subseqs }
{ $subsection re-split }
{ $subsection re-replace }
{ $subsection count-matches } ;
{ $values { "string" string } { "regexp" regexp } { "?" "a boolean" } }
{ $description "Tests if the string as a whole matches the given regular expression." } ;
-HELP: re-split1
-{ $values { "string" string } { "regexp" regexp } { "before" string } { "after/f" string } }
-{ $description "Searches the string for a substring which matches the pattern. If found, the input string is split on the leftmost and longest occurence of the match, and the two halves are given as output. If no match is found, then the input string and " { $link f } " are output." } ;
-
-HELP: all-matches
+HELP: all-matching-slices
{ $values { "string" string } { "regexp" regexp } { "seq" "a sequence of slices of the input" } }
{ $description "Finds a sequence of disjoint substrings which each match the pattern. It chooses this by finding the leftmost longest match, and then the leftmost longest match which starts after the end of the previous match, and so on." } ;
HELP: count-matches
{ $values { "string" string } { "regexp" regexp } { "n" integer } }
-{ $description "Counts how many disjoint matches the regexp has in the string, as made unambiguous by " { $link all-matches } "." } ;
+{ $description "Counts how many disjoint matches the regexp has in the string, as made unambiguous by " { $link all-matching-slices } "." } ;
HELP: re-split
{ $values { "string" string } { "regexp" regexp } { "seq" "a sequence of slices of the input" } }
-{ $description "Splits the input string into chunks separated by the regular expression. Each chunk contains no match of the regexp. The chunks are chosen by the strategy of " { $link all-matches } "." } ;
+{ $description "Splits the input string into chunks separated by the regular expression. Each chunk contains no match of the regexp. The chunks are chosen by the strategy of " { $link all-matching-slices } "." } ;
HELP: re-replace
{ $values { "string" string } { "regexp" regexp } { "replacement" string } { "result" string } }
-{ $description "Replaces substrings which match the input regexp with the given replacement text. The boundaries of the substring are chosen by the strategy used by " { $link all-matches } "." } ;
+{ $description "Replaces substrings which match the input regexp with the given replacement text. The boundaries of the substring are chosen by the strategy used by " { $link all-matching-slices } "." } ;
HELP: first-match
{ $values { "string" string } { "regexp" regexp } { "slice/f" "the match, if one exists" } }
[ { "a" "" } ] [ "a=" R/ =/ re-split [ >string ] map ] unit-test
[ { "ABC" "DEF" "GHI" } ]
-[ "1ABC2DEF3GHI4" R/ [A-Z]+/ all-matches [ >string ] map ] unit-test
+[ "1ABC2DEF3GHI4" R/ [A-Z]+/ all-matching-subseqs ] unit-test
[ 3 ]
[ "1ABC2DEF3GHI4" R/ [A-Z]+/ count-matches ] unit-test
[ f ] [ "a bar b" R/ foo/ re-contains? ] unit-test
[ t ] [ "foo" R/ foo/ re-contains? ] unit-test
-! [ t ] [ "foo" "\\bfoo\\b" <regexp> matches? ] unit-test
-! [ t ] [ "afoob" "\\Bfoo\\B" <regexp> matches? ] unit-test
-! [ t ] [ "afoob" "\\bfoo\\b" <regexp> matches? ] unit-test
-! [ f ] [ "foo" "\\Bfoo\\B" <regexp> matches? ] unit-test
-
-! [ 3 ] [ "foo bar" "foo\\b" <regexp> match-index-head ] unit-test
-! [ f ] [ "fooxbar" "foo\\b" <regexp> matches? ] unit-test
-! [ t ] [ "foo" "foo\\b" <regexp> matches? ] unit-test
-! [ t ] [ "foo bar" "foo\\b bar" <regexp> matches? ] unit-test
-! [ f ] [ "fooxbar" "foo\\bxbar" <regexp> matches? ] unit-test
-! [ f ] [ "foo" "foo\\bbar" <regexp> matches? ] unit-test
-
-! [ f ] [ "foo bar" "foo\\B" <regexp> matches? ] unit-test
-! [ 3 ] [ "fooxbar" "foo\\B" <regexp> match-index-head ] unit-test
-! [ t ] [ "foo" "foo\\B" <regexp> matches? ] unit-test
-! [ f ] [ "foo bar" "foo\\B bar" <regexp> matches? ] unit-test
-! [ t ] [ "fooxbar" "foo\\Bxbar" <regexp> matches? ] unit-test
-! [ f ] [ "foo" "foo\\Bbar" <regexp> matches? ] unit-test
-
-! [ 1 ] [ "aaacb" "a+?" <regexp> match-index-head ] unit-test
-! [ 1 ] [ "aaacb" "aa??" <regexp> match-index-head ] unit-test
-! [ f ] [ "aaaab" "a++ab" <regexp> matches? ] unit-test
-! [ t ] [ "aaacb" "a++cb" <regexp> matches? ] unit-test
-! [ 3 ] [ "aacb" "aa?c" <regexp> match-index-head ] unit-test
-! [ 3 ] [ "aacb" "aa??c" <regexp> match-index-head ] unit-test
-
-! "ab" "a(?=b*)" <regexp> match
-! "abbbbbc" "a(?=b*c)" <regexp> match
-! "ab" "a(?=b*)" <regexp> match
-
-! "baz" "(az)(?<=b)" <regexp> first-match
-! "cbaz" "a(?<=b*)" <regexp> first-match
-! "baz" "a(?<=b)" <regexp> first-match
-
-! "baz" "a(?<!b)" <regexp> first-match
-! "caz" "a(?<!b)" <regexp> first-match
-
-! "abcdefg" "a(?=bcdefg)bcd" <regexp> first-match
-! "abcdefg" "a(?#bcdefg)bcd" <regexp> first-match
-! "abcdefg" "a(?:bcdefg)" <regexp> first-match
-
-! "caba" "a(?<=b)" <regexp> first-match
-
-! capture group 1: "aaaa" 2: ""
-! "aaaa" "(a*)(a*)" <regexp> match*
-! "aaaa" "(a*)(a+)" <regexp> match*
+[ { "foo" "fxx" "fab" } ] [ "fab fxx foo" R/ f../r all-matching-subseqs ] unit-test
+
+[ t ] [ "foo" "\\bfoo\\b" <regexp> re-contains? ] unit-test
+[ t ] [ "afoob" "\\Bfoo\\B" <regexp> re-contains? ] unit-test
+[ f ] [ "afoob" "\\bfoo\\b" <regexp> re-contains? ] unit-test
+[ f ] [ "foo" "\\Bfoo\\B" <regexp> re-contains? ] unit-test
+
+[ 3 ] [ "foo bar" "foo\\b" <regexp> first-match length ] unit-test
+[ f ] [ "fooxbar" "foo\\b" <regexp> re-contains? ] unit-test
+[ t ] [ "foo" "foo\\b" <regexp> re-contains? ] unit-test
+[ t ] [ "foo bar" "foo\\b bar" <regexp> matches? ] unit-test
+[ f ] [ "fooxbar" "foo\\bxbar" <regexp> matches? ] unit-test
+[ f ] [ "foo" "foo\\bbar" <regexp> matches? ] unit-test
+
+[ f ] [ "foo bar" "foo\\B" <regexp> re-contains? ] unit-test
+[ 3 ] [ "fooxbar" "foo\\B" <regexp> first-match length ] unit-test
+[ f ] [ "foo" "foo\\B" <regexp> re-contains? ] unit-test
+[ f ] [ "foo bar" "foo\\B bar" <regexp> matches? ] unit-test
+[ t ] [ "fooxbar" "foo\\Bxbar" <regexp> matches? ] unit-test
+[ f ] [ "foo" "foo\\Bbar" <regexp> matches? ] unit-test
+
+[ t ] [ "ab" "a(?=b*)" <regexp> re-contains? ] unit-test
+[ t ] [ "abbbbbc" "a(?=b*c)" <regexp> re-contains? ] unit-test
+[ f ] [ "abbbbb" "a(?=b*c)" <regexp> re-contains? ] unit-test
+[ t ] [ "ab" "a(?=b*)" <regexp> re-contains? ] unit-test
+
+[ "az" ] [ "baz" "(?<=b)(az)" <regexp> first-match >string ] unit-test
+[ f ] [ "chaz" "(?<=b)(az)" <regexp> re-contains? ] unit-test
+[ "a" ] [ "cbaz" "(?<=b*)a" <regexp> first-match >string ] unit-test
+[ f ] [ "baz" "a(?<=b)" <regexp> re-contains? ] unit-test
+
+[ f ] [ "baz" "(?<!b)a" <regexp> re-contains? ] unit-test
+[ t ] [ "caz" "(?<!b)a" <regexp> re-contains? ] unit-test
+
+[ "abcd" ] [ "abcdefg" "a(?=bcdefg)bcd" <regexp> first-match >string ] unit-test
+[ t ] [ "abcdefg" "a(?#bcdefg)bcd" <regexp> re-contains? ] unit-test
+[ t ] [ "abcdefg" "a(?:bcdefg)" <regexp> matches? ] unit-test
+
+[ 3 ] [ "caba" "(?<=b)a" <regexp> first-match from>> ] unit-test
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators kernel math sequences strings sets
-assocs prettyprint.backend prettyprint.custom make lexer
-namespaces parser arrays fry locals regexp.parser splitting
-sorting regexp.ast regexp.negation regexp.compiler words
-call call.private math.ranges ;
+USING: accessors combinators kernel kernel.private math sequences
+sequences.private strings sets assocs prettyprint.backend
+prettyprint.custom make lexer namespaces parser arrays fry locals
+regexp.parser splitting sorting regexp.ast regexp.negation
+regexp.compiler words call call.private math.ranges ;
IN: regexp
TUPLE: regexp
<PRIVATE
-: maybe-negated ( lookaround quot -- regexp-quot )
- '[ term>> @ ] [ positive?>> [ ] [ not ] ? ] bi compose ; inline
-
M: lookahead question>quot ! Returns ( index string -- ? )
- [ ast>dfa dfa>shortest-word '[ f _ execute ] ] maybe-negated ;
+ term>> ast>dfa dfa>shortest-word '[ f _ execute ] ;
: <reversed-option> ( ast -- reversed )
"r" string>options <with-options> ;
M: lookbehind question>quot ! Returns ( index string -- ? )
- [
- <reversed-option>
- ast>dfa dfa>reverse-shortest-word
- '[ [ 1- ] dip f _ execute ]
- ] maybe-negated ;
-
-<PRIVATE
+ term>> <reversed-option>
+ ast>dfa dfa>reverse-shortest-word
+ '[ [ 1- ] dip f _ execute ] ;
: check-string ( string -- string )
! Make this configurable
: match-index-from ( i string regexp -- index/f )
! This word is unsafe. It assumes that i is a fixnum
! and that string is a string.
- dup dfa>> execute( index string regexp -- i/f ) ;
+ dup dfa>> execute-unsafe( index string regexp -- i/f ) ;
GENERIC: end/start ( string regexp -- end start )
M: regexp end/start drop length 0 ;
PRIVATE>
: matches? ( string regexp -- ? )
- [ end/start ] 2keep
[ check-string ] dip
+ [ end/start ] 2keep
match-index-from
- [ swap = ] [ drop f ] if* ;
+ [ = ] [ drop f ] if* ;
<PRIVATE
-: match-slice ( i string quot -- slice/f )
- [ 2dup ] dip call
- [ swap <slice> ] [ 2drop f ] if* ; inline
+:: (next-match) ( i string regexp quot: ( i string regexp -- j ) reverse? -- i start end ? )
+ i string regexp quot call dup [| j |
+ j i j
+ reverse? [ swap [ 1+ ] bi@ ] when
+ string
+ ] [ drop f f f f ] if ; inline
+
+: search-range ( i string reverse? -- seq )
+ [ drop dup 1+ -1 ] [ length 1 ] if range boa ; inline
-: match-from ( i string quot -- slice/f )
- [ [ length [a,b) ] keep ] dip
- '[ _ _ match-slice ] map-find drop ; inline
+:: next-match ( i string regexp quot: ( i string regexp -- j ) reverse? -- i start end ? )
+ f f f f
+ i string reverse? search-range
+ [ [ 2drop 2drop ] dip string regexp quot reverse? (next-match) dup ] find 2drop ; inline
-: next-match ( i string quot -- i match/f )
- match-from [ dup [ to>> ] when ] keep ; inline
+: do-next-match ( i string regexp -- i start end ? )
+ dup next-match>>
+ execute-unsafe( i string regexp -- i start end ? ) ; inline
-: do-next-match ( i string regexp -- i match/f )
- dup next-match>> execute( i string regexp -- i match/f ) ;
+:: (each-match) ( i string regexp quot: ( start end string -- ) -- )
+ i string regexp do-next-match [| i' start end |
+ start end string quot call
+ i' string regexp quot (each-match)
+ ] [ 3drop ] if ; inline recursive
+
+: prepare-match-iterator ( string regexp -- i string regexp )
+ [ check-string ] dip [ end/start nip ] 2keep ; inline
PRIVATE>
-: all-matches ( string regexp -- seq )
- [ check-string ] dip
- [ 0 [ dup ] ] 2dip '[ _ _ do-next-match ] produce
- nip but-last ;
+: each-match ( string regexp quot: ( start end string -- ) -- )
+ [ prepare-match-iterator ] dip (each-match) ; inline
+
+: map-matches ( string regexp quot: ( start end string -- obj ) -- seq )
+ accumulator [ each-match ] dip >array ; inline
+
+: all-matching-slices ( string regexp -- seq )
+ [ slice boa ] map-matches ;
+
+: all-matching-subseqs ( string regexp -- seq )
+ [ subseq ] map-matches ;
: count-matches ( string regexp -- n )
- all-matches length ;
+ [ 0 ] 2dip [ 3drop 1+ ] each-match ;
<PRIVATE
-:: split-slices ( string slices -- new-slices )
- slices [ to>> ] map 0 prefix
- slices [ from>> ] map string length suffix
- [ string <slice> ] 2map ;
+:: (re-split) ( string regexp quot -- new-slices )
+ 0 string regexp [| end start end' string |
+ end' ! leave it on the stack for the next iteration
+ end start string quot call
+ ] map-matches
+ ! Final chunk
+ swap string length string quot call suffix ; inline
PRIVATE>
: first-match ( string regexp -- slice/f )
- [ 0 ] [ check-string ] [ ] tri*
- do-next-match nip ;
+ [ prepare-match-iterator do-next-match ] [ drop ] 2bi
+ '[ _ slice boa nip ] [ 3drop f ] if ;
: re-contains? ( string regexp -- ? )
- first-match >boolean ;
-
-: re-split1 ( string regexp -- before after/f )
- dupd first-match [ 1array split-slices first2 ] [ f ] if* ;
+ prepare-match-iterator do-next-match [ 3drop ] dip >boolean ;
: re-split ( string regexp -- seq )
- dupd all-matches split-slices ;
+ [ slice boa ] (re-split) ;
: re-replace ( string regexp replacement -- result )
- [ re-split ] dip join ;
+ [ [ subseq ] (re-split) ] dip join ;
<PRIVATE
M: reverse-regexp compile-regexp ( regexp -- regexp )
t backwards? [ do-compile-regexp ] with-variable ;
-GENERIC: compile-next-match ( regexp -- regexp )
+DEFER: compile-next-match
-: next-initial-word ( i string regexp -- i slice/f )
+: next-initial-word ( i string regexp -- i start end string )
compile-next-match do-next-match ;
-M: regexp compile-next-match ( regexp -- regexp )
+: compile-next-match ( regexp -- regexp )
dup '[
dup \ next-initial-word = [
- drop _ compile-regexp dfa>>
- '[ _ '[ _ _ execute ] next-match ]
- (( i string -- i match/f )) simple-define-temp
+ drop _ [ compile-regexp dfa>> def>> ] [ reverse-regexp? ] bi
+ '[ { array-capacity string regexp } declare _ _ next-match ]
+ (( i string regexp -- i start end string )) simple-define-temp
] when
] change-next-match ;
-! Write M: reverse-regexp compile-next-match
-
PRIVATE>
: new-regexp ( string ast options class -- regexp )
[ '[ _ condition-at ] change-start-state ]
[ '[ [ _ at ] map-set ] change-final-states ]
[ '[ _ number-transitions ] change-transitions ] tri ;
+
+: expand-one-or ( or-class transition -- alist )
+ [ seq>> ] dip '[ _ 2array ] map ;
+
+: expand-or ( state-transitions -- new-transitions )
+ >alist [
+ first2 over or-class?
+ [ expand-one-or ] [ 2array 1array ] if
+ ] map concat >hashtable ;
+
+: expand-ors ( transition-table -- transition-table )
+ [ [ expand-or ] assoc-map ] change-transitions ;
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators kernel math
-quotations sequences regexp.classes fry arrays regexp.matchers
-combinators.short-circuit prettyprint regexp.nfa ;
-IN: regexp.traversal
-
-TUPLE: dfa-traverser
- dfa-table
- current-state
- text
- current-index
- match-index ;
-
-: <dfa-traverser> ( start-index text dfa -- match )
- dfa-traverser new
- swap [ start-state>> >>current-state ] [ >>dfa-table ] bi
- swap >>text
- swap >>current-index ;
-
-: final-state? ( dfa-traverser -- ? )
- [ current-state>> ]
- [ dfa-table>> final-states>> ] bi key? ;
-
-: end-of-text? ( dfa-traverser -- ? )
- [ current-index>> ] [ text>> length ] bi >= ; inline
-
-: text-finished? ( dfa-traverser -- ? )
- {
- [ current-state>> not ]
- [ end-of-text? ]
- } 1|| ;
-
-: save-final-state ( dfa-traverser -- dfa-traverser )
- dup current-index>> >>match-index ;
-
-: match-done? ( dfa-traverser -- ? )
- dup final-state? [ save-final-state ] when text-finished? ;
-
-: increment-state ( dfa-traverser state -- dfa-traverser )
- >>current-state
- [ 1 + ] change-current-index ;
-
-: match-literal ( transition from-state table -- to-state/f )
- transitions>> at at ;
-
-: match-class ( transition from-state table -- to-state/f )
- transitions>> at* [
- swap '[ drop _ swap class-member? ] assoc-find spin ?
- ] [ drop ] if ;
-
-: match-transition ( obj from-state dfa -- to-state/f )
- { [ match-literal ] [ match-class ] } 3|| ;
-
-: setup-match ( match -- obj state dfa-table )
- [ [ current-index>> ] [ text>> ] bi nth ]
- [ current-state>> ]
- [ dfa-table>> ] tri ;
-
-: do-match ( dfa-traverser -- dfa-traverser )
- dup match-done? [
- dup setup-match match-transition
- [ increment-state do-match ] when*
- ] unless ;
-
-TUPLE: dfa-matcher dfa ;
-C: <dfa-matcher> dfa-matcher
-M: dfa-matcher match-index-from
- dfa>> <dfa-traverser> do-match match-index>> ;
--- /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
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 ;
{ $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." } ;
kernel sequences io io.styles io.streams.string tools.test
prettyprint definitions help help.syntax help.markup
help.stylesheet splitting tools.test.ui models math summary
-inspector accessors help.topics ;
+inspector accessors help.topics see ;
IN: ui.gadgets.panes.tests
: #children "pane" get children>> length ;
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"
grapheme-break-test parse-test-file [ >graphemes ] test
word-break-test parse-test-file [ >words ] test
+
+[ { t f t t f t } ] [ 6 [ "as df" word-break-at? ] map ] unit-test
: >words ( str -- words )
[ first-word ] >pieces ;
+
+<PRIVATE
+
+: nth-next ( i str -- str[i-1] str[i] )
+ [ [ 1- ] keep ] dip '[ _ nth ] bi@ ;
+
+PRIVATE>
+
+: word-break-at? ( i str -- ? )
+ {
+ [ drop zero? ]
+ [ length = ]
+ [
+ [ nth-next [ word-break-prop ] dip ] 2keep
+ word-break-next nip
+ ]
+ } 2|| ;
tools.test multiline splitting memoize
kernel io.streams.string xml.writer ;
+\ htmlize-file must-infer
+
[ ] [ \ (load-mode) reset-memoized ] unit-test
[ ] [
-USING: kernel classes.singleton tools.test prettyprint io.streams.string ;
+USING: kernel classes.singleton tools.test prettyprint io.streams.string see ;
IN: classes.singleton.tests
[ ] [ SINGLETON: bzzt ] unit-test
generic.standard effects classes.tuple classes.tuple.private
arrays vectors strings compiler.units accessors classes.algebra
calendar prettyprint io.streams.string splitting summary
-columns math.order classes.private slots slots.private eval ;
+columns math.order classes.private slots slots.private eval see ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files
compiler.units kernel.private sorting vocabs io.streams.string
-eval ;
+eval see ;
IN: classes.union.tests
! DEFER: bah
{ $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:"
namespaces make quotations stack-checker vectors growable
hashtables sbufs prettyprint byte-vectors bit-vectors
specialized-vectors.double definitions generic sets graphs assocs
-grouping ;
+grouping see ;
GENERIC: lo-tag-test ( obj -- obj' )
"This operation is efficient and does not copy the quotation." }
{ $examples
{ $example "USING: kernel prettyprint ;" "5 [ . ] curry ." "[ 5 . ]" }
- { $example "USING: kernel prettyprint ;" "\\ = [ see ] curry ." "[ \\ = see ]" }
+ { $example "USING: kernel prettyprint see ;" "\\ = [ see ] curry ." "[ \\ = see ]" }
{ $example "USING: kernel math prettyprint sequences ;" "{ 1 2 3 } 2 [ - ] curry map ." "{ -1 0 1 }" }
} ;
"memory"
"namespaces"
"prettyprint"
+ "see"
"sequences"
"slicing"
"sorting"
: collapse-slice ( m n slice -- m' n' seq )
[ from>> ] [ seq>> ] bi [ [ + ] curry bi@ ] dip ; inline
-ERROR: slice-error from to seq reason ;
+TUPLE: slice-error from to seq reason ;
+
+: slice-error ( from to seq ? string -- from to seq )
+ [ \ slice-error boa throw ] curry when ; inline
: check-slice ( from to seq -- from to seq )
- pick 0 < [ "start < 0" slice-error ] when
- dup length pick < [ "end > sequence" slice-error ] when
- 2over > [ "start > end" slice-error ] when ; inline
+ 3dup
+ [ 2drop 0 < "start < 0" slice-error ]
+ [ nip length > "end > sequence" slice-error ]
+ [ drop > "start > end" slice-error ] 3tri ; inline
: <slice> ( from to seq -- slice )
dup slice? [ collapse-slice ] when
[ (append) ] new-like ; inline
: 3append-as ( seq1 seq2 seq3 exemplar -- newseq )
- [ pick length pick length pick length + + ] dip [
- [ [ pick length pick length + ] dip copy ]
+ [ 3dup [ length ] tri@ + + ] dip [
+ [ [ 2over [ length ] bi@ + ] dip copy ]
[ (append) ] bi
] new-like ; inline
{ $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: descriptive kernel math tools.test continuations prettyprint io.streams.string ;\r
+USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see ;\r
IN: descriptive.tests\r
\r
DESCRIPTIVE: divide ( num denom -- fraction ) / ;\r
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
IN: multi-methods.tests
USING: multi-methods tools.test math sequences namespaces system
kernel strings definitions prettyprint debugger arrays
-hashtables continuations classes assocs accessors ;
+hashtables continuations classes assocs accessors see ;
GENERIC: first-test
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 ;
+
projects / factor.git / commitdiff