From 8bf0176e8ce10708a520e744f45897770a1b850b Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 12 Jan 2009 03:09:50 +0100 Subject: [PATCH 01/16] FUEL: Typo. --- misc/fuel/fuel-debug-uses.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/misc/fuel/fuel-debug-uses.el b/misc/fuel/fuel-debug-uses.el index d37cf7b58d..af4f2ae60b 100644 --- a/misc/fuel/fuel-debug-uses.el +++ b/misc/fuel/fuel-debug-uses.el @@ -72,7 +72,7 @@ (defvar fuel-debug--uses-restarts nil)) (defsubst fuel-debug--uses-insert-title () - (insert "Infering USING: stanza for " fuel-debug--uses-file ".\n\n")) + (insert "Inferring USING: stanza for " fuel-debug--uses-file ".\n\n")) (defun fuel-debug--uses-prepare (file) (fuel--with-popup (fuel-debug--uses-buffer) @@ -173,7 +173,7 @@ map)) (defconst fuel-debug--uses-header-regex - (format "^%s.*$" (regexp-opt '("Infering USING: stanza for " + (format "^%s.*$" (regexp-opt '("Inferring USING: stanza for " "Current USING: is already fine!" "Current vocabulary list:" "Correct vocabulary list:" From fb98eaf9905126006e8c9e45ea1a29d175096c18 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 12 Jan 2009 03:16:56 +0100 Subject: [PATCH 02/16] FUEL: Fix stack effect font-lock. --- misc/fuel/fuel-font-lock.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el index b12be1eac7..7b129eef2a 100644 --- a/misc/fuel/fuel-font-lock.el +++ b/misc/fuel/fuel-font-lock.el @@ -72,10 +72,10 @@ ;;; Font lock: (defconst fuel-font-lock--font-lock-keywords - `((,fuel-syntax--parsing-words-regex . 'factor-font-lock-parsing-word) + `((,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect) + (,fuel-syntax--parsing-words-regex . 'factor-font-lock-parsing-word) (,fuel-syntax--brace-words-regex 1 'factor-font-lock-parsing-word) ("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word) - (,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect) (,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name) (,fuel-syntax--declaration-words-regex . 'factor-font-lock-declaration) (,fuel-syntax--word-definition-regex 2 'factor-font-lock-word) From fcf86d3bc34d4162629772f40a48873c6c761579 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 11 Jan 2009 21:07:39 -0600 Subject: [PATCH 03/16] test pooled db connections, change bogus test --- basis/db/tester/tester.factor | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/basis/db/tester/tester.factor b/basis/db/tester/tester.factor index 4e53ad3df7..490f6bbef5 100644 --- a/basis/db/tester/tester.factor +++ b/basis/db/tester/tester.factor @@ -46,12 +46,17 @@ test-2 "TEST2" { : db-tester2 ( test-db -- ) [ - [ test-1 recreate-table ] with-db - ] [ [ - 2 [ - 10 random 100 random 100 random 100 random test-1 boa - insert-tuple yield - ] parallel-each + test-1 ensure-table + test-2 ensure-table ] with-db + ] [ + [ + 10 [ + 10 [ + f 100 random 100 random 100 random test-1 boa + insert-tuple yield + ] times + ] parallel-each + ] with-pooled-db ] bi ; From e6aa33ac1248ee453f100806a090c455ebbc885a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 12 Jan 2009 01:51:38 -0600 Subject: [PATCH 04/16] Add new intersects? word and use it in a few places instead of intersect empty? --- basis/http/http.factor | 8 ++++---- basis/regexp/dfa/dfa.factor | 2 +- basis/smtp/smtp.factor | 8 ++++---- basis/validators/validators.factor | 4 ++-- core/sets/sets-docs.factor | 10 +++++++++- core/sets/sets-tests.factor | 8 ++++++++ core/sets/sets.factor | 17 +++++++++++++---- core/splitting/splitting.factor | 6 +++--- 8 files changed, 44 insertions(+), 19 deletions(-) diff --git a/basis/http/http.factor b/basis/http/http.factor index 0aeb771c11..4702f88830 100644 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -45,8 +45,8 @@ IN: http : check-header-string ( str -- str ) #! http://en.wikipedia.org/wiki/HTTP_Header_Injection - dup "\r\n\"" intersect empty? - [ "Header injection attack" throw ] unless ; + dup "\r\n\"" intersects? + [ "Header injection attack" throw ] when ; : write-header ( assoc -- ) >alist sort-keys [ @@ -97,8 +97,8 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s ] { } make ; : check-cookie-string ( string -- string' ) - dup "=;'\"\r\n" intersect empty? - [ "Bad cookie name or value" throw ] unless ; + dup "=;'\"\r\n" intersects? + [ "Bad cookie name or value" throw ] when ; : unparse-cookie-value ( key value -- ) { diff --git a/basis/regexp/dfa/dfa.factor b/basis/regexp/dfa/dfa.factor index 0abd1c2edc..c3e98ae1ec 100644 --- a/basis/regexp/dfa/dfa.factor +++ b/basis/regexp/dfa/dfa.factor @@ -57,7 +57,7 @@ IN: regexp.dfa dup [ nfa-table>> final-states>> keys ] [ dfa-table>> transitions>> states ] bi - [ intersect empty? not ] with filter + [ intersects? ] with filter swap dfa-table>> final-states>> [ conjoin ] curry each ; diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 0f16863a79..c17db13b01 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -68,8 +68,8 @@ ERROR: bad-email-address email ; : validate-address ( string -- string' ) #! Make sure we send funky stuff to the server by accident. - dup "\r\n>" intersect empty? - [ bad-email-address ] unless ; + dup "\r\n>" intersects? + [ bad-email-address ] when ; : mail-from ( fromaddr -- ) validate-address @@ -170,8 +170,8 @@ M: plain-auth send-auth ERROR: invalid-header-string string ; : validate-header ( string -- string' ) - dup "\r\n" intersect empty? - [ invalid-header-string ] unless ; + dup "\r\n" intersects? + [ invalid-header-string ] when ; : write-header ( key value -- ) [ validate-header write ] diff --git a/basis/validators/validators.factor b/basis/validators/validators.factor index 78e01fdaf7..a70e20d7b6 100644 --- a/basis/validators/validators.factor +++ b/basis/validators/validators.factor @@ -69,8 +69,8 @@ IN: validators : v-one-line ( str -- str ) v-required - dup "\r\n" intersect empty? - [ "must be a single line" throw ] unless ; + dup "\r\n" intersects? + [ "must be a single line" throw ] when ; : v-one-word ( str -- str ) v-required diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index 5f7f4acf7a..428bf10401 100644 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -13,6 +13,8 @@ $nl { $subsection diff } { $subsection intersect } { $subsection union } +"Set-theoretic predicates:" +{ $subsection intersects? } { $subsection subset? } { $subsection set= } "A word used to implement the above:" @@ -104,9 +106,15 @@ HELP: union { diff intersect union } related-words +HELP: intersects? +{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "seq1" } " and " { $snippet "seq2" } " have any elements in common." } +{ $notes "If one of the sequences is empty, the result is always " { $link f } "." } ; + HELP: subset? { $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } } -{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." } ; +{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." } +{ $notes "If " { $snippet "seq1" } " is empty, the result is always " { $link t } "." } ; HELP: set= { $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } } diff --git a/core/sets/sets-tests.factor b/core/sets/sets-tests.factor index b6e6443afa..838a0a82b8 100644 --- a/core/sets/sets-tests.factor +++ b/core/sets/sets-tests.factor @@ -21,3 +21,11 @@ IN: sets.tests [ V{ 1 2 3 } ] [ 3 V{ 1 3 2 } clone [ adjoin ] keep ] unit-test + +[ t ] [ { 1 2 } { 1 3 } intersects? ] unit-test + +[ f ] [ { 4 2 } { 1 3 } intersects? ] unit-test + +[ f ] [ { } { 1 } intersects? ] unit-test + +[ f ] [ { 1 } { } intersects? ] unit-test diff --git a/core/sets/sets.factor b/core/sets/sets.factor index c411bfcdcd..88dffa6777 100644 --- a/core/sets/sets.factor +++ b/core/sets/sets.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov, Doug Coleman. +! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: assocs hashtables kernel sequences vectors ; IN: sets @@ -31,17 +31,26 @@ IN: sets : all-unique? ( seq -- ? ) dup length [ (all-unique?) ] curry all? ; + + : intersect ( seq1 seq2 -- newseq ) - unique [ key? ] curry filter ; + tester filter ; + +: intersects? ( seq1 seq2 -- newseq ) + tester contains? ; : diff ( seq1 seq2 -- newseq ) - unique [ key? not ] curry filter ; + tester [ not ] compose filter ; : union ( seq1 seq2 -- newseq ) append prune ; : subset? ( seq1 seq2 -- ? ) - unique [ key? ] curry all? ; + tester all? ; : set= ( seq1 seq2 -- ? ) [ unique ] bi@ = ; diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 29fee2e5c3..a2a302d995 100644 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -48,12 +48,12 @@ IN: splitting : split ( seq separators -- pieces ) [ split, ] { } make ; : string-lines ( str -- seq ) - dup "\r\n" intersect empty? [ - 1array - ] [ + dup "\r\n" intersects? [ "\n" split [ but-last-slice [ "\r" ?tail drop "\r" split ] map ] keep peek "\r" split suffix concat + ] [ + 1array ] if ; From 093c615dfae113bd4539057534c0104eb3111e50 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 12 Jan 2009 10:35:59 +0100 Subject: [PATCH 05/16] FUEL: Use better defaults for factor's binary and image file. --- extra/fuel/authors.txt | 1 - misc/fuel/README | 6 ++++++ misc/fuel/fu.el | 6 +++++- misc/fuel/fuel-listener.el | 6 ++++-- 4 files changed, 15 insertions(+), 4 deletions(-) diff --git a/extra/fuel/authors.txt b/extra/fuel/authors.txt index ecfb757fd2..43ae04c322 100644 --- a/extra/fuel/authors.txt +++ b/extra/fuel/authors.txt @@ -1,2 +1 @@ Jose Antonio Ortega Ruiz -Eduardo Cavazos diff --git a/misc/fuel/README b/misc/fuel/README index 678bd25365..41dabe564e 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -41,6 +41,12 @@ beast. To start the listener, try M-x run-factor. + By default, FUEL will try to use the binary and image files in the + factor installation directory. You can customize them with: + + (setq fuel-listener-factor-binary ) + (setq fuel-listener-factor-image ) + Many aspects of the environment can be customized: M-x customize-group fuel will show you how many. diff --git a/misc/fuel/fu.el b/misc/fuel/fu.el index e78502a6ee..95365964ab 100644 --- a/misc/fuel/fu.el +++ b/misc/fuel/fu.el @@ -8,7 +8,11 @@ ;;; Code: -(add-to-list 'load-path (file-name-directory load-file-name)) +(setq fuel-factor-fuel-dir (file-name-directory load-file-name)) + +(setq fuel-factor-root-dir (expand-file-name "../../" fuel-factor-fuel-dir)) + +(add-to-list 'load-path fuel-factor-fuel-dir) (add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode)) (autoload 'factor-mode "factor-mode.el" diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el index 3ad1b77978..66034225f1 100644 --- a/misc/fuel/fuel-listener.el +++ b/misc/fuel/fuel-listener.el @@ -30,12 +30,14 @@ "Interacting with a Factor listener inside Emacs." :group 'fuel) -(defcustom fuel-listener-factor-binary "~/factor/factor" +(defcustom fuel-listener-factor-binary + (expand-file-name "factor" fuel-factor-root-dir) "Full path to the factor executable to use when starting a listener." :type '(file :must-match t) :group 'fuel-listener) -(defcustom fuel-listener-factor-image "~/factor/factor.image" +(defcustom fuel-listener-factor-image + (expand-file-name "factor.image" fuel-factor-root-dir) "Full path to the factor image to use when starting a listener." :type '(file :must-match t) :group 'fuel-listener) From 18c2c9cf033a6d0937afde322e789eae5278f1c2 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 12 Jan 2009 12:13:21 +0100 Subject: [PATCH 06/16] FUEL: Fix indentation of multiline TUPLE:, SYMBOLS: & similar forms. --- misc/fuel/factor-mode.el | 3 +-- misc/fuel/fuel-syntax.el | 33 ++++++++++++++++++++++++--------- 2 files changed, 25 insertions(+), 11 deletions(-) diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el index 4164e14c5e..ba9be2edd3 100644 --- a/misc/fuel/factor-mode.el +++ b/misc/fuel/factor-mode.el @@ -144,8 +144,7 @@ code in the buffer." (cond ((or (fuel-syntax--at-end-of-def) (fuel-syntax--at-setter-line)) (fuel-syntax--decreased-indentation)) - ((and (fuel-syntax--at-begin-of-def) - (not (fuel-syntax--at-using))) + ((fuel-syntax--at-begin-of-indent-def) (fuel-syntax--increased-indentation)) (t (current-indentation))))) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 6b93787a50..be7293f181 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -132,16 +132,28 @@ (defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$") +(defconst fuel-syntax--indent-def-starts '("" ":" + "FROM" + "INTERSECTION:" + "M" "MACRO" "MACRO:" + "MEMO" "MEMO:" "METHOD" + "PREDICATE" "PRIMITIVE" + "UNION")) + +(defconst fuel-syntax--no-indent-def-starts '("SINGLETONS" + "SYMBOLS" + "TUPLE" + "VARS")) + +(defconst fuel-syntax--indent-def-start-regex + (format "^\\(%s:\\) " (regexp-opt fuel-syntax--indent-def-starts))) + +(defconst fuel-syntax--no-indent-def-start-regex + (format "^\\(%s:\\) " (regexp-opt fuel-syntax--no-indent-def-starts))) + (defconst fuel-syntax--definition-start-regex - (format "^\\(%s:\\) " (regexp-opt '("" ":" - "FROM" - "INTERSECTION:" - "MACRO" "MACRO:" "M" "MEMO" "MEMO:" "METHOD" - "PREDICATE" "PRIMITIVE" - "SINGLETONS" "SYMBOLS" - "TUPLE" - "UNION" - "VARS")))) + (format "^\\(%s:\\) " (regexp-opt (append fuel-syntax--no-indent-def-starts + fuel-syntax--indent-def-starts)))) (defconst fuel-syntax--definition-end-regex (format "\\(\\(^\\| +\\);\\( *%s\\)*\\($\\| +\\)\\)" @@ -256,6 +268,9 @@ (defsubst fuel-syntax--at-begin-of-def () (looking-at fuel-syntax--begin-of-def-regex)) +(defsubst fuel-syntax--at-begin-of-indent-def () + (looking-at fuel-syntax--indent-def-start-regex)) + (defsubst fuel-syntax--at-end-of-def () (looking-at fuel-syntax--end-of-def-regex)) From daf86c693ecdec54722238b0bac3a4acfc2a4862 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 12 Jan 2009 14:32:14 -0600 Subject: [PATCH 07/16] Fix help-lint for sets vocab --- core/sets/sets.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/sets/sets.factor b/core/sets/sets.factor index 88dffa6777..3435298f6e 100644 --- a/core/sets/sets.factor +++ b/core/sets/sets.factor @@ -40,7 +40,7 @@ PRIVATE> : intersect ( seq1 seq2 -- newseq ) tester filter ; -: intersects? ( seq1 seq2 -- newseq ) +: intersects? ( seq1 seq2 -- ? ) tester contains? ; : diff ( seq1 seq2 -- newseq ) From 01cd3ce99a1779b84488b0326eed596ef5f161a3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 12 Jan 2009 16:17:52 -0600 Subject: [PATCH 08/16] Throw an error if Chloe encounters an unknown tag --- basis/html/templates/chloe/chloe-tests.factor | 9 ++++++++- basis/html/templates/chloe/compiler/compiler.factor | 7 +++++-- basis/html/templates/chloe/test/test13.xml | 7 +++++++ 3 files changed, 20 insertions(+), 3 deletions(-) create mode 100644 basis/html/templates/chloe/test/test13.xml diff --git a/basis/html/templates/chloe/chloe-tests.factor b/basis/html/templates/chloe/chloe-tests.factor index 5114b4088a..542dfa0e05 100644 --- a/basis/html/templates/chloe/chloe-tests.factor +++ b/basis/html/templates/chloe/chloe-tests.factor @@ -1,7 +1,8 @@ USING: html.templates html.templates.chloe tools.test io.streams.string kernel sequences ascii boxes namespaces xml html.components html.forms -splitting unicode.categories furnace accessors ; +splitting unicode.categories furnace accessors +html.templates.chloe.compiler ; IN: html.templates.chloe.tests : run-template @@ -163,3 +164,9 @@ TUPLE: person first-name last-name ; "test12" test-template call-template ] run-template ] unit-test + +[ + [ + "test13" test-template call-template + ] run-template +] [ error>> T{ unknown-chloe-tag f "this-tag-does-not-exist" } = ] must-fail-with diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index d4f34ab8aa..331b565b98 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -76,10 +76,13 @@ DEFER: compile-element [ drop tag-stack get pop* ] } cleave ; +ERROR: unknown-chloe-tag tag ; + : compile-chloe-tag ( tag -- ) - ! "Unknown chloe tag: " prepend throw dup main>> dup tags get at - [ curry assert-depth ] [ 2drop ] ?if ; + [ curry assert-depth ] + [ unknown-chloe-tag ] + ?if ; : compile-element ( element -- ) { diff --git a/basis/html/templates/chloe/test/test13.xml b/basis/html/templates/chloe/test/test13.xml new file mode 100644 index 0000000000..adf5daf93c --- /dev/null +++ b/basis/html/templates/chloe/test/test13.xml @@ -0,0 +1,7 @@ + + + + + + + From daab5e4ac823019072a0d9c1b01c28e0473f081c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 12 Jan 2009 16:17:58 -0600 Subject: [PATCH 09/16] Fix calculator --- extra/webapps/calculator/calculator.factor | 4 ++-- extra/webapps/calculator/calculator.xml | 2 ++ 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/extra/webapps/calculator/calculator.factor b/extra/webapps/calculator/calculator.factor index d19946d39b..a8c8383e62 100644 --- a/extra/webapps/calculator/calculator.factor +++ b/extra/webapps/calculator/calculator.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: furnace.actions furnace.redirection +USING: furnace furnace.actions furnace.redirection http.server.dispatchers html.forms validators urls accessors math ; IN: webapps.calculator diff --git a/extra/webapps/calculator/calculator.xml b/extra/webapps/calculator/calculator.xml index ed8e60d89a..4dcf5d563a 100644 --- a/extra/webapps/calculator/calculator.xml +++ b/extra/webapps/calculator/calculator.xml @@ -2,6 +2,7 @@ + Calculator @@ -24,5 +25,6 @@ + From cbb91284c9b7dde71e2ecb45b38170cc42d1c3e4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 12 Jan 2009 16:18:08 -0600 Subject: [PATCH 10/16] Well-formed HTML for counter --- extra/webapps/counter/counter.xml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/webapps/counter/counter.xml b/extra/webapps/counter/counter.xml index 75e7cf3c4b..88154438f1 100644 --- a/extra/webapps/counter/counter.xml +++ b/extra/webapps/counter/counter.xml @@ -2,12 +2,13 @@ - +

++ -- + From 104b052e7e0c9a614af6fdeb80c28a7ad557cbcc Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 13 Jan 2009 00:14:54 +0100 Subject: [PATCH 11/16] FUEL: Better word extraction: detect existing words and extend refactoring. --- misc/fuel/fuel-refactor.el | 114 ++++++++++++++++++++++++++++++------- 1 file changed, 92 insertions(+), 22 deletions(-) diff --git a/misc/fuel/fuel-refactor.el b/misc/fuel/fuel-refactor.el index 38367b4cd8..380b00f763 100644 --- a/misc/fuel/fuel-refactor.el +++ b/misc/fuel/fuel-refactor.el @@ -18,36 +18,106 @@ (require 'fuel-syntax) (require 'fuel-base) + +;;; Word definitions in buffer + +(defconst fuel-refactor--next-defun-regex + (format "^\\(:\\|MEMO:\\|MACRO:\\):? +\\(\\w+\\)\\(%s\\)\\([^;]+?\\) ;\\_>" + fuel-syntax--stack-effect-regex)) + +(defun fuel-refactor--previous-defun () + (let ((pos) (result)) + (while (and (not result) + (setq pos (fuel-syntax--beginning-of-defun))) + (setq result (looking-at fuel-refactor--next-defun-regex))) + (when (and result pos) + (let ((name (match-string-no-properties 2)) + (body (match-string-no-properties 4)) + (end (match-end 0))) + (list (split-string body nil t) name pos end))))) + +(defun fuel-refactor--find (code to) + (let ((candidate) (result)) + (while (and (not result) + (setq candidate (fuel-refactor--previous-defun)) + (> (point) to)) + (when (equal (car candidate) code) + (setq result (cdr candidate)))) + result)) + +(defun fuel-refactor--reuse-p (word) + (save-excursion + (mark-defun) + (move-overlay fuel-stack--overlay (1+ (point)) (mark)) + (unwind-protect + (and (y-or-n-p (format "Use existing word '%s'? " word)) word) + (delete-overlay fuel-stack--overlay)))) + +(defun fuel-refactor--code-rx (code) + (let ((words (split-string code nil t))) + (mapconcat 'regexp-quote words "[ \n\f\r]+"))) + ;;; Extract word: +(defun fuel-refactor--reuse-existing (code) + (save-excursion + (mark-defun) + (let ((code (split-string (substring-no-properties code) nil t)) + (down (mark)) + (found) + (result)) + (while (and (not result) + (setq found (fuel-refactor--find code (point-min)))) + (when found (setq result (fuel-refactor--reuse-p (car found))))) + (goto-char (point-max)) + (while (and (not result) + (setq found (fuel-refactor--find code down))) + (when found (setq result (fuel-refactor--reuse-p (car found))))) + (and result found)))) + +(defun fuel-refactor--insert-word (word stack-effect code) + (let ((beg (save-excursion (fuel-syntax--beginning-of-defun) (point))) + (end (save-excursion + (re-search-backward fuel-syntax--end-of-def-regex nil t) + (forward-line 1) + (skip-syntax-forward "-")))) + (let ((start (goto-char (max beg end)))) + (open-line 1) + (insert ": " word " " stack-effect "\n" code " ;\n") + (indent-region start (point)) + (move-overlay fuel-stack--overlay start (point))))) + +(defun fuel-refactor--extract-other (start end code) + (unwind-protect + (when (y-or-n-p "Apply refactoring to rest of buffer? ") + (save-excursion + (let ((rx (fuel-refactor--code-rx code)) + (end (point))) + (query-replace-regexp rx word t (point-min) start) + (query-replace-regexp rx word t end (point-max))))) + (delete-overlay fuel-stack--overlay))) + (defun fuel-refactor--extract (begin end) - (let* ((word (read-string "New word name: ")) - (code (buffer-substring begin end)) - (code-str (fuel--region-to-string begin end)) - (stack-effect (or (fuel-stack--infer-effect code-str) - (read-string "Stack effect: ")))) - (unless (< begin end) (error "No proper region to extract")) + (unless (< begin end) (error "No proper region to extract")) + (let* ((code (buffer-substring begin end)) + (existing (fuel-refactor--reuse-existing code)) + (code-str (or existing (fuel--region-to-string begin end))) + (stack-effect (or existing + (fuel-stack--infer-effect code-str) + (read-string "Stack effect: "))) + (word (or (car existing) (read-string "New word name: ")))) (goto-char begin) (delete-region begin end) (insert word) (indent-region begin (point)) - (set-mark (point)) - (let ((beg (save-excursion (fuel-syntax--beginning-of-defun) (point))) - (end (save-excursion - (re-search-backward fuel-syntax--end-of-def-regex nil t) - (forward-line 1) - (skip-syntax-forward "-") - (point)))) - (goto-char (max beg end))) - (open-line 1) - (let ((start (point))) - (insert ": " word " " stack-effect "\n" code " ;\n") - (indent-region start (point)) - (move-overlay fuel-stack--overlay start (point)) - (goto-char (mark)) - (sit-for fuel-stack-highlight-period) - (delete-overlay fuel-stack--overlay)))) + (save-excursion + (let ((start (or (cadr existing) (point)))) + (unless existing + (fuel-refactor--insert-word word stack-effect code)) + (fuel-refactor--extract-other start + (or (car (cddr existing)) (point)) + code))))) (defun fuel-refactor-extract-region (begin end) "Extracts current region as a separate word." From a70018bcc444775ab053b5fd1fef014ec40b9125 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 13 Jan 2009 01:44:22 +0100 Subject: [PATCH 12/16] FUEL: Correct font-lock for string literals (no multiline). --- misc/fuel/fuel-font-lock.el | 7 ++++--- misc/fuel/fuel-syntax.el | 8 ++++++-- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el index 7b129eef2a..99a7c7b8fb 100644 --- a/misc/fuel/fuel-font-lock.el +++ b/misc/fuel/fuel-font-lock.el @@ -66,7 +66,8 @@ (symbol variable-name "name of symbol being defined") (type-name type "type names") (vocabulary-name constant "vocabulary names") - (word function-name "word, generic or method being defined"))) + (word function-name "word, generic or method being defined") + (invalid-syntax warning "syntactically invalid constructs"))) ;;; Font lock: @@ -92,8 +93,8 @@ (,fuel-syntax--constructor-regex . 'factor-font-lock-constructor) (,fuel-syntax--setter-regex . 'factor-font-lock-setter-word) (,fuel-syntax--getter-regex . 'factor-font-lock-getter-word) - (,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol)) - "Font lock keywords definition for Factor mode.") + (,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol) + (,fuel-syntax--bad-string-regex . 'factor-font-lock-invalid-syntax))) (defun fuel-font-lock--font-lock-setup (&optional keywords no-syntax) (set (make-local-variable 'comment-start) "! ") diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index be7293f181..7f0fa313c2 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -93,6 +93,9 @@ (defconst fuel-syntax--float-regex "\\_<-?[0-9]+\\.[0-9]*\\([eE][+-]?[0-9]+\\)?\\_>") +(defconst fuel-syntax--bad-string-regex + "\"[^\"]*$") + (defconst fuel-syntax--word-definition-regex (fuel-syntax--second-word-regex '(":" "::" "GENERIC:" "DEFER:" "HOOK:" "MAIN:" "MATH:" "POSTPONE:" @@ -211,8 +214,7 @@ (modify-syntax-entry ?\ " " table) (modify-syntax-entry ?\n " " table) - ;; Strings - (modify-syntax-entry ?\" "\"" table) + ;; Char quote (modify-syntax-entry ?\\ "/" table) table)) @@ -223,6 +225,8 @@ ("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">")) ;; CHARs: ("CHAR: \\(.\\)\\( \\|$\\)" (1 "w")) + ;; Strings + ("\\(\"\\)[^\n\r\f]*\\(\"\\)" (1 "\"") (2 "\"")) ;; Let and lambda: ("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">")) ("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]")) From 0b36b8b25968e8e316f82df3ebd033e1080d06ac Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 13 Jan 2009 02:58:33 +0100 Subject: [PATCH 13/16] FUEL: M-. improvements and new M-,. --- misc/fuel/README | 3 ++- misc/fuel/fuel-edit.el | 36 ++++++++++++++++++++++++++++++++---- misc/fuel/fuel-mode.el | 1 + 3 files changed, 35 insertions(+), 5 deletions(-) diff --git a/misc/fuel/README b/misc/fuel/README index 41dabe564e..5fed408bbf 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -80,7 +80,8 @@ beast. - C-cz : switch to listener - C-co : cycle between code, tests and docs factor files - - M-. : edit word at point in Emacs + - M-. : edit word at point in Emacs (see fuel-edit-word-method custom var) + - M-, : go back to where M-. was last invoked - M-TAB : complete word at point - C-cC-eu : update USING: line - C-cC-ev : edit vocabulary (M-x fuel-edit-vocabulary) diff --git a/misc/fuel/fuel-edit.el b/misc/fuel/fuel-edit.el index e5988d1392..20e1f1eb01 100644 --- a/misc/fuel/fuel-edit.el +++ b/misc/fuel/fuel-edit.el @@ -17,6 +17,19 @@ (require 'fuel-eval) (require 'fuel-base) +(require 'etags) + + +;;; Customization + +(defcustom fuel-edit-word-method nil + "How the new buffer is opened when invoking +\\[fuel-edit-word-at-point]." + :group 'fuel + :type '(choice (const :tag "Other window" window) + (const :tag "Other frame" frame) + (const :tag "Current window" nil))) + ;;; Auxiliar functions: @@ -27,7 +40,9 @@ (error "Couldn't find edit location")) (unless (file-readable-p (car loc)) (error "Couldn't open '%s' for read" (car loc))) - (find-file-other-window (car loc)) + (cond ((eq fuel-edit-word-method 'window) (find-file-other-window (car loc))) + ((eq fuel-edit-word-method 'frame) (find-file-other-frame (car loc))) + (t (find-file (car loc)))) (goto-line (if (numberp (cadr loc)) (cadr loc) 1)))) (defun fuel-edit--read-vocabulary-name (refresh) @@ -46,6 +61,7 @@ (defvar fuel-edit--word-history nil) (defvar fuel-edit--vocab-history nil) +(defvar fuel-edit--previous-location nil) (defun fuel-edit-vocabulary (&optional refresh vocab) "Visits vocabulary file in Emacs. @@ -74,10 +90,12 @@ With prefix, asks for the word to edit." (interactive "P") (let* ((word (or (and (not arg) (fuel-syntax-symbol-at-point)) (fuel-completion--read-word "Edit word: "))) - (cmd `(:fuel* ((:quote ,word) fuel-get-edit-location)))) + (cmd `(:fuel* ((:quote ,word) fuel-get-edit-location))) + (marker (and (not arg) (point-marker)))) (condition-case nil (fuel-edit--try-edit (fuel-eval--send/wait cmd)) - (error (fuel-edit-vocabulary nil word))))) + (error (fuel-edit-vocabulary nil word))) + (when marker (ring-insert find-tag-marker-ring marker)))) (defun fuel-edit-word-doc-at-point (&optional arg word) "Opens a new window visiting the documentation file for the word at point. @@ -86,7 +104,8 @@ With prefix, asks for the word to edit." (let* ((word (or word (and (not arg) (fuel-syntax-symbol-at-point)) (fuel-completion--read-word "Edit word: "))) - (cmd `(:fuel* ((:quote ,word) fuel-get-doc-location)))) + (cmd `(:fuel* ((:quote ,word) fuel-get-doc-location))) + (marker (and (not arg) (point-marker)))) (condition-case nil (fuel-edit--try-edit (fuel-eval--send/wait cmd)) (error @@ -95,10 +114,19 @@ With prefix, asks for the word to edit." (y-or-n-p (concat "No documentation found. " "Do you want to open the vocab's " "doc file? "))) + (when marker (ring-insert find-tag-marker-ring marker)) (find-file-other-window (format "%s-docs.factor" (file-name-sans-extension (buffer-file-name))))))))) +(defun fuel-edit-pop-edit-word-stack () + "Pop back to where \\[fuel-edit-word-at-point] or \\[fuel-edit-word-doc-at-point] +was last invoked." + (interactive) + (condition-case nil + (pop-tag-mark) + (error "No previous location for find word or vocab invokation"))) + (provide 'fuel-edit) ;;; fuel-edit.el ends here diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index ed0104d1cb..0b863507ff 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -181,6 +181,7 @@ interacting with a factor listener is at your disposal. (define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition) (define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region) (define-key fuel-mode-map "\M-." 'fuel-edit-word-at-point) +(define-key fuel-mode-map "\M-," 'fuel-edit-pop-edit-word-stack) (define-key fuel-mode-map "\C-c\M-<" 'fuel-show-callers) (define-key fuel-mode-map "\C-c\M->" 'fuel-show-callees) (define-key fuel-mode-map (kbd "M-TAB") 'fuel-completion--complete-symbol) From 5909ca0bd85bd8bcc6368ac7e36898ea7d8f09d1 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 13 Jan 2009 04:06:21 +0100 Subject: [PATCH 14/16] FUEL: New refactoring: inline word. --- extra/fuel/fuel.factor | 5 ++++- extra/fuel/help/help.factor | 5 ++++- misc/fuel/README | 1 + misc/fuel/fuel-mode.el | 1 + misc/fuel/fuel-refactor.el | 23 +++++++++++++++++++++++ 5 files changed, 33 insertions(+), 2 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index a399ab2776..46d6ba12c7 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -148,6 +148,8 @@ MEMO: fuel-get-article-title ( name -- ) : fuel-word-see ( name -- ) (fuel-word-see) fuel-eval-set-result ; +: fuel-word-def ( name -- ) (fuel-word-def) fuel-eval-set-result ; + : fuel-vocab-help ( name -- ) (fuel-vocab-help) fuel-eval-set-result ; : fuel-vocab-summary ( name -- ) @@ -170,4 +172,5 @@ MEMO: fuel-get-article-title ( name -- ) dup require dup scaffold-help vocab-docs-path (normalize-path) fuel-eval-set-result ; -: fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ; \ No newline at end of file +: fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ; + diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor index 537e92ddd8..298124ffb4 100644 --- a/extra/fuel/help/help.factor +++ b/extra/fuel/help/help.factor @@ -87,13 +87,16 @@ SYMBOL: vocab-list PRIVATE> -: (fuel-word-help) ( object -- object ) +: (fuel-word-help) ( name -- elem ) fuel-find-word [ [ auto-use? on (fuel-word-element) ] with-scope ] [ f ] if* ; : (fuel-word-see) ( word -- elem ) [ name>> \ article swap ] [ [ 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-vocab-summary) ( name -- str ) >vocab-link summary ; inline : (fuel-vocab-help) ( name -- str ) diff --git a/misc/fuel/README b/misc/fuel/README index 5fed408bbf..eb280d796c 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -105,6 +105,7 @@ beast. - C-cC-xs : extract innermost sexp (up to point) as a separate word - C-cC-xr : extract region as a separate word + - C-cC-xi : replace word at point by its definition - C-cC-xv : extract region as a separate vocabulary *** In the listener: diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index 0b863507ff..9936d052fc 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -198,6 +198,7 @@ interacting with a factor listener is at your disposal. (fuel-mode--key ?x ?s 'fuel-refactor-extract-sexp) (fuel-mode--key ?x ?r 'fuel-refactor-extract-region) (fuel-mode--key ?x ?v 'fuel-refactor-extract-vocab) +(fuel-mode--key ?x ?i 'fuel-refactor-inline-word) (fuel-mode--key ?d ?> 'fuel-show-callees) (fuel-mode--key ?d ?< 'fuel-show-callers) diff --git a/misc/fuel/fuel-refactor.el b/misc/fuel/fuel-refactor.el index 380b00f763..788033cf88 100644 --- a/misc/fuel/fuel-refactor.el +++ b/misc/fuel/fuel-refactor.el @@ -141,6 +141,29 @@ word." (if (looking-at-p ";") (point) (fuel-syntax--end-of-symbol-pos)))) + +;;; Inline word: + +(defun fuel-refactor--word-def (word) + (let ((def (fuel-eval--retort-result + (fuel-eval--send/wait `(:fuel* (,word fuel-word-def) "fuel"))))) + (when def + (substring (substring def 2) 0 -2)))) + +(defun fuel-refactor-inline-word () + "Inserts definition of word at point." + (interactive) + (let ((word (fuel-syntax-symbol-at-point))) + (unless word (error "No word at point")) + (let ((code (fuel-refactor--word-def word))) + (unless code (error "Word's definition not found")) + (fuel-syntax--beginning-of-symbol) + (kill-word 1) + (let ((start (point))) + (insert code) + (save-excursion (font-lock-fontify-region start (point))) + (indent-region start (point)))))) + ;;; Extract vocab: From 4a01649d15669a474a964bcc544adb7900d4f651 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 13 Jan 2009 00:05:19 -0600 Subject: [PATCH 15/16] 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 16/16] 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 ] ;