From 69c1453f830205e8e261a36c0ea330f0c75f274e Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 11 Jan 2009 00:53:23 -0500 Subject: [PATCH 01/14] Adding a checkbox validator --- basis/validators/validators-docs.factor | 5 +++++ basis/validators/validators.factor | 3 +++ 2 files changed, 8 insertions(+) diff --git a/basis/validators/validators-docs.factor b/basis/validators/validators-docs.factor index 4f03fa915b..42503a7155 100644 --- a/basis/validators/validators-docs.factor +++ b/basis/validators/validators-docs.factor @@ -2,6 +2,10 @@ USING: help.markup help.syntax io.streams.string quotations strings math regexp regexp.backend ; IN: validators +HEPL: v-checkbox +{ $values { "str" string } } +{ $description "Converts the string value of a checkbox component (either \"on\" or \"off\") to a boolean value." } ; + HELP: v-captcha { $values { "str" string } } { $description "Throws a validation error if the string is non-empty. This is used to create bait fields for spam-bots to fill in." } ; @@ -99,6 +103,7 @@ $nl { $subsection v-one-line } { $subsection v-one-word } { $subsection v-captcha } +{ $subsection v-checkbox } "More complex validators:" { $subsection v-email } { $subsection v-url } diff --git a/basis/validators/validators.factor b/basis/validators/validators.factor index 78e01fdaf7..755c9f9111 100644 --- a/basis/validators/validators.factor +++ b/basis/validators/validators.factor @@ -5,6 +5,9 @@ math.parser math.ranges assocs regexp unicode.categories arrays hashtables words classes quotations xmode.catalog ; IN: validators +: v-checkbox ( str -- ? ) + "on" = ; + : v-default ( str def -- str/def ) over empty? spin ? ; From 0f2e0d077284623f92bd7adc8ed717693cb58ad8 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 11 Jan 2009 00:58:00 -0500 Subject: [PATCH 02/14] Fixing typo in docs for v-checkbox --- basis/validators/validators-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/validators/validators-docs.factor b/basis/validators/validators-docs.factor index 42503a7155..67c9f4fceb 100644 --- a/basis/validators/validators-docs.factor +++ b/basis/validators/validators-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax io.streams.string quotations strings math regexp regexp.backend ; IN: validators -HEPL: v-checkbox +HELP: v-checkbox { $values { "str" string } } { $description "Converts the string value of a checkbox component (either \"on\" or \"off\") to a boolean value." } ; From ab05d5b47d99fd5b51214b45c0c3d44daf1ad673 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 11 Jan 2009 01:11:06 -0500 Subject: [PATCH 03/14] Adding unit tests for v-checkbox --- basis/validators/validators-tests.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/basis/validators/validators-tests.factor b/basis/validators/validators-tests.factor index d4f3487d0b..acdcdda5d2 100644 --- a/basis/validators/validators-tests.factor +++ b/basis/validators/validators-tests.factor @@ -10,6 +10,9 @@ namespaces assocs ; [ "hello" ] [ "hello" v-one-word ] unit-test [ "hello world" v-one-word ] must-fail +[ t ] [ "on" v-checkbox ] unit-test +[ f ] [ "off" v-checkbox ] unit-test + [ "foo" v-number ] must-fail [ 123 ] [ "123" v-number ] unit-test [ 123 ] [ "123" v-integer ] unit-test From 4a01649d15669a474a964bcc544adb7900d4f651 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 13 Jan 2009 00:05:19 -0600 Subject: [PATCH 04/14] add with-directory-entries and file-type>trailing --- basis/io/directories/directories-docs.factor | 5 ++ basis/io/directories/directories.factor | 3 + basis/io/files/info/unix/unix.factor | 68 +++++++++++++------- 3 files changed, 52 insertions(+), 24 deletions(-) diff --git a/basis/io/directories/directories-docs.factor b/basis/io/directories/directories-docs.factor index edfcf480b0..a469f5b816 100644 --- a/basis/io/directories/directories-docs.factor +++ b/basis/io/directories/directories-docs.factor @@ -50,6 +50,10 @@ HELP: with-directory-files { $values { "path" "a pathname string" } { "quot" quotation } } { $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ; +HELP: with-directory-entries +{ $values { "path" "a pathname string" } { "quot" quotation } } +{ $description "Calls the quotation with the directory entries on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ; + HELP: delete-file { $values { "path" "a pathname string" } } { $description "Deletes a file." } @@ -122,6 +126,7 @@ ARTICLE: "io.directories.listing" "Directory listing" "Directory listing:" { $subsection directory-entries } { $subsection directory-files } +{ $subsection with-directory-entries } { $subsection with-directory-files } ; ARTICLE: "io.directories.create" "Creating directories" diff --git a/basis/io/directories/directories.factor b/basis/io/directories/directories.factor index 2630be8ce2..6ae55b7f7b 100755 --- a/basis/io/directories/directories.factor +++ b/basis/io/directories/directories.factor @@ -41,6 +41,9 @@ HOOK: (directory-entries) os ( path -- seq ) : directory-files ( path -- seq ) directory-entries [ name>> ] map ; +: with-directory-entries ( path quot -- ) + '[ "" directory-entries @ ] with-directory ; inline + : with-directory-files ( path quot -- ) '[ "" directory-files @ ] with-directory ; inline diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index 9287e7f4ad..b7edc14c2c 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/basis/io/files/info/unix/unix.factor @@ -114,30 +114,6 @@ M: file-info file-mode? [ permissions>> ] dip mask? ; PRIVATE> -: ch>file-type ( ch -- type ) - { - { CHAR: b [ +block-device+ ] } - { CHAR: c [ +character-device+ ] } - { CHAR: d [ +directory+ ] } - { CHAR: l [ +symbolic-link+ ] } - { CHAR: s [ +socket+ ] } - { CHAR: p [ +fifo+ ] } - { CHAR: - [ +regular-file+ ] } - [ drop +unknown+ ] - } case ; - -: file-type>ch ( type -- string ) - { - { +block-device+ [ CHAR: b ] } - { +character-device+ [ CHAR: c ] } - { +directory+ [ CHAR: d ] } - { +symbolic-link+ [ CHAR: l ] } - { +socket+ [ CHAR: s ] } - { +fifo+ [ CHAR: p ] } - { +regular-file+ [ CHAR: - ] } - [ drop CHAR: - ] - } case ; - : UID OCT: 0004000 ; inline : GID OCT: 0002000 ; inline : STICKY OCT: 0001000 ; inline @@ -251,3 +227,47 @@ M: string set-file-group ( path string -- ) : file-group-name ( path -- string ) file-group-id group-name ; + +: ch>file-type ( ch -- type ) + { + { CHAR: b [ +block-device+ ] } + { CHAR: c [ +character-device+ ] } + { CHAR: d [ +directory+ ] } + { CHAR: l [ +symbolic-link+ ] } + { CHAR: s [ +socket+ ] } + { CHAR: p [ +fifo+ ] } + { CHAR: - [ +regular-file+ ] } + [ drop +unknown+ ] + } case ; + +: file-type>ch ( type -- ch ) + { + { +block-device+ [ CHAR: b ] } + { +character-device+ [ CHAR: c ] } + { +directory+ [ CHAR: d ] } + { +symbolic-link+ [ CHAR: l ] } + { +socket+ [ CHAR: s ] } + { +fifo+ [ CHAR: p ] } + { +regular-file+ [ CHAR: - ] } + [ drop CHAR: - ] + } case ; + +executable ( directory-entry -- string ) + name>> any-execute? "*" "" ? ; + +PRIVATE> + +: file-type>trailing ( directory-entry -- string ) + dup type>> + { + { +directory+ [ drop "/" ] } + { +symbolic-link+ [ drop "@" ] } + { +fifo+ [ drop "|" ] } + { +socket+ [ drop "=" ] } + { +whiteout+ [ drop "%" ] } + { +unknown+ [ file-type>executable ] } + { +regular-file+ [ file-type>executable ] } + [ drop file-type>executable ] + } case ; From f920007959292abed2c89fbaafea594e86ec4cb8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 13 Jan 2009 00:20:34 -0600 Subject: [PATCH 05/14] extend sort-by-slots to work with nested objects, add split-by-slots for already-sorted sequences of tuples --- basis/sorting/slots/slots-docs.factor | 13 ++- basis/sorting/slots/slots-tests.factor | 105 +++++++++++++++++++++++-- basis/sorting/slots/slots.factor | 21 +++-- 3 files changed, 126 insertions(+), 13 deletions(-) diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor index 64d0a1efdf..a3bdbf9ac1 100644 --- a/basis/sorting/slots/slots-docs.factor +++ b/basis/sorting/slots/slots-docs.factor @@ -6,17 +6,17 @@ IN: sorting.slots HELP: compare-slots { $values - { "sort-specs" "a sequence of accessor/comparator pairs" } + { "sort-specs" "a sequence of accessors ending with a comparator" } { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } } } { $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ; HELP: sort-by-slots { $values - { "seq" sequence } { "sort-specs" "a sequence of accessor/comparator pairs" } + { "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" } { "seq'" sequence } } -{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a slot accessor and a comparator." } +{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." } { $examples "Sort by slot c, then b descending:" { $example @@ -32,6 +32,13 @@ HELP: sort-by-slots } } ; +HELP: split-by-slots +{ $values + { "accessor-seqs" "a sequence of sequences of tuple accessors" } + { "quot" quotation } +} +{ $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ; + ARTICLE: "sorting.slots" "Sorting by slots" "The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl "Comparing two objects by a sequence of slots:" diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor index ab130d1eed..7a4eeb8e75 100644 --- a/basis/sorting/slots/slots-tests.factor +++ b/basis/sorting/slots/slots-tests.factor @@ -1,10 +1,12 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors math.order sorting.slots tools.test -sorting.human ; +sorting.human arrays sequences kernel assocs multiline ; IN: sorting.literals.tests -TUPLE: sort-test a b c ; +TUPLE: sort-test a b c tuple2 ; + +TUPLE: tuple2 d ; [ { @@ -43,8 +45,101 @@ TUPLE: sort-test a b c ; ] unit-test [ - { } + { + { + T{ sort-test { a 1 } { b 1 } { c 10 } } + T{ sort-test { a 1 } { b 1 } { c 11 } } + } + { T{ sort-test { a 1 } { b 3 } { c 9 } } } + { + T{ sort-test { a 2 } { b 5 } { c 3 } } + T{ sort-test { a 2 } { b 5 } { c 2 } } + } + } ] [ - { } - { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots + { + T{ sort-test f 1 3 9 } + T{ sort-test f 1 1 10 } + T{ sort-test f 1 1 11 } + T{ sort-test f 2 5 3 } + T{ sort-test f 2 5 2 } + } + { { a>> human-<=> } { b>> <=> } } [ sort-by-slots ] keep + [ but-last-slice ] map split-by-slots [ >array ] map +] unit-test + +: split-test ( seq -- seq' ) + { { a>> } { b>> } } split-by-slots ; + +[ split-test ] must-infer + +[ { } ] +[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test + +[ + { + T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } } + T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } } + T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } } + T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } } + T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } } + T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } } + } +] [ + { + T{ sort-test f 6 f f T{ tuple2 f 1 } } + T{ sort-test f 5 f f T{ tuple2 f 4 } } + T{ sort-test f 6 f f T{ tuple2 f 3 } } + T{ sort-test f 6 f f T{ tuple2 f 3 } } + T{ sort-test f 5 f f T{ tuple2 f 3 } } + T{ sort-test f 6 f f T{ tuple2 f 2 } } + } { { tuple2>> d>> <=> } { a>> <=> } } sort-by-slots +] unit-test + +[ + { + { + T{ sort-test + { a 6 } + { tuple2 T{ tuple2 { d 1 } } } + } + } + { + T{ sort-test + { a 6 } + { tuple2 T{ tuple2 { d 2 } } } + } + } + { + T{ sort-test + { a 5 } + { tuple2 T{ tuple2 { d 3 } } } + } + } + { + T{ sort-test + { a 6 } + { tuple2 T{ tuple2 { d 3 } } } + } + T{ sort-test + { a 6 } + { tuple2 T{ tuple2 { d 3 } } } + } + } + { + T{ sort-test + { a 5 } + { tuple2 T{ tuple2 { d 4 } } } + } + } + } +] [ + { + T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } } + T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } } + T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } } + T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } } + T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } } + T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } } + } { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map ] unit-test diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index 02a11428f9..56b6a115f0 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -1,19 +1,30 @@ ! Copyright (C) 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: combinators.short-circuit fry kernel macros math.order -sequences words sorting ; +sequences words sorting sequences.deep assocs splitting.monotonic +math ; IN: sorting.slots MACRO: compare-slots ( sort-specs -- <=> ) - #! sort-spec: { accessor comparator } - [ first2 slot-comparator ] map '[ _ 2|| +eq+ or ] ; + #! sort-spec: { accessors comparator } + [ slot-comparator ] map '[ _ 2|| +eq+ or ] ; : sort-by-slots ( seq sort-specs -- seq' ) '[ _ compare-slots ] sort ; + +MACRO: split-by-slots ( accessor-seqs -- quot ) + [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map + '[ [ _ 2&& ] slice monotonic-slice ] ; From 16c067e71a1f69e601b11f0048bceb92d686cbe5 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 13 Jan 2009 10:29:27 +0100 Subject: [PATCH 06/14] FUEL: Bug fix. --- extra/fuel/help/help.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor index 298124ffb4..ff7239ac8f 100644 --- a/extra/fuel/help/help.factor +++ b/extra/fuel/help/help.factor @@ -95,7 +95,7 @@ PRIVATE> [ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline : (fuel-word-def) ( name -- str ) - fuel-find-word [ [ def>> pprint ] with-string-writer ] when* ; inline + fuel-find-word [ [ def>> pprint ] with-string-writer ] [ f ] if* ; inline : (fuel-vocab-summary) ( name -- str ) >vocab-link summary ; inline From 7e751b4195c6279cdee4cf9dc880bed2f9fa2e50 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 13 Jan 2009 11:57:59 +0100 Subject: [PATCH 07/14] FUEL: Fix the fix to multiline string literals font-lock. --- misc/fuel/fuel-syntax.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 7f0fa313c2..b74b0afc11 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -94,7 +94,7 @@ "\\_<-?[0-9]+\\.[0-9]*\\([eE][+-]?[0-9]+\\)?\\_>") (defconst fuel-syntax--bad-string-regex - "\"[^\"]*$") + "\"\\([^\"]\\|\\\\\"\\)*\n") (defconst fuel-syntax--word-definition-regex (fuel-syntax--second-word-regex @@ -226,7 +226,7 @@ ;; CHARs: ("CHAR: \\(.\\)\\( \\|$\\)" (1 "w")) ;; Strings - ("\\(\"\\)[^\n\r\f]*\\(\"\\)" (1 "\"") (2 "\"")) + ("\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\\"?\\)*\\(\"\\)" (1 "\"") (3 "\"")) ;; Let and lambda: ("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">")) ("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]")) From 5fbfc1acf1ad56959d342bb2b1f73a464ed5f4c5 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Tue, 13 Jan 2009 16:34:28 +0100 Subject: [PATCH 08/14] Remove duplicate inverse definition --- extra/inverse/inverse.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index a38af644b0..b9e0788192 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -148,7 +148,6 @@ MACRO: undo ( quot -- ) [undo] ; \ exp [ log ] define-inverse \ log [ exp ] define-inverse -\ not [ not ] define-inverse \ sq [ sqrt ] define-inverse \ sqrt [ sq ] define-inverse From 280564b6ecd6321dbf1d2a5615b09d61d8e52dbe Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Tue, 13 Jan 2009 16:39:34 +0100 Subject: [PATCH 09/14] Define reciprocal inverses with "define-dual" --- extra/inverse/inverse-docs.factor | 7 ++++++- extra/inverse/inverse-tests.factor | 3 +++ extra/inverse/inverse.factor | 15 +++++++-------- 3 files changed, 16 insertions(+), 9 deletions(-) diff --git a/extra/inverse/inverse-docs.factor b/extra/inverse/inverse-docs.factor index 8204f7174c..c2615fc411 100644 --- a/extra/inverse/inverse-docs.factor +++ b/extra/inverse/inverse-docs.factor @@ -14,7 +14,12 @@ HELP: undo HELP: define-inverse { $values { "word" "a word" } { "quot" "the inverse" } } { $description "Defines the inverse of a given word, taking no arguments from the quotation, only the stack." } -{ $see-also define-pop-inverse } ; +{ $see-also define-dual define-pop-inverse } ; + +HELP: define-dual +{ $values { "word1" "a word" } { "word2" "a word" } } +{ $description "Defines the inverse of each word as being the other one." } +{ $see-also define-inverse } ; HELP: define-pop-inverse { $values { "word" "a word" } { "n" "number of arguments to be taken from the inverted quotation" } { "quot" "a quotation" } } diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor index 5e662ed78f..3dce620857 100644 --- a/extra/inverse/inverse-tests.factor +++ b/extra/inverse/inverse-tests.factor @@ -75,3 +75,6 @@ C: nil [ { 3 } ] [ { 1 2 3 } [ { 1 2 } prepend ] undo ] unit-test [ { 1 2 3 } [ { 1 2 } append ] undo ] must-fail [ { 1 2 3 } [ { 2 3 } prepend ] undo ] must-fail + +[ [ sq ] ] [ [ sqrt ] [undo] ] unit-test +[ [ sqrt ] ] [ [ sq ] [undo] ] unit-test diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index b9e0788192..ec4df1ba69 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -20,6 +20,9 @@ M: fail summary drop "Matching failed" ; : define-inverse ( word quot -- ) "inverse" set-word-prop ; +: define-dual ( word1 word2 -- ) + 2dup swap [ 1quotation define-inverse ] 2bi@ ; + : define-math-inverse ( word quot1 quot2 -- ) pick 1quotation 3array "math-inverse" set-word-prop ; @@ -139,17 +142,14 @@ MACRO: undo ( quot -- ) [undo] ; \ not [ not ] define-inverse \ >boolean [ { t f } memq? assure ] define-inverse -\ tuple>array [ >tuple ] define-inverse -\ >tuple [ tuple>array ] define-inverse +\ tuple>array \ >tuple define-dual \ reverse [ reverse ] define-inverse \ undo 1 [ [ call ] curry ] define-pop-inverse \ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse -\ exp [ log ] define-inverse -\ log [ exp ] define-inverse -\ sq [ sqrt ] define-inverse -\ sqrt [ sq ] define-inverse +\ exp \ log define-dual +\ sq \ sqrt define-dual ERROR: missing-literal ; @@ -203,8 +203,7 @@ DEFER: _ \ first3 [ 3array ] define-inverse \ first4 [ 4array ] define-inverse -\ prefix [ unclip ] define-inverse -\ unclip [ prefix ] define-inverse +\ prefix \ unclip define-dual \ suffix [ dup but-last swap peek ] define-inverse \ append 1 [ [ ?tail assure ] curry ] define-pop-inverse From dccb72befef2081e5e3a59c63d3b5cd5955d8c7d Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Tue, 13 Jan 2009 16:58:31 +0100 Subject: [PATCH 10/14] Define involutary words with "define-involution" --- extra/inverse/inverse-docs.factor | 9 +++++++-- extra/inverse/inverse-tests.factor | 2 ++ extra/inverse/inverse.factor | 8 +++++--- 3 files changed, 14 insertions(+), 5 deletions(-) diff --git a/extra/inverse/inverse-docs.factor b/extra/inverse/inverse-docs.factor index c2615fc411..6b575d6d08 100644 --- a/extra/inverse/inverse-docs.factor +++ b/extra/inverse/inverse-docs.factor @@ -14,12 +14,17 @@ HELP: undo HELP: define-inverse { $values { "word" "a word" } { "quot" "the inverse" } } { $description "Defines the inverse of a given word, taking no arguments from the quotation, only the stack." } -{ $see-also define-dual define-pop-inverse } ; +{ $see-also define-dual define-involution define-pop-inverse } ; HELP: define-dual { $values { "word1" "a word" } { "word2" "a word" } } { $description "Defines the inverse of each word as being the other one." } -{ $see-also define-inverse } ; +{ $see-also define-inverse define-involution } ; + +HELP: define-involution +{ $values { "word" "a word" } } +{ $description "Defines a word as being its own inverse." } +{ $see-also define-dual define-inverse } ; HELP: define-pop-inverse { $values { "word" "a word" } { "n" "number of arguments to be taken from the inverted quotation" } { "quot" "a quotation" } } diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor index 3dce620857..a9234fcff4 100644 --- a/extra/inverse/inverse-tests.factor +++ b/extra/inverse/inverse-tests.factor @@ -78,3 +78,5 @@ C: nil [ [ sq ] ] [ [ sqrt ] [undo] ] unit-test [ [ sqrt ] ] [ [ sq ] [undo] ] unit-test +[ [ not ] ] [ [ not ] [undo] ] unit-test +[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] undo ] unit-test diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index ec4df1ba69..924a6d3814 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -23,6 +23,8 @@ M: fail summary drop "Matching failed" ; : define-dual ( word1 word2 -- ) 2dup swap [ 1quotation define-inverse ] 2bi@ ; +: define-involution ( word -- ) dup 1quotation define-inverse ; + : define-math-inverse ( word quot1 quot2 -- ) pick 1quotation 3array "math-inverse" set-word-prop ; @@ -132,18 +134,18 @@ MACRO: undo ( quot -- ) [undo] ; ! Inverse of selected words -\ swap [ swap ] define-inverse +\ swap define-involution \ dup [ [ =/fail ] keep ] define-inverse \ 2dup [ over =/fail over =/fail ] define-inverse \ 3dup [ pick =/fail pick =/fail pick =/fail ] define-inverse \ pick [ [ pick ] dip =/fail ] define-inverse \ tuck [ swapd [ =/fail ] keep ] define-inverse -\ not [ not ] define-inverse +\ not define-involution \ >boolean [ { t f } memq? assure ] define-inverse \ tuple>array \ >tuple define-dual -\ reverse [ reverse ] define-inverse +\ reverse define-involution \ undo 1 [ [ call ] curry ] define-pop-inverse \ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse From 3db9705a9939422d996fec25b2b109a029f73464 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 13 Jan 2009 15:48:59 -0600 Subject: [PATCH 11/14] making directory listing tool configurable, use bi in io.directories.search --- basis/io/directories/search/search.factor | 2 +- basis/tools/files/files-tests.factor | 4 +- basis/tools/files/files.factor | 96 +++++++++++++++++------ basis/tools/files/unix/unix.factor | 42 ++++++---- basis/tools/files/windows/windows.factor | 21 +++-- 5 files changed, 108 insertions(+), 57 deletions(-) diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index d1fdff34f9..f9a0a14d0c 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -14,7 +14,7 @@ TUPLE: directory-iterator path bfs queue ; : push-directory ( path iter -- ) [ qualified-directory ] dip [ - dup queue>> swap bfs>> + [ queue>> ] [ bfs>> ] bi [ push-front ] [ push-back ] if ] curry each ; diff --git a/basis/tools/files/files-tests.factor b/basis/tools/files/files-tests.factor index 6cbc7d192c..aa4273f35f 100644 --- a/basis/tools/files/files-tests.factor +++ b/basis/tools/files/files-tests.factor @@ -1,10 +1,8 @@ -! Copyright (C) 2008 Your name. +! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: tools.test tools.files strings kernel ; IN: tools.files.tests -\ directory. must-infer - [ ] [ "" directory. ] unit-test [ ] [ file-systems. ] unit-test diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 9066f3a219..47c7d57c09 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -1,24 +1,29 @@ -! Copyright (C) 2008 Doug Coleman. +! Copyright (C) 2008, 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators io io.files io.files.info -io.directories kernel math.parser sequences system vocabs.loader -calendar math fry prettyprint ; +USING: accessors arrays calendar combinators fry io io.directories +io.files.info kernel math math.parser prettyprint sequences system +vocabs.loader sorting.slots ; IN: tools.files -SYMBOLS: permissions file-name nlinks file-size date ; - " 20 CHAR: \s pad-right + ] [ + size>> number>string 20 CHAR: \s pad-left + ] if ; + +: listing-time ( timestamp -- string ) [ hour>> ] [ minute>> ] bi [ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ; -: ls-timestamp ( timestamp -- string ) +: listing-timestamp ( timestamp -- string ) [ month>> month-abbreviation ] [ day>> number>string 2 CHAR: \s pad-left ] [ dup year>> dup now year>> = - [ drop ls-time ] [ nip number>string ] if + [ drop listing-time ] [ nip number>string ] if 5 CHAR: \s pad-left ] tri 3array " " join ; @@ -28,12 +33,53 @@ SYMBOLS: permissions file-name nlinks file-size date ; : execute>string ( ? -- string ) "x" "-" ? ; inline -HOOK: (directory.) os ( path -- lines ) - PRIVATE> -: directory. ( path -- ) - [ (directory.) ] with-directory-files [ print ] each ; +SYMBOLS: file-name file-name/type permissions file-type nlinks file-size +file-datetime file-time uid gid user group link-target unix-datetime +directory-or-size ; + +TUPLE: listing-tool path specs sort ; + +TUPLE: file-listing directory-entry file-info ; + +C: file-listing + +: ( path -- listing-tool ) + listing-tool new + swap >>path + { file-name } >>specs ; + +: list-slow? ( listing-tool -- ? ) + specs>> { file-name } sequence= not ; + +ERROR: unknown-file-spec symbol ; + +HOOK: file-spec>string os ( file-listing spec -- string ) + +M: object file-spec>string ( file-listing spec -- string ) + { + { file-name [ directory-entry>> name>> ] } + { directory-or-size [ file-info>> dir-or-size ] } + [ unknown-file-spec ] + } case ; + +: list-files-fast ( listing-tool -- array ) + path>> [ [ name>> 1array ] map ] with-directory-entries ; inline + +: list-files-slow ( listing-tool -- array ) + [ path>> ] [ sort>> ] [ specs>> ] tri '[ + [ dup name>> file-info file-listing boa ] map + _ [ sort-by-slots ] when* + [ _ [ file-spec>string ] with map ] map + ] with-directory-entries ; inline + +: list-files ( listing-tool -- array ) + dup list-slow? [ list-files-slow ] [ list-files-fast ] if ; inline + +HOOK: (directory.) os ( path -- lines ) + +: directory. ( path -- ) (directory.) simple-table. ; SYMBOLS: device-name mount-point type available-space free-space used-space total-space @@ -43,16 +89,16 @@ percent-used percent-free ; : file-system-spec ( file-system-info obj -- str ) { - { device-name [ device-name>> [ "" ] unless* ] } - { mount-point [ mount-point>> [ "" ] unless* ] } - { type [ type>> [ "" ] unless* ] } - { available-space [ available-space>> [ 0 ] unless* ] } - { free-space [ free-space>> [ 0 ] unless* ] } - { used-space [ used-space>> [ 0 ] unless* ] } - { total-space [ total-space>> [ 0 ] unless* ] } + { device-name [ device-name>> "" or ] } + { mount-point [ mount-point>> "" or ] } + { type [ type>> "" or ] } + { available-space [ available-space>> 0 or ] } + { free-space [ free-space>> 0 or ] } + { used-space [ used-space>> 0 or ] } + { total-space [ total-space>> 0 or ] } { percent-used [ [ used-space>> ] [ total-space>> ] bi - [ [ 0 ] unless* ] bi@ dup 0 = + [ 0 or ] bi@ dup 0 = [ 2drop 0 ] [ / percent ] if ] } } case ; @@ -65,10 +111,12 @@ percent-used percent-free ; [ [ unparse ] map ] bi prefix simple-table. ; : file-systems. ( -- ) - { device-name available-space free-space used-space total-space percent-used mount-point } - print-file-systems ; + { + device-name available-space free-space used-space + total-space percent-used mount-point + } print-file-systems ; { { [ os unix? ] [ "tools.files.unix" ] } { [ os windows? ] [ "tools.files.windows" ] } -} cond require +} cond require \ No newline at end of file diff --git a/basis/tools/files/unix/unix.factor b/basis/tools/files/unix/unix.factor index 9757db171a..c6bc7fc2c1 100755 --- a/basis/tools/files/unix/unix.factor +++ b/basis/tools/files/unix/unix.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators kernel system unicode.case io.files -io.files.info io.files.info.unix tools.files generalizations +io.files.info io.files.info.unix generalizations strings arrays sequences math.parser unix.groups unix.users -tools.files.private unix.stat math fry macros combinators.smart ; +tools.files.private unix.stat math fry macros combinators.smart +io.files.info.unix io tools.files math.order prettyprint ; IN: tools.files.unix > number>string 3 CHAR: \s pad-left ] - [ uid>> user-name ] - [ gid>> group-name ] - [ size>> number>string 15 CHAR: \s pad-left ] - [ modified>> ls-timestamp ] - } cleave - ] output>array swap suffix " " join - ] map - ] with-group-cache ] with-user-cache ; + + { permissions nlinks user group file-size file-datetime file-name } >>specs + { { directory-entry>> name>> <=> } } >>sort + [ [ list-files ] with-group-cache ] with-user-cache ; -PRIVATE> +M: unix file-spec>string ( file-listing spec -- string ) + { + { file-name/type [ + directory-entry>> [ name>> ] [ file-type>trailing ] bi append + ] } + { permissions [ file-info>> permissions-string ] } + { nlinks [ file-info>> nlink>> number>string ] } + { file-size [ file-info>> size>> number>string ] } + { user [ file-info>> uid>> user-name ] } + { group [ file-info>> gid>> group-name ] } + { uid [ file-info>> uid>> number>string ] } + { gid [ file-info>> gid>> number>string ] } + { file-datetime [ file-info>> modified>> listing-timestamp ] } + { file-time [ file-info>> modified>> listing-time ] } + [ call-next-method ] + } case ; + +PRIVATE> \ No newline at end of file diff --git a/basis/tools/files/windows/windows.factor b/basis/tools/files/windows/windows.factor index 328bb8dc71..3284ec8d8b 100755 --- a/basis/tools/files/windows/windows.factor +++ b/basis/tools/files/windows/windows.factor @@ -7,19 +7,16 @@ IN: tools.files.windows " 20 CHAR: \s pad-right - ] [ - size>> number>string 20 CHAR: \s pad-left - ] if ; +M: windows file-spec>string ( file-listing spec -- string ) + { + { listing-datetime [ modified>> timestamp>ymdhms ] } + [ call-next-method ] + } case ; M: windows (directory.) ( entries -- lines ) - [ - dup file-info { - [ modified>> timestamp>ymdhms ] - [ directory-or-size ] - } cleave 2 narray swap suffix " " join - ] map ; + + { file-size file-datetime file-name } >>specs + { { directory-entry>> name>> <=> } } >>sort + list-files ; PRIVATE> From 4204fd495fcddb78f376fa98493d5ea3d289b634 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 13 Jan 2009 17:12:43 -0600 Subject: [PATCH 12/14] Move formatted stream output words to io.styles; they didn't belong in core, and this reduces deployed image size --- basis/bootstrap/threads/threads.factor | 10 +- basis/compiler/codegen/codegen.factor | 9 +- basis/compiler/compiler.factor | 8 +- basis/compiler/utilities/utilities.factor | 8 +- basis/delegate/protocols/protocols.factor | 2 +- basis/help/handbook/handbook.factor | 2 +- basis/io/styles/styles-docs.factor | 130 +++++++++++++++++++- basis/io/styles/styles.factor | 136 ++++++++++++++++++++- basis/prettyprint/sections/sections.factor | 2 +- basis/ui/gadgets/grids/grids.factor | 4 +- basis/ui/gadgets/panes/panes.factor | 2 +- core/io/io-docs.factor | 101 --------------- core/io/io.factor | 32 +---- core/io/streams/nested/authors.txt | 1 - core/io/streams/nested/nested-docs.factor | 2 - core/io/streams/nested/nested.factor | 74 ----------- core/io/streams/nested/summary.txt | 1 - core/io/streams/plain/plain-docs.factor | 9 -- core/io/streams/plain/plain.factor | 15 +-- core/io/streams/string/string.factor | 20 +-- core/vocabs/loader/loader.factor | 2 - 21 files changed, 291 insertions(+), 279 deletions(-) delete mode 100644 core/io/streams/nested/authors.txt delete mode 100644 core/io/streams/nested/nested-docs.factor delete mode 100644 core/io/streams/nested/nested.factor delete mode 100644 core/io/streams/nested/summary.txt diff --git a/basis/bootstrap/threads/threads.factor b/basis/bootstrap/threads/threads.factor index 8b751f8458..24cbba6af8 100644 --- a/basis/bootstrap/threads/threads.factor +++ b/basis/bootstrap/threads/threads.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: vocabs vocabs.loader kernel ; +USING: vocabs vocabs.loader kernel io.thread threads +compiler.utilities namespaces ; IN: bootstrap.threads -USE: io.thread -USE: threads - "debugger" vocab [ "debugger.threads" require ] when + +[ yield ] yield-hook set-global \ No newline at end of file diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 0dc5a855e3..91acbeed19 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces make math math.order math.parser sequences accessors kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.structs -alien.strings alien.arrays sets threads libc continuations.private +alien.strings alien.arrays sets libc continuations.private fry cpu.architecture compiler.errors compiler.alien @@ -11,7 +11,8 @@ compiler.cfg compiler.cfg.instructions compiler.cfg.registers compiler.cfg.builder -compiler.codegen.fixup ; +compiler.codegen.fixup +compiler.utilities ; IN: compiler.codegen GENERIC: generate-insn ( insn -- ) @@ -463,7 +464,7 @@ TUPLE: callback-context ; dup current-callback eq? [ drop ] [ - yield wait-to-return + yield-hook get call wait-to-return ] if ; : do-callback ( quot token -- ) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 0d24daef71..2fa234e381 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -1,14 +1,14 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces arrays sequences io words fry continuations vocabs assocs dlists definitions math -threads graphs generic combinators deques search-deques io +graphs generic combinators deques search-deques io stack-checker stack-checker.state stack-checker.inlining compiler.errors compiler.units compiler.tree.builder compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization compiler.cfg.two-operand compiler.cfg.linear-scan -compiler.cfg.stack-frame compiler.codegen ; +compiler.cfg.stack-frame compiler.codegen compiler.utilities ; IN: compiler SYMBOL: compile-queue @@ -107,7 +107,7 @@ t compile-dependencies? set-global ] with-return ; : compile-loop ( deque -- ) - [ (compile) yield ] slurp-deque ; + [ (compile) yield-hook get call ] slurp-deque ; : decompile ( word -- ) f 2array 1array t modify-code-heap ; diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor index e8082edb68..ec4ced8c9f 100644 --- a/basis/compiler/utilities/utilities.factor +++ b/basis/compiler/utilities/utilities.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences sequences.private arrays vectors fry -math.order ; +math.order namespaces assocs ; IN: compiler.utilities : flattener ( seq quot -- seq vector quot' ) @@ -21,3 +21,7 @@ IN: compiler.utilities : map-flat ( seq quot -- seq' ) [ each ] flattening ; inline : 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline + +SYMBOL: yield-hook + +yield-hook global [ [ ] or ] change-at diff --git a/basis/delegate/protocols/protocols.factor b/basis/delegate/protocols/protocols.factor index c21f33ec8e..edbec804c1 100644 --- a/basis/delegate/protocols/protocols.factor +++ b/basis/delegate/protocols/protocols.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: delegate sequences.private sequences assocs -io definitions kernel continuations ; +io io.styles definitions kernel continuations ; IN: delegate.protocols PROTOCOL: sequence-protocol diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index f63bb35f65..c67a378796 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -183,7 +183,7 @@ ARTICLE: "io" "Input and output" { $subsection "io.streams.byte-array" } { $heading "Utilities" } { $subsection "stream-binary" } -{ $subsection "styles" } +{ $subsection "io.styles" } { $subsection "checksums" } { $heading "Implementation" } { $subsection "io.streams.c" } diff --git a/basis/io/styles/styles-docs.factor b/basis/io/styles/styles-docs.factor index c29f3d5d70..82f5de3d70 100644 --- a/basis/io/styles/styles-docs.factor +++ b/basis/io/styles/styles-docs.factor @@ -1,7 +1,116 @@ USING: help.markup help.syntax io.streams.plain io strings -hashtables ; +hashtables kernel quotations ; IN: io.styles +HELP: stream-format +{ $values { "str" string } { "style" "a hashtable" } { "stream" "an output stream" } } +{ $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." +$nl +"The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." } +$io-error ; + +HELP: make-block-stream +{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } } +{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "." +$nl +"Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output." +$nl +"The " { $snippet "style" } " hashtable holds paragraph style information. See " { $link "paragraph-styles" } "." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link with-nesting } "; see " { $link "stdio" } "." } +$io-error ; + +HELP: stream-write-table +{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" "a hashtable" } { "stream" "an output stream" } } +{ $contract "Prints a table of cells produced by " { $link with-cell } "." +$nl +"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link tabular-output } "; see " { $link "stdio" } "." } +$io-error ; + +HELP: make-cell-stream +{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } } +{ $contract "Creates an output stream which writes to a table cell object." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." } +$io-error ; + +HELP: make-span-stream +{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } } +{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "." +$nl +"Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." } +{ $notes "Most code only works on one stream at a time and should instead use " { $link with-style } "; see " { $link "stdio" } "." } +$io-error ; + +HELP: format +{ $values { "str" string } { "style" "a hashtable" } } +{ $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } +{ $notes "Details are in the documentation for " { $link stream-format } "." } +$io-error ; + +HELP: with-nesting +{ $values { "style" "a hashtable" } { "quot" quotation } } +{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." } +{ $notes "Details are in the documentation for " { $link make-block-stream } "." } +$io-error ; + +HELP: tabular-output +{ $values { "style" "a hashtable" } { "quot" quotation } } +{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "." +$nl +"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." } +{ $examples + { $code + "{ { 1 2 } { 3 4 } }" + "H{ { table-gap { 10 10 } } } [" + " [ [ [ [ . ] with-cell ] each ] with-row ] each" + "] tabular-output" + } +} +$io-error ; + +HELP: with-row +{ $values { "quot" quotation } } +{ $description "Calls a quotation which emits a series of table cells using " { $link with-cell } ". This word can only be called inside the quotation given to " { $link tabular-output } "." } +$io-error ; + +HELP: with-cell +{ $values { "quot" quotation } } +{ $description "Calls a quotation in a new scope with " { $link output-stream } " rebound. Output performed by the quotation is displayed in a table cell. This word can only be called inside the quotation given to " { $link with-row } "." } +$io-error ; + +HELP: write-cell +{ $values { "str" string } } +{ $description "Outputs a table cell containing a single string. This word can only be called inside the quotation given to " { $link with-row } "." } +$io-error ; + +HELP: with-style +{ $values { "style" "a hashtable" } { "quot" quotation } } +{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." } +{ $notes "Details are in the documentation for " { $link make-span-stream } "." } +$io-error ; + +ARTICLE: "formatted-stream-protocol" "Formatted stream protocol" +"The " { $vocab-link "io.styles" } " vocabulary defines a protocol for output streams that support rich text." +{ $subsection stream-format } +{ $subsection make-span-stream } +{ $subsection make-block-stream } +{ $subsection make-cell-stream } +{ $subsection stream-write-table } ; + +ARTICLE: "formatted-stdout" "Formatted output on the default stream" +"The below words perform formatted output on " { $link output-stream } "." +$nl +"Formatted output:" +{ $subsection format } +{ $subsection with-style } +{ $subsection with-nesting } +"Tabular output:" +{ $subsection tabular-output } +{ $subsection with-row } +{ $subsection with-cell } +{ $subsection write-cell } ; + ARTICLE: "character-styles" "Character styles" "Character styles for " { $link stream-format } " and " { $link with-style } ":" { $subsection foreground } @@ -33,7 +142,7 @@ ARTICLE: "presentations" "Presentations" "The " { $link presented } " style can be used to emit clickable objects. A utility word for outputting this style:" { $subsection write-object } ; -ARTICLE: "styles" "Formatted output" +ARTICLE: "styles" "Styled text" "The " { $link stream-format } ", " { $link with-style } ", " { $link with-nesting } " and " { $link tabular-output } " words take a hashtable of style attributes. Output stream implementations are free to ignore style information." $nl "Style hashtables are keyed by symbols from the " { $vocab-link "io.styles" } " vocabulary." @@ -42,7 +151,13 @@ $nl { $subsection "table-styles" } { $subsection "presentations" } ; -ABOUT: "styles" +ARTICLE: "io.styles" "Formatted output" +"The " { $vocab-link "io.styles" } " vocabulary defines a protocol for formatted output. This is used by the prettyprinter, help system, and various developer tools. Implementations include " { $vocab-link "ui.gadgets.panes" } ", " { $vocab-link "html.streams" } ", and " { $vocab-link "io.streams.plain" } "." +{ $subsection "formatted-stream-protocol" } +{ $subsection "formatted-stdout" } +{ $subsection "styles" } ; + +ABOUT: "io.styles" HELP: plain { $description "A value for the " { $link font-style } " character style denoting plain text." } ; @@ -157,3 +272,12 @@ HELP: HELP: standard-table-style { $values { "style" hashtable } } { $description "Outputs a table style where cells are separated by 5-pixel gaps and framed by a light gray border. This style can be passed to " { $link tabular-output } "." } ; + +ARTICLE: "io.streams.plain" "Plain writer streams" +"Plain writer streams wrap an underlying stream and provide a default implementation of " +{ $link stream-nl } ", " +{ $link stream-format } ", " +{ $link make-span-stream } ", " +{ $link make-block-stream } " and " +{ $link make-cell-stream } "." +{ $subsection plain-writer } ; \ No newline at end of file diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor index e07753c640..0e07c8bda9 100644 --- a/basis/io/styles/styles.factor +++ b/basis/io/styles/styles.factor @@ -1,9 +1,139 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: hashtables io colors summary make accessors splitting -kernel ; +USING: hashtables io io.streams.plain io.streams.string +colors summary make accessors splitting math.order +kernel namespaces assocs destructors strings sequences ; IN: io.styles +GENERIC: stream-format ( str style stream -- ) +GENERIC: make-span-stream ( style stream -- stream' ) +GENERIC: make-block-stream ( style stream -- stream' ) +GENERIC: make-cell-stream ( style stream -- stream' ) +GENERIC: stream-write-table ( table-cells style stream -- ) + +: format ( str style -- ) output-stream get stream-format ; + +: tabular-output ( style quot -- ) + swap [ { } make ] dip output-stream get stream-write-table ; inline + +: with-row ( quot -- ) + { } make , ; inline + +: with-cell ( quot -- ) + H{ } output-stream get make-cell-stream + [ swap with-output-stream ] keep , ; inline + +: write-cell ( str -- ) + [ write ] with-cell ; inline + +: with-style ( style quot -- ) + swap dup assoc-empty? [ + drop call + ] [ + output-stream get make-span-stream swap with-output-stream + ] if ; inline + +: with-nesting ( style quot -- ) + [ output-stream get make-block-stream ] dip + with-output-stream ; inline + +TUPLE: filter-writer stream ; + +M: filter-writer stream-format + stream>> stream-format ; + +M: filter-writer stream-write + stream>> stream-write ; + +M: filter-writer stream-write1 + stream>> stream-write1 ; + +M: filter-writer make-span-stream + stream>> make-span-stream ; + +M: filter-writer make-block-stream + stream>> make-block-stream ; + +M: filter-writer make-cell-stream + stream>> make-cell-stream ; + +M: filter-writer stream-flush + stream>> stream-flush ; + +M: filter-writer stream-nl + stream>> stream-nl ; + +M: filter-writer stream-write-table + stream>> stream-write-table ; + +M: filter-writer dispose + stream>> dispose ; + +TUPLE: ignore-close-stream < filter-writer ; + +M: ignore-close-stream dispose drop ; + +C: ignore-close-stream + +TUPLE: style-stream < filter-writer style ; + +: do-nested-style ( style style-stream -- style stream ) + [ style>> swap assoc-union ] [ stream>> ] bi ; inline + +C: style-stream + +M: style-stream stream-format + do-nested-style stream-format ; + +M: style-stream stream-write + [ style>> ] [ stream>> ] bi stream-format ; + +M: style-stream stream-write1 + [ 1string ] dip stream-write ; + +M: style-stream make-span-stream + do-nested-style make-span-stream ; + +M: style-stream make-block-stream + [ do-nested-style make-block-stream ] [ style>> ] bi + ; + +M: style-stream make-cell-stream + [ do-nested-style make-cell-stream ] [ style>> ] bi + ; + +M: style-stream stream-write-table + [ [ [ stream>> ] map ] map ] [ ] [ stream>> ] tri* + stream-write-table ; + +M: plain-writer stream-format + nip stream-write ; + +M: plain-writer make-span-stream + swap ; + +M: plain-writer make-block-stream + nip ; + +: format-column ( seq ? -- seq ) + [ + [ 0 [ length max ] reduce ] keep + swap [ CHAR: \s pad-right ] curry map + ] unless ; + +: map-last ( seq quot -- seq ) + [ dup length ] dip [ 0 = ] prepose 2map ; inline + +: format-table ( table -- seq ) + flip [ format-column ] map-last + flip [ " " join ] map ; + +M: plain-writer stream-write-table + [ drop format-table [ print ] each ] with-output-stream* ; + +M: plain-writer make-cell-stream 2drop ; + +! Font styles SYMBOL: plain SYMBOL: bold SYMBOL: italic diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor index 102d005f39..faa254be69 100644 --- a/basis/prettyprint/sections/sections.factor +++ b/basis/prettyprint/sections/sections.factor @@ -3,7 +3,7 @@ USING: arrays generic hashtables io kernel math assocs namespaces make sequences strings io.styles vectors words prettyprint.config splitting classes continuations -io.streams.nested accessors sets ; +accessors sets ; IN: prettyprint.sections ! State diff --git a/basis/ui/gadgets/grids/grids.factor b/basis/ui/gadgets/grids/grids.factor index eab8833120..e40da44483 100644 --- a/basis/ui/gadgets/grids/grids.factor +++ b/basis/ui/gadgets/grids/grids.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2006, 2008 Slava Pestov. +! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math namespaces make sequences words io -io.streams.string math.vectors ui.gadgets columns accessors +io.styles math.vectors ui.gadgets columns accessors math.geometry.rect locals fry ; IN: ui.gadgets.grids diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index efdd54bcc7..569d6e0f3f 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/basis/ui/gadgets/panes/panes.factor @@ -6,7 +6,7 @@ ui.gadgets.incremental ui.gadgets.packs ui.gadgets.theme ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render hashtables io kernel namespaces sequences io.styles strings quotations math opengl combinators math.vectors sorting -splitting io.streams.nested assocs ui.gadgets.presentations +splitting assocs ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines classes.tuple models continuations destructors accessors math.geometry.rect fry ; diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 02af963e1a..95bccd8b18 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -57,45 +57,6 @@ HELP: stream-nl { $notes "Most code only works on one stream at a time and should instead use " { $link nl } "; see " { $link "stdio" } "." } $io-error ; -HELP: stream-format -{ $values { "str" string } { "style" "a hashtable" } { "stream" "an output stream" } } -{ $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." -$nl -"The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." } -{ $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." } -$io-error ; - -HELP: make-block-stream -{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } } -{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "." -$nl -"Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output." -$nl -"The " { $snippet "style" } " hashtable holds paragraph style information. See " { $link "paragraph-styles" } "." } -{ $notes "Most code only works on one stream at a time and should instead use " { $link with-nesting } "; see " { $link "stdio" } "." } -$io-error ; - -HELP: stream-write-table -{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" "a hashtable" } { "stream" "an output stream" } } -{ $contract "Prints a table of cells produced by " { $link with-cell } "." -$nl -"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." } -{ $notes "Most code only works on one stream at a time and should instead use " { $link tabular-output } "; see " { $link "stdio" } "." } -$io-error ; - -HELP: make-cell-stream -{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } } -{ $contract "Creates an output stream which writes to a table cell object." } -{ $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." } -$io-error ; - -HELP: make-span-stream -{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } } -{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "." -$nl -"Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." } -{ $notes "Most code only works on one stream at a time and should instead use " { $link with-style } "; see " { $link "stdio" } "." } -$io-error ; HELP: stream-print { $values { "str" string } { "stream" "an output stream" } } @@ -161,54 +122,6 @@ HELP: nl { $description "Writes a line terminator to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } $io-error ; -HELP: format -{ $values { "str" string } { "style" "a hashtable" } } -{ $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } -{ $notes "Details are in the documentation for " { $link stream-format } "." } -$io-error ; - -HELP: with-nesting -{ $values { "style" "a hashtable" } { "quot" quotation } } -{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." } -{ $notes "Details are in the documentation for " { $link make-block-stream } "." } -$io-error ; - -HELP: tabular-output -{ $values { "style" "a hashtable" } { "quot" quotation } } -{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "." -$nl -"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." } -{ $examples - { $code - "{ { 1 2 } { 3 4 } }" - "H{ { table-gap { 10 10 } } } [" - " [ [ [ [ . ] with-cell ] each ] with-row ] each" - "] tabular-output" - } -} -$io-error ; - -HELP: with-row -{ $values { "quot" quotation } } -{ $description "Calls a quotation which emits a series of table cells using " { $link with-cell } ". This word can only be called inside the quotation given to " { $link tabular-output } "." } -$io-error ; - -HELP: with-cell -{ $values { "quot" quotation } } -{ $description "Calls a quotation in a new scope with " { $link output-stream } " rebound. Output performed by the quotation is displayed in a table cell. This word can only be called inside the quotation given to " { $link with-row } "." } -$io-error ; - -HELP: write-cell -{ $values { "str" string } } -{ $description "Outputs a table cell containing a single string. This word can only be called inside the quotation given to " { $link with-row } "." } -$io-error ; - -HELP: with-style -{ $values { "style" "a hashtable" } { "quot" quotation } } -{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." } -{ $notes "Details are in the documentation for " { $link make-span-stream } "." } -$io-error ; - HELP: print { $values { "string" string } } { $description "Writes a newline-terminated string to " { $link output-stream } "." } @@ -279,12 +192,7 @@ $nl { $subsection stream-flush } { $subsection stream-write1 } { $subsection stream-write } -{ $subsection stream-format } { $subsection stream-nl } -{ $subsection make-span-stream } -{ $subsection make-block-stream } -{ $subsection make-cell-stream } -{ $subsection stream-write-table } { $see-also "io.timeouts" } ; ARTICLE: "stdio" "Default input and output streams" @@ -347,15 +255,6 @@ $nl { $subsection print } { $subsection nl } { $subsection bl } -"Formatted output:" -{ $subsection format } -{ $subsection with-style } -{ $subsection with-nesting } -"Tabular output:" -{ $subsection tabular-output } -{ $subsection with-row } -{ $subsection with-cell } -{ $subsection write-cell } "A pair of combinators for rebinding the " { $link output-stream } " variable:" { $subsection with-output-stream } { $subsection with-output-stream* } diff --git a/core/io/io.factor b/core/io/io.factor index c1fd69a16a..a2f6fbb58d 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: hashtables generic kernel math namespaces make sequences continuations destructors assocs ; @@ -13,11 +13,6 @@ GENERIC: stream-write1 ( ch stream -- ) GENERIC: stream-write ( str stream -- ) GENERIC: stream-flush ( stream -- ) GENERIC: stream-nl ( stream -- ) -GENERIC: stream-format ( str style stream -- ) -GENERIC: make-span-stream ( style stream -- stream' ) -GENERIC: make-block-stream ( style stream -- stream' ) -GENERIC: make-cell-stream ( style stream -- stream' ) -GENERIC: stream-write-table ( table-cells style stream -- ) : stream-print ( str stream -- ) [ stream-write ] keep stream-nl ; @@ -46,7 +41,6 @@ SYMBOL: error-stream : flush ( -- ) output-stream get stream-flush ; : nl ( -- ) output-stream get stream-nl ; -: format ( str style -- ) output-stream get stream-format ; : with-input-stream* ( stream quot -- ) input-stream swap with-variable ; inline @@ -68,30 +62,6 @@ SYMBOL: error-stream [ [ drop dispose dispose ] 3curry ] 3bi [ ] cleanup ; inline -: tabular-output ( style quot -- ) - swap [ { } make ] dip output-stream get stream-write-table ; inline - -: with-row ( quot -- ) - { } make , ; inline - -: with-cell ( quot -- ) - H{ } output-stream get make-cell-stream - [ swap with-output-stream ] keep , ; inline - -: write-cell ( str -- ) - [ write ] with-cell ; inline - -: with-style ( style quot -- ) - swap dup assoc-empty? [ - drop call - ] [ - output-stream get make-span-stream swap with-output-stream - ] if ; inline - -: with-nesting ( style quot -- ) - [ output-stream get make-block-stream ] dip - with-output-stream ; inline - : print ( string -- ) output-stream get stream-print ; : bl ( -- ) " " write ; diff --git a/core/io/streams/nested/authors.txt b/core/io/streams/nested/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/core/io/streams/nested/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/core/io/streams/nested/nested-docs.factor b/core/io/streams/nested/nested-docs.factor deleted file mode 100644 index e7e18e353c..0000000000 --- a/core/io/streams/nested/nested-docs.factor +++ /dev/null @@ -1,2 +0,0 @@ -USING: io io.streams.nested help.markup help.syntax ; - diff --git a/core/io/streams/nested/nested.factor b/core/io/streams/nested/nested.factor deleted file mode 100644 index a155f842af..0000000000 --- a/core/io/streams/nested/nested.factor +++ /dev/null @@ -1,74 +0,0 @@ -! Copyright (C) 2006, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic assocs kernel namespaces strings -quotations io continuations destructors accessors sequences ; -IN: io.streams.nested - -TUPLE: filter-writer stream ; - -M: filter-writer stream-format - stream>> stream-format ; - -M: filter-writer stream-write - stream>> stream-write ; - -M: filter-writer stream-write1 - stream>> stream-write1 ; - -M: filter-writer make-span-stream - stream>> make-span-stream ; - -M: filter-writer make-block-stream - stream>> make-block-stream ; - -M: filter-writer make-cell-stream - stream>> make-cell-stream ; - -M: filter-writer stream-flush - stream>> stream-flush ; - -M: filter-writer stream-nl - stream>> stream-nl ; - -M: filter-writer stream-write-table - stream>> stream-write-table ; - -M: filter-writer dispose - stream>> dispose ; - -TUPLE: ignore-close-stream < filter-writer ; - -M: ignore-close-stream dispose drop ; - -C: ignore-close-stream - -TUPLE: style-stream < filter-writer style ; - -: do-nested-style ( style style-stream -- style stream ) - [ style>> swap assoc-union ] [ stream>> ] bi ; inline - -C: style-stream - -M: style-stream stream-format - do-nested-style stream-format ; - -M: style-stream stream-write - [ style>> ] [ stream>> ] bi stream-format ; - -M: style-stream stream-write1 - [ 1string ] dip stream-write ; - -M: style-stream make-span-stream - do-nested-style make-span-stream ; - -M: style-stream make-block-stream - [ do-nested-style make-block-stream ] [ style>> ] bi - ; - -M: style-stream make-cell-stream - [ do-nested-style make-cell-stream ] [ style>> ] bi - ; - -M: style-stream stream-write-table - [ [ [ stream>> ] map ] map ] [ ] [ stream>> ] tri* - stream-write-table ; diff --git a/core/io/streams/nested/summary.txt b/core/io/streams/nested/summary.txt deleted file mode 100644 index cf1c6626f0..0000000000 --- a/core/io/streams/nested/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Support for with-stream-style implementation diff --git a/core/io/streams/plain/plain-docs.factor b/core/io/streams/plain/plain-docs.factor index a84e5be4f7..4ebdc20216 100644 --- a/core/io/streams/plain/plain-docs.factor +++ b/core/io/streams/plain/plain-docs.factor @@ -1,15 +1,6 @@ USING: help.markup help.syntax io ; IN: io.streams.plain -ARTICLE: "io.streams.plain" "Plain writer streams" -"Plain writer streams wrap an underlying stream and provide a default implementation of " -{ $link stream-nl } ", " -{ $link stream-format } ", " -{ $link make-span-stream } ", " -{ $link make-block-stream } " and " -{ $link make-cell-stream } "." -{ $subsection plain-writer } ; - ABOUT: "io.streams.plain" HELP: plain-writer diff --git a/core/io/streams/plain/plain.factor b/core/io/streams/plain/plain.factor index 47bff681cd..9cd18adcc6 100644 --- a/core/io/streams/plain/plain.factor +++ b/core/io/streams/plain/plain.factor @@ -1,18 +1,9 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel io io.streams.nested ; +USING: kernel io ; IN: io.streams.plain MIXIN: plain-writer M: plain-writer stream-nl - CHAR: \n swap stream-write1 ; - -M: plain-writer stream-format - nip stream-write ; - -M: plain-writer make-span-stream - swap ; - -M: plain-writer make-block-stream - nip ; + CHAR: \n swap stream-write1 ; \ No newline at end of file diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index 57c0cb37e8..4582490726 100644 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors io kernel math namespaces sequences sbufs strings generic splitting continuations destructors @@ -17,21 +17,8 @@ SINGLETON: null-encoding M: null-encoding decode-char drop stream-read1 ; -: format-column ( seq ? -- seq ) - [ - [ 0 [ length max ] reduce ] keep - swap [ CHAR: \s pad-right ] curry map - ] unless ; - -: map-last ( seq quot -- seq ) - [ dup length ] dip [ 0 = ] prepose 2map ; inline - PRIVATE> -: format-table ( table -- seq ) - flip [ format-column ] map-last - flip [ " " join ] map ; - M: growable dispose drop ; M: growable stream-write1 push ; @@ -78,8 +65,3 @@ M: growable stream-read-partial [ ] dip with-input-stream ; inline INSTANCE: growable plain-writer - -M: plain-writer stream-write-table - [ drop format-table [ print ] each ] with-output-stream* ; - -M: plain-writer make-cell-stream 2drop ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 53f8fbadf6..48e8737fd2 100644 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -57,8 +57,6 @@ PRIVATE> SYMBOL: load-help? -ERROR: circular-dependency name ; - Date: Tue, 13 Jan 2009 17:35:45 -0600 Subject: [PATCH 13/14] Update html.elements for refactoring --- basis/html/elements/elements.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/html/elements/elements.factor b/basis/html/elements/elements.factor index 2149bf7bf6..7bca545df5 100644 --- a/basis/html/elements/elements.factor +++ b/basis/html/elements/elements.factor @@ -3,7 +3,7 @@ ! Copyright (C) 2004 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: io kernel namespaces prettyprint quotations +USING: io io.styles kernel namespaces prettyprint quotations sequences strings words xml.entities compiler.units effects urls math math.parser combinators present fry ; From cefd85013cd32713f6db23a2fda5ecf53e6d1dc8 Mon Sep 17 00:00:00 2001 From: "U-FROGGER\\erg" Date: Tue, 13 Jan 2009 18:44:47 -0600 Subject: [PATCH 14/14] fix file listing on windows, refactor tools.files cross-platform code --- basis/tools/files/files.factor | 12 ++++++++---- basis/tools/files/unix/unix.factor | 7 ++----- basis/tools/files/windows/windows.factor | 10 ++-------- 3 files changed, 12 insertions(+), 17 deletions(-) diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 47c7d57c09..936c682322 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays calendar combinators fry io io.directories io.files.info kernel math math.parser prettyprint sequences system -vocabs.loader sorting.slots ; +vocabs.loader sorting.slots calendar.format ; IN: tools.files > ] [ minute>> ] bi [ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ; -: listing-timestamp ( timestamp -- string ) +: listing-date ( timestamp -- string ) [ month>> month-abbreviation ] [ day>> number>string 2 CHAR: \s pad-left ] [ @@ -36,7 +36,7 @@ IN: tools.files PRIVATE> SYMBOLS: file-name file-name/type permissions file-type nlinks file-size -file-datetime file-time uid gid user group link-target unix-datetime +file-date file-time file-datetime uid gid user group link-target unix-datetime directory-or-size ; TUPLE: listing-tool path specs sort ; @@ -61,6 +61,10 @@ M: object file-spec>string ( file-listing spec -- string ) { { file-name [ directory-entry>> name>> ] } { directory-or-size [ file-info>> dir-or-size ] } + { file-size [ file-info>> size>> number>string ] } + { file-date [ file-info>> modified>> listing-date ] } + { file-time [ file-info>> modified>> listing-time ] } + { file-datetime [ file-info>> modified>> timestamp>ymdhms ] } [ unknown-file-spec ] } case ; @@ -119,4 +123,4 @@ percent-used percent-free ; { { [ os unix? ] [ "tools.files.unix" ] } { [ os windows? ] [ "tools.files.windows" ] } -} cond require \ No newline at end of file +} cond require diff --git a/basis/tools/files/unix/unix.factor b/basis/tools/files/unix/unix.factor index c6bc7fc2c1..e63ab09076 100755 --- a/basis/tools/files/unix/unix.factor +++ b/basis/tools/files/unix/unix.factor @@ -47,7 +47,7 @@ IN: tools.files.unix M: unix (directory.) ( path -- lines ) - { permissions nlinks user group file-size file-datetime file-name } >>specs + { permissions nlinks user group file-size file-date file-name } >>specs { { directory-entry>> name>> <=> } } >>sort [ [ list-files ] with-group-cache ] with-user-cache ; @@ -58,14 +58,11 @@ M: unix file-spec>string ( file-listing spec -- string ) ] } { permissions [ file-info>> permissions-string ] } { nlinks [ file-info>> nlink>> number>string ] } - { file-size [ file-info>> size>> number>string ] } { user [ file-info>> uid>> user-name ] } { group [ file-info>> gid>> group-name ] } { uid [ file-info>> uid>> number>string ] } { gid [ file-info>> gid>> number>string ] } - { file-datetime [ file-info>> modified>> listing-timestamp ] } - { file-time [ file-info>> modified>> listing-time ] } [ call-next-method ] } case ; -PRIVATE> \ No newline at end of file +PRIVATE> diff --git a/basis/tools/files/windows/windows.factor b/basis/tools/files/windows/windows.factor index 3284ec8d8b..f321c2fc7f 100755 --- a/basis/tools/files/windows/windows.factor +++ b/basis/tools/files/windows/windows.factor @@ -2,20 +2,14 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors calendar.format combinators io.files kernel math.parser sequences splitting system tools.files -generalizations tools.files.private io.files.info ; +generalizations tools.files.private io.files.info math.order ; IN: tools.files.windows string ( file-listing spec -- string ) - { - { listing-datetime [ modified>> timestamp>ymdhms ] } - [ call-next-method ] - } case ; - M: windows (directory.) ( entries -- lines ) - { file-size file-datetime file-name } >>specs + { file-datetime directory-or-size file-name } >>specs { { directory-entry>> name>> <=> } } >>sort list-files ;