diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 4a2e8671fb..e451694f48 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -514,4 +514,9 @@ cell-bits 32 = [ [ 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 diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 45bc5bf50a..627fd95384 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -220,7 +220,7 @@ M: assert error. 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" ; diff --git a/basis/globs/globs.factor b/basis/globs/globs.factor index 173187574b..cac7fd9a2f 100644 --- a/basis/globs/globs.factor +++ b/basis/globs/globs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences kernel regexp.combinators regexp.matchers strings unicode.case +USING: sequences kernel regexp.combinators strings unicode.case peg.ebnf regexp arrays ; IN: globs diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index b2b65c3913..d6693cd94f 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -1,6 +1,6 @@ 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" diff --git a/basis/help/definitions/definitions.factor b/basis/help/definitions/definitions.factor index 3e4066d8b7..91ee1c9c79 100644 --- a/basis/help/definitions/definitions.factor +++ b/basis/help/definitions/definitions.factor @@ -1,8 +1,8 @@ -! 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 diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index 331fafbbd1..f20732c7ee 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -194,6 +194,7 @@ ARTICLE: "io" "Input and output" ARTICLE: "tools" "Developer tools" { $subsection "tools.vocabs" } "Exploratory tools:" +{ $subsection "see" } { $subsection "editor" } { $subsection "listener" } { $subsection "tools.crossref" } diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor index 8384799dbd..733199fc60 100644 --- a/basis/help/help-docs.factor +++ b/basis/help/help-docs.factor @@ -1,6 +1,6 @@ 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" diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 57f64459c8..2281c295c3 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -132,6 +132,11 @@ SYMBOL: vocabs-quot [ check-descriptions ] } cleave ; +: check-class-description ( word element -- ) + [ class? not ] + [ { $class-description } swap elements empty? not ] bi* and + [ "A word that is not a class has a $class-description" throw ] when ; + : all-word-help ( words -- seq ) [ word-help ] filter ; @@ -153,7 +158,8 @@ M: help-error error. dup '[ _ dup word-help [ check-values ] - [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2bi + [ check-class-description ] + [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2tri ] check-something ] [ drop ] if ; diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index d4f664d6ff..ea64def751 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -4,7 +4,7 @@ USING: accessors arrays definitions generic io kernel assocs 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 @@ -13,7 +13,6 @@ 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? ; @@ -44,7 +43,7 @@ M: f print-element drop ; [ 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 @@ -218,7 +217,7 @@ ALIAS: $slot $snippet 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 [ @@ -301,7 +300,7 @@ M: f ($instance) ] with-style ] ($block) ; inline -: $see ( element -- ) first [ see ] ($see) ; +: $see ( element -- ) first [ see* ] ($see) ; : $synopsis ( element -- ) first [ synopsis write ] ($see) ; @@ -346,6 +345,8 @@ M: f ($instance) 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 " diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 88eb984488..cf16df7d82 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -108,11 +108,6 @@ M: bitmap-image load-image* ( path bitmap -- bitmap ) load-bitmap-data process-bitmap-data fill-image-slots ; -M: bitmap-image normalize-scan-line-order - dup dim>> '[ - _ first 4 * reverse concat - ] change-bitmap ; - MACRO: (nbits>bitmap) ( bits -- ) [ -3 shift ] keep '[ bitmap-image new @@ -121,6 +116,7 @@ MACRO: (nbits>bitmap) ( bits -- ) swap >>width swap array-copy [ >>bitmap ] [ >>color-index ] bi _ >>bit-count fill-image-slots + t >>upside-down? ] ; : bgr>bitmap ( array height width -- bitmap ) diff --git a/basis/images/images.factor b/basis/images/images.factor index 82576774f4..cb44825e62 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -27,7 +27,7 @@ R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ; { R32G32B32A32 [ 16 ] } } case ; -TUPLE: image dim component-order bitmap ; +TUPLE: image dim component-order upside-down? bitmap ; : ( -- image ) image new ; inline @@ -82,11 +82,16 @@ M: ARGB normalize-component-order* M: ABGR normalize-component-order* drop ARGB>RGBA 4 BGR>RGB ; -GENERIC: normalize-scan-line-order ( image -- image ) - -M: image normalize-scan-line-order ; +: normalize-scan-line-order ( image -- image ) + dup upside-down?>> [ + dup dim>> first 4 * '[ + _ reverse concat + ] change-bitmap + f >>upside-down? + ] when ; : normalize-image ( image -- image ) [ >byte-array ] change-bitmap normalize-component-order - normalize-scan-line-order ; + normalize-scan-line-order + RGBA >>component-order ; diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index a50ac0cad9..2ea1b08e20 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -503,7 +503,7 @@ ERROR: unknown-component-order ifd ; : ifd>image ( ifd -- image ) { [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] - [ ifd-component-order ] + [ ifd-component-order f ] [ bitmap>> ] } cleave tiff-image boa ; diff --git a/basis/inspector/inspector.factor b/basis/inspector/inspector.factor index 05c4dc2a94..8cab5b5ad3 100644 --- a/basis/inspector/inspector.factor +++ b/basis/inspector/inspector.factor @@ -9,7 +9,7 @@ IN: inspector SYMBOL: +number-rows+ -: summary. ( obj -- ) [ summary ] keep write-object nl ; +: print-summary ( obj -- ) [ summary ] keep write-object ; ; 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 ; diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index 2ee0832269..78a9c03d20 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -84,7 +84,7 @@ SYMBOL: max-stack-items bi ] with-row ] each - ] tabular-output + ] tabular-output nl ] unless-empty ; : trimmed-stack. ( seq -- ) diff --git a/basis/locals/definitions/definitions.factor b/basis/locals/definitions/definitions.factor index 99f9d0bd22..a4299d0684 100644 --- a/basis/locals/definitions/definitions.factor +++ b/basis/locals/definitions/definitions.factor @@ -1,7 +1,7 @@ ! 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 ; diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index 0998d84530..18dabed4b0 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -1,5 +1,5 @@ USING: help.syntax help.markup kernel macros prettyprint -memoize combinators arrays generalizations ; +memoize combinators arrays generalizations see ; IN: locals HELP: [| diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index 6618578a99..08cd8fb470 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -84,7 +84,7 @@ M: word integer-op-input-classes : 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 diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index 79af9be48b..48cdafb837 100644 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -11,14 +11,16 @@ IN: opengl.textures TUPLE: texture loc dim texture-coords texture display-list disposed ; -format ( component-order -- format type ) +M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ; +M: BGR component-order>format drop GL_BGR GL_UNSIGNED_BYTE ; M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ; M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ; M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; + + : with-use ( obj quot -- ) make-pprint use/in. do-pprint ; inline @@ -165,214 +165,4 @@ SYMBOL: pprint-string-cells? ] 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 - - 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* - ; - -M: intersection-class see-class* - ; - -M: mixin-class see-class* - block> ; - -M: predicate-class see-class* - 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 - - \ } 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* - - 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 diff --git a/basis/prettyprint/sections/sections-docs.factor b/basis/prettyprint/sections/sections-docs.factor index 4f1c073a2d..ce7430d040 100644 --- a/basis/prettyprint/sections/sections-docs.factor +++ b/basis/prettyprint/sections/sections-docs.factor @@ -199,7 +199,7 @@ HELP: 1 2array ] unit-test [ f ] [ t ] unit-test [ t ] [ f ] unit-test -[ f ] [ 1 1 t replace-question ] unit-test +[ f ] [ 1 1 t answer ] unit-test ! Making classes into nested conditionals [ V{ 1 2 3 4 } ] [ T{ and-class f { 1 T{ not-class f 2 } T{ or-class f { 3 4 } } 2 } } class>questions ] unit-test [ { 3 } ] [ { { 3 t } } table>condition ] unit-test [ { T{ primitive-class } } ] [ { { 1 t } { 2 T{ primitive-class } } } table>questions ] unit-test -[ { { 1 t } { 2 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } t answer ] unit-test -[ { { 1 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } f answer ] unit-test +[ { { 1 t } { 2 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } t assoc-answer ] unit-test +[ { { 1 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } f assoc-answer ] unit-test [ T{ condition f T{ primitive-class } { 1 2 } { 1 } } ] [ { { 1 t } { 2 T{ primitive-class } } } table>condition ] unit-test SYMBOL: foo @@ -46,13 +46,13 @@ SYMBOL: bar [ T{ condition f T{ primitive-class f bar } T{ condition f T{ primitive-class f foo } { 1 3 2 } { 1 3 } } T{ condition f T{ primitive-class f foo } { 1 2 } { 1 } } } ] [ { { 1 t } { 3 T{ primitive-class f bar } } { 2 T{ primitive-class f foo } } } table>condition ] unit-test -[ t ] [ foo dup t replace-question ] unit-test -[ f ] [ foo dup f replace-question ] unit-test -[ T{ primitive-class f foo } ] [ foo bar t replace-question ] unit-test -[ T{ primitive-class f foo } ] [ foo bar f replace-question ] unit-test -[ T{ primitive-class f foo } ] [ foo bar 2array bar t replace-question ] unit-test -[ T{ primitive-class f bar } ] [ foo bar 2array foo t replace-question ] unit-test -[ f ] [ foo bar 2array foo f replace-question ] unit-test -[ f ] [ foo bar 2array bar f replace-question ] unit-test -[ t ] [ foo bar 2array bar t replace-question ] unit-test -[ T{ primitive-class f foo } ] [ foo bar 2array bar f replace-question ] unit-test +[ t ] [ foo dup t answer ] unit-test +[ f ] [ foo dup f answer ] unit-test +[ T{ primitive-class f foo } ] [ foo bar t answer ] unit-test +[ T{ primitive-class f foo } ] [ foo bar f answer ] unit-test +[ T{ primitive-class f foo } ] [ foo bar 2array bar t answer ] unit-test +[ T{ primitive-class f bar } ] [ foo bar 2array foo t answer ] unit-test +[ f ] [ foo bar 2array foo f answer ] unit-test +[ f ] [ foo bar 2array bar f answer ] unit-test +[ t ] [ foo bar 2array bar t answer ] unit-test +[ T{ primitive-class f foo } ] [ foo bar 2array bar f answer ] unit-test diff --git a/basis/regexp/classes/classes.factor b/basis/regexp/classes/classes.factor index 8912082ec3..4ddd470189 100644 --- a/basis/regexp/classes/classes.factor +++ b/basis/regexp/classes/classes.factor @@ -163,20 +163,32 @@ M: integer combine-or : 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 try-combine swap combined! ] find drop + 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 ] + } case ; inline + :: combine ( seq quot: ( elt1 elt2 -- combined/f ? ) empty class -- newseq ) seq class flatten - { } [ quot prefix-combining ] reduce - dup length { - { 0 [ drop empty ] } - { 1 [ first ] } - [ drop class new swap >>seq ] - } case ; inline + [ quot try-combine ] combine-by + ! [ empty try-cancel ] combine-by ! This makes the algorithm O(n^4) + empty class seq>instance ; inline : ( seq -- class ) [ combine-and ] t and-class combine ; @@ -218,36 +230,36 @@ UNION: class primitive-class not-class or-class and-class range ; TUPLE: condition question yes no ; C: condition -GENERIC# replace-question 2 ( class from to -- new-class ) +GENERIC# answer 2 ( class from to -- new-class ) -M:: object replace-question ( class from to -- new-class ) +M:: object answer ( class from to -- new-class ) class from = to class ? ; : replace-compound ( class from to -- seq ) - [ seq>> ] 2dip '[ _ _ replace-question ] map ; + [ seq>> ] 2dip '[ _ _ answer ] map ; -M: and-class replace-question +M: and-class answer replace-compound ; -M: or-class replace-question +M: or-class answer replace-compound ; -M: not-class replace-question - [ class>> ] 2dip replace-question ; +M: not-class answer + [ class>> ] 2dip answer ; -: answer ( table question answer -- new-table ) - '[ _ _ replace-question ] assoc-map +: assoc-answer ( table question answer -- new-table ) + '[ _ _ answer ] assoc-map [ nip ] assoc-filter ; -: answers ( table questions answer -- new-table ) - '[ _ answer ] each ; +: assoc-answers ( table questions answer -- new-table ) + '[ _ assoc-answer ] each ; DEFER: make-condition : (make-condition) ( table questions question -- condition ) [ 2nip ] - [ swap [ t answer ] dip make-condition ] - [ swap [ f answer ] dip make-condition ] 3tri + [ swap [ t assoc-answer ] dip make-condition ] + [ swap [ f assoc-answer ] dip make-condition ] 3tri 2dup = [ 2nip ] [ ] if ; : make-condition ( table questions -- condition ) diff --git a/basis/regexp/combinators/combinators-tests.factor b/basis/regexp/combinators/combinators-tests.factor index 0ba2831842..ddfd0dcaad 100644 --- a/basis/regexp/combinators/combinators-tests.factor +++ b/basis/regexp/combinators/combinators-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: regexp.combinators tools.test regexp kernel sequences regexp.matchers ; +USING: regexp.combinators tools.test regexp kernel sequences ; IN: regexp.combinators.tests : strings ( -- regexp ) @@ -16,7 +16,7 @@ USE: multiline { R' .*a' R' b.*' } ; [ t ] [ "bljhasflsda" conj matches? ] unit-test -[ f ] [ "bsdfdfs" conj matches? ] unit-test ! why does this fail? +[ f ] [ "bsdfdfs" conj matches? ] unit-test [ f ] [ "fsfa" conj matches? ] unit-test [ f ] [ "bljhasflsda" conj matches? ] unit-test diff --git a/basis/regexp/compiler/compiler.factor b/basis/regexp/compiler/compiler.factor index 4e615d15d7..0e0c0eaae6 100644 --- a/basis/regexp/compiler/compiler.factor +++ b/basis/regexp/compiler/compiler.factor @@ -1,19 +1,19 @@ ! Copyright (C) 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: regexp.classes kernel sequences regexp.negation -quotations regexp.minimize assocs fry math locals combinators +quotations assocs fry math locals combinators accessors words compiler.units kernel.private strings -sequences.private arrays regexp.matchers call namespaces +sequences.private arrays call namespaces regexp.transition-tables combinators.short-circuit ; IN: regexp.compiler GENERIC: question>quot ( question -- quot ) -quot drop [ 2drop t ] ; M: beginning-of-input question>quot @@ -64,7 +64,7 @@ C: box : non-literals>dispatch ( literals non-literals -- quot ) [ swap ] assoc-map ! we want state => predicate, and get the opposite as input - swap keys f answers + swap keys f assoc-answers table>condition [ ] condition-map condition>quot ; : literals>cases ( literal-transitions -- case-body ) @@ -106,13 +106,15 @@ C: box transitions>quot ; : states>code ( words dfa -- ) - '[ + [ ! with-compilation-unit doesn't compile, so we need call( -- ) [ - dup _ word>quot - (( last-match index string -- ? )) - define-declared - ] each - ] with-compilation-unit ; + '[ + dup _ word>quot + (( last-match index string -- ? )) + define-declared + ] each + ] with-compilation-unit + ] call( words dfa -- ) ; : states>words ( dfa -- words dfa ) dup transitions>> keys [ gensym ] H{ } map>assoc @@ -120,34 +122,23 @@ C: box [ values ] bi swap ; -: dfa>word ( dfa -- word ) +: dfa>main-word ( dfa -- word ) states>words [ states>code ] keep start-state>> ; -: check-string ( string -- string ) - ! Make this configurable - dup string? [ "String required" throw ] unless ; - -: setup-regexp ( start-index string -- f start-index string ) - [ f ] [ >fixnum ] [ check-string ] tri* ; inline - PRIVATE> -! The quotation returned is ( start-index string -- i/f ) +: simple-define-temp ( quot effect -- word ) + [ [ define-temp ] with-compilation-unit ] call( quot effect -- word ) ; -: dfa>quotation ( dfa -- quot ) - dfa>word execution-quot '[ setup-regexp @ ] ; +: dfa>word ( dfa -- quot ) + dfa>main-word execution-quot '[ drop [ f ] 2dip @ ] + (( start-index string regexp -- i/f )) simple-define-temp ; -: dfa>shortest-quotation ( dfa -- quot ) - t shortest? [ dfa>quotation ] with-variable ; +: dfa>shortest-word ( dfa -- word ) + t shortest? [ dfa>word ] with-variable ; -: dfa>reverse-quotation ( dfa -- quot ) - t backwards? [ dfa>quotation ] with-variable ; +: dfa>reverse-word ( dfa -- word ) + t backwards? [ dfa>word ] with-variable ; -: dfa>reverse-shortest-quotation ( dfa -- quot ) - t backwards? [ dfa>shortest-quotation ] with-variable ; - -TUPLE: quot-matcher quot ; -C: quot-matcher - -M: quot-matcher match-index-from - quot>> call( index string -- i/f ) ; +: dfa>reverse-shortest-word ( dfa -- word ) + t backwards? [ dfa>shortest-word ] with-variable ; diff --git a/basis/regexp/matchers/matchers.factor b/basis/regexp/matchers/matchers.factor deleted file mode 100644 index 87df845958..0000000000 --- a/basis/regexp/matchers/matchers.factor +++ /dev/null @@ -1,59 +0,0 @@ -! 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 ] [ 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 ; - -> ] 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 ; - -> ] map 0 prefix - slices [ from>> ] map string length suffix - [ string ] 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 ; diff --git a/basis/regexp/negation/negation.factor b/basis/regexp/negation/negation.factor index 0633dca192..8b0a2f6edf 100644 --- a/basis/regexp/negation/negation.factor +++ b/basis/regexp/negation/negation.factor @@ -6,9 +6,6 @@ regexp.ast regexp.transition-tables regexp.minimize regexp.dfa namespaces ; IN: regexp.negation -: ast>dfa ( parse-tree -- minimal-dfa ) - construct-nfa disambiguate construct-dfa minimize ; - CONSTANT: fail-state -1 : add-default-transition ( state's-transitions -- new-state's-transitions ) @@ -49,5 +46,8 @@ CONSTANT: fail-state -1 [ final-states>> keys first ] [ nfa-table get [ transitions>> ] bi@ swap update ] tri ; +: ast>dfa ( parse-tree -- minimal-dfa ) + construct-nfa disambiguate construct-dfa minimize ; + M: negation nfa-node ( node -- start end ) term>> ast>dfa negate-table adjoin-dfa ; diff --git a/basis/regexp/regexp-docs.factor b/basis/regexp/regexp-docs.factor index d77abe877e..d31b185b2f 100644 --- a/basis/regexp/regexp-docs.factor +++ b/basis/regexp/regexp-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel strings help.markup help.syntax regexp.matchers math ; +USING: kernel strings help.markup help.syntax math ; IN: regexp ABOUT: "regexp" @@ -23,7 +23,7 @@ ARTICLE: { "regexp" "construction" } "Constructing regular expressions" { $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 @@ -39,13 +39,14 @@ ARTICLE: { "regexp" "theory" } "The theory of regular expressions" "The Factor regular expression engine was built with the design decision to support negation and intersection at the expense of backreferences. This lets us have a guaranteed linear-time matching algorithm. Systems like Ragel and Lex also use this algorithm, but in the Factor regular expression engine, all other features of regexps are still present." ; ARTICLE: { "regexp" "operations" } "Matching operations with regular expressions" -{ $subsection all-matches } { $subsection matches? } +{ $subsection re-contains? } +{ $subsection first-match } +{ $subsection all-matches } { $subsection re-split1 } { $subsection re-split } { $subsection re-replace } -{ $subsection count-matches } -{ $subsection re-replace } ; +{ $subsection count-matches } ; HELP: { $values { "string" string } { "regexp" regexp } } @@ -63,25 +64,33 @@ HELP: regexp { $class-description "The class of regular expressions. To construct these, see " { $link { "regexp" "construction" } } "." } ; HELP: matches? -{ $values { "string" string } { "matcher" regexp } { "?" "a boolean" } } +{ $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 } { "matcher" regexp } { "before" string } { "after/f" string } } +{ $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 -{ $values { "string" string } { "matcher" regexp } { "seq" "a sequence of slices of the input" } } +{ $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 } { "matcher" regexp } { "n" integer } } +{ $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 } "." } ; HELP: re-split -{ $values { "string" string } { "matcher" regexp } { "seq" "a sequence of slices of the input" } } +{ $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 } "." } ; HELP: re-replace -{ $values { "string" string } { "matcher" regexp } { "replacement" string } { "result" string } } +{ $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 } "." } ; + +HELP: first-match +{ $values { "string" string } { "regexp" regexp } { "slice/f" "the match, if one exists" } } +{ $description "Finds the first match of the regular expression in the string, and returns it as a slice. If there is no match, then " { $link f } " is returned." } ; + +HELP: re-contains? +{ $values { "string" string } { "regexp" regexp } { "?" "a boolean" } } +{ $description "Determines whether the string has a substring which matches the regular expression given." } ; diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 0a448ed276..e01241552d 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -1,13 +1,12 @@ ! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: regexp tools.test kernel sequences regexp.parser regexp.private -eval strings multiline accessors regexp.matchers ; +eval strings multiline accessors ; IN: regexp-tests \ must-infer -! the following don't compile because [ ] with-compilation-unit doesn't compile -! \ compile-regexp must-infer -! \ matches? must-infer +\ compile-regexp must-infer +\ matches? must-infer [ f ] [ "b" "a*" matches? ] unit-test [ t ] [ "" "a*" matches? ] unit-test @@ -212,8 +211,8 @@ IN: regexp-tests [ f ] [ "aaaxb" "a+ab" matches? ] unit-test [ t ] [ "aaacb" "a+cb" matches? ] unit-test -[ 3 ] [ "aaacb" "a*" match-index-head ] unit-test -[ 2 ] [ "aaacb" "aa?" match-index-head ] unit-test +[ "aaa" ] [ "aaacb" "a*" first-match >string ] unit-test +[ "aa" ] [ "aaacb" "aa?" first-match >string ] unit-test [ t ] [ "aaa" R/ AAA/i matches? ] unit-test [ f ] [ "aax" R/ AAA/i matches? ] unit-test @@ -240,11 +239,11 @@ IN: regexp-tests [ f ] [ "A" "\\p{Lower}" matches? ] unit-test [ t ] [ "A" R/ \p{Lower}/i matches? ] unit-test -[ t ] [ "abc" reverse R/ abc/r matches? ] unit-test -[ t ] [ "abc" reverse R/ a[bB][cC]/r matches? ] unit-test +[ t ] [ "abc" R/ abc/r matches? ] unit-test +[ t ] [ "abc" R/ a[bB][cC]/r matches? ] unit-test -[ t ] [ 3 "xabc" R/ abc/ match-index-from >boolean ] unit-test -[ t ] [ 3 "xabc" R/ a[bB][cC]/ match-index-from >boolean ] unit-test +[ t ] [ 3 "xabc" R/ abc/r match-index-from >boolean ] unit-test +[ t ] [ 3 "xabc" R/ a[bB][cC]/r match-index-from >boolean ] unit-test [ t ] [ "s@f" "[a-z.-]@[a-z]" matches? ] unit-test [ f ] [ "a" "[a-z.-]@[a-z]" matches? ] unit-test @@ -269,13 +268,13 @@ IN: regexp-tests [ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] unit-test -[ "ab" ] [ "ab" "(a|ab)(bc)?" match-head >string ] unit-test -[ "abc" ] [ "abc" "(a|ab)(bc)?" match-head >string ] unit-test +[ "ab" ] [ "ab" "(a|ab)(bc)?" first-match >string ] unit-test +[ "abc" ] [ "abc" "(a|ab)(bc)?" first-match >string ] unit-test -[ "ab" ] [ "ab" "(ab|a)(bc)?" match-head >string ] unit-test -[ "abc" ] [ "abc" "(ab|a)(bc)?" match-head >string ] unit-test +[ "ab" ] [ "ab" "(ab|a)(bc)?" first-match >string ] unit-test +[ "abc" ] [ "abc" "(ab|a)(bc)?" first-match >string ] unit-test -[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" match-head >string ] unit-test +[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" first-match >string ] unit-test [ { "1" "2" "3" "4" } ] [ "1ABC2DEF3GHI4" R/ [A-Z]+/ re-split [ >string ] map ] unit-test @@ -301,18 +300,18 @@ IN: regexp-tests [ "-- title --" ] [ "== title ==" R/ =/ "-" re-replace ] unit-test -[ "" ] [ "ab" "a(?!b)" match-head >string ] unit-test -[ "a" ] [ "ac" "a(?!b)" match-head >string ] unit-test +[ "" ] [ "ab" "a(?!b)" first-match >string ] unit-test +[ "a" ] [ "ac" "a(?!b)" first-match >string ] unit-test [ t ] [ "fxxbar" ".{3}(?!foo)bar" matches? ] unit-test [ t ] [ "foobar" ".{3}(?!foo)bar" matches? ] unit-test [ t ] [ "fxxbar" "(?!foo).{3}bar" matches? ] unit-test [ f ] [ "foobar" "(?!foo).{3}bar" matches? ] unit-test -[ "a" ] [ "ab" "a(?=b)(?=b)" match-head >string ] unit-test -[ "a" ] [ "ba" "(?<=b)(?<=b)a" match-head >string ] unit-test -[ "a" ] [ "cab" "(?<=c)a(?=b)" match-head >string ] unit-test +[ "a" ] [ "ab" "a(?=b)(?=b)" first-match >string ] unit-test +[ "a" ] [ "ba" "(?<=b)(?<=b)a" first-match >string ] unit-test +[ "a" ] [ "cab" "(?<=c)a(?=b)" first-match >string ] unit-test -[ 3 ] [ "foobar" "foo(?=bar)" match-index-head ] unit-test -[ f ] [ "foobxr" "foo(?=bar)" match-index-head ] unit-test +[ 3 ] [ "foobar" "foo(?=bar)" first-match length ] unit-test +[ f ] [ "foobxr" "foo(?=bar)" first-match ] unit-test ! Bug in parsing word [ t ] [ "a" R' a' matches? ] unit-test @@ -342,9 +341,19 @@ IN: regexp-tests [ t ] [ "aaaa" R/ .*a./ matches? ] unit-test +[ f ] [ "ab" R/ (?~ac|\p{Lower}b)/ matches? ] unit-test +[ f ] [ "ab" R/ (?~ac|[a-z]b)/ matches? ] unit-test +[ f ] [ "ac" R/ (?~ac|\p{Lower}b)/ matches? ] unit-test +[ f ] [ "ac" R/ (?~ac|[a-z]b)/ matches? ] unit-test +[ f ] [ "ac" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test +[ f ] [ "ab" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test +[ f ] [ "πb" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test +[ t ] [ "πc" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test +[ t ] [ "Ab" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test + ! DFA is compiled when needed, or when literal -[ f ] [ "foo" dfa>> >boolean ] unit-test -[ t ] [ R/ foo/ dfa>> >boolean ] unit-test +[ regexp-initial-word ] [ "foo" dfa>> ] unit-test +[ f ] [ R/ foo/ dfa>> \ regexp-initial-word = ] unit-test [ t ] [ "a" R/ ^a/ matches? ] unit-test [ f ] [ "\na" R/ ^a/ matches? ] unit-test @@ -415,8 +424,14 @@ IN: regexp-tests [ 1 ] [ "a\r" R/ a$/m count-matches ] unit-test [ 1 ] [ "a\r\n" R/ a$/m count-matches ] unit-test -[ f ] [ "foobxr" "foo\\z" match-index-head ] unit-test -[ 3 ] [ "foo" "foo\\z" match-index-head ] unit-test +[ f ] [ "foobxr" "foo\\z" first-match ] unit-test +[ 3 ] [ "foo" "foo\\z" first-match length ] unit-test + +[ t ] [ "a foo b" R/ foo/ re-contains? ] unit-test +[ f ] [ "a bar b" R/ foo/ re-contains? ] unit-test +[ t ] [ "foo" R/ foo/ re-contains? ] unit-test + +[ { "foo" "fxx" "fab" } ] [ "fab fxx foo" R/ f../r all-matches [ >string ] map ] unit-test ! [ t ] [ "foo" "\\bfoo\\b" matches? ] unit-test ! [ t ] [ "afoob" "\\Bfoo\\B" matches? ] unit-test diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index f938ddf60a..7f27a13104 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -2,71 +2,194 @@ ! 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.minimize -regexp.parser regexp.nfa regexp.dfa regexp.classes -regexp.transition-tables splitting sorting regexp.ast -regexp.negation regexp.matchers regexp.compiler ; +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 { raw read-only } { parse-tree read-only } { options read-only } - dfa reverse-dfa ; + dfa next-match ; -: make-regexp ( string ast -- regexp ) - f f f f regexp boa ; foldable - ! Foldable because, when the dfa slot is set, - ! it'll be set to the same thing regardless of who sets it +TUPLE: reverse-regexp < regexp ; -: ( string options -- regexp ) - [ dup parse-regexp ] [ string>options ] bi* - f f regexp boa ; + ( string -- regexp ) "" ; +: maybe-negated ( lookaround quot -- regexp-quot ) + '[ term>> @ ] [ positive?>> [ ] [ not ] ? ] bi compose ; inline -TUPLE: reverse-matcher regexp ; -C: reverse-matcher -! Reverse matchers won't work properly with most combinators, for now +M: lookahead question>quot ! Returns ( index string -- ? ) + [ ast>dfa dfa>shortest-word '[ f _ execute ] ] maybe-negated ; + +: ( ast -- reversed ) + "r" string>options ; + +M: lookbehind question>quot ! Returns ( index string -- ? ) + [ + + ast>dfa dfa>reverse-shortest-word + '[ [ 1- ] dip f _ execute ] + ] maybe-negated ; + +: check-string ( string -- string ) + ! Make this configurable + dup string? [ "String required" throw ] unless ; + +: 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-unsafe( index string regexp -- i/f ) ; + +GENERIC: end/start ( string regexp -- end start ) +M: regexp end/start drop length 0 ; +M: reverse-regexp end/start drop length 1- -1 swap ; + +PRIVATE> + +: matches? ( string regexp -- ? ) + [ end/start ] 2keep + [ check-string ] dip + match-index-from + [ swap = ] [ drop f ] if* ; + +result ( match reverse? -- i start end string ) + over [ + [ [ i>> ] [ j>> tuck ] [ seq>> ] tri ] dip + [ [ swap [ 1+ ] bi@ ] dip ] when + ] [ 2drop f f f f ] if ; inline + +:: next-match ( i string quot reverse? -- i start end string ) + i string reverse? search-range + [ string quot match-slice ] map-find drop + reverse? match>result ; inline + +: do-next-match ( i string regexp -- i start end string ) + dup next-match>> + execute-unsafe( i string regexp -- i start end string ) ; + +: next-slice ( i string regexp -- i/f slice/f ) + do-next-match + [ slice boa ] [ drop ] if* ; inline + +PRIVATE> + +TUPLE: match-iterator + { string read-only } + { regexp read-only } + { i read-only } + { value read-only } ; + +: iterate ( iterator -- iterator'/f ) + dup + [ i>> ] [ string>> ] [ regexp>> ] tri next-slice + [ [ [ string>> ] [ regexp>> ] bi ] 2dip match-iterator boa ] + [ 2drop f ] if* ; + +: value ( iterator/f -- value/f ) + dup [ value>> ] when ; + +: ( string regexp -- match-iterator ) + [ check-string ] dip + 2dup end/start nip f + match-iterator boa + iterate ; inline + +: all-matches ( string regexp -- seq ) + [ iterate ] follow [ value ] map ; + +: count-matches ( string regexp -- n ) + all-matches length ; + +> ] map 0 prefix + slices [ from>> ] map string length suffix + [ string ] 2map ; + +PRIVATE> + +: first-match ( string regexp -- slice/f ) + value ; + +: re-contains? ( string regexp -- ? ) + first-match >boolean ; + +: re-split1 ( string regexp -- before after/f ) + dupd first-match [ 1array split-slices first2 ] [ f ] if* ; + +: re-split ( string regexp -- seq ) + dupd all-matches split-slices ; + +: re-replace ( string regexp replacement -- result ) + [ re-split ] dip join ; > ] [ options>> ] bi ; -: compile-regexp ( regexp -- regexp ) - dup '[ [ _ get-ast ast>dfa dfa>quotation ] unless* ] change-dfa ; +GENERIC: compile-regexp ( regex -- regexp ) -: ( ast -- reversed ) - "r" string>options ; +: regexp-initial-word ( i string regexp -- i/f ) + compile-regexp match-index-from ; -: maybe-negated ( lookaround quot -- regexp-quot ) - '[ term>> @ ] [ positive?>> [ ] [ not ] ? ] bi compose ; inline - -M: lookahead question>quot ! Returns ( index string -- ? ) - [ ast>dfa dfa>shortest-quotation ] maybe-negated ; - -M: lookbehind question>quot ! Returns ( index string -- ? ) - [ - - ast>dfa dfa>reverse-shortest-quotation - [ [ 1- ] dip ] prepose - ] maybe-negated ; - -: compile-reverse ( regexp -- regexp ) +: do-compile-regexp ( regexp -- regexp ) dup '[ - [ - _ get-ast - ast>dfa dfa>reverse-quotation - ] unless* - ] change-reverse-dfa ; + dup \ regexp-initial-word = + [ drop _ get-ast ast>dfa dfa>word ] when + ] change-dfa ; -M: regexp match-index-from - compile-regexp dfa>> match-index-from ; +M: regexp compile-regexp ( regexp -- regexp ) + do-compile-regexp ; -M: reverse-matcher match-index-from - regexp>> compile-reverse reverse-dfa>> - match-index-from ; +M: reverse-regexp compile-regexp ( regexp -- regexp ) + t backwards? [ do-compile-regexp ] with-variable ; + +DEFER: compile-next-match + +: next-initial-word ( i string regexp -- i start end string ) + compile-next-match do-next-match ; + +: compile-next-match ( regexp -- regexp ) + dup '[ + dup \ next-initial-word = [ + drop _ [ compile-regexp dfa>> ] [ reverse-regexp? ] bi + '[ _ '[ _ _ execute ] _ next-match ] + (( i string regexp -- i start end string )) simple-define-temp + ] when + ] change-next-match ; + +PRIVATE> + +: new-regexp ( string ast options class -- regexp ) + [ \ regexp-initial-word \ next-initial-word ] dip boa ; inline + +: make-regexp ( string ast -- regexp ) + f f regexp new-regexp ; + +: ( string options -- regexp ) + [ dup parse-regexp ] [ string>options ] bi* + dup on>> reversed-regexp swap member? + [ reverse-regexp new-regexp ] + [ regexp new-regexp ] if ; + +: ( string -- regexp ) "" ; + + compile-regexp parsed ; + compile-next-match parsed ; PRIVATE> @@ -120,3 +243,4 @@ M: regexp pprint* [ options>> options>string % ] bi ] "" make ] keep present-text ; + diff --git a/basis/regexp/traversal/traversal.factor b/basis/regexp/traversal/traversal.factor deleted file mode 100644 index b890ca7e12..0000000000 --- a/basis/regexp/traversal/traversal.factor +++ /dev/null @@ -1,69 +0,0 @@ -! 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 ; - -: ( 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 -M: dfa-matcher match-index-from - dfa>> do-match match-index>> ; diff --git a/basis/see/authors.txt b/basis/see/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/see/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/see/see-docs.factor b/basis/see/see-docs.factor new file mode 100644 index 0000000000..755d4ac9bc --- /dev/null +++ b/basis/see/see-docs.factor @@ -0,0 +1,55 @@ +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 diff --git a/basis/see/see.factor b/basis/see/see.factor new file mode 100644 index 0000000000..ab9fa2006f --- /dev/null +++ b/basis/see/see.factor @@ -0,0 +1,227 @@ +! 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* ; + +> 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 + + 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* + ; + +M: intersection-class see-class* + ; + +M: mixin-class see-class* + block> ; + +M: predicate-class see-class* + 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 + + \ } 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* + + 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 diff --git a/basis/see/summary.txt b/basis/see/summary.txt new file mode 100644 index 0000000000..a6274bcfe2 --- /dev/null +++ b/basis/see/summary.txt @@ -0,0 +1 @@ +Printing loaded definitions as source code diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 78f357b1cb..9e867f4fbb 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -155,7 +155,7 @@ M: object apply-object push-literal ; "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 ) [ diff --git a/basis/tools/crossref/crossref-docs.factor b/basis/tools/crossref/crossref-docs.factor index 820c957cbc..f49ac7ea76 100644 --- a/basis/tools/crossref/crossref-docs.factor +++ b/basis/tools/crossref/crossref-docs.factor @@ -3,7 +3,7 @@ IN: tools.crossref ARTICLE: "tools.crossref" "Cross-referencing tools" { $subsection usage. } -{ $see-also "definitions" "words" see see-methods } ; +{ $see-also "definitions" "words" "see" } ; ABOUT: "tools.crossref" diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor index 494e022243..36ccaadc98 100644 --- a/basis/tools/crossref/crossref.factor +++ b/basis/tools/crossref/crossref.factor @@ -1,11 +1,11 @@ -! 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 ; diff --git a/basis/tools/memory/memory.factor b/basis/tools/memory/memory.factor index 9b727b48de..3d9166aafa 100644 --- a/basis/tools/memory/memory.factor +++ b/basis/tools/memory/memory.factor @@ -63,11 +63,12 @@ PRIVATE> { "" "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 @@ -83,4 +84,4 @@ PRIVATE> pick at pprint-cell ] with-row ] each 2drop - ] tabular-output ; + ] tabular-output nl ; diff --git a/basis/tools/profiler/profiler.factor b/basis/tools/profiler/profiler.factor index 19646e55c2..864a637096 100644 --- a/basis/tools/profiler/profiler.factor +++ b/basis/tools/profiler/profiler.factor @@ -46,9 +46,7 @@ IN: tools.profiler 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 diff --git a/basis/tools/threads/threads.factor b/basis/tools/threads/threads.factor index fc4ba1f6b2..18dd8ce2b7 100644 --- a/basis/tools/threads/threads.factor +++ b/basis/tools/threads/threads.factor @@ -29,4 +29,4 @@ IN: tools.threads threads >alist sort-keys values [ [ thread. ] with-row ] each - ] tabular-output ; + ] tabular-output nl ; diff --git a/basis/tools/vocabs/browser/browser.factor b/basis/tools/vocabs/browser/browser.factor index 7896cabd2e..70588d5f21 100644 --- a/basis/tools/vocabs/browser/browser.factor +++ b/basis/tools/vocabs/browser/browser.factor @@ -66,15 +66,18 @@ C: vocab-author : 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 [ ] map [ "Files" $heading [ - snippet-style get [ - code-style get [ - stack. - ] with-nesting - ] with-style + files. ] ($block) ] unless-empty ; diff --git a/basis/ui/gadgets/glass/glass-docs.factor b/basis/ui/gadgets/glass/glass-docs.factor new file mode 100644 index 0000000000..bd9028d414 --- /dev/null +++ b/basis/ui/gadgets/glass/glass-docs.factor @@ -0,0 +1,55 @@ +IN: ui.gadgets.glass +USING: help.markup help.syntax ui.gadgets math.rectangles ; + +HELP: show-glass +{ $values { "owner" gadget } { "child" gadget } { "visible-rect" rect } } +{ $description "Displays " { $snippet "child" } " in the glass layer of the window containing " { $snippet "owner" } "." + $nl + "The child's position is calculated with a heuristic:" + { $list + "The child must fit inside the window" + { "The child must not obscure " { $snippet "visible-rect" } ", which is a rectangle whose origin is relative to " { $snippet "owner" } } + { "The child must otherwise be as close as possible to the edges of " { $snippet "visible-rect" } } + } + "For example, when displaying a menu, " { $snippet "visible-rect" } " is a single point at the mouse location, and when displaying a completion popup, " { $snippet "visible-rect" } " contains the bounds of the text element being completed." +} ; + +HELP: hide-glass +{ $values { "child" gadget } } +{ $description "Hides a gadget displayed in a glass layer." } ; + +HELP: hide-glass-hook +{ $values { "gadget" gadget } } +{ $description "Called when a gadget displayed in a glass layer is hidden. The gadget can perform cleanup tasks here." } ; + +HELP: pass-to-popup +{ $values { "gesture" "a gesture" } { "owner" "the popup's owner" } { "?" "a boolean" } } +{ $description "Resends the gesture to the popup displayed by " { $snippet "owner" } ". The owner must have a " { $slot "popup" } " slot. Outputs " { $link f } " if the gesture was handled, " { $link t } " otherwise." } ; + +HELP: show-popup +{ $values { "owner" gadget } { "popup" gadget } { "visible-rect" rect } } +{ $description "Displays " { $snippet "popup" } " in the glass layer of the window containing " { $snippet "owner" } " as a popup." + $nl + "This word differs from " { $link show-glass } " in two respects:" + { $list + { "The popup is stored in the owner's " { $slot "popup" } " slot; the owner can call " { $link pass-to-popup } " to pass keyboard gestures to the popup" } + { "Pressing " { $snippet "ESC" } " with the popup visible will hide it" } + } +} ; + +ARTICLE: "ui.gadgets.glass" "Glass layers" +"The " { $vocab-link "ui.gadgets.glass" } " vocabulary implements support for displaying gadgets in the glass layer of a window. The gadget can be positioned arbitrarily within the glass layer, and while it is visible, mouse clicks outside of the glass layer are intercepted to hide the glass layer. Multiple glass layers can be active at a time; they behave as if stacked on top of each other." +$nl +"This feature is used for completion popups and " { $link "ui.gadgets.menus" } " in the " { $link "ui-tools" } "." +$nl +"Displaying a gadget in a glass layer:" +{ $subsection show-glass } +"Hiding a gadget in a glass layer:" +{ $subsection hide-glass } +"Callback generic invoked on the gadget when its glass layer is hidden:" +{ $subsection hide-glass-hook } +"Popup gadgets add support for forwarding keyboard gestures from an owner gadget to the glass layer:" +{ $subsection show-popup } +{ $subsection pass-to-popup } ; + +ABOUT: "ui.gadgets.glass" \ No newline at end of file diff --git a/basis/ui/gadgets/glass/glass.factor b/basis/ui/gadgets/glass/glass.factor index a8f438c85e..af169235b4 100644 --- a/basis/ui/gadgets/glass/glass.factor +++ b/basis/ui/gadgets/glass/glass.factor @@ -71,7 +71,7 @@ popup H{ { T{ key-down f f "ESC" } [ hide-glass ] } } set-gestures -: pass-to-popup ( gesture interactor -- ? ) +: pass-to-popup ( gesture owner -- ? ) popup>> focusable-child resend-gesture ; : show-popup ( owner popup visible-rect -- ) diff --git a/basis/ui/gadgets/menus/menus-docs.factor b/basis/ui/gadgets/menus/menus-docs.factor index d7297217ed..ad0881a382 100644 --- a/basis/ui/gadgets/menus/menus-docs.factor +++ b/basis/ui/gadgets/menus/menus-docs.factor @@ -16,7 +16,7 @@ HELP: show-commands-menu { $notes "Useful for right-click context menus." } ; ARTICLE: "ui.gadgets.menus" "Popup menus" -"The " { $vocab-link "ui.gadgets.menus" } " vocabulary implements popup menus." +"The " { $vocab-link "ui.gadgets.menus" } " vocabulary displays popup menus in " { $link "ui.gadgets.glass" } "." { $subsection } { $subsection show-menu } { $subsection show-commands-menu } ; diff --git a/basis/ui/gadgets/panes/panes-docs.factor b/basis/ui/gadgets/panes/panes-docs.factor index afb2307b1e..cb747bf84d 100644 --- a/basis/ui/gadgets/panes/panes-docs.factor +++ b/basis/ui/gadgets/panes/panes-docs.factor @@ -26,10 +26,6 @@ HELP: gadget. { $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." } ; diff --git a/basis/ui/gadgets/panes/panes-tests.factor b/basis/ui/gadgets/panes/panes-tests.factor index 680b6fe57f..e486bffd38 100644 --- a/basis/ui/gadgets/panes/panes-tests.factor +++ b/basis/ui/gadgets/panes/panes-tests.factor @@ -19,7 +19,7 @@ IN: ui.gadgets.panes.tests : 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 @@ -87,6 +87,28 @@ IN: ui.gadgets.panes.tests ] 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." ; diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index c52c361b86..bf166f993a 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/basis/ui/gadgets/panes/panes.factor @@ -17,6 +17,12 @@ TUPLE: pane < track output current input last-line prototype scrolls? selection-color caret mark selecting? ; +TUPLE: pane-stream pane ; + +C: pane-stream + +>caret f >>mark ; inline @@ -49,12 +55,6 @@ M: pane gadget-selection? pane-caret&mark and ; 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 ) +baseline+ >>align >>prototype ; inline @@ -70,17 +70,6 @@ M: pane gadget-selection ( pane -- string/f ) [ >>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 ) f pane new-pane ; - GENERIC: draw-selection ( loc obj -- ) : if-fits ( rect quot -- ) @@ -112,10 +101,6 @@ M: pane draw-gadget* : scroll-pane ( pane -- ) dup scrolls?>> [ scroll>bottom ] [ drop ] if ; -TUPLE: pane-stream pane ; - -C: pane-stream - : smash-line ( current -- gadget ) dup children>> { { [ dup empty? ] [ 2drop ""