Merge commit 'factor/master'
commit
829dd6b584
basis
bootstrap
help
unicode
combinators/smart
compiler/tree/propagation/inlining
editors
gvim
vim/generate-syntax
grouping
help/handbook
io/files
info/unix
math/bitwise
regexp
nfa
parser
soundex
splitting/monotonic
tools
cocoa
files
ui/gadgets/buttons
unicode
unix
statfs
values
xmode/marker
core
math/order
parser
sorting
extra
benchmark/reverse-complement
fuel
geo-ip
parser-combinators/regexp
usa-cities
|
@ -37,6 +37,26 @@ HELP: quotable?
|
|||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ;
|
||||
|
||||
HELP: ascii?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Tests for whether a number is an ASCII character." } ;
|
||||
|
||||
HELP: ch>lower
|
||||
{ $values { "ch" "a character" } { "lower" "a character" } }
|
||||
{ $description "Converts an ASCII character to lower case." } ;
|
||||
|
||||
HELP: ch>upper
|
||||
{ $values { "ch" "a character" } { "upper" "a character" } }
|
||||
{ $description "Converts an ASCII character to upper case." } ;
|
||||
|
||||
HELP: >lower
|
||||
{ $values { "str" "a string" } { "lower" "a string" } }
|
||||
{ $description "Converts an ASCII string to lower case." } ;
|
||||
|
||||
HELP: >upper
|
||||
{ $values { "str" "a string" } { "upper" "a string" } }
|
||||
{ $description "Converts an ASCII string to upper case." } ;
|
||||
|
||||
ARTICLE: "ascii" "ASCII character classes"
|
||||
"The " { $vocab-link "ascii" } " vocabulary implements traditional ASCII character classes:"
|
||||
{ $subsection blank? }
|
||||
|
@ -46,6 +66,12 @@ ARTICLE: "ascii" "ASCII character classes"
|
|||
{ $subsection printable? }
|
||||
{ $subsection control? }
|
||||
{ $subsection quotable? }
|
||||
"Modern applications should use Unicode 5.0 instead (" { $vocab-link "unicode.categories" } ")." ;
|
||||
{ $subsection ascii? }
|
||||
"ASCII case conversion is also implemented:"
|
||||
{ $subsection ch>lower }
|
||||
{ $subsection ch>upper }
|
||||
{ $subsection >lower }
|
||||
{ $subsection >upper }
|
||||
"Modern applications should use Unicode 5.1 instead (" { $vocab-link "unicode.categories" } ")." ;
|
||||
|
||||
ABOUT: "ascii"
|
||||
|
|
|
@ -12,3 +12,8 @@ IN: ascii.tests
|
|||
0 "There are Four Upper Case characters"
|
||||
[ LETTER? [ 1+ ] when ] each
|
||||
] unit-test
|
||||
|
||||
[ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test
|
||||
|
||||
[ "HELLO HOW ARE YOU?" ] [ "hellO hOw arE YOU?" >upper ] unit-test
|
||||
[ "i'm good thx bai" ] [ "I'm Good THX bai" >lower ] unit-test
|
||||
|
|
|
@ -4,6 +4,8 @@ USING: kernel math math.order sequences
|
|||
combinators.short-circuit ;
|
||||
IN: ascii
|
||||
|
||||
: ascii? ( ch -- ? ) 0 127 between? ; inline
|
||||
|
||||
: blank? ( ch -- ? ) " \t\n\r" member? ; inline
|
||||
|
||||
: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline
|
||||
|
@ -25,3 +27,15 @@ IN: ascii
|
|||
|
||||
: alpha? ( ch -- ? )
|
||||
[ [ Letter? ] [ digit? ] ] 1|| ;
|
||||
|
||||
: ch>lower ( ch -- lower )
|
||||
dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ;
|
||||
|
||||
: >lower ( str -- lower )
|
||||
[ ch>lower ] map ;
|
||||
|
||||
: ch>upper ( ch -- upper )
|
||||
dup CHAR: a CHAR: z between? [ HEX: 20 - ] when ;
|
||||
|
||||
: >upper ( str -- upper )
|
||||
[ ch>upper ] map ;
|
||||
|
|
|
@ -4,6 +4,7 @@ parser vocabs.loader vocabs.loader.private accessors assocs ;
|
|||
IN: bootstrap.help
|
||||
|
||||
: load-help ( -- )
|
||||
"help.lint" require
|
||||
"alien.syntax" require
|
||||
"compiler" require
|
||||
|
||||
|
|
|
@ -1,5 +0,0 @@
|
|||
USING: strings.parser kernel namespaces unicode unicode.data ;
|
||||
IN: bootstrap.unicode
|
||||
|
||||
[ name>char [ "Invalid character" throw ] unless* ]
|
||||
name>char-hook set-global
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
|
@ -0,0 +1,91 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel quotations math sequences
|
||||
multiline ;
|
||||
IN: combinators.smart
|
||||
|
||||
HELP: input<sequence
|
||||
{ $values
|
||||
{ "quot" quotation }
|
||||
{ "newquot" quotation }
|
||||
}
|
||||
{ $description "Infers the number of inputs, " { $snippet "n" } ", to " { $snippet "quot" } " and calls the " { $snippet "quot" } " with the first " { $snippet "n" } " values from a sequence." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: combinators.smart math prettyprint ;"
|
||||
"{ 1 2 3 } [ + + ] input<sequence ."
|
||||
"6"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: output>array
|
||||
{ $values
|
||||
{ "quot" quotation }
|
||||
{ "newquot" quotation }
|
||||
}
|
||||
{ $description "Infers the number or outputs from the quotation and constructs an array from those outputs." }
|
||||
{ $examples
|
||||
{ $example
|
||||
<" USING: combinators combinators.smart math prettyprint ;
|
||||
9 [
|
||||
{ [ 1- ] [ 1+ ] [ sq ] } cleave
|
||||
] output>array .">
|
||||
"{ 8 10 81 }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: output>sequence
|
||||
{ $values
|
||||
{ "quot" quotation } { "exemplar" "an exemplar" }
|
||||
{ "newquot" quotation }
|
||||
}
|
||||
{ $description "Infers the number of outputs from the quotation and constructs a new sequence from those objects of the same type as the exemplar." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: combinators.smart kernel math prettyprint ;"
|
||||
"4 [ [ 1 + ] [ 2 + ] [ 3 + ] tri ] V{ } output>sequence ."
|
||||
"V{ 5 6 7 }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: reduce-outputs
|
||||
{ $values
|
||||
{ "quot" quotation } { "operation" quotation }
|
||||
{ "newquot" quotation }
|
||||
}
|
||||
{ $description "Infers the number of outputs from " { $snippet "quot" } " and reduces them using " { $snippet "operation" } ". The identity for the " { $link reduce } " operation is the first output." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: combinators.smart kernel math prettyprint ;"
|
||||
"3 [ [ 4 * ] [ 4 / ] [ 4 - ] tri ] [ * ] reduce-outputs ."
|
||||
"-9"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: sum-outputs
|
||||
{ $values
|
||||
{ "quot" quotation }
|
||||
{ "n" integer }
|
||||
}
|
||||
{ $description "Infers the number of outputs from " { $snippet "quot" } " and returns their sum." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: combinators.smart kernel math prettyprint ;"
|
||||
"10 [ [ 1- ] [ 1+ ] bi ] sum-outputs ."
|
||||
"20"
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "combinators.smart" "Smart combinators"
|
||||
"The " { $vocab-link "combinators.smart" } " vocabulary implements " { $emphasis "smart combinators" } ". A smart combinator is one whose behavior depends on the static stack effect of an input quotation." $nl
|
||||
"Smart inputs from a sequence:"
|
||||
{ $subsection input<sequence }
|
||||
"Smart outputs to a sequence:"
|
||||
{ $subsection output>sequence }
|
||||
{ $subsection output>array }
|
||||
"Reducing the output of a quotation:"
|
||||
{ $subsection reduce-outputs }
|
||||
"Summing the output of a quotation:"
|
||||
{ $subsection sum-outputs } ;
|
||||
|
||||
ABOUT: "combinators.smart"
|
|
@ -0,0 +1,21 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test combinators.smart math kernel ;
|
||||
IN: combinators.smart.tests
|
||||
|
||||
: test-bi ( -- 9 11 )
|
||||
10 [ 1- ] [ 1+ ] bi ;
|
||||
|
||||
[ [ test-bi ] output>array ] must-infer
|
||||
[ { 9 11 } ] [ [ test-bi ] output>array ] unit-test
|
||||
|
||||
[ { 9 11 } [ + ] input<sequence ] must-infer
|
||||
[ 20 ] [ { 9 11 } [ + ] input<sequence ] unit-test
|
||||
|
||||
|
||||
|
||||
[ 6 ] [ [ 1 2 3 ] [ + ] reduce-outputs ] unit-test
|
||||
|
||||
[ [ 1 2 3 ] [ + ] reduce-outputs ] must-infer
|
||||
|
||||
[ 6 ] [ [ 1 2 3 ] sum-outputs ] unit-test
|
|
@ -0,0 +1,22 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors fry generalizations kernel macros math.order
|
||||
stack-checker math ;
|
||||
IN: combinators.smart
|
||||
|
||||
MACRO: output>sequence ( quot exemplar -- newquot )
|
||||
[ dup infer out>> ] dip
|
||||
'[ @ _ _ nsequence ] ;
|
||||
|
||||
: output>array ( quot -- newquot )
|
||||
{ } output>sequence ; inline
|
||||
|
||||
MACRO: input<sequence ( quot -- newquot )
|
||||
[ infer in>> ] keep
|
||||
'[ _ firstn @ ] ;
|
||||
|
||||
MACRO: reduce-outputs ( quot operation -- newquot )
|
||||
[ dup infer out>> 1 [-] ] dip n*quot compose ;
|
||||
|
||||
: sum-outputs ( quot -- n )
|
||||
[ + ] reduce-outputs ; inline
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors kernel arrays sequences math math.order
|
||||
math.partial-dispatch generic generic.standard generic.math
|
||||
classes.algebra classes.union sets quotations assocs combinators
|
||||
words namespaces continuations classes fry
|
||||
words namespaces continuations classes fry combinators.smart
|
||||
compiler.tree
|
||||
compiler.tree.builder
|
||||
compiler.tree.recursive
|
||||
|
@ -134,17 +134,19 @@ DEFER: (flat-length)
|
|||
over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
|
||||
|
||||
: inlining-rank ( #call word -- n )
|
||||
[ classes-known? 2 0 ? ]
|
||||
[
|
||||
{
|
||||
[ body-length-bias ]
|
||||
[ "default" word-prop -4 0 ? ]
|
||||
[ "specializer" word-prop 1 0 ? ]
|
||||
[ method-body? 1 0 ? ]
|
||||
} cleave
|
||||
node-count-bias
|
||||
loop-nesting get 0 or 2 *
|
||||
] bi* + + + + + + ;
|
||||
[ classes-known? 2 0 ? ]
|
||||
[
|
||||
{
|
||||
[ body-length-bias ]
|
||||
[ "default" word-prop -4 0 ? ]
|
||||
[ "specializer" word-prop 1 0 ? ]
|
||||
[ method-body? 1 0 ? ]
|
||||
} cleave
|
||||
node-count-bias
|
||||
loop-nesting get 0 or 2 *
|
||||
] bi*
|
||||
] sum-outputs ;
|
||||
|
||||
: should-inline? ( #call word -- ? )
|
||||
dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
|
||||
|
|
|
@ -0,0 +1,2 @@
|
|||
Slava Pestov
|
||||
Doug Coleman
|
|
@ -0,0 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test db.tester ;
|
||||
IN: db.tester.tests
|
||||
|
||||
[ ] [ sqlite-test-db db-tester ] unit-test
|
||||
[ ] [ sqlite-test-db db-tester2 ] unit-test
|
|
@ -0,0 +1,57 @@
|
|||
! Copyright (C) 2008 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: concurrency.combinators db.pools db.sqlite db.tuples
|
||||
db.types kernel math random threads tools.test db sequences
|
||||
io prettyprint ;
|
||||
IN: db.tester
|
||||
|
||||
TUPLE: test-1 id a b c ;
|
||||
|
||||
test-1 "TEST1" {
|
||||
{ "id" "ID" INTEGER +db-assigned-id+ }
|
||||
{ "a" "A" { VARCHAR 256 } +not-null+ }
|
||||
{ "b" "B" { VARCHAR 256 } +not-null+ }
|
||||
{ "c" "C" { VARCHAR 256 } +not-null+ }
|
||||
} define-persistent
|
||||
|
||||
TUPLE: test-2 id x y z ;
|
||||
|
||||
test-2 "TEST2" {
|
||||
{ "id" "ID" INTEGER +db-assigned-id+ }
|
||||
{ "x" "X" { VARCHAR 256 } +not-null+ }
|
||||
{ "y" "Y" { VARCHAR 256 } +not-null+ }
|
||||
{ "z" "Z" { VARCHAR 256 } +not-null+ }
|
||||
} define-persistent
|
||||
|
||||
: sqlite-test-db ( -- db ) "test.db" <sqlite-db> ;
|
||||
: test-db ( -- db ) "test.db" <sqlite-db> ;
|
||||
|
||||
: db-tester ( test-db -- )
|
||||
[
|
||||
[
|
||||
test-1 ensure-table
|
||||
test-2 ensure-table
|
||||
] with-db
|
||||
] [
|
||||
10 [
|
||||
drop
|
||||
10 [
|
||||
dup [
|
||||
f 100 random 100 random 100 random test-1 boa
|
||||
insert-tuple yield
|
||||
] with-db
|
||||
] times
|
||||
] with parallel-each
|
||||
] bi ;
|
||||
|
||||
: 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
|
||||
] with-db
|
||||
] bi ;
|
|
@ -8,7 +8,7 @@ SINGLETON: gvim
|
|||
HOOK: gvim-path io-backend ( -- path )
|
||||
|
||||
M: gvim vim-command ( file line -- string )
|
||||
[ gvim-path , swap , "+" swap number>string append , ] { } make ;
|
||||
[ gvim-path , "+" swap number>string append , , ] { } make ;
|
||||
|
||||
gvim vim-editor set-global
|
||||
|
||||
|
|
|
@ -1,6 +1,5 @@
|
|||
! Generate a new factor.vim file for syntax highlighting
|
||||
USING: http.server.templating http.server.templating.fhtml
|
||||
io.files ;
|
||||
USING: html.templates html.templates.fhtml io.files io.pathnames ;
|
||||
IN: editors.vim.generate-syntax
|
||||
|
||||
: generate-vim-syntax ( -- )
|
||||
|
|
|
@ -49,7 +49,7 @@ HELP: <groups>
|
|||
}
|
||||
{ $example
|
||||
"USING: kernel prettyprint sequences grouping ;"
|
||||
"{ 1 2 3 4 5 6 } 3 <groups> 0 swap nth ."
|
||||
"{ 1 2 3 4 5 6 } 3 <groups> first ."
|
||||
"{ 1 2 3 }"
|
||||
}
|
||||
} ;
|
||||
|
@ -66,7 +66,7 @@ HELP: <sliced-groups>
|
|||
}
|
||||
{ $example
|
||||
"USING: kernel prettyprint sequences grouping ;"
|
||||
"{ 1 2 3 4 5 6 } 3 <sliced-groups> 1 swap nth ."
|
||||
"{ 1 2 3 4 5 6 } 3 <sliced-groups> second ."
|
||||
"T{ slice { from 3 } { to 6 } { seq { 1 2 3 4 5 6 } } }"
|
||||
}
|
||||
} ;
|
||||
|
|
|
@ -209,7 +209,8 @@ ARTICLE: "tools" "Developer tools"
|
|||
{ $subsection "timing" }
|
||||
{ $subsection "tools.disassembler" }
|
||||
"Deployment tools:"
|
||||
{ $subsection "tools.deploy" } ;
|
||||
{ $subsection "tools.deploy" }
|
||||
{ $see-also "ui-tools" } ;
|
||||
|
||||
ARTICLE: "article-index" "Article index"
|
||||
{ $index [ articles get keys ] } ;
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors alien.c-types alien.syntax combinators
|
||||
io.backend io.files io.files.info io.files.unix kernel math system unix
|
||||
unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd
|
||||
sequences grouping alien.strings io.encodings.utf8
|
||||
sequences grouping alien.strings io.encodings.utf8 unix.types
|
||||
specialized-arrays.direct.uint arrays io.files.info.unix ;
|
||||
IN: io.files.info.unix.freebsd
|
||||
|
||||
|
|
|
@ -5,7 +5,7 @@ io.backend io.encodings.utf8 io.files io.files.info io.streams.string
|
|||
io.files.unix kernel math.order namespaces sequences sorting
|
||||
system unix unix.statfs.linux unix.statvfs.linux io.files.links
|
||||
specialized-arrays.direct.uint arrays io.files.info.unix assocs
|
||||
io.pathnames ;
|
||||
io.pathnames unix.types ;
|
||||
IN: io.files.info.unix.linux
|
||||
|
||||
TUPLE: linux-file-system-info < unix-file-system-info
|
||||
|
|
|
@ -22,11 +22,11 @@ HELP: file-permissions
|
|||
{ "n" integer } }
|
||||
{ $description "Returns the Unix file permissions for a given file." } ;
|
||||
|
||||
HELP: file-username
|
||||
HELP: file-user-name
|
||||
{ $values
|
||||
{ "path" "a pathname string" }
|
||||
{ "string" string } }
|
||||
{ $description "Returns the username for a given file." } ;
|
||||
{ $description "Returns the user-name for a given file." } ;
|
||||
|
||||
HELP: file-user-id
|
||||
{ $values
|
||||
|
@ -110,7 +110,7 @@ HELP: set-file-times
|
|||
HELP: set-file-user
|
||||
{ $values
|
||||
{ "path" "a pathname string" } { "string/id" "a string or a user id" } }
|
||||
{ $description "Sets a file's user id from the given user id or username." } ;
|
||||
{ $description "Sets a file's user id from the given user id or user-name." } ;
|
||||
|
||||
HELP: set-file-modified-time
|
||||
{ $values
|
||||
|
@ -258,7 +258,7 @@ ARTICLE: "unix-file-timestamps" "Unix file timestamps"
|
|||
ARTICLE: "unix-file-ids" "Unix file user and group ids"
|
||||
"Reading file user data:"
|
||||
{ $subsection file-user-id }
|
||||
{ $subsection file-username }
|
||||
{ $subsection file-user-name }
|
||||
"Setting file user data:"
|
||||
{ $subsection set-file-user }
|
||||
"Reading file group data:"
|
||||
|
|
|
@ -243,8 +243,8 @@ M: string set-file-group ( path string -- )
|
|||
: file-user-id ( path -- uid )
|
||||
normalize-path file-info uid>> ;
|
||||
|
||||
: file-username ( path -- string )
|
||||
file-user-id username ;
|
||||
: file-user-name ( path -- string )
|
||||
file-user-id user-name ;
|
||||
|
||||
: file-group-id ( path -- gid )
|
||||
normalize-path file-info gid>> ;
|
||||
|
|
|
@ -117,12 +117,12 @@ prepare-test-file
|
|||
[ ] [ test-file f f 2array set-file-times ] unit-test
|
||||
|
||||
|
||||
[ ] [ test-file real-username set-file-user ] unit-test
|
||||
[ ] [ test-file real-user-name set-file-user ] unit-test
|
||||
[ ] [ test-file real-user-id set-file-user ] unit-test
|
||||
[ ] [ test-file real-group-name set-file-group ] unit-test
|
||||
[ ] [ test-file real-group-id set-file-group ] unit-test
|
||||
|
||||
[ t ] [ test-file file-username real-username = ] unit-test
|
||||
[ t ] [ test-file file-user-name real-user-name = ] unit-test
|
||||
[ t ] [ test-file file-group-name real-group-name = ] unit-test
|
||||
|
||||
[ ]
|
||||
|
|
|
@ -32,3 +32,7 @@ IN: math.bitwise.tests
|
|||
|
||||
[ 8 ] [ 0 3 toggle-bit ] unit-test
|
||||
[ 0 ] [ 8 3 toggle-bit ] unit-test
|
||||
|
||||
[ 4 ] [ BIN: 1010101 bit-count ] unit-test
|
||||
[ 0 ] [ BIN: 0 bit-count ] unit-test
|
||||
[ 1 ] [ BIN: 1 bit-count ] unit-test
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math math.functions sequences
|
||||
sequences.private words namespaces macros hints
|
||||
combinators fry io.binary ;
|
||||
combinators fry io.binary combinators.smart ;
|
||||
IN: math.bitwise
|
||||
|
||||
! utilities
|
||||
|
@ -76,12 +76,14 @@ DEFER: byte-bit-count
|
|||
GENERIC: (bit-count) ( x -- n )
|
||||
|
||||
M: fixnum (bit-count)
|
||||
{
|
||||
[ byte-bit-count ]
|
||||
[ -8 shift byte-bit-count ]
|
||||
[ -16 shift byte-bit-count ]
|
||||
[ -24 shift byte-bit-count ]
|
||||
} cleave + + + ;
|
||||
[
|
||||
{
|
||||
[ byte-bit-count ]
|
||||
[ -8 shift byte-bit-count ]
|
||||
[ -16 shift byte-bit-count ]
|
||||
[ -24 shift byte-bit-count ]
|
||||
} cleave
|
||||
] sum-outputs ;
|
||||
|
||||
M: bignum (bit-count)
|
||||
dup 0 = [ drop 0 ] [
|
||||
|
|
|
@ -3,7 +3,10 @@
|
|||
USING: accessors arrays assocs grouping kernel regexp.backend
|
||||
locals math namespaces regexp.parser sequences fry quotations
|
||||
math.order math.ranges vectors unicode.categories regexp.utils
|
||||
regexp.transition-tables words sets regexp.classes unicode.case ;
|
||||
regexp.transition-tables words sets regexp.classes unicode.case.private ;
|
||||
! This uses unicode.case.private for ch>upper and ch>lower
|
||||
! but case-insensitive matching should be done by case-folding everything
|
||||
! before processing starts
|
||||
IN: regexp.nfa
|
||||
|
||||
SYMBOL: negation-mode
|
||||
|
@ -160,6 +163,8 @@ M: LETTER-class nfa-node ( node -- )
|
|||
|
||||
M: character-class-range nfa-node ( node -- )
|
||||
case-insensitive option? [
|
||||
! This should be implemented for Unicode by case-folding
|
||||
! the input and all strings in the regexp.
|
||||
dup [ from>> ] [ to>> ] bi
|
||||
2dup [ Letter? ] bi@ and [
|
||||
rot drop
|
||||
|
|
|
@ -3,8 +3,8 @@
|
|||
USING: accessors arrays assocs combinators io io.streams.string
|
||||
kernel math math.parser namespaces sets
|
||||
quotations sequences splitting vectors math.order
|
||||
unicode.categories strings regexp.backend regexp.utils
|
||||
unicode.case words locals regexp.classes ;
|
||||
strings regexp.backend regexp.utils
|
||||
unicode.case unicode.categories words locals regexp.classes ;
|
||||
IN: regexp.parser
|
||||
|
||||
FROM: math.ranges => [a,b] ;
|
||||
|
@ -261,7 +261,7 @@ ERROR: bad-escaped-literals seq ;
|
|||
parse-til-E
|
||||
drop1
|
||||
[ epsilon ] [
|
||||
[ quot call <constant> ] V{ } map-as
|
||||
quot call [ <constant> ] V{ } map-as
|
||||
first|concatenation
|
||||
] if-empty ; inline
|
||||
|
||||
|
@ -269,10 +269,10 @@ ERROR: bad-escaped-literals seq ;
|
|||
[ ] (parse-escaped-literals) ;
|
||||
|
||||
: lower-case-literals ( -- obj )
|
||||
[ ch>lower ] (parse-escaped-literals) ;
|
||||
[ >lower ] (parse-escaped-literals) ;
|
||||
|
||||
: upper-case-literals ( -- obj )
|
||||
[ ch>upper ] (parse-escaped-literals) ;
|
||||
[ >upper ] (parse-escaped-literals) ;
|
||||
|
||||
: parse-escaped ( -- obj )
|
||||
read1
|
||||
|
|
|
@ -0,0 +1,71 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel math.order quotations
|
||||
sequences strings ;
|
||||
IN: sorting.human
|
||||
|
||||
HELP: find-numbers
|
||||
{ $values
|
||||
{ "string" string }
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "Splits a string on numbers and returns a sequence of sequences and integers." } ;
|
||||
|
||||
HELP: human-<=>
|
||||
{ $values
|
||||
{ "obj1" object } { "obj2" object }
|
||||
{ "<=>" "an ordering specifier" }
|
||||
}
|
||||
{ $description "Compares two objects after converting numbers in the string into integers." } ;
|
||||
|
||||
HELP: human->=<
|
||||
{ $values
|
||||
{ "obj1" object } { "obj2" object }
|
||||
{ ">=<" "an ordering specifier" }
|
||||
}
|
||||
{ $description "Compares two objects using the " { $link human-<=> } " word and inverts the result." } ;
|
||||
|
||||
HELP: human-compare
|
||||
{ $values
|
||||
{ "obj1" object } { "obj2" object } { "quot" quotation }
|
||||
{ "<=>" "an ordering specifier" }
|
||||
}
|
||||
{ $description "Compares the results of applying the quotation to both objects via <=>." } ;
|
||||
|
||||
HELP: human-sort
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "seq'" sequence }
|
||||
}
|
||||
{ $description "Sorts a sequence of objects by comparing the magnitude of any integers in the input string using the <=> word." } ;
|
||||
|
||||
HELP: human-sort-keys
|
||||
{ $values
|
||||
{ "seq" "an alist" }
|
||||
{ "sortedseq" "a new sorted sequence" }
|
||||
}
|
||||
{ $description "Sorts the elements comparing first elements of pairs using the " { $link human-<=> } " word." } ;
|
||||
|
||||
HELP: human-sort-values
|
||||
{ $values
|
||||
{ "seq" "an alist" }
|
||||
{ "sortedseq" "a new sorted sequence" }
|
||||
}
|
||||
{ $description "Sorts the elements comparing second elements of pairs using the " { $link human-<=> } " word." } ;
|
||||
|
||||
{ <=> >=< human-compare human-sort human-sort-keys human-sort-values } related-words
|
||||
|
||||
ARTICLE: "sorting.human" "sorting.human"
|
||||
"The " { $vocab-link "sorting.human" } " vocabulary sorts by numbers as a human would -- by comparing their magnitudes -- rather than in a lexicographic way. For example, sorting a1, a10, a03, a2 with human sort returns a1, a2, a03, a10, while sorting with natural sort returns a03, a1, a10, a2." $nl
|
||||
"Comparing two objects:"
|
||||
{ $subsection human-<=> }
|
||||
{ $subsection human->=< }
|
||||
{ $subsection human-compare }
|
||||
"Sort a sequence:"
|
||||
{ $subsection human-sort }
|
||||
{ $subsection human-sort-keys }
|
||||
{ $subsection human-sort-values }
|
||||
"Splitting a string into substrings and integers:"
|
||||
{ $subsection find-numbers } ;
|
||||
|
||||
ABOUT: "sorting.human"
|
|
@ -1,10 +1,22 @@
|
|||
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: peg.ebnf math.parser kernel assocs sorting ;
|
||||
USING: peg.ebnf math.parser kernel assocs sorting fry
|
||||
math.order sequences ascii splitting.monotonic ;
|
||||
IN: sorting.human
|
||||
|
||||
: find-numbers ( string -- seq )
|
||||
[EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ;
|
||||
|
||||
: human-sort ( seq -- seq' )
|
||||
[ dup find-numbers ] { } map>assoc sort-values keys ;
|
||||
: human-<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ;
|
||||
|
||||
: human->=< ( obj1 obj2 -- >=< ) human-<=> invert-comparison ; inline
|
||||
|
||||
: human-compare ( obj1 obj2 quot -- <=> ) bi@ human-<=> ;
|
||||
|
||||
: human-sort ( seq -- seq' ) [ human-<=> ] sort ;
|
||||
|
||||
: human-sort-keys ( seq -- sortedseq )
|
||||
[ [ first ] human-compare ] sort ;
|
||||
|
||||
: human-sort-values ( seq -- sortedseq )
|
||||
[ [ second ] human-compare ] sort ;
|
||||
|
|
|
@ -0,0 +1,2 @@
|
|||
Doug Coleman
|
||||
Slava Pestov
|
|
@ -0,0 +1,42 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel quotations math.order
|
||||
sequences ;
|
||||
IN: sorting.slots
|
||||
|
||||
HELP: compare-slots
|
||||
{ $values
|
||||
{ "sort-specs" "a sequence of accessor/comparator pairs" }
|
||||
{ "<=>" { $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 }
|
||||
}
|
||||
{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a slot accessor and a comparator." }
|
||||
{ $examples
|
||||
"Sort by slot c, then b descending:"
|
||||
{ $example
|
||||
"USING: accessors math.order prettyprint sorting.slots ;"
|
||||
"IN: scratchpad"
|
||||
"TUPLE: sort-me a b ;"
|
||||
"{"
|
||||
" T{ sort-me f 2 3 } T{ sort-me f 3 2 }"
|
||||
" T{ sort-me f 4 3 } T{ sort-me f 2 1 }"
|
||||
"}"
|
||||
"{ { a>> <=> } { b>> >=< } } sort-by-slots ."
|
||||
"{\n T{ sort-me { a 2 } { b 3 } }\n T{ sort-me { a 2 } { b 1 } }\n T{ sort-me { a 3 } { b 2 } }\n T{ sort-me { a 4 } { b 3 } }\n}"
|
||||
}
|
||||
} ;
|
||||
|
||||
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:"
|
||||
{ $subsection compare-slots }
|
||||
"Sorting a sequence by a sequence of slots:"
|
||||
{ $subsection sort-by-slots } ;
|
||||
|
||||
ABOUT: "sorting.slots"
|
|
@ -0,0 +1,50 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors math.order sorting.slots tools.test
|
||||
sorting.human ;
|
||||
IN: sorting.literals.tests
|
||||
|
||||
TUPLE: sort-test a b c ;
|
||||
|
||||
[
|
||||
{
|
||||
T{ sort-test { a 1 } { b 3 } { c 9 } }
|
||||
T{ sort-test { a 1 } { b 1 } { c 10 } }
|
||||
T{ sort-test { a 1 } { b 1 } { c 11 } }
|
||||
T{ sort-test { a 2 } { b 5 } { c 2 } }
|
||||
T{ sort-test { a 2 } { b 5 } { c 3 } }
|
||||
}
|
||||
] [
|
||||
{
|
||||
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>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ sort-test { a 1 } { b 3 } { c 9 } }
|
||||
T{ sort-test { a 1 } { b 1 } { c 10 } }
|
||||
T{ sort-test { a 1 } { b 1 } { c 11 } }
|
||||
T{ sort-test { a 2 } { b 5 } { c 2 } }
|
||||
T{ sort-test { a 2 } { b 5 } { c 3 } }
|
||||
}
|
||||
] [
|
||||
{
|
||||
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>> human->=< } { c>> <=> } } sort-by-slots
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ }
|
||||
] [
|
||||
{ }
|
||||
{ { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots
|
||||
] unit-test
|
|
@ -0,0 +1,19 @@
|
|||
! 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 ;
|
||||
IN: sorting.slots
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: slot-comparator ( accessor comparator -- quot )
|
||||
'[ [ _ execute ] bi@ _ execute dup +eq+ eq? [ drop f ] when ] ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO: compare-slots ( sort-specs -- <=> )
|
||||
#! sort-spec: { accessor comparator }
|
||||
[ first2 slot-comparator ] map '[ _ 2|| +eq+ or ] ;
|
||||
|
||||
: sort-by-slots ( seq sort-specs -- seq' )
|
||||
'[ _ compare-slots ] sort ;
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences grouping assocs kernel ascii unicode.case tr ;
|
||||
USING: sequences grouping assocs kernel ascii ascii tr ;
|
||||
IN: soundex
|
||||
|
||||
TR: soundex-tr
|
||||
|
|
|
@ -0,0 +1,109 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel quotations classes sequences
|
||||
multiline ;
|
||||
IN: splitting.monotonic
|
||||
|
||||
HELP: monotonic-slice
|
||||
{ $values
|
||||
{ "seq" sequence } { "quot" quotation } { "class" class }
|
||||
{ "slices" "a sequence of slices" }
|
||||
}
|
||||
{ $description "Monotonically splits a sequence into slices of the type " { $snippet "class" } "." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: splitting.monotonic math prettyprint ;"
|
||||
"{ 1 2 3 2 3 4 } [ < ] upward-slice monotonic-slice ."
|
||||
<" {
|
||||
T{ upward-slice
|
||||
{ from 0 }
|
||||
{ to 3 }
|
||||
{ seq { 1 2 3 2 3 4 } }
|
||||
}
|
||||
T{ upward-slice
|
||||
{ from 3 }
|
||||
{ to 6 }
|
||||
{ seq { 1 2 3 2 3 4 } }
|
||||
}
|
||||
}">
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: monotonic-split
|
||||
{ $values
|
||||
{ "seq" sequence } { "quot" quotation }
|
||||
{ "newseq" "a sequence of sequences" }
|
||||
}
|
||||
{ $description "Compares pairs of elements in a sequence and collects elements into sequences while they satisfy the predicate. Once the predicate fails, a new sequence is started, and all sequences are returned in a single sequence." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: splitting.monotonic math prettyprint ;"
|
||||
"{ 1 2 3 2 3 4 } [ < ] monotonic-split ."
|
||||
"{ V{ 1 2 3 } V{ 2 3 4 } }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: downward-slices
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "slices" "a sequence of downward-slices" }
|
||||
}
|
||||
{ $description "Returns an array of monotonically decreasing slices of type " { $link downward-slice } ". Slices of one element are discarded." } ;
|
||||
|
||||
HELP: stable-slices
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "slices" "a sequence of stable-slices" }
|
||||
}
|
||||
{ $description "Returns an array of monotonically decreasing slices of type " { $link downward-slice } ". Slices of one element are discarded." } ;
|
||||
|
||||
HELP: upward-slices
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "slices" "a sequence of upward-slices" }
|
||||
}
|
||||
{ $description "Returns an array of monotonically increasing slices of type " { $link downward-slice } ". Slices of one element are discarded." } ;
|
||||
|
||||
HELP: trends
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "slices" "a sequence of downward, stable, and upward slices" }
|
||||
}
|
||||
{ $description "Returns a sorted sequence of downward, stable, or upward slices. The endpoints of some slices may overlap with each other." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: splitting.monotonic math prettyprint ;"
|
||||
"{ 1 2 3 3 2 1 } trends ."
|
||||
<" {
|
||||
T{ upward-slice
|
||||
{ from 0 }
|
||||
{ to 3 }
|
||||
{ seq { 1 2 3 3 2 1 } }
|
||||
}
|
||||
T{ stable-slice
|
||||
{ from 2 }
|
||||
{ to 4 }
|
||||
{ seq { 1 2 3 3 2 1 } }
|
||||
}
|
||||
T{ downward-slice
|
||||
{ from 3 }
|
||||
{ to 6 }
|
||||
{ seq { 1 2 3 3 2 1 } }
|
||||
}
|
||||
}">
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "splitting.monotonic" "Splitting trending sequences"
|
||||
"The " { $vocab-link "splitting.monotonic" } " vocabulary splits sequences that are trending downwards, upwards, or stably." $nl
|
||||
"Splitting into sequences:"
|
||||
{ $subsection monotonic-split }
|
||||
"Splitting into slices:"
|
||||
{ $subsection monotonic-slice }
|
||||
"Trending:"
|
||||
{ $subsection downward-slices }
|
||||
{ $subsection stable-slices }
|
||||
{ $subsection upward-slices }
|
||||
{ $subsection trends } ;
|
||||
|
||||
ABOUT: "splitting.monotonic"
|
|
@ -6,3 +6,50 @@ USING: tools.test math arrays kernel sequences ;
|
|||
[ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ]
|
||||
[ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test
|
||||
|
||||
[ { } ]
|
||||
[ { } [ = ] slice monotonic-slice ] unit-test
|
||||
|
||||
[ t ]
|
||||
[ { 1 } [ = ] slice monotonic-slice [ slice? ] all? ] unit-test
|
||||
|
||||
[ { { 1 } } ]
|
||||
[ { 1 } [ = ] slice monotonic-slice [ >array ] map ] unit-test
|
||||
|
||||
[ { 1 } [ = ] slice monotonic-slice ] must-infer
|
||||
|
||||
[ t ]
|
||||
[ { 1 1 1 2 2 3 3 4 } [ = ] slice monotonic-slice [ slice? ] all? ] unit-test
|
||||
|
||||
[ { { 1 1 1 } { 2 2 } { 3 3 } { 4 } } ]
|
||||
[ { 1 1 1 2 2 3 3 4 } [ = ] slice monotonic-slice [ >array ] map ] unit-test
|
||||
|
||||
[ { { 3 3 } } ]
|
||||
[ { 3 3 } [ = ] slice monotonic-slice [ >array ] map ] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ upward-slice { from 0 } { to 3 } { seq { 1 2 3 2 1 } } }
|
||||
T{ downward-slice { from 2 } { to 5 } { seq { 1 2 3 2 1 } } }
|
||||
}
|
||||
]
|
||||
[ { 1 2 3 2 1 } trends ] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ upward-slice
|
||||
{ from 0 }
|
||||
{ to 3 }
|
||||
{ seq { 1 2 3 3 2 1 } }
|
||||
}
|
||||
T{ stable-slice
|
||||
{ from 2 }
|
||||
{ to 4 }
|
||||
{ seq { 1 2 3 3 2 1 } }
|
||||
}
|
||||
T{ downward-slice
|
||||
{ from 3 }
|
||||
{ to 6 }
|
||||
{ seq { 1 2 3 3 2 1 } }
|
||||
}
|
||||
}
|
||||
] [ { 1 2 3 3 2 1 } trends ] unit-test
|
||||
|
|
|
@ -1,8 +1,11 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! Copyright (C) 2008, 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: make namespaces sequences kernel fry ;
|
||||
USING: make namespaces sequences kernel fry arrays compiler.utilities
|
||||
math accessors circular grouping combinators sorting math.order ;
|
||||
IN: splitting.monotonic
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: ,, ( obj -- ) building get peek push ;
|
||||
: v, ( -- ) V{ } clone , ;
|
||||
: ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ;
|
||||
|
@ -13,5 +16,54 @@ IN: splitting.monotonic
|
|||
v, '[ over ,, @ [ v, ] unless ] 2each ,v
|
||||
] { } make ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: monotonic-split ( seq quot -- newseq )
|
||||
over empty? [ 2drop { } ] [ (monotonic-split) ] if ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (monotonic-slice) ( seq quot class -- slices )
|
||||
[
|
||||
dupd '[
|
||||
[ length ] [ ] [ <circular> 1 over change-circular-start ] tri
|
||||
[ @ not [ , ] [ drop ] if ] 3each
|
||||
] { } make
|
||||
dup empty? [ over length 1- prefix ] when -1 prefix 2 clump
|
||||
swap
|
||||
] dip
|
||||
'[ first2 [ 1+ ] bi@ _ _ boa ] map ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: monotonic-slice ( seq quot class -- slices )
|
||||
pick length {
|
||||
{ 0 [ 2drop ] }
|
||||
{ 1 [ nip [ 0 1 rot ] dip boa 1array ] }
|
||||
[ drop (monotonic-slice) ]
|
||||
} case ; inline
|
||||
|
||||
TUPLE: downward-slice < slice ;
|
||||
TUPLE: stable-slice < slice ;
|
||||
TUPLE: upward-slice < slice ;
|
||||
|
||||
: downward-slices ( seq -- slices )
|
||||
[ > ] downward-slice monotonic-slice [ length 1 > ] filter ;
|
||||
|
||||
: stable-slices ( seq -- slices )
|
||||
[ = ] stable-slice monotonic-slice [ length 1 > ] filter ;
|
||||
|
||||
: upward-slices ( seq -- slices )
|
||||
[ < ] upward-slice monotonic-slice [ length 1 > ] filter ;
|
||||
|
||||
: trends ( seq -- slices )
|
||||
dup length {
|
||||
{ 0 [ ] }
|
||||
{ 1 [ [ 0 1 ] dip stable-slice boa ] }
|
||||
[
|
||||
drop
|
||||
[ downward-slices ]
|
||||
[ stable-slices ]
|
||||
[ upward-slices ] tri 3append [ [ from>> ] compare ] sort
|
||||
]
|
||||
} case ;
|
||||
|
|
|
@ -1,16 +1,18 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays cocoa.messages cocoa.runtime combinators
|
||||
prettyprint ;
|
||||
prettyprint combinators.smart ;
|
||||
IN: tools.cocoa
|
||||
|
||||
: method. ( method -- )
|
||||
{
|
||||
[ method_getName sel_getName ]
|
||||
[ method-return-type ]
|
||||
[ method-arg-types ]
|
||||
[ method_getImplementation ]
|
||||
} cleave 4array . ;
|
||||
[
|
||||
{
|
||||
[ method_getName sel_getName ]
|
||||
[ method-return-type ]
|
||||
[ method-arg-types ]
|
||||
[ method_getImplementation ]
|
||||
} cleave
|
||||
] output>array . ;
|
||||
|
||||
: methods. ( class -- )
|
||||
[ method. ] each-method-in-class ;
|
||||
|
|
|
@ -5,6 +5,8 @@ io.directories kernel math.parser sequences system vocabs.loader
|
|||
calendar math fry prettyprint ;
|
||||
IN: tools.files
|
||||
|
||||
SYMBOLS: permissions file-name nlinks file-size date ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: ls-time ( timestamp -- string )
|
||||
|
@ -63,7 +65,7 @@ percent-used percent-free ;
|
|||
[ [ unparse ] map ] bi prefix simple-table. ;
|
||||
|
||||
: file-systems. ( -- )
|
||||
{ device-name free-space used-space total-space percent-used mount-point }
|
||||
{ device-name available-space free-space used-space total-space percent-used mount-point }
|
||||
print-file-systems ;
|
||||
|
||||
{
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors combinators kernel system unicode.case io.files
|
||||
io.files.info io.files.info.unix tools.files generalizations
|
||||
strings arrays sequences math.parser unix.groups unix.users
|
||||
tools.files.private unix.stat math ;
|
||||
tools.files.private unix.stat math fry macros combinators.smart ;
|
||||
IN: tools.files.unix
|
||||
|
||||
<PRIVATE
|
||||
|
@ -17,18 +17,20 @@ IN: tools.files.unix
|
|||
} case ;
|
||||
|
||||
: permissions-string ( permissions -- str )
|
||||
{
|
||||
[ type>> file-type>ch 1string ]
|
||||
[ user-read? read>string ]
|
||||
[ user-write? write>string ]
|
||||
[ [ uid? ] [ user-execute? ] bi 2array "s" unix-execute>string ]
|
||||
[ group-read? read>string ]
|
||||
[ group-write? write>string ]
|
||||
[ [ gid? ] [ group-execute? ] bi 2array "s" unix-execute>string ]
|
||||
[ other-read? read>string ]
|
||||
[ other-write? write>string ]
|
||||
[ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
|
||||
} cleave 10 narray concat ;
|
||||
[
|
||||
{
|
||||
[ type>> file-type>ch 1string ]
|
||||
[ user-read? read>string ]
|
||||
[ user-write? write>string ]
|
||||
[ [ uid? ] [ user-execute? ] bi 2array "s" unix-execute>string ]
|
||||
[ group-read? read>string ]
|
||||
[ group-write? write>string ]
|
||||
[ [ gid? ] [ group-execute? ] bi 2array "s" unix-execute>string ]
|
||||
[ other-read? read>string ]
|
||||
[ other-write? write>string ]
|
||||
[ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
|
||||
} cleave
|
||||
] output>array concat ;
|
||||
|
||||
: mode>symbol ( mode -- ch )
|
||||
S_IFMT bitand
|
||||
|
@ -45,15 +47,16 @@ IN: tools.files.unix
|
|||
M: unix (directory.) ( path -- lines )
|
||||
[ [
|
||||
[
|
||||
dup file-info
|
||||
{
|
||||
[ permissions-string ]
|
||||
[ nlink>> number>string 3 CHAR: \s pad-left ]
|
||||
! [ uid>> ]
|
||||
! [ gid>> ]
|
||||
[ size>> number>string 15 CHAR: \s pad-left ]
|
||||
[ modified>> ls-timestamp ]
|
||||
} cleave 4 narray swap suffix " " join
|
||||
dup file-info [
|
||||
{
|
||||
[ permissions-string ]
|
||||
[ nlink>> 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 ;
|
||||
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
IN: tr.tests
|
||||
USING: tr tools.test unicode.case ;
|
||||
USING: tr tools.test ascii ;
|
||||
|
||||
TR: tr-test ch>upper "ABC" "XYZ" ;
|
||||
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: byte-arrays strings sequences sequences.private
|
||||
USING: byte-arrays strings sequences sequences.private ascii
|
||||
fry kernel words parser lexer assocs math math.order summary ;
|
||||
IN: tr
|
||||
|
||||
|
@ -11,8 +11,6 @@ M: bad-tr summary
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: ascii? ( ch -- ? ) 0 127 between? ; inline
|
||||
|
||||
: tr-nth ( n mapping -- ch ) nth-unsafe 127 bitand ; inline
|
||||
|
||||
: check-tr ( from to -- )
|
||||
|
|
|
@ -6,7 +6,7 @@ classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
|
|||
ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme
|
||||
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
|
||||
ui.render math.geometry.rect locals alien.c-types
|
||||
specialized-arrays.float fry ;
|
||||
specialized-arrays.float fry combinators.smart ;
|
||||
IN: ui.gadgets.buttons
|
||||
|
||||
TUPLE: button < border pressed? selected? quot ;
|
||||
|
@ -111,12 +111,14 @@ TUPLE: checkmark-paint < caching-pen color last-vertices ;
|
|||
<PRIVATE
|
||||
|
||||
: checkmark-points ( dim -- points )
|
||||
{
|
||||
[ { 0 0 } v* { 0.5 0.5 } v+ ]
|
||||
[ { 1 1 } v* { 0.5 0.5 } v+ ]
|
||||
[ { 1 0 } v* { -0.3 0.5 } v+ ]
|
||||
[ { 0 1 } v* { -0.3 0.5 } v+ ]
|
||||
} cleave 4array ;
|
||||
[
|
||||
{
|
||||
[ { 0 0 } v* { 0.5 0.5 } v+ ]
|
||||
[ { 1 1 } v* { 0.5 0.5 } v+ ]
|
||||
[ { 1 0 } v* { -0.3 0.5 } v+ ]
|
||||
[ { 0 1 } v* { -0.3 0.5 } v+ ]
|
||||
} cleave
|
||||
] output>array ;
|
||||
|
||||
: checkmark-vertices ( dim -- vertices )
|
||||
checkmark-points concat >float-array ;
|
||||
|
|
|
@ -3,8 +3,9 @@
|
|||
USING: combinators.short-circuit unicode.categories kernel math
|
||||
combinators splitting sequences math.parser io.files io assocs
|
||||
arrays namespaces make math.ranges unicode.normalize.private values
|
||||
io.encodings.ascii unicode.syntax unicode.data compiler.units
|
||||
alien.syntax sets accessors interval-maps memoize locals words ;
|
||||
io.encodings.ascii unicode.syntax unicode.data compiler.units fry
|
||||
alien.syntax sets accessors interval-maps memoize locals words
|
||||
strings hints ;
|
||||
IN: unicode.breaks
|
||||
|
||||
<PRIVATE
|
||||
|
@ -58,38 +59,31 @@ SYMBOL: table
|
|||
: finish-table ( -- table )
|
||||
table get [ [ 1 = ] map ] map ;
|
||||
|
||||
: set-table ( class1 class2 val -- )
|
||||
: eval-seq ( seq -- seq ) [ dup word? [ execute ] when ] map ;
|
||||
|
||||
: (set-table) ( class1 class2 val -- )
|
||||
-rot table get nth [ swap or ] change-nth ;
|
||||
|
||||
: set-table ( classes1 classes2 val -- )
|
||||
[ [ eval-seq ] bi@ ] dip
|
||||
[ [ (set-table) ] curry with each ] 2curry each ;
|
||||
|
||||
: connect ( class1 class2 -- ) 1 set-table ;
|
||||
: disconnect ( class1 class2 -- ) 0 set-table ;
|
||||
|
||||
: check-before ( class classes value -- )
|
||||
[ set-table ] curry with each ;
|
||||
|
||||
: check-after ( classes class value -- )
|
||||
[ set-table ] 2curry each ;
|
||||
|
||||
: connect-before ( class classes -- )
|
||||
1 check-before ;
|
||||
|
||||
: connect-after ( classes class -- )
|
||||
1 check-after ;
|
||||
|
||||
: break-around ( classes1 classes2 -- )
|
||||
[ [ 2dup disconnect swap disconnect ] with each ] curry each ;
|
||||
[ disconnect ] [ swap disconnect ] 2bi ;
|
||||
|
||||
: make-grapheme-table ( -- )
|
||||
CR LF connect
|
||||
Control CR LF 3array graphemes break-around
|
||||
L L V LV LVT 4array connect-before
|
||||
V V T 2array connect-before
|
||||
LV V T 2array connect-before
|
||||
T T connect
|
||||
LVT T connect
|
||||
graphemes Extend connect-after
|
||||
graphemes SpacingMark connect-after
|
||||
Prepend graphemes connect-before ;
|
||||
{ CR } { LF } connect
|
||||
{ Control CR LF } graphemes disconnect
|
||||
graphemes { Control CR LF } disconnect
|
||||
{ L } { L V LV LVT } connect
|
||||
{ LV V } { V T } connect
|
||||
{ LVT T } { T } connect
|
||||
graphemes { Extend } connect
|
||||
graphemes { SpacingMark } connect
|
||||
{ Prepend } graphemes connect ;
|
||||
|
||||
VALUE: grapheme-table
|
||||
|
||||
|
@ -99,26 +93,18 @@ VALUE: grapheme-table
|
|||
: chars ( i str n -- str[i] str[i+n] )
|
||||
swap [ dupd + ] dip [ ?nth ] curry bi@ ;
|
||||
|
||||
: find-index ( seq quot -- i ) find drop ; inline
|
||||
: find-last-index ( seq quot -- i ) find-last drop ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: first-grapheme ( str -- i )
|
||||
unclip-slice grapheme-class over
|
||||
[ grapheme-class tuck grapheme-break? ] find-index
|
||||
[ grapheme-class tuck grapheme-break? ] find drop
|
||||
nip swap length or 1+ ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
:: (>pieces) ( str quot -- )
|
||||
str [
|
||||
dup quot call cut-slice
|
||||
swap , quot (>pieces)
|
||||
] unless-empty ; inline recursive
|
||||
|
||||
: >pieces ( str quot -- graphemes )
|
||||
[ (>pieces) ] { } make ; inline
|
||||
: >pieces ( str quot: ( str -- i ) -- graphemes )
|
||||
[ dup empty? not ] swap '[ dup @ cut-slice swap ]
|
||||
[ ] produce nip ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
@ -130,7 +116,7 @@ PRIVATE>
|
|||
|
||||
: last-grapheme ( str -- i )
|
||||
unclip-last-slice grapheme-class swap
|
||||
[ grapheme-class dup rot grapheme-break? ] find-last-index ?1+ nip ;
|
||||
[ grapheme-class dup rot grapheme-break? ] find-last drop ?1+ nip ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
@ -161,27 +147,23 @@ wMidNum wMidNumLet wNumeric wExtendNumLet words ;
|
|||
word-break-table interval-at
|
||||
word-break-classes at [ wOther ] unless* ;
|
||||
|
||||
: e ( seq -- seq ) [ execute ] map ;
|
||||
|
||||
SYMBOL: check-letter-before
|
||||
SYMBOL: check-letter-after
|
||||
SYMBOL: check-number-before
|
||||
SYMBOL: check-number-after
|
||||
|
||||
: make-word-table ( -- )
|
||||
wCR wLF connect
|
||||
{ wNewline wCR wLF } e words break-around
|
||||
wALetter dup connect
|
||||
wALetter { wMidLetter wMidNumLet } e check-letter-after check-before
|
||||
{ wMidLetter wMidNumLet } e wALetter check-letter-before check-after
|
||||
wNumeric dup connect
|
||||
wALetter wNumeric connect
|
||||
wNumeric wALetter connect
|
||||
wNumeric { wMidNum wMidNumLet } e check-number-after check-before
|
||||
{ wMidNum wMidNumLet } e wNumeric check-number-before check-after
|
||||
wKatakana dup connect
|
||||
{ wALetter wNumeric wKatakana wExtendNumLet } e wExtendNumLet
|
||||
[ connect-after ] [ swap connect-before ] 2bi ;
|
||||
{ wCR } { wLF } connect
|
||||
{ wNewline wCR wLF } words disconnect
|
||||
words { wNewline wCR wLF } disconnect
|
||||
{ wALetter } { wMidLetter wMidNumLet } check-letter-after set-table
|
||||
{ wMidLetter wMidNumLet } { wALetter } check-letter-before set-table
|
||||
{ wNumeric wALetter } { wNumeric wALetter } connect
|
||||
{ wNumeric } { wMidNum wMidNumLet } check-number-after set-table
|
||||
{ wMidNum wMidNumLet } { wNumeric } check-number-before set-table
|
||||
{ wKatakana } { wKatakana } connect
|
||||
{ wALetter wNumeric wKatakana wExtendNumLet } { wExtendNumLet }
|
||||
[ connect ] [ swap connect ] 2bi ;
|
||||
|
||||
VALUE: word-table
|
||||
|
||||
|
@ -197,48 +179,58 @@ to: word-table
|
|||
: word-table-nth ( class1 class2 -- ? )
|
||||
word-table nth nth ;
|
||||
|
||||
: property-not= ( i str property -- ? )
|
||||
pick [
|
||||
[ ?nth ] dip swap
|
||||
[ word-break-prop = not ] [ drop f ] if*
|
||||
] [ 3drop t ] if ;
|
||||
:: property-not= ( str i property -- ? )
|
||||
i [
|
||||
i str ?nth [ word-break-prop property = not ]
|
||||
[ f ] if*
|
||||
] [ t ] if ;
|
||||
|
||||
: format/extended? ( ch -- ? )
|
||||
word-break-prop { 4 5 } member? ;
|
||||
|
||||
:: walk-up ( str i -- j )
|
||||
i 1 + str [ format/extended? not ] find-from drop
|
||||
1+ str [ format/extended? not ] find-from drop ; ! possible bounds error?
|
||||
: (walk-up) ( str i -- j )
|
||||
swap [ format/extended? not ] find-from drop ;
|
||||
|
||||
:: walk-down ( str i -- j )
|
||||
i str [ format/extended? not ] find-last-from drop
|
||||
1- str [ format/extended? not ] find-last-from drop ; ! possible bounds error?
|
||||
: walk-up ( str i -- j )
|
||||
dupd 1+ (walk-up) [ 1+ (walk-up) ] [ drop f ] if* ;
|
||||
|
||||
:: word-break? ( table-entry i str -- ? )
|
||||
table-entry {
|
||||
{ t [ f ] }
|
||||
{ f [ t ] }
|
||||
: (walk-down) ( str i -- j )
|
||||
swap [ format/extended? not ] find-last-from drop ;
|
||||
|
||||
: walk-down ( str i -- j )
|
||||
dupd (walk-down) [ 1- (walk-down) ] [ drop f ] if* ;
|
||||
|
||||
: word-break? ( table-entry i str -- ? )
|
||||
spin {
|
||||
{ t [ 2drop f ] }
|
||||
{ f [ 2drop t ] }
|
||||
{ check-letter-after
|
||||
[ str i walk-up str wALetter property-not= ] }
|
||||
[ dupd walk-up wALetter property-not= ] }
|
||||
{ check-letter-before
|
||||
[ str i walk-down str wALetter property-not= ] }
|
||||
[ dupd walk-down wALetter property-not= ] }
|
||||
{ check-number-after
|
||||
[ str i walk-up str wNumeric property-not= ] }
|
||||
[ dupd walk-up wNumeric property-not= ] }
|
||||
{ check-number-before
|
||||
[ str i walk-down str wNumeric property-not= ] }
|
||||
} case ;
|
||||
[ dupd walk-down wNumeric property-not= ] }
|
||||
} case ; inline
|
||||
|
||||
:: word-break-next ( old-class new-char i str -- next-class ? )
|
||||
new-char word-break-prop dup { 4 5 } member?
|
||||
[ drop old-class dup { 1 2 3 } member? ]
|
||||
[ old-class over word-table-nth i str word-break? ] if ;
|
||||
new-char dup format/extended?
|
||||
[ drop old-class dup { 1 2 3 } member? ] [
|
||||
word-break-prop old-class over word-table-nth
|
||||
i str word-break?
|
||||
] if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
:: first-word ( str -- i )
|
||||
str unclip-slice word-break-prop over <enum>
|
||||
[ swap str word-break-next ] assoc-find 2drop
|
||||
nip swap length or 1+ ;
|
||||
: first-word ( str -- i )
|
||||
[ unclip-slice word-break-prop over <enum> ] keep
|
||||
'[ swap _ word-break-next ] assoc-find 2drop
|
||||
nip swap length or 1+ ; inline
|
||||
|
||||
HINTS: first-word string ;
|
||||
|
||||
: >words ( str -- words )
|
||||
[ first-word ] >pieces ;
|
||||
|
||||
HINTS: >words string ;
|
||||
|
|
|
@ -9,10 +9,6 @@ ARTICLE: "unicode.case" "Case mapping"
|
|||
{ $subsection >lower }
|
||||
{ $subsection >title }
|
||||
{ $subsection >case-fold }
|
||||
"There are analogous routines which operate on individual code points, but these should " { $emphasis "not be used" } " in general as they have slightly different behavior. In some cases, for example, they do not perform the case operation, as a single code point must expand to more than one."
|
||||
{ $subsection ch>upper }
|
||||
{ $subsection ch>lower }
|
||||
{ $subsection ch>title }
|
||||
"To test if a string is in a given case:"
|
||||
{ $subsection upper? }
|
||||
{ $subsection lower? }
|
||||
|
@ -35,7 +31,7 @@ HELP: >title
|
|||
{ $description "Converts a string to title case." } ;
|
||||
|
||||
HELP: >case-fold
|
||||
{ $values { "string" string } { "case-fold" string } }
|
||||
{ $values { "string" string } { "fold" string } }
|
||||
{ $description "Converts a string to case-folded form." } ;
|
||||
|
||||
HELP: upper?
|
||||
|
@ -53,18 +49,3 @@ HELP: title?
|
|||
HELP: case-fold?
|
||||
{ $values { "string" string } { "?" "a boolean" } }
|
||||
{ $description "Tests if a string is in case-folded form." } ;
|
||||
|
||||
HELP: ch>lower
|
||||
{ $values { "ch" "a code point" } { "lower" "a code point" } }
|
||||
{ $description "Converts a code point to lower case." }
|
||||
{ $warning "Don't use this unless you know what you're doing! " { $code ">lower" } " is not the same as " { $code "[ ch>lower ] map" } "." } ;
|
||||
|
||||
HELP: ch>upper
|
||||
{ $values { "ch" "a code point" } { "upper" "a code point" } }
|
||||
{ $description "Converts a code point to upper case." }
|
||||
{ $warning "Don't use this unless you know what you're doing! " { $code ">upper" } " is not the same as " { $code "[ ch>upper ] map" } "." } ;
|
||||
|
||||
HELP: ch>title
|
||||
{ $values { "ch" "a code point" } { "title" "a code point" } }
|
||||
{ $description "Converts a code point to title case." }
|
||||
{ $warning "Don't use this unless you know what you're doing! " { $code ">title" } " is not the same as " { $code "[ ch>title ] map" } "." } ;
|
||||
|
|
|
@ -4,14 +4,14 @@ USING: unicode.case tools.test namespaces ;
|
|||
\ >lower must-infer
|
||||
\ >title must-infer
|
||||
|
||||
[ "Hello How Are You? I'M Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test
|
||||
[ "Hello How Are You? I'm Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test
|
||||
[ "FUSS" ] [ "Fu\u0000DF" >upper ] unit-test
|
||||
[ "\u0003C3\u0003C2" ] [ "\u0003A3\u0003A3" >lower ] unit-test
|
||||
[ "\u0003C3a\u0003C2 \u0003C3\u0003C2 \u0003C3a\u0003C2" ] [ "\u0003A3A\u0003A3 \u0003A3\u0003A3 \u0003A3A\u0003A3" >lower ] unit-test
|
||||
[ t ] [ "hello how are you?" lower? ] unit-test
|
||||
[
|
||||
"tr" locale set
|
||||
[ "i\u000131i \u000131jj" ] [ "i\u000131I\u000307 IJj" >lower ] unit-test
|
||||
! [ "I\u00307\u000131i Ijj" ] [ "i\u000131I\u000307 IJj" >title ] unit-test
|
||||
[ "I\u000307\u000131i Ijj" ] [ "i\u000131I\u000307 IJj" >title ] unit-test
|
||||
[ "I\u000307II\u000307 IJJ" ] [ "i\u000131I\u000307 IJj" >upper ] unit-test
|
||||
"lt" locale set
|
||||
! Lithuanian casing tests
|
||||
|
|
|
@ -1,21 +1,30 @@
|
|||
! Copyright (C) 2008 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: unicode.data sequences sequences.next namespaces make
|
||||
unicode.normalize math unicode.categories combinators
|
||||
assocs strings splitting kernel accessors ;
|
||||
USING: unicode.data sequences sequences.next namespaces
|
||||
sbufs make unicode.syntax unicode.normalize math hints
|
||||
unicode.categories combinators unicode.syntax assocs
|
||||
strings splitting kernel accessors unicode.breaks fry locals ;
|
||||
QUALIFIED: ascii
|
||||
IN: unicode.case
|
||||
|
||||
<PRIVATE
|
||||
: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ;
|
||||
PRIVATE>
|
||||
: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ; inline
|
||||
|
||||
: ch>lower ( ch -- lower ) simple-lower at-default ;
|
||||
: ch>upper ( ch -- upper ) simple-upper at-default ;
|
||||
: ch>title ( ch -- title ) simple-title at-default ;
|
||||
: ch>lower ( ch -- lower ) simple-lower at-default ; inline
|
||||
: ch>upper ( ch -- upper ) simple-upper at-default ; inline
|
||||
: ch>title ( ch -- title ) simple-title at-default ; inline
|
||||
PRIVATE>
|
||||
|
||||
SYMBOL: locale ! Just casing locale, or overall?
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: split-subseq ( string sep -- strings )
|
||||
[ dup ] swap '[ _ split1-slice swap ] [ ] produce nip ;
|
||||
|
||||
: replace ( old new str -- newstr )
|
||||
[ split-subseq ] dip join ; inline
|
||||
|
||||
: i-dot? ( -- ? )
|
||||
locale get { "tr" "az" } member? ;
|
||||
|
||||
|
@ -23,82 +32,90 @@ SYMBOL: locale ! Just casing locale, or overall?
|
|||
|
||||
: dot-over ( -- ch ) HEX: 307 ;
|
||||
|
||||
: lithuanian-ch>upper ( ? next ch -- ? )
|
||||
rot [ 2drop f ]
|
||||
[ swap dot-over = over "ij" member? and swap , ] if ;
|
||||
|
||||
: lithuanian>upper ( string -- lower )
|
||||
[ f swap [ lithuanian-ch>upper ] each-next drop ] "" make ;
|
||||
"i\u000307" "i" replace
|
||||
"j\u000307" "j" replace ;
|
||||
|
||||
: mark-above? ( ch -- ? )
|
||||
combining-class 230 = ;
|
||||
|
||||
: lithuanian-ch>lower ( next ch -- )
|
||||
! This fails to add a dot above in certain edge cases
|
||||
! where there is a non-above combining mark before an above one
|
||||
! in Lithuanian
|
||||
dup , "IJ" member? swap mark-above? and [ dot-over , ] when ;
|
||||
: with-rest ( seq quot: ( seq -- seq ) -- seq )
|
||||
[ unclip ] dip swap slip prefix ; inline
|
||||
|
||||
: add-dots ( seq -- seq )
|
||||
[ [ "" ] [
|
||||
dup first mark-above?
|
||||
[ CHAR: combining-dot-above prefix ] when
|
||||
] if-empty ] with-rest ; inline
|
||||
|
||||
: lithuanian>lower ( string -- lower )
|
||||
[ [ lithuanian-ch>lower ] each-next ] "" make ;
|
||||
|
||||
: turk-ch>upper ( ch -- )
|
||||
dup CHAR: i =
|
||||
[ drop CHAR: I , dot-over , ] [ , ] if ;
|
||||
"i" split add-dots "i" join
|
||||
"j" split add-dots "i" join ; inline
|
||||
|
||||
: turk>upper ( string -- upper-i )
|
||||
[ [ turk-ch>upper ] each ] "" make ;
|
||||
|
||||
: turk-ch>lower ( ? next ch -- ? )
|
||||
{
|
||||
{ [ rot ] [ 2drop f ] }
|
||||
{ [ dup CHAR: I = ] [
|
||||
drop dot-over =
|
||||
dup CHAR: i HEX: 131 ? ,
|
||||
] }
|
||||
[ , drop f ]
|
||||
} cond ;
|
||||
"i" "I\u000307" replace ; inline
|
||||
|
||||
: turk>lower ( string -- lower-i )
|
||||
[ f swap [ turk-ch>lower ] each-next drop ] "" make ;
|
||||
"I\u000307" "i" replace
|
||||
"I" "\u000131" replace ; inline
|
||||
|
||||
: word-boundary ( prev char -- new ? )
|
||||
dup non-starter? [ drop dup ] when
|
||||
swap uncased? ;
|
||||
: fix-sigma-end ( string -- string )
|
||||
[ "" ] [
|
||||
dup peek CHAR: greek-small-letter-sigma =
|
||||
[ 1 head* CHAR: greek-small-letter-final-sigma suffix ] when
|
||||
] if-empty ; inline
|
||||
|
||||
: sigma-map ( string -- string )
|
||||
[
|
||||
swap [ uncased? ] keep not or
|
||||
[ drop HEX: 3C2 ] when
|
||||
] map-next ;
|
||||
{ CHAR: greek-capital-letter-sigma } split [ [
|
||||
[ { CHAR: greek-small-letter-sigma } ] [
|
||||
dup first uncased?
|
||||
CHAR: greek-small-letter-final-sigma
|
||||
CHAR: greek-small-letter-sigma ? prefix
|
||||
] if-empty
|
||||
] map ] with-rest concat fix-sigma-end ; inline
|
||||
|
||||
: final-sigma ( string -- string )
|
||||
HEX: 3A3 over member? [ sigma-map ] when ;
|
||||
CHAR: greek-capital-letter-sigma
|
||||
over member? [ sigma-map ] when
|
||||
"" like ; inline
|
||||
|
||||
:: map-case ( string string-quot char-quot -- case )
|
||||
string length <sbuf> :> out
|
||||
string [
|
||||
dup special-casing at
|
||||
[ string-quot call out push-all ]
|
||||
[ char-quot call out push ] ?if
|
||||
] each out "" like ; inline
|
||||
|
||||
: map-case ( string string-quot char-quot -- case )
|
||||
[
|
||||
[
|
||||
[ dup special-casing at ] 2dip
|
||||
[ [ % ] compose ] [ [ , ] compose ] bi* ?if
|
||||
] 2curry each
|
||||
] "" make ; inline
|
||||
PRIVATE>
|
||||
|
||||
: >lower ( string -- lower )
|
||||
i-dot? [ turk>lower ] when
|
||||
final-sigma [ lower>> ] [ ch>lower ] map-case ;
|
||||
i-dot? [ turk>lower ] when final-sigma
|
||||
[ lower>> ] [ ch>lower ] map-case ;
|
||||
|
||||
HINTS: >lower string ;
|
||||
|
||||
: >upper ( string -- upper )
|
||||
i-dot? [ turk>upper ] when
|
||||
[ upper>> ] [ ch>upper ] map-case ;
|
||||
|
||||
HINTS: >upper string ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (>title) ( string -- title )
|
||||
i-dot? [ turk>upper ] when
|
||||
[ title>> ] [ ch>title ] map-case ; inline
|
||||
|
||||
: title-word ( string -- title )
|
||||
unclip 1string [ >lower ] [ (>title) ] bi* prepend ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: >title ( string -- title )
|
||||
final-sigma
|
||||
CHAR: \s swap
|
||||
[ tuck word-boundary swapd
|
||||
[ title>> ] [ lower>> ] if ]
|
||||
[ tuck word-boundary swapd
|
||||
[ ch>title ] [ ch>lower ] if ]
|
||||
map-case nip ;
|
||||
final-sigma >words [ title-word ] map concat ;
|
||||
|
||||
HINTS: >title string ;
|
||||
|
||||
: >case-fold ( string -- fold )
|
||||
>upper >lower ;
|
||||
|
|
|
@ -3,57 +3,47 @@
|
|||
USING: help.markup help.syntax kernel ;
|
||||
IN: unicode.categories
|
||||
|
||||
HELP: LETTER?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether the code point is an upper-cased letter" } ;
|
||||
HELP: LETTER
|
||||
{ $class-description "The class of upper cased letters" } ;
|
||||
|
||||
HELP: Letter?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether the code point is a letter of any case" } ;
|
||||
HELP: Letter
|
||||
{ $class-description "The class of letters" } ;
|
||||
|
||||
HELP: alpha?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether the code point is alphanumeric" } ;
|
||||
HELP: alpha
|
||||
{ $class-description "The class of code points which are alphanumeric" } ;
|
||||
|
||||
HELP: blank?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether the code point is whitespace" } ;
|
||||
HELP: blank
|
||||
{ $class-description "The class of code points which are whitespace" } ;
|
||||
|
||||
HELP: character?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether a number is a code point which has been assigned" } ;
|
||||
HELP: character
|
||||
{ $class-description "The class of numbers which are pre-defined Unicode code points" } ;
|
||||
|
||||
HELP: control?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether a code point is a control character" } ;
|
||||
HELP: control
|
||||
{ $class-description "The class of control characters" } ;
|
||||
|
||||
HELP: digit?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether a code point is a digit" } ;
|
||||
HELP: digit
|
||||
{ $class-description "The class of code coints which are digits" } ;
|
||||
|
||||
HELP: letter?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether a code point is a lower-cased letter" } ;
|
||||
HELP: letter
|
||||
{ $class-description "The class of code points which are lower-cased letters" } ;
|
||||
|
||||
HELP: printable?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether a code point is printable, as opposed to being a control character or formatting character" } ;
|
||||
HELP: printable
|
||||
{ $class-description "The class of characters which are printable, as opposed to being control or formatting characters" } ;
|
||||
|
||||
HELP: uncased?
|
||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
||||
{ $description "Determines whether a character has a case" } ;
|
||||
HELP: uncased
|
||||
{ $class-description "The class of letters which don't have a case" } ;
|
||||
|
||||
ARTICLE: "unicode.categories" "Character classes"
|
||||
{ $vocab-link "unicode.categories" } " is a vocabulary which provides predicates for determining if a code point has a particular property, for example being a lower cased letter. These should be used in preference to the " { $vocab-link "ASCII" "ascii" } " equivalents in most cases. Below are links to the useful predicates, but note that each of these is defined to be a predicate class."
|
||||
{ $subsection blank? }
|
||||
{ $subsection letter? }
|
||||
{ $subsection LETTER? }
|
||||
{ $subsection Letter? }
|
||||
{ $subsection digit? }
|
||||
{ $subsection printable? }
|
||||
{ $subsection alpha? }
|
||||
{ $subsection control? }
|
||||
{ $subsection uncased? }
|
||||
{ $subsection character? } ;
|
||||
{ $vocab-link "unicode.categories" } " is a vocabulary which provides predicates for determining if a code point has a particular property, for example being a lower cased letter. These should be used in preference to the " { $vocab-link "ascii" } " equivalents in most cases. Below are links to classes of characters, but note that each of these also has a predicate defined, which is usually more useful."
|
||||
{ $subsection blank }
|
||||
{ $subsection letter }
|
||||
{ $subsection LETTER }
|
||||
{ $subsection Letter }
|
||||
{ $subsection digit }
|
||||
{ $subsection printable }
|
||||
{ $subsection alpha }
|
||||
{ $subsection control }
|
||||
{ $subsection uncased }
|
||||
{ $subsection character } ;
|
||||
|
||||
ABOUT: "unicode.categories"
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
USING: io io.files splitting grouping unicode.collation
|
||||
sequences kernel io.encodings.utf8 math.parser math.order
|
||||
tools.test assocs io.streams.null words ;
|
||||
tools.test assocs words ;
|
||||
IN: unicode.collation.tests
|
||||
|
||||
: parse-test ( -- strings )
|
||||
|
@ -25,4 +25,4 @@ IN: unicode.collation.tests
|
|||
unit-test
|
||||
|
||||
parse-test 2 <clumps>
|
||||
[ [ test-two ] assoc-each ] with-null-writer
|
||||
[ test-two ] assoc-each
|
||||
|
|
|
@ -15,37 +15,37 @@ ARTICLE: "unicode.data" "Unicode data tables"
|
|||
{ $subsection property? } ;
|
||||
|
||||
HELP: load-script
|
||||
{ $value { "filename" string } { "table" "an interval map" } }
|
||||
{ $values { "filename" string } { "table" "an interval map" } }
|
||||
{ $description "This loads a file that looks like Script.txt in the Unicode Character Database and converts it into an efficient interval map, where the keys are characters and the values are strings for the properties." } ;
|
||||
|
||||
HELP: canonical-entry
|
||||
{ $value { "char" "a code point" } { "seq" string } }
|
||||
{ $values { "char" "a code point" } { "seq" string } }
|
||||
{ $description "Finds the canonical decomposition (NFD) for a code point" } ;
|
||||
|
||||
HELP: combine-chars
|
||||
{ $value { "a" "a code point" } { "b" "a code point" } { "char/f" "a code point" } }
|
||||
{ $values { "a" "a code point" } { "b" "a code point" } { "char/f" "a code point" } }
|
||||
{ $description "If a followed by b can be combined in NFC, this returns the code point of their combination." } ;
|
||||
|
||||
HELP: compatibility-entry
|
||||
{ $value { "char" "a code point" } { "seq" string } }
|
||||
{ $values { "char" "a code point" } { "seq" string } }
|
||||
{ $description "This returns the compatibility decomposition (NFKD) for a code point" } ;
|
||||
|
||||
HELP: combining-class
|
||||
{ $value { "char" "a code point" } { "n" "an integer" } }
|
||||
{ $values { "char" "a code point" } { "n" "an integer" } }
|
||||
{ $description "Finds the combining class of a code point." } ;
|
||||
|
||||
HELP: non-starter?
|
||||
{ $value { "char" "a code point" } { "?" "a boolean" } }
|
||||
{ $values { "char" "a code point" } { "?" "a boolean" } }
|
||||
{ $description "Returns true if the code point has a combining class." } ;
|
||||
|
||||
HELP: char>name
|
||||
{ $value { "char" "a code point" } { "name" string } }
|
||||
{ $values { "char" "a code point" } { "name" string } }
|
||||
{ $description "Looks up the name of a given code point. Warning: this is not optimized for speed, to save space." } ;
|
||||
|
||||
HELP: name>char
|
||||
{ $value { "name" string } { "char" "a code point" } }
|
||||
{ $values { "name" string } { "char" "a code point" } }
|
||||
{ $description "Looks up the code point corresponding to a given name." } ;
|
||||
|
||||
HELP: property?
|
||||
{ $value { "char" "a code point" } { "property" string } { "?" "a boolean" } }
|
||||
{ $values { "char" "a code point" } { "property" string } { "?" "a boolean" } }
|
||||
{ $description "Tests whether the code point is listed under the given property in PropList.txt in the Unicode Character Database." } ;
|
||||
|
|
|
@ -4,7 +4,8 @@ USING: combinators.short-circuit assocs math kernel sequences
|
|||
io.files hashtables quotations splitting grouping arrays io
|
||||
math.parser hash2 math.order byte-arrays words namespaces words
|
||||
compiler.units parser io.encodings.ascii values interval-maps
|
||||
ascii sets combinators locals math.ranges sorting make io.encodings.utf8 ;
|
||||
ascii sets combinators locals math.ranges sorting make
|
||||
strings.parser io.encodings.utf8 ;
|
||||
IN: unicode.data
|
||||
|
||||
VALUE: simple-lower
|
||||
|
@ -23,9 +24,9 @@ VALUE: properties
|
|||
: combine-chars ( a b -- char/f ) combine-map hash2 ;
|
||||
: compatibility-entry ( char -- seq ) compatibility-map at ;
|
||||
: combining-class ( char -- n ) class-map at ;
|
||||
: non-starter? ( char -- ? ) class-map key? ;
|
||||
: name>char ( string -- char ) name-map at ;
|
||||
: char>name ( char -- string ) name-map value-at ;
|
||||
: non-starter? ( char -- ? ) combining-class { 0 f } member? not ;
|
||||
: name>char ( name -- char ) name-map at ;
|
||||
: char>name ( char -- name ) name-map value-at ;
|
||||
: property? ( char property -- ? ) properties at interval-key? ;
|
||||
|
||||
! Loading data from UnicodeData.txt
|
||||
|
@ -128,12 +129,9 @@ VALUE: properties
|
|||
cat categories index char table ?set-nth
|
||||
] assoc-each table fill-ranges ] ;
|
||||
|
||||
: ascii-lower ( string -- lower )
|
||||
[ dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ] map ;
|
||||
|
||||
: process-names ( data -- names-hash )
|
||||
1 swap (process-data) [
|
||||
ascii-lower { { CHAR: \s CHAR: - } } substitute swap
|
||||
>lower { { CHAR: \s CHAR: - } } substitute swap
|
||||
] H{ } assoc-map-as ;
|
||||
|
||||
: multihex ( hexstring -- string )
|
||||
|
@ -183,6 +181,13 @@ load-data {
|
|||
[ process-category to: category-map ]
|
||||
} cleave
|
||||
|
||||
: postprocess-class ( -- )
|
||||
combine-map [ [ second ] map ] map concat
|
||||
[ combining-class not ] filter
|
||||
[ 0 swap class-map set-at ] each ;
|
||||
|
||||
postprocess-class
|
||||
|
||||
load-special-casing to: special-casing
|
||||
|
||||
load-properties to: properties
|
||||
|
@ -214,3 +219,6 @@ SYMBOL: interned
|
|||
|
||||
: load-script ( filename -- table )
|
||||
ascii <file-reader> parse-script process-script ;
|
||||
|
||||
[ name>char [ "Invalid character" throw ] unless* ]
|
||||
name>char-hook set-global
|
||||
|
|
|
@ -23,5 +23,5 @@ HELP: nfkc
|
|||
{ $description "Converts a string to Normalization Form KC" } ;
|
||||
|
||||
HELP: nfkd
|
||||
{ $values { "string" string } { "nfc" "a string in NFKD" } }
|
||||
{ $values { "string" string } { "nfkd" "a string in NFKD" } }
|
||||
{ $description "Converts a string to Normalization Form KD" } ;
|
||||
|
|
|
@ -3,6 +3,8 @@ unicode.data io.encodings.utf8 io.files splitting math.parser
|
|||
locals math quotations assocs combinators unicode.normalize.private ;
|
||||
IN: unicode.normalize.tests
|
||||
|
||||
{ nfc nfkc nfd nfkd } [ must-infer ] each
|
||||
|
||||
[ "ab\u000323\u000302cd" ] [ "ab\u000302" "\u000323cd" string-append ] unit-test
|
||||
|
||||
[ "ab\u00064b\u000347\u00034e\u00034d\u000346" ] [ "ab\u000346\u000347\u00064b\u00034e\u00034d" dup reorder ] unit-test
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences namespaces make unicode.data kernel math arrays
|
||||
locals sorting.insertion accessors assocs math.order ;
|
||||
USING: ascii sequences namespaces make unicode.data kernel math arrays
|
||||
locals sorting.insertion accessors assocs math.order combinators
|
||||
unicode.syntax strings sbufs hints combinators.short-circuit vectors ;
|
||||
IN: unicode.normalize
|
||||
|
||||
<PRIVATE
|
||||
|
@ -18,16 +19,16 @@ CONSTANT: medial-count 21
|
|||
CONSTANT: final-count 28
|
||||
|
||||
: ?between? ( n/f from to -- ? )
|
||||
pick [ between? ] [ 3drop f ] if ;
|
||||
pick [ between? ] [ 3drop f ] if ; inline
|
||||
|
||||
: hangul? ( ch -- ? ) hangul-base hangul-end ?between? ;
|
||||
: jamo? ( ch -- ? ) HEX: 1100 HEX: 11FF ?between? ;
|
||||
: hangul? ( ch -- ? ) hangul-base hangul-end ?between? ; inline
|
||||
: jamo? ( ch -- ? ) HEX: 1100 HEX: 11FF ?between? ; inline
|
||||
|
||||
! These numbers come from UAX 29
|
||||
: initial? ( ch -- ? )
|
||||
dup HEX: 1100 HEX: 1159 ?between? [ ] [ HEX: 115F = ] ?if ;
|
||||
: medial? ( ch -- ? ) HEX: 1160 HEX: 11A2 ?between? ;
|
||||
: final? ( ch -- ? ) HEX: 11A8 HEX: 11F9 ?between? ;
|
||||
dup HEX: 1100 HEX: 1159 ?between? [ ] [ HEX: 115F = ] ?if ; inline
|
||||
: medial? ( ch -- ? ) HEX: 1160 HEX: 11A2 ?between? ; inline
|
||||
: final? ( ch -- ? ) HEX: 11A8 HEX: 11F9 ?between? ; inline
|
||||
|
||||
: hangul>jamo ( hangul -- jamo-string )
|
||||
hangul-base - final-count /mod final-base +
|
||||
|
@ -47,16 +48,16 @@ CONSTANT: final-count 28
|
|||
|
||||
: reorder-slice ( string start -- slice done? )
|
||||
2dup swap [ non-starter? not ] find-from drop
|
||||
[ [ over length ] unless* rot <slice> ] keep not ;
|
||||
[ [ over length ] unless* rot <slice> ] keep not ; inline
|
||||
|
||||
: reorder-next ( string i -- new-i done? )
|
||||
over [ non-starter? ] find-from drop [
|
||||
reorder-slice
|
||||
[ dup [ combining-class ] insertion-sort to>> ] dip
|
||||
] [ length t ] if* ;
|
||||
] [ length t ] if* ; inline
|
||||
|
||||
: reorder-loop ( string start -- )
|
||||
dupd reorder-next [ 2drop ] [ reorder-loop ] if ;
|
||||
dupd reorder-next [ 2drop ] [ reorder-loop ] if ; inline recursive
|
||||
|
||||
: reorder ( string -- )
|
||||
0 reorder-loop ;
|
||||
|
@ -65,108 +66,131 @@ CONSTANT: final-count 28
|
|||
over [ non-starter? not ] find-last-from drop ?1+ reorder-next 2drop ;
|
||||
|
||||
:: decompose ( string quot -- decomposed )
|
||||
! When there are 8 and 32-bit strings, this'll be
|
||||
! equivalent to clone on 8 and the contents of the last
|
||||
! main quotation on 32.
|
||||
string [ 127 < ] all? [ string ] [
|
||||
[
|
||||
string [
|
||||
dup hangul? [ hangul>jamo % ]
|
||||
[ dup quot call [ % ] [ , ] ?if ] if
|
||||
] each
|
||||
] "" make
|
||||
dup reorder
|
||||
] if ; inline
|
||||
string length <sbuf> :> out
|
||||
string [
|
||||
>fixnum dup ascii? [ out push ] [
|
||||
dup hangul? [ hangul>jamo out push-all ]
|
||||
[ dup quot call [ out push-all ] [ out push ] ?if ] if
|
||||
] if
|
||||
] each
|
||||
out "" like dup reorder ; inline
|
||||
|
||||
: with-string ( str quot -- str )
|
||||
over aux>> [ call ] [ drop ] if ; inline
|
||||
|
||||
: (nfd) ( string -- nfd )
|
||||
[ canonical-entry ] decompose ;
|
||||
|
||||
HINTS: (nfd) string ;
|
||||
|
||||
: (nfkd) ( string -- nfkd )
|
||||
[ compatibility-entry ] decompose ;
|
||||
|
||||
HINTS: (nfkd) string ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: nfd ( string -- nfd )
|
||||
[ canonical-entry ] decompose ;
|
||||
[ (nfd) ] with-string ;
|
||||
|
||||
: nfkd ( string -- nfkd )
|
||||
[ compatibility-entry ] decompose ;
|
||||
[ (nfkd) ] with-string ;
|
||||
|
||||
: string-append ( s1 s2 -- string )
|
||||
[ append ] keep
|
||||
0 over ?nth non-starter?
|
||||
[ length dupd reorder-back ] [ drop ] if ;
|
||||
|
||||
HINTS: string-append string string ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! Normalization -- Composition
|
||||
SYMBOL: main-str
|
||||
SYMBOL: ind
|
||||
SYMBOL: after
|
||||
SYMBOL: char
|
||||
|
||||
: get-str ( i -- ch ) ind get + main-str get ?nth ;
|
||||
: current ( -- ch ) 0 get-str ;
|
||||
: to ( -- ) ind inc ;
|
||||
: initial-medial? ( str i -- ? )
|
||||
{ [ swap nth initial? ] [ 1+ swap ?nth medial? ] } 2&& ;
|
||||
|
||||
: initial-medial? ( -- ? )
|
||||
current initial? [ 1 get-str medial? ] [ f ] if ;
|
||||
: --final? ( str i -- ? )
|
||||
2 + swap ?nth final? ;
|
||||
|
||||
: --final? ( -- ? )
|
||||
2 get-str final? ;
|
||||
: imf, ( str i -- str i )
|
||||
[ tail-slice first3 jamo>hangul , ]
|
||||
[ 3 + ] 2bi ;
|
||||
|
||||
: imf, ( -- )
|
||||
current to current to current jamo>hangul , ;
|
||||
: im, ( str i -- str i )
|
||||
[ tail-slice first2 final-base jamo>hangul , ]
|
||||
[ 2 + ] 2bi ;
|
||||
|
||||
: im, ( -- )
|
||||
current to current final-base jamo>hangul , ;
|
||||
: compose-jamo ( str i -- str i )
|
||||
2dup initial-medial? [
|
||||
2dup --final? [ imf, ] [ im, ] if
|
||||
] [ 2dup swap nth , 1+ ] if ;
|
||||
|
||||
: compose-jamo ( -- )
|
||||
initial-medial? [
|
||||
--final? [ imf, ] [ im, ] if
|
||||
] [ current , ] if to ;
|
||||
: pass-combining ( str -- str i )
|
||||
dup [ non-starter? not ] find drop
|
||||
[ dup length ] unless*
|
||||
2dup head-slice % ;
|
||||
|
||||
: pass-combining ( -- )
|
||||
current non-starter? [ current , to pass-combining ] when ;
|
||||
TUPLE: compose-state i str char after last-class ;
|
||||
|
||||
:: try-compose ( last-class new-char current-class -- new-class )
|
||||
last-class current-class = [ new-char after get push last-class ] [
|
||||
char get new-char combine-chars
|
||||
[ char set last-class ]
|
||||
[ new-char after get push current-class ] if*
|
||||
] if ;
|
||||
: get-str ( state i -- ch )
|
||||
swap [ i>> + ] [ str>> ] bi ?nth ; inline
|
||||
: current ( state -- ch ) 0 get-str ; inline
|
||||
: to ( state -- state ) [ 1+ ] change-i ; inline
|
||||
: push-after ( ch state -- state ) [ ?push ] change-after ; inline
|
||||
|
||||
:: try-compose ( state new-char current-class -- state )
|
||||
state last-class>> current-class =
|
||||
[ new-char state push-after ] [
|
||||
state char>> new-char combine-chars
|
||||
[ state swap >>char ] [
|
||||
new-char state push-after
|
||||
current-class >>last-class
|
||||
] if*
|
||||
] if ; inline
|
||||
|
||||
DEFER: compose-iter
|
||||
|
||||
: try-noncombining ( char -- )
|
||||
char get swap combine-chars
|
||||
[ char set to f compose-iter ] when* ;
|
||||
: try-noncombining ( char state -- state )
|
||||
tuck char>> swap combine-chars
|
||||
[ >>char to f >>last-class compose-iter ] when* ; inline
|
||||
|
||||
: compose-iter ( last-class -- )
|
||||
current [
|
||||
dup combining-class
|
||||
[ try-compose to compose-iter ]
|
||||
[ swap [ drop ] [ try-noncombining ] if ] if*
|
||||
] [ drop ] if* ;
|
||||
: compose-iter ( state -- state )
|
||||
dup current [
|
||||
dup combining-class {
|
||||
{ f [ drop ] }
|
||||
{ 0 [
|
||||
over last-class>>
|
||||
[ drop ] [ swap try-noncombining ] if ] }
|
||||
[ try-compose to compose-iter ]
|
||||
} case
|
||||
] when* ; inline recursive
|
||||
|
||||
: ?new-after ( -- )
|
||||
after [ dup empty? [ drop SBUF" " clone ] unless ] change ;
|
||||
: compose-combining ( ch str i -- str i )
|
||||
compose-state new
|
||||
swap >>i
|
||||
swap >>str
|
||||
swap >>char
|
||||
compose-iter
|
||||
{ [ char>> , ] [ after>> % ] [ str>> ] [ i>> ] } cleave ; inline
|
||||
|
||||
: (compose) ( -- )
|
||||
current [
|
||||
dup jamo? [ drop compose-jamo ] [
|
||||
char set to ?new-after
|
||||
f compose-iter
|
||||
char get , after get %
|
||||
:: (compose) ( str i -- )
|
||||
i str ?nth [
|
||||
dup jamo? [ drop str i compose-jamo ] [
|
||||
i 1+ str ?nth combining-class
|
||||
[ str i 1+ compose-combining ] [ , str i 1+ ] if
|
||||
] if (compose)
|
||||
] when* ;
|
||||
] when* ; inline recursive
|
||||
|
||||
: compose ( str -- comp )
|
||||
[
|
||||
main-str set
|
||||
0 ind set
|
||||
SBUF" " clone after set
|
||||
pass-combining (compose)
|
||||
] "" make ;
|
||||
: combine ( str -- comp )
|
||||
[ pass-combining (compose) ] "" make ;
|
||||
|
||||
HINTS: combine string ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: nfc ( string -- nfc )
|
||||
nfd compose ;
|
||||
[ (nfd) combine ] with-string ;
|
||||
|
||||
: nfkc ( string -- nfkc )
|
||||
nfkd compose ;
|
||||
[ (nfkd) combine ] with-string ;
|
||||
|
|
|
@ -24,8 +24,8 @@ HELP: group-cache
|
|||
HELP: group-id
|
||||
{ $values
|
||||
{ "string" string }
|
||||
{ "id" integer } }
|
||||
{ $description "Returns the group id given a group name." } ;
|
||||
{ "id/f" "an integer or f" } }
|
||||
{ $description "Returns the group id given a group name. Returns " { $link f } " if the group does not exist." } ;
|
||||
|
||||
HELP: group-name
|
||||
{ $values
|
||||
|
@ -36,7 +36,7 @@ HELP: group-name
|
|||
HELP: group-struct
|
||||
{ $values
|
||||
{ "obj" object }
|
||||
{ "group" "a group struct" } }
|
||||
{ "group/f" "a group struct or f" } }
|
||||
{ $description "Returns an alien group struct to be turned into a group tuple by calling subsequent words." } ;
|
||||
|
||||
HELP: real-group-id
|
||||
|
|
|
@ -3,7 +3,6 @@
|
|||
USING: tools.test unix.groups kernel strings math ;
|
||||
IN: unix.groups.tests
|
||||
|
||||
|
||||
[ ] [ all-groups drop ] unit-test
|
||||
|
||||
\ all-groups must-infer
|
||||
|
@ -24,3 +23,9 @@ IN: unix.groups.tests
|
|||
[ ] [ effective-group-id [ ] with-effective-group ] unit-test
|
||||
|
||||
[ ] [ [ ] with-group-cache ] unit-test
|
||||
|
||||
[ ] [ real-group-id group-name drop ] unit-test
|
||||
|
||||
[ "888888888888888" ] [ 888888888888888 group-name ] unit-test
|
||||
[ f ]
|
||||
[ "please-oh-please-don't-have-a-group-named-this123lalala" group-struct ] unit-test
|
||||
|
|
|
@ -13,7 +13,7 @@ TUPLE: group id name passwd members ;
|
|||
|
||||
SYMBOL: group-cache
|
||||
|
||||
GENERIC: group-struct ( obj -- group )
|
||||
GENERIC: group-struct ( obj -- group/f )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
@ -24,11 +24,14 @@ GENERIC: group-struct ( obj -- group )
|
|||
"group" <c-object> tuck 4096
|
||||
[ <byte-array> ] keep f <void*> ;
|
||||
|
||||
M: integer group-struct ( id -- group )
|
||||
(group-struct) getgrgid_r io-error ;
|
||||
: check-group-struct ( group-struct ptr -- group-struct/f )
|
||||
*void* [ drop f ] unless ;
|
||||
|
||||
M: string group-struct ( string -- group )
|
||||
(group-struct) getgrnam_r 0 = [ (io-error) ] unless ;
|
||||
M: integer group-struct ( id -- group/f )
|
||||
(group-struct) [ getgrgid_r io-error ] keep check-group-struct ;
|
||||
|
||||
M: string group-struct ( string -- group/f )
|
||||
(group-struct) [ getgrnam_r io-error ] keep check-group-struct ;
|
||||
|
||||
: group-struct>group ( group-struct -- group )
|
||||
[ \ group new ] dip
|
||||
|
@ -43,14 +46,14 @@ PRIVATE>
|
|||
|
||||
: group-name ( id -- string )
|
||||
dup group-cache get [
|
||||
at
|
||||
dupd at* [ name>> nip ] [ drop number>string ] if
|
||||
] [
|
||||
group-struct group-gr_name
|
||||
group-struct [ group-gr_name ] [ f ] if*
|
||||
] if*
|
||||
[ nip ] [ number>string ] if* ;
|
||||
|
||||
: group-id ( string -- id )
|
||||
group-struct group-gr_gid ;
|
||||
: group-id ( string -- id/f )
|
||||
group-struct [ group-gr_gid ] [ f ] if* ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
@ -71,7 +74,7 @@ M: string user-groups ( string -- seq )
|
|||
(user-groups) ;
|
||||
|
||||
M: integer user-groups ( id -- seq )
|
||||
username (user-groups) ;
|
||||
user-name (user-groups) ;
|
||||
|
||||
: all-groups ( -- seq )
|
||||
[ getgrent dup ] [ group-struct>group ] [ drop ] produce ;
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax ;
|
||||
USING: alien.syntax unix.types unix.stat ;
|
||||
IN: unix.statfs.freebsd
|
||||
|
||||
CONSTANT: MFSNAMELEN 16 ! length of type name including null */
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax ;
|
||||
USING: alien.syntax unix.types unix.stat ;
|
||||
IN: unix.statfs.linux
|
||||
|
||||
C-STRUCT: statfs64
|
||||
|
|
|
@ -2,7 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types io.encodings.utf8 io.encodings.string
|
||||
kernel sequences unix.stat accessors unix combinators math
|
||||
grouping system alien.strings math.bitwise alien.syntax ;
|
||||
grouping system alien.strings math.bitwise alien.syntax
|
||||
unix.types ;
|
||||
IN: unix.statfs.macosx
|
||||
|
||||
CONSTANT: MNT_RDONLY HEX: 00000001
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax ;
|
||||
USING: alien.syntax unix.types unix.stat ;
|
||||
IN: unix.statfs.openbsd
|
||||
|
||||
CONSTANT: MFSNAMELEN 16
|
||||
|
|
|
@ -7,13 +7,13 @@ HELP: all-users
|
|||
{ $values { "seq" sequence } }
|
||||
{ $description "Returns a sequence of high-level " { $link passwd } " tuples that are platform-dependent and field for field complete with the Unix " { $link passwd } " structure." } ;
|
||||
|
||||
HELP: effective-username
|
||||
HELP: effective-user-name
|
||||
{ $values { "string" string } }
|
||||
{ $description "Returns the effective username for the current user." } ;
|
||||
{ $description "Returns the effective user-name for the current user." } ;
|
||||
|
||||
HELP: effective-user-id
|
||||
{ $values { "id" integer } }
|
||||
{ $description "Returns the effective username id for the current user." } ;
|
||||
{ $description "Returns the effective user-name id for the current user." } ;
|
||||
|
||||
HELP: new-passwd
|
||||
{ $values { "passwd" passwd } }
|
||||
|
@ -31,9 +31,9 @@ HELP: passwd>new-passwd
|
|||
{ "new-passwd" "a passwd tuple" } }
|
||||
{ $description "A platform-specific conversion routine from a passwd structure to a passwd tuple." } ;
|
||||
|
||||
HELP: real-username
|
||||
HELP: real-user-name
|
||||
{ $values { "string" string } }
|
||||
{ $description "The real username of the current user." } ;
|
||||
{ $description "The real user-name of the current user." } ;
|
||||
|
||||
HELP: real-user-id
|
||||
{ $values { "id" integer } }
|
||||
|
@ -41,34 +41,34 @@ HELP: real-user-id
|
|||
|
||||
HELP: set-effective-user
|
||||
{ $values { "string/id" "a string or a user id" } }
|
||||
{ $description "Sets the current effective user given a username or a user id." } ;
|
||||
{ $description "Sets the current effective user given a user-name or a user id." } ;
|
||||
|
||||
HELP: set-real-user
|
||||
{ $values { "string/id" "a string or a user id" } }
|
||||
{ $description "Sets the current real user given a username or a user id." } ;
|
||||
{ $description "Sets the current real user given a user-name or a user id." } ;
|
||||
|
||||
HELP: user-passwd
|
||||
{ $values
|
||||
{ "obj" object }
|
||||
{ "passwd/f" "passwd or f" } }
|
||||
{ $description "Returns the passwd tuple given a username string or user id." } ;
|
||||
{ $description "Returns the passwd tuple given a user-name string or user id." } ;
|
||||
|
||||
HELP: username
|
||||
HELP: user-name
|
||||
{ $values
|
||||
{ "id" integer }
|
||||
{ "string" string } }
|
||||
{ $description "Returns the username associated with the user id." } ;
|
||||
{ $description "Returns the user-name associated with the user id." } ;
|
||||
|
||||
HELP: user-id
|
||||
{ $values
|
||||
{ "string" string }
|
||||
{ "id" integer } }
|
||||
{ $description "Returns the user id associated with the username." } ;
|
||||
{ $description "Returns the user id associated with the user-name." } ;
|
||||
|
||||
HELP: with-effective-user
|
||||
{ $values
|
||||
{ "string/id" "a string or a uid" } { "quot" quotation } }
|
||||
{ $description "Sets the effective username and calls the quotation. Restores the current username on success or on error after the call." } ;
|
||||
{ $description "Sets the effective user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ;
|
||||
|
||||
HELP: with-user-cache
|
||||
{ $values
|
||||
|
@ -78,11 +78,11 @@ HELP: with-user-cache
|
|||
HELP: with-real-user
|
||||
{ $values
|
||||
{ "string/id" "a string or a uid" } { "quot" quotation } }
|
||||
{ $description "Sets the real username and calls the quotation. Restores the current username on success or on error after the call." } ;
|
||||
{ $description "Sets the real user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ;
|
||||
|
||||
{
|
||||
real-username real-user-id set-real-user
|
||||
effective-username effective-user-id
|
||||
real-user-name real-user-id set-real-user
|
||||
effective-user-name effective-user-id
|
||||
set-effective-user
|
||||
} related-words
|
||||
|
||||
|
@ -93,11 +93,11 @@ $nl
|
|||
{ $subsection all-users }
|
||||
"Returning a passwd tuple:"
|
||||
"Real user:"
|
||||
{ $subsection real-username }
|
||||
{ $subsection real-user-name }
|
||||
{ $subsection real-user-id }
|
||||
{ $subsection set-real-user }
|
||||
"Effective user:"
|
||||
{ $subsection effective-username }
|
||||
{ $subsection effective-user-name }
|
||||
{ $subsection effective-user-id }
|
||||
{ $subsection set-effective-user }
|
||||
"Combinators to change users:"
|
||||
|
|
|
@ -8,8 +8,8 @@ IN: unix.users.tests
|
|||
|
||||
\ all-users must-infer
|
||||
|
||||
[ t ] [ real-username string? ] unit-test
|
||||
[ t ] [ effective-username string? ] unit-test
|
||||
[ t ] [ real-user-name string? ] unit-test
|
||||
[ t ] [ effective-user-name string? ] unit-test
|
||||
|
||||
[ t ] [ real-user-id integer? ] unit-test
|
||||
[ t ] [ effective-user-id integer? ] unit-test
|
||||
|
@ -17,14 +17,14 @@ IN: unix.users.tests
|
|||
[ ] [ real-user-id set-real-user ] unit-test
|
||||
[ ] [ effective-user-id set-effective-user ] unit-test
|
||||
|
||||
[ ] [ real-username [ ] with-real-user ] unit-test
|
||||
[ ] [ real-user-name [ ] with-real-user ] unit-test
|
||||
[ ] [ real-user-id [ ] with-real-user ] unit-test
|
||||
|
||||
[ ] [ effective-username [ ] with-effective-user ] unit-test
|
||||
[ ] [ effective-user-name [ ] with-effective-user ] unit-test
|
||||
[ ] [ effective-user-id [ ] with-effective-user ] unit-test
|
||||
|
||||
[ ] [ [ ] with-user-cache ] unit-test
|
||||
|
||||
[ "9999999999999999999" ] [ 9999999999999999999 username ] unit-test
|
||||
[ "9999999999999999999" ] [ 9999999999999999999 user-name ] unit-test
|
||||
|
||||
[ f ] [ 89898989898989898989898989898 user-passwd ] unit-test
|
||||
|
|
|
@ -7,7 +7,7 @@ accessors math.parser fry assocs namespaces continuations
|
|||
vocabs.loader system ;
|
||||
IN: unix.users
|
||||
|
||||
TUPLE: passwd username password uid gid gecos dir shell ;
|
||||
TUPLE: passwd user-name password uid gid gecos dir shell ;
|
||||
|
||||
HOOK: new-passwd os ( -- passwd )
|
||||
HOOK: passwd>new-passwd os ( passwd -- new-passwd )
|
||||
|
@ -20,7 +20,7 @@ M: unix new-passwd ( -- passwd )
|
|||
M: unix passwd>new-passwd ( passwd -- seq )
|
||||
[ new-passwd ] dip
|
||||
{
|
||||
[ passwd-pw_name >>username ]
|
||||
[ passwd-pw_name >>user-name ]
|
||||
[ passwd-pw_passwd >>password ]
|
||||
[ passwd-pw_uid >>uid ]
|
||||
[ passwd-pw_gid >>gid ]
|
||||
|
@ -56,9 +56,9 @@ M: integer user-passwd ( id -- passwd/f )
|
|||
M: string user-passwd ( string -- passwd/f )
|
||||
getpwnam dup [ passwd>new-passwd ] when ;
|
||||
|
||||
: username ( id -- string )
|
||||
: user-name ( id -- string )
|
||||
dup user-passwd
|
||||
[ nip username>> ] [ number>string ] if* ;
|
||||
[ nip user-name>> ] [ number>string ] if* ;
|
||||
|
||||
: user-id ( string -- id )
|
||||
user-passwd uid>> ;
|
||||
|
@ -66,14 +66,14 @@ M: string user-passwd ( string -- passwd/f )
|
|||
: real-user-id ( -- id )
|
||||
getuid ; inline
|
||||
|
||||
: real-username ( -- string )
|
||||
real-user-id username ; inline
|
||||
: real-user-name ( -- string )
|
||||
real-user-id user-name ; inline
|
||||
|
||||
: effective-user-id ( -- id )
|
||||
geteuid ; inline
|
||||
|
||||
: effective-username ( -- string )
|
||||
effective-user-id username ; inline
|
||||
: effective-user-name ( -- string )
|
||||
effective-user-id user-name ; inline
|
||||
|
||||
GENERIC: set-real-user ( string/id -- )
|
||||
|
||||
|
|
|
@ -15,7 +15,17 @@ ABOUT: "values"
|
|||
HELP: VALUE:
|
||||
{ $syntax "VALUE: word" }
|
||||
{ $values { "word" "a word to be created" } }
|
||||
{ $description "Creates a value on the given word, initializing it to hold " { $code f } ". To get the value, just run the word. To set it, use " { $link set-value } "." } ;
|
||||
{ $description "Creates a value on the given word, initializing it to hold " { $snippet "f" } ". To get the value, just run the word. To set it, use " { $link POSTPONE: to: } "." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: values math prettyprint ;"
|
||||
"IN: scratchpad"
|
||||
"VALUE: x"
|
||||
"2 2 + to: x"
|
||||
"x ."
|
||||
"4"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: get-value
|
||||
{ $values { "word" "a value word" } { "value" "the contents" } }
|
||||
|
|
|
@ -5,7 +5,7 @@ USING: kernel namespaces make xmode.rules xmode.tokens
|
|||
xmode.marker.state xmode.marker.context xmode.utilities
|
||||
xmode.catalog sequences math assocs combinators strings
|
||||
parser-combinators.regexp splitting parser-combinators ascii
|
||||
unicode.case combinators.short-circuit accessors ;
|
||||
ascii combinators.short-circuit accessors ;
|
||||
|
||||
! Based on org.gjt.sp.jedit.syntax.TokenMarker
|
||||
|
||||
|
|
|
@ -15,6 +15,12 @@ HELP: <=>
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: >=<
|
||||
{ $values { "obj1" object } { "obj2" object } { ">=<" "an ordering specifier" } }
|
||||
{ $description "Compares two objects using the " { $link <=> } " comparator and inverts the output." } ;
|
||||
|
||||
{ <=> >=< } related-words
|
||||
|
||||
HELP: +lt+
|
||||
{ $description "Output by " { $link <=> } " when the first object is strictly less than the second object." } ;
|
||||
|
||||
|
@ -85,6 +91,7 @@ ARTICLE: "order-specifiers" "Ordering specifiers"
|
|||
ARTICLE: "math.order" "Linear order protocol"
|
||||
"Some classes have an intrinsic order amongst instances:"
|
||||
{ $subsection <=> }
|
||||
{ $subsection >=< }
|
||||
{ $subsection compare }
|
||||
{ $subsection invert-comparison }
|
||||
"The above words output order specifiers."
|
||||
|
|
|
@ -13,6 +13,8 @@ SYMBOL: +gt+
|
|||
|
||||
GENERIC: <=> ( obj1 obj2 -- <=> )
|
||||
|
||||
: >=< ( obj1 obj2 -- >=< ) <=> invert-comparison ; inline
|
||||
|
||||
M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ;
|
||||
|
||||
GENERIC: before? ( obj1 obj2 -- ? )
|
||||
|
|
|
@ -34,6 +34,7 @@ ARTICLE: "defining-words" "Defining words"
|
|||
{ $see POSTPONE: SYMBOL: }
|
||||
"The key factor in the definition of " { $link POSTPONE: SYMBOL: } " is " { $link CREATE } ", which reads a token from the input and creates a word with that name. This word is then passed to " { $link define-symbol } "."
|
||||
{ $subsection CREATE }
|
||||
{ $subsection CREATE-WORD }
|
||||
"Colon definitions are defined in a more elaborate way:"
|
||||
{ $subsection POSTPONE: : }
|
||||
"The " { $link POSTPONE: : } " word first calls " { $link CREATE } ", and then reads input until reaching " { $link POSTPONE: ; } " using a utility word:"
|
||||
|
|
|
@ -338,6 +338,10 @@ HELP: 2each
|
|||
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- )" } } }
|
||||
{ $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
|
||||
|
||||
HELP: 3each
|
||||
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- )" } } }
|
||||
{ $description "Applies the quotation to triples of elements from " { $snippet "seq1" } ", " { $snippet "seq2" } " and " { $snippet "seq3" } "." } ;
|
||||
|
||||
HELP: 2reduce
|
||||
{ $values { "seq1" sequence }
|
||||
{ "seq2" sequence }
|
||||
|
@ -350,10 +354,18 @@ HELP: 2map
|
|||
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } }
|
||||
{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ;
|
||||
|
||||
HELP: 3map
|
||||
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- new )" } } { "newseq" "a new sequence" } }
|
||||
{ $description "Applies the quotation to each triple of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ;
|
||||
|
||||
HELP: 2map-as
|
||||
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
|
||||
{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ;
|
||||
|
||||
HELP: 3map-as
|
||||
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
|
||||
{ $description "Applies the quotation to each triple of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ;
|
||||
|
||||
HELP: 2all?
|
||||
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- ? )" } } { "?" "a boolean" } }
|
||||
{ $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
|
||||
|
@ -1262,6 +1274,17 @@ HELP: shorten
|
|||
"V{ 1 2 3 }"
|
||||
} } ;
|
||||
|
||||
HELP: iota
|
||||
{ $values { "n" integer } { "iota" iota } }
|
||||
{ $description "Creates an immutable virtual sequence containing the integers from 0 to " { $snippet "n-1" } "." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: math sequences prettyprint ;"
|
||||
"3 iota [ sq ] map ."
|
||||
"{ 0 1 4 }"
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
|
||||
"The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance."
|
||||
$nl
|
||||
|
@ -1422,16 +1445,23 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
|
|||
{ $subsection all? }
|
||||
"Testing how elements are related:"
|
||||
{ $subsection monotonic? }
|
||||
{ $subsection "sequence-2combinators" } ;
|
||||
{ $subsection "sequence-2combinators" }
|
||||
{ $subsection "sequence-3combinators" } ;
|
||||
|
||||
ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators"
|
||||
"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined."
|
||||
"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, then only the prefix having the length of the minimum of the two is examined."
|
||||
{ $subsection 2each }
|
||||
{ $subsection 2reduce }
|
||||
{ $subsection 2map }
|
||||
{ $subsection 2map-as }
|
||||
{ $subsection 2all? } ;
|
||||
|
||||
ARTICLE: "sequence-3combinators" "Triple-wise sequence combinators"
|
||||
"There is a set of combinators which traverse three sequences triple-wise. If one sequence is shorter than the others, then only the prefix having the length of the minimum of the three is examined."
|
||||
{ $subsection 3each }
|
||||
{ $subsection 3map }
|
||||
{ $subsection 3map-as } ;
|
||||
|
||||
ARTICLE: "sequences-tests" "Testing sequences"
|
||||
"Testing for an empty sequence:"
|
||||
{ $subsection empty? }
|
||||
|
|
|
@ -276,4 +276,8 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ;
|
|||
|
||||
{ 3 0 } [ [ 3drop ] 3each ] must-infer-as
|
||||
|
||||
[ V{ 0 3 } ] [ "A" { "A" "B" "C" "A" "D" } indices ] unit-test
|
||||
[ V{ 0 3 } ] [ "A" { "A" "B" "C" "A" "D" } indices ] unit-test
|
||||
|
||||
[ "asdf" iota ] must-fail
|
||||
[ T{ iota { n 10 } } ] [ 10 iota ] unit-test
|
||||
[ 0 ] [ 10 iota first ] unit-test
|
||||
|
|
|
@ -101,6 +101,20 @@ M: integer nth-unsafe drop ;
|
|||
|
||||
INSTANCE: integer immutable-sequence
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! In the future, this will replace integer sequences
|
||||
TUPLE: iota { n integer read-only } ;
|
||||
|
||||
: iota ( n -- iota ) \ iota boa ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
M: iota length n>> ;
|
||||
M: iota nth-unsafe drop ;
|
||||
|
||||
INSTANCE: iota immutable-sequence
|
||||
|
||||
: first-unsafe ( seq -- first )
|
||||
0 swap nth-unsafe ; inline
|
||||
|
||||
|
|
|
@ -20,7 +20,8 @@ ABOUT: "sequences-sorting"
|
|||
|
||||
HELP: sort
|
||||
{ $values { "seq" "a sequence" } { "quot" { $quotation "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } }
|
||||
{ $description "Sorts the elements into a new array." } ;
|
||||
{ $description "Sorts the elements into a new array using a stable sort." }
|
||||
{ $notes "The algorithm used is the merge sort." } ;
|
||||
|
||||
HELP: sort-keys
|
||||
{ $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } }
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
USING: io io.files io.files.temp io.streams.duplex kernel
|
||||
sequences sequences.private strings vectors words memoize
|
||||
splitting grouping hints tr continuations io.encodings.ascii
|
||||
unicode.case ;
|
||||
ascii ;
|
||||
IN: benchmark.reverse-complement
|
||||
|
||||
TR: trans-map ch>upper "ACGTUMRYKVHDB" "TGCAAKYRMBDHV" ;
|
||||
|
|
|
@ -201,6 +201,9 @@ SYMBOL: :uses
|
|||
: fuel-apropos-xref ( str -- )
|
||||
words-matching fuel-format-xrefs fuel-eval-set-result ; inline
|
||||
|
||||
: fuel-vocab-xref ( vocab -- )
|
||||
words fuel-format-xrefs fuel-eval-set-result ; inline
|
||||
|
||||
! Completion support
|
||||
|
||||
: fuel-filter-prefix ( seq prefix -- seq )
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: kernel sequences io.files io.files.temp io.launcher
|
|||
io.pathnames io.encodings.ascii io.streams.string http.client
|
||||
generalizations combinators math.parser math.vectors
|
||||
math.intervals interval-maps memoize csv accessors assocs
|
||||
strings math splitting grouping arrays ;
|
||||
strings math splitting grouping arrays combinators.smart ;
|
||||
IN: geo-ip
|
||||
|
||||
: db-path ( -- path ) "IpToCountry.csv" temp-file ;
|
||||
|
@ -20,15 +20,17 @@ IN: geo-ip
|
|||
TUPLE: ip-entry from to registry assigned city cntry country ;
|
||||
|
||||
: parse-ip-entry ( row -- ip-entry )
|
||||
7 firstn {
|
||||
[ string>number ]
|
||||
[ string>number ]
|
||||
[ ]
|
||||
[ ]
|
||||
[ ]
|
||||
[ ]
|
||||
[ ]
|
||||
} spread ip-entry boa ;
|
||||
[
|
||||
{
|
||||
[ string>number ]
|
||||
[ string>number ]
|
||||
[ ]
|
||||
[ ]
|
||||
[ ]
|
||||
[ ]
|
||||
[ ]
|
||||
} spread
|
||||
] input<sequence ip-entry boa ;
|
||||
|
||||
MEMO: ip-db ( -- seq )
|
||||
download-db ascii file-lines
|
||||
|
|
|
@ -2,7 +2,7 @@ USING: arrays combinators kernel lists math math.parser
|
|||
namespaces parser lexer parser-combinators
|
||||
parser-combinators.simple promises quotations sequences strings
|
||||
math.order assocs prettyprint.backend prettyprint.custom memoize
|
||||
unicode.case unicode.categories combinators.short-circuit
|
||||
ascii unicode.categories combinators.short-circuit
|
||||
accessors make io ;
|
||||
IN: parser-combinators.regexp
|
||||
|
||||
|
|
|
@ -0,0 +1,6 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel tools.test usa-cities ;
|
||||
IN: usa-cities.tests
|
||||
|
||||
[ t ] [ 55406 find-zip-code name>> "Minneapolis" = ] unit-test
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.files io.encodings.ascii sequences generalizations
|
||||
math.parser combinators kernel memoize csv summary
|
||||
words accessors math.order binary-search ;
|
||||
words accessors math.order binary-search combinators.smart ;
|
||||
IN: usa-cities
|
||||
|
||||
SINGLETONS: AK AL AR AS AZ CA CO CT DC DE FL GA HI IA ID IL IN
|
||||
|
@ -30,15 +30,17 @@ first-zip name state latitude longitude gmt-offset dst-offset ;
|
|||
MEMO: cities ( -- seq )
|
||||
"resource:extra/usa-cities/zipcode.csv" ascii <file-reader>
|
||||
csv rest-slice [
|
||||
7 firstn {
|
||||
[ string>number ]
|
||||
[ ]
|
||||
[ string>state ]
|
||||
[ string>number ]
|
||||
[ string>number ]
|
||||
[ string>number ]
|
||||
[ string>number ]
|
||||
} spread city boa
|
||||
[
|
||||
{
|
||||
[ string>number ]
|
||||
[ ]
|
||||
[ string>state ]
|
||||
[ string>number ]
|
||||
[ string>number ]
|
||||
[ string>number ]
|
||||
[ string>number ]
|
||||
} spread
|
||||
] input<sequence city boa
|
||||
] map ;
|
||||
|
||||
MEMO: cities-named ( name -- cities )
|
||||
|
|
|
@ -70,11 +70,13 @@ beast.
|
|||
- C-cC-ds : short help word at point
|
||||
- C-cC-de : show stack effect of current sexp (with prefix, region)
|
||||
- C-cC-dp : find words containing given substring (M-x fuel-apropos)
|
||||
- C-cC-dv : show words in current file (with prefix, ask for vocab)
|
||||
|
||||
- C-cM-<, C-cC-d< : show callers of word at point
|
||||
- C-cM->, C-cC-d> : show callees of word at point
|
||||
|
||||
- C-cC-xw : extract region as a separate word
|
||||
- C-cC-xs : extract innermost sexp (up to point) as a separate word
|
||||
- C-cC-xr : extract region as a separate word
|
||||
|
||||
*** In the listener:
|
||||
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
;;; factor-mode.el -- mode for editing Factor source
|
||||
|
||||
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
|
||||
;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
|
@ -28,6 +28,14 @@
|
|||
:group 'fuel
|
||||
:group 'languages)
|
||||
|
||||
(defcustom factor-mode-cycle-always-ask-p t
|
||||
"Whether to always ask for file creation when cycling to a
|
||||
source/docs/tests file.
|
||||
|
||||
When set to false, you'll be asked only once."
|
||||
:type 'boolean
|
||||
:group 'factor-mode)
|
||||
|
||||
(defcustom factor-mode-use-fuel t
|
||||
"Whether to use the full FUEL facilities in factor mode.
|
||||
|
||||
|
@ -174,33 +182,58 @@ code in the buffer."
|
|||
(defconst factor-mode--cycle-endings
|
||||
'(".factor" "-tests.factor" "-docs.factor"))
|
||||
|
||||
(defconst factor-mode--regex-cycle-endings
|
||||
(format "\\(.*?\\)\\(%s\\)$"
|
||||
(regexp-opt factor-mode--cycle-endings)))
|
||||
(make-local-variable
|
||||
(defvar factor-mode--cycling-no-ask nil))
|
||||
|
||||
(defconst factor-mode--cycle-endings-ring
|
||||
(defvar factor-mode--cycle-ring
|
||||
(let ((ring (make-ring (length factor-mode--cycle-endings))))
|
||||
(dolist (e factor-mode--cycle-endings ring)
|
||||
(ring-insert ring e))))
|
||||
(ring-insert ring e))
|
||||
ring))
|
||||
|
||||
(defconst factor-mode--cycle-basename-regex
|
||||
(format "\\(.+?\\)\\(%s\\)$" (regexp-opt factor-mode--cycle-endings)))
|
||||
|
||||
(defun factor-mode--cycle-split (basename)
|
||||
(when (string-match factor-mode--cycle-basename-regex basename)
|
||||
(cons (match-string 1 basename) (match-string 2 basename))))
|
||||
|
||||
(defun factor-mode--cycle-next (file)
|
||||
(let* ((match (string-match factor-mode--regex-cycle-endings file))
|
||||
(base (and match (match-string-no-properties 1 file)))
|
||||
(ending (and match (match-string-no-properties 2 file)))
|
||||
(idx (and ending (ring-member factor-mode--cycle-endings-ring ending)))
|
||||
(gfl (lambda (i) (concat base (ring-ref factor-mode--cycle-endings-ring i)))))
|
||||
(if (not idx) file
|
||||
(let ((l (length factor-mode--cycle-endings)) (i 1) next)
|
||||
(while (and (not next) (< i l))
|
||||
(when (file-exists-p (funcall gfl (+ idx i)))
|
||||
(setq next (+ idx i)))
|
||||
(setq i (1+ i)))
|
||||
(funcall gfl (or next idx))))))
|
||||
(let* ((dir (file-name-directory file))
|
||||
(basename (file-name-nondirectory file))
|
||||
(p/s (factor-mode--cycle-split basename))
|
||||
(prefix (car p/s))
|
||||
(ring factor-mode--cycle-ring)
|
||||
(idx (or (ring-member ring (cdr p/s)) 0))
|
||||
(len (ring-size ring))
|
||||
(i 1)
|
||||
(result nil))
|
||||
(while (and (< i len) (not result))
|
||||
(let* ((suffix (ring-ref ring (+ i idx)))
|
||||
(path (expand-file-name (concat prefix suffix) dir)))
|
||||
(when (or (file-exists-p path)
|
||||
(and (not (member suffix factor-mode--cycling-no-ask))
|
||||
(y-or-n-p (format "Create %s? " path))))
|
||||
(setq result path))
|
||||
(when (and (not factor-mode-cycle-always-ask-p)
|
||||
(not (member suffix factor-mode--cycling-no-ask)))
|
||||
(setq factor-mode--cycling-no-ask
|
||||
(cons name factor-mode--cycling-no-ask))))
|
||||
(setq i (1+ i)))
|
||||
result))
|
||||
|
||||
(defsubst factor-mode--cycling-setup ()
|
||||
(setq factor-mode--cycling-no-ask nil))
|
||||
|
||||
(defun factor-mode-visit-other-file (&optional file)
|
||||
"Cycle between code, tests and docs factor files."
|
||||
(interactive)
|
||||
(find-file (factor-mode--cycle-next (or file (buffer-file-name)))))
|
||||
(let ((file (factor-mode--cycle-next (or file (buffer-file-name)))))
|
||||
(unless file (error "No other file found"))
|
||||
(find-file file)
|
||||
(unless (file-exists-p file)
|
||||
(set-buffer-modified-p t)
|
||||
(save-buffer))))
|
||||
|
||||
|
||||
;;; Keymap:
|
||||
|
@ -208,7 +241,7 @@ code in the buffer."
|
|||
(defun factor-mode-insert-and-indent (n)
|
||||
(interactive "p")
|
||||
(self-insert-command n)
|
||||
(indent-for-tab-command))
|
||||
(indent-according-to-mode))
|
||||
|
||||
(defvar factor-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
|
@ -237,6 +270,7 @@ code in the buffer."
|
|||
(factor-mode--keymap-setup)
|
||||
(factor-mode--indentation-setup)
|
||||
(factor-mode--syntax-setup)
|
||||
(factor-mode--cycling-setup)
|
||||
(when factor-mode-use-fuel (require 'fuel-mode) (fuel-mode))
|
||||
(run-hooks 'factor-mode-hook))
|
||||
|
||||
|
|
|
@ -57,7 +57,10 @@
|
|||
(defun fuel-autodoc--eldoc-function ()
|
||||
(or (and fuel-autodoc--fallback-function
|
||||
(funcall fuel-autodoc--fallback-function))
|
||||
(fuel-autodoc--word-synopsis)))
|
||||
(condition-case e
|
||||
(fuel-autodoc--word-synopsis)
|
||||
(error (format "Autodoc not available (%s)"
|
||||
(error-message-string e))))))
|
||||
|
||||
|
||||
;;; Autodoc mode:
|
||||
|
|
|
@ -29,10 +29,7 @@
|
|||
(defun fuel-con--get-connection (buffer/proc)
|
||||
(if (processp buffer/proc)
|
||||
(fuel-con--get-connection (process-buffer buffer/proc))
|
||||
(with-current-buffer buffer/proc
|
||||
(or fuel-con--connection
|
||||
(setq fuel-con--connection
|
||||
(fuel-con--setup-connection buffer/proc))))))
|
||||
(with-current-buffer buffer/proc fuel-con--connection)))
|
||||
|
||||
|
||||
;;; Request and connection datatypes:
|
||||
|
@ -126,19 +123,20 @@
|
|||
(defun fuel-con--setup-connection (buffer)
|
||||
(set-buffer buffer)
|
||||
(fuel-con--cleanup-connection fuel-con--connection)
|
||||
(setq fuel-con--connection nil)
|
||||
(let ((conn (fuel-con--make-connection buffer)))
|
||||
(fuel-con--setup-comint)
|
||||
(prog1
|
||||
(setq fuel-con--connection conn)
|
||||
(fuel-con--connection-start-timer conn))))
|
||||
(fuel-con--establish-connection conn buffer)))
|
||||
|
||||
(defconst fuel-con--prompt-regex "( .+ ) ")
|
||||
(defconst fuel-con--eot-marker "<~FUEL~>")
|
||||
(defconst fuel-con--init-stanza "USE: fuel fuel-retort")
|
||||
|
||||
(defconst fuel-con--comint-finished-regex
|
||||
(defconst fuel-con--comint-finished-regex-connected
|
||||
(format "^%s$" fuel-con--eot-marker))
|
||||
|
||||
(defvar fuel-con--comint-finished-regex fuel-con--prompt-regex)
|
||||
|
||||
(defun fuel-con--setup-comint ()
|
||||
(set (make-local-variable 'comint-redirect-insert-matching-regexp) t)
|
||||
(add-hook 'comint-redirect-filter-functions
|
||||
|
@ -154,17 +152,43 @@
|
|||
(setq comint-redirect-finished-regexp fuel-con--prompt-regex))
|
||||
str)
|
||||
|
||||
(defun fuel-con--establish-connection (conn buffer)
|
||||
(with-current-buffer (fuel-con--comint-buffer) (erase-buffer))
|
||||
(with-current-buffer buffer
|
||||
(setq fuel-con--connection conn)
|
||||
(setq fuel-con--comint-finished-regex fuel-con--prompt-regex)
|
||||
(fuel-con--send-string/wait buffer
|
||||
fuel-con--init-stanza
|
||||
'fuel-con--establish-connection-cont
|
||||
20000)
|
||||
conn))
|
||||
|
||||
(defun fuel-con--establish-connection-cont (ignore)
|
||||
(let ((str (with-current-buffer (fuel-con--comint-buffer) (buffer-string))))
|
||||
(if (string-match fuel-con--eot-marker str)
|
||||
(progn
|
||||
(setq fuel-con--comint-finished-regex
|
||||
fuel-con--comint-finished-regex-connected)
|
||||
(fuel-con--connection-start-timer conn)
|
||||
(message "FUEL listener up and running!"))
|
||||
(fuel-con--connection-clean-current-request fuel-con--connection)
|
||||
(setq fuel-con--connection nil)
|
||||
(message "An error occurred initialising FUEL's Factor library!")
|
||||
(pop-to-buffer (fuel-con--comint-buffer)))))
|
||||
|
||||
|
||||
;;; Requests handling:
|
||||
|
||||
(defsubst fuel-con--comint-buffer ()
|
||||
(get-buffer-create " *fuel connection retort*"))
|
||||
|
||||
(defsubst fuel-con--comint-buffer-form ()
|
||||
(defun fuel-con--comint-buffer-form ()
|
||||
(with-current-buffer (fuel-con--comint-buffer)
|
||||
(goto-char (point-min))
|
||||
(condition-case nil
|
||||
(read (current-buffer))
|
||||
(let ((form (read (current-buffer))))
|
||||
(if (listp form) form
|
||||
(list 'fuel-con-error (buffer-string))))
|
||||
(error (list 'fuel-con-error (buffer-string))))))
|
||||
|
||||
(defun fuel-con--process-next (con)
|
||||
|
@ -208,11 +232,12 @@
|
|||
|
||||
;;; Message sending interface:
|
||||
|
||||
(defconst fuel-con--error-message "FUEL connection not active")
|
||||
|
||||
(defun fuel-con--send-string (buffer/proc str cont &optional sender-buffer)
|
||||
(save-current-buffer
|
||||
(let ((con (fuel-con--get-connection buffer/proc)))
|
||||
(unless con
|
||||
(error "FUEL: couldn't find connection"))
|
||||
(unless con (error fuel-con--error-message))
|
||||
(let ((req (fuel-con--make-request str cont sender-buffer)))
|
||||
(fuel-con--connection-queue-request con req)
|
||||
(fuel-con--process-next con)
|
||||
|
@ -223,22 +248,23 @@
|
|||
|
||||
(defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf)
|
||||
(save-current-buffer
|
||||
(let* ((con (fuel-con--get-connection buffer/proc))
|
||||
(req (fuel-con--send-string buffer/proc str cont sbuf))
|
||||
(id (and req (fuel-con--request-id req)))
|
||||
(time (or timeout fuel-connection-timeout))
|
||||
(step 100)
|
||||
(waitsecs (/ step 1000.0)))
|
||||
(when id
|
||||
(condition-case nil
|
||||
(while (and (> time 0)
|
||||
(not (fuel-con--connection-completed-p con id)))
|
||||
(accept-process-output nil waitsecs)
|
||||
(setq time (- time step)))
|
||||
(error (setq time 0)))
|
||||
(or (> time 0)
|
||||
(fuel-con--request-deactivate req)
|
||||
nil)))))
|
||||
(let ((con (fuel-con--get-connection buffer/proc)))
|
||||
(unless con (error fuel-con--error-message))
|
||||
(let* ((req (fuel-con--send-string buffer/proc str cont sbuf))
|
||||
(id (and req (fuel-con--request-id req)))
|
||||
(time (or timeout fuel-connection-timeout))
|
||||
(step 100)
|
||||
(waitsecs (/ step 1000.0)))
|
||||
(when id
|
||||
(condition-case nil
|
||||
(while (and (> time 0)
|
||||
(not (fuel-con--connection-completed-p con id)))
|
||||
(accept-process-output nil waitsecs)
|
||||
(setq time (- time step)))
|
||||
(error (setq time 0)))
|
||||
(or (> time 0)
|
||||
(fuel-con--request-deactivate req)
|
||||
nil))))))
|
||||
|
||||
|
||||
(provide 'fuel-connection)
|
||||
|
|
|
@ -54,6 +54,7 @@
|
|||
factor-font-lock font-lock factor-mode
|
||||
((comment comment "comments")
|
||||
(constructor type "constructors (<foo>)")
|
||||
(constant constant "constants and literal values")
|
||||
(declaration keyword "declaration words")
|
||||
(parsing-word keyword "parsing words")
|
||||
(setter-word function-name "setter words (>>foo)")
|
||||
|
@ -73,17 +74,21 @@
|
|||
(,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)
|
||||
(,fuel-syntax--alias-definition-regex (1 'factor-font-lock-word)
|
||||
(2 'factor-font-lock-word))
|
||||
(,fuel-syntax--int-constant-def-regex 2 'factor-font-lock-constant)
|
||||
(,fuel-syntax--number-regex . 'factor-font-lock-constant)
|
||||
(,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name)
|
||||
(,fuel-syntax--method-definition-regex (1 'factor-font-lock-type-name)
|
||||
(2 'factor-font-lock-word))
|
||||
(,fuel-syntax--parent-type-regex 1 'factor-font-lock-type-name)
|
||||
(,fuel-syntax--parent-type-regex 2 'factor-font-lock-type-name)
|
||||
(,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)
|
||||
(,fuel-syntax--use-line-regex 1 'factor-font-lock-vocabulary-name))
|
||||
(,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol))
|
||||
"Font lock keywords definition for Factor mode.")
|
||||
|
||||
(defun fuel-font-lock--font-lock-setup (&optional keywords no-syntax)
|
||||
|
|
|
@ -78,11 +78,7 @@ buffer."
|
|||
(make-comint-in-buffer "fuel listener" (current-buffer) factor nil
|
||||
"-run=listener" (format "-i=%s" image))
|
||||
(fuel-listener--wait-for-prompt 10000)
|
||||
(fuel-con--setup-connection (current-buffer))
|
||||
(fuel-con--send-string/wait (current-buffer)
|
||||
fuel-con--init-stanza
|
||||
'(lambda (s) (message "FUEL listener up and running!"))
|
||||
20000)))
|
||||
(fuel-con--setup-connection (current-buffer))))
|
||||
|
||||
(defun fuel-listener--process (&optional start)
|
||||
(or (and (buffer-live-p (fuel-listener--buffer))
|
||||
|
|
|
@ -132,37 +132,6 @@ With prefix argument, ask for the file name."
|
|||
(let ((file (car (fuel-mode--read-file arg))))
|
||||
(when file (fuel-debug--uses-for-file file))))
|
||||
|
||||
(defvar fuel-mode--word-history nil)
|
||||
|
||||
(defun fuel-show-callers (&optional arg)
|
||||
"Show a list of callers of word at point.
|
||||
With prefix argument, ask for word."
|
||||
(interactive "P")
|
||||
(let ((word (if arg (fuel-completion--read-word "Find callers for: "
|
||||
(fuel-syntax-symbol-at-point)
|
||||
fuel-mode--word-history)
|
||||
(fuel-syntax-symbol-at-point))))
|
||||
(when word
|
||||
(message "Looking up %s's callers ..." word)
|
||||
(fuel-xref--show-callers word))))
|
||||
|
||||
(defun fuel-show-callees (&optional arg)
|
||||
"Show a list of callers of word at point.
|
||||
With prefix argument, ask for word."
|
||||
(interactive "P")
|
||||
(let ((word (if arg (fuel-completion--read-word "Find callees for: "
|
||||
(fuel-syntax-symbol-at-point)
|
||||
fuel-mode--word-history)
|
||||
(fuel-syntax-symbol-at-point))))
|
||||
(when word
|
||||
(message "Looking up %s's callees ..." word)
|
||||
(fuel-xref--show-callees word))))
|
||||
|
||||
(defun fuel-apropos (str)
|
||||
"Show a list of words containing the given substring."
|
||||
(interactive "MFind words containing: ")
|
||||
(message "Looking up %s's references ..." str)
|
||||
(fuel-xref--apropos str))
|
||||
|
||||
;;; Minor mode definition:
|
||||
|
||||
|
@ -225,10 +194,12 @@ interacting with a factor listener is at your disposal.
|
|||
(fuel-mode--key ?e ?w 'fuel-edit-word)
|
||||
(fuel-mode--key ?e ?x 'fuel-eval-definition)
|
||||
|
||||
(fuel-mode--key ?x ?w 'fuel-refactor-extract-word)
|
||||
(fuel-mode--key ?x ?s 'fuel-refactor-extract-sexp)
|
||||
(fuel-mode--key ?x ?r 'fuel-refactor-extract-region)
|
||||
|
||||
(fuel-mode--key ?d ?> 'fuel-show-callees)
|
||||
(fuel-mode--key ?d ?< 'fuel-show-callers)
|
||||
(fuel-mode--key ?d ?v 'fuel-show-file-words)
|
||||
(fuel-mode--key ?d ?a 'fuel-autodoc-mode)
|
||||
(fuel-mode--key ?d ?p 'fuel-apropos)
|
||||
(fuel-mode--key ?d ?d 'fuel-help)
|
||||
|
|
|
@ -20,29 +20,25 @@
|
|||
|
||||
;;; Extract word:
|
||||
|
||||
(defun fuel-refactor-extract-word (begin end)
|
||||
"Extracts current region as a separate word."
|
||||
(interactive "r")
|
||||
(defun fuel-refactor--extract (begin end)
|
||||
(let* ((word (read-string "New word name: "))
|
||||
(begin (save-excursion
|
||||
(goto-char begin)
|
||||
(when (zerop (skip-syntax-backward "w"))
|
||||
(skip-syntax-forward "-"))
|
||||
(point)))
|
||||
(end (save-excursion
|
||||
(goto-char end)
|
||||
(skip-syntax-forward "w")
|
||||
(point)))
|
||||
(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"))
|
||||
(goto-char begin)
|
||||
(delete-region begin end)
|
||||
(insert word)
|
||||
(indent-region begin (point))
|
||||
(set-mark (point))
|
||||
(fuel-syntax--beginning-of-defun)
|
||||
(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")
|
||||
|
@ -52,6 +48,29 @@
|
|||
(sit-for fuel-stack-highlight-period)
|
||||
(delete-overlay fuel-stack--overlay))))
|
||||
|
||||
(defun fuel-refactor-extract-region (begin end)
|
||||
"Extracts current region as a separate word."
|
||||
(interactive "r")
|
||||
(let ((begin (save-excursion
|
||||
(goto-char begin)
|
||||
(when (zerop (skip-syntax-backward "w"))
|
||||
(skip-syntax-forward "-"))
|
||||
(point)))
|
||||
(end (save-excursion
|
||||
(goto-char end)
|
||||
(skip-syntax-forward "w")
|
||||
(point))))
|
||||
(fuel-refactor--extract begin end)))
|
||||
|
||||
(defun fuel-refactor-extract-sexp ()
|
||||
"Extracts current innermost sexp (up to point) as a separate
|
||||
word."
|
||||
(interactive)
|
||||
(fuel-refactor-extract-region (1+ (fuel-syntax--beginning-of-sexp-pos))
|
||||
(if (looking-at-p ";") (point)
|
||||
(fuel-syntax--end-of-symbol-pos))))
|
||||
|
||||
|
||||
|
||||
(provide 'fuel-refactor)
|
||||
;;; fuel-refactor.el ends here
|
||||
|
|
|
@ -44,16 +44,24 @@
|
|||
|
||||
(defconst fuel-syntax--parsing-words
|
||||
'(":" "::" ";" "<<" "<PRIVATE" ">>"
|
||||
"B" "BIN:" "C:" "C-STRUCT:" "C-UNION:" "CHAR:"
|
||||
"DEFER:" "ERROR:" "EXCLUDE:" "FORGET:"
|
||||
"GENERIC#" "GENERIC:" "HEX:" "HOOK:"
|
||||
"IN:" "INSTANCE:" "INTERSECTION:"
|
||||
"ALIAS:"
|
||||
"B" "BIN:"
|
||||
"C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CONSTANT:" "call-next-method"
|
||||
"DEFER:"
|
||||
"ERROR:" "EXCLUDE:"
|
||||
"f" "FORGET:" "FROM:"
|
||||
"GENERIC#" "GENERIC:"
|
||||
"HEX:" "HOOK:"
|
||||
"IN:" "initial:" "INSTANCE:" "INTERSECTION:"
|
||||
"M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "MEMO:" "METHOD:" "MIXIN:"
|
||||
"OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
|
||||
"REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:"
|
||||
"OCT:"
|
||||
"POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
|
||||
"QUALIFIED-WITH:" "QUALIFIED:"
|
||||
"read-only" "RENAME:" "REQUIRE:" "REQUIRES:"
|
||||
"SINGLETON:" "SINGLETONS:" "SLOT:" "SYMBOL:" "SYMBOLS:"
|
||||
"TUPLE:" "t" "t?" "TYPEDEF:"
|
||||
"UNION:" "USE:" "USING:" "VARS:"
|
||||
"call-next-method" "delimiter" "f" "initial:" "read-only"))
|
||||
"UNION:" "USE:" "USING:"
|
||||
"VARS:"))
|
||||
|
||||
(defconst fuel-syntax--bracers
|
||||
'("B" "BV" "C" "CS" "H" "T" "V" "W"))
|
||||
|
@ -65,7 +73,7 @@
|
|||
(format "%s{" (regexp-opt fuel-syntax--bracers t)))
|
||||
|
||||
(defconst fuel-syntax--declaration-words
|
||||
'("flushable" "foldable" "inline" "parsing" "recursive"))
|
||||
'("flushable" "foldable" "inline" "parsing" "recursive" "delimiter"))
|
||||
|
||||
(defconst fuel-syntax--declaration-words-regex
|
||||
(regexp-opt fuel-syntax--declaration-words 'words))
|
||||
|
@ -76,13 +84,29 @@
|
|||
(defconst fuel-syntax--method-definition-regex
|
||||
"^M: +\\([^ ]+\\) +\\([^ ]+\\)")
|
||||
|
||||
(defconst fuel-syntax--number-regex
|
||||
"\\(\\+\\|-\\)?\\([0-9]+\\.?[0-9]*\\|\\.[0-9]+\\)\\([eE]\\(\\+\\|-\\)?[0-9]+\\)?")
|
||||
|
||||
(defconst fuel-syntax--word-definition-regex
|
||||
(fuel-syntax--second-word-regex '(":" "::" "GENERIC:")))
|
||||
(fuel-syntax--second-word-regex
|
||||
'(":" "::" "GENERIC:" "DEFER:" "HOOK:" "MAIN:" "MATH:" "POSTPONE:"
|
||||
"SYMBOL:" "RENAME:")))
|
||||
|
||||
(defconst fuel-syntax--alias-definition-regex
|
||||
"^ALIAS: +\\(\\_<.+?\\_>\\) +\\(\\_<.+?\\_>\\)")
|
||||
|
||||
(defconst fuel-syntax--vocab-ref-regexp
|
||||
(fuel-syntax--second-word-regex
|
||||
'("IN:" "USE:" "FROM:" "EXCLUDE:" "QUALIFIED:" "QUALIFIED-WITH:")))
|
||||
|
||||
(defconst fuel-syntax--int-constant-def-regex
|
||||
(fuel-syntax--second-word-regex '("CHAR:" "BIN:" "HEX:" "OCT:")))
|
||||
|
||||
(defconst fuel-syntax--type-definition-regex
|
||||
(fuel-syntax--second-word-regex '("TUPLE:" "SINGLETON:")))
|
||||
(fuel-syntax--second-word-regex '("MIXIN:" "TUPLE:" "SINGLETON:" "UNION:")))
|
||||
|
||||
(defconst fuel-syntax--parent-type-regex "^TUPLE: +[^ ]+ +< +\\([^ ]+\\)")
|
||||
(defconst fuel-syntax--parent-type-regex
|
||||
"^\\(TUPLE\\|PREDICTE\\): +[^ ]+ +< +\\([^ ]+\\)")
|
||||
|
||||
(defconst fuel-syntax--constructor-regex "<[^ >]+>")
|
||||
|
||||
|
@ -102,21 +126,37 @@
|
|||
|
||||
(defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")
|
||||
|
||||
(defconst fuel-syntax--definition-starters-regex
|
||||
(regexp-opt
|
||||
'("VARS" "TUPLE" "MACRO" "MACRO:" "M" "MEMO" "MEMO:" "METHOD" ":" "")))
|
||||
|
||||
(defconst fuel-syntax--definition-start-regex
|
||||
(format "^\\(%s:\\) " fuel-syntax--definition-starters-regex))
|
||||
(format "^\\(%s:\\) " (regexp-opt '("" ":"
|
||||
"FROM"
|
||||
"INTERSECTION:"
|
||||
"MACRO" "MACRO:" "M" "MEMO" "MEMO:" "METHOD"
|
||||
"PREDICATE" "PRIMITIVE"
|
||||
"SINGLETONS" "SYMBOLS"
|
||||
"TUPLE"
|
||||
"UNION"
|
||||
"VARS"))))
|
||||
|
||||
(defconst fuel-syntax--definition-end-regex
|
||||
(format "\\(\\(^\\| +\\);\\( *%s\\)*\\($\\| +\\)\\)"
|
||||
fuel-syntax--declaration-words-regex))
|
||||
|
||||
(defconst fuel-syntax--single-liner-regex
|
||||
(format "^%s" (regexp-opt '("C:" "DEFER:" "GENERIC:" "IN:"
|
||||
"PRIVATE>" "<PRIVATE"
|
||||
"SINGLETON:" "SYMBOL:" "USE:" "VAR:"))))
|
||||
(format "^%s" (regexp-opt '("ALIAS:"
|
||||
"CONSTANT:" "C:"
|
||||
"DEFER:"
|
||||
"FORGET:"
|
||||
"GENERIC:" "GENERIC#"
|
||||
"HEX:" "HOOK:"
|
||||
"IN:" "INSTANCE:"
|
||||
"MAIN:" "MATH:" "MIXIN:"
|
||||
"OCT:"
|
||||
"POSTPONE:" "PRIVATE>" "<PRIVATE"
|
||||
"QUALIFIED-WITH:" "QUALIFIED:"
|
||||
"RENAME:"
|
||||
"SINGLETON:" "SLOT:" "SYMBOL:"
|
||||
"USE:"
|
||||
"VAR:"))))
|
||||
|
||||
(defconst fuel-syntax--begin-of-def-regex
|
||||
(format "^USING: \\|\\(%s\\)\\|\\(%s .*\\)"
|
||||
|
@ -312,6 +352,12 @@
|
|||
(defsubst fuel-syntax--usings ()
|
||||
(funcall fuel-syntax--usings-function))
|
||||
|
||||
(defun fuel-syntax--file-has-private ()
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(and (re-search-forward "\\_<<PRIVATE\\_>" nil t)
|
||||
(re-search-forward "\\_<PRIVATE>\\_>" nil t))))
|
||||
|
||||
(defun fuel-syntax--find-usings (&optional no-private)
|
||||
(save-excursion
|
||||
(let ((usings))
|
||||
|
@ -319,10 +365,7 @@
|
|||
(while (re-search-backward fuel-syntax--using-lines-regex nil t)
|
||||
(dolist (u (split-string (match-string-no-properties 1) nil t))
|
||||
(push u usings)))
|
||||
(goto-char (point-min))
|
||||
(when (and (not no-private)
|
||||
(re-search-forward "\\_<<PRIVATE\\_>" nil t)
|
||||
(re-search-forward "\\_<PRIVATE>\\_>" nil t))
|
||||
(when (and (not no-private) (fuel-syntax--file-has-private))
|
||||
(goto-char (point-max))
|
||||
(push (concat (fuel-syntax--find-in) ".private") usings))
|
||||
usings)))
|
||||
|
|
|
@ -13,6 +13,8 @@
|
|||
|
||||
;;; Code:
|
||||
|
||||
(require 'fuel-edit)
|
||||
(require 'fuel-completion)
|
||||
(require 'fuel-help)
|
||||
(require 'fuel-eval)
|
||||
(require 'fuel-syntax)
|
||||
|
@ -82,7 +84,7 @@ cursor at the first ocurrence of the used word."
|
|||
((= 1 count) (format "1 word %s %s:" cc word))
|
||||
(t (format "%s words %s %s:" count cc word))))
|
||||
|
||||
(defun fuel-xref--insert-ref (ref)
|
||||
(defun fuel-xref--insert-ref (ref &optional no-vocab)
|
||||
(when (and (stringp (first ref))
|
||||
(stringp (third ref))
|
||||
(numberp (fourth ref)))
|
||||
|
@ -94,29 +96,28 @@ cursor at the first ocurrence of the used word."
|
|||
(fourth ref))
|
||||
'file (third ref)
|
||||
'line (fourth ref))
|
||||
(when (stringp (second ref))
|
||||
(when (and (not no-vocab) (stringp (second ref)))
|
||||
(insert (format " (in %s)" (second ref))))
|
||||
(newline)
|
||||
t))
|
||||
|
||||
(defun fuel-xref--fill-buffer (word cc refs)
|
||||
(defun fuel-xref--fill-buffer (word cc refs &optional no-vocab app)
|
||||
(let ((inhibit-read-only t)
|
||||
(count 0))
|
||||
(with-current-buffer (fuel-xref--buffer)
|
||||
(erase-buffer)
|
||||
(dolist (ref refs)
|
||||
(when (fuel-xref--insert-ref ref) (setq count (1+ count))))
|
||||
(goto-char (point-min))
|
||||
(insert (fuel-xref--title word cc count) "\n\n")
|
||||
(when (> count 0)
|
||||
(setq fuel-xref--word (and cc word))
|
||||
(goto-char (point-max))
|
||||
(insert "\n" fuel-xref--help-string "\n"))
|
||||
(goto-char (point-min))
|
||||
count)))
|
||||
(let ((start (if app (goto-char (point-max))
|
||||
(erase-buffer)
|
||||
(point-min))))
|
||||
(dolist (ref refs)
|
||||
(when (fuel-xref--insert-ref ref no-vocab) (setq count (1+ count))))
|
||||
(newline)
|
||||
(goto-char start)
|
||||
(save-excursion
|
||||
(insert (fuel-xref--title word cc count) "\n\n"))
|
||||
count))))
|
||||
|
||||
(defun fuel-xref--fill-and-display (word cc refs)
|
||||
(let ((count (fuel-xref--fill-buffer word cc refs)))
|
||||
(defun fuel-xref--fill-and-display (word cc refs &optional no-vocab)
|
||||
(let ((count (fuel-xref--fill-buffer word cc refs no-vocab)))
|
||||
(if (zerop count)
|
||||
(error (fuel-xref--title word cc 0))
|
||||
(message "")
|
||||
|
@ -137,6 +138,65 @@ cursor at the first ocurrence of the used word."
|
|||
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
(fuel-xref--fill-and-display str "containing" res)))
|
||||
|
||||
(defun fuel-xref--show-vocab (vocab &optional app)
|
||||
(let* ((cmd `(:fuel* ((,vocab fuel-vocab-xref)) ,vocab))
|
||||
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
(fuel-xref--fill-buffer vocab "in vocabulary" res t app)))
|
||||
|
||||
(defun fuel-xref--show-vocab-words (vocab &optional private)
|
||||
(fuel-xref--show-vocab vocab)
|
||||
(when private
|
||||
(fuel-xref--show-vocab (format "%s.private" (substring-no-properties vocab))
|
||||
t))
|
||||
(fuel-popup--display (fuel-xref--buffer))
|
||||
(goto-char (point-min)))
|
||||
|
||||
|
||||
;;; User commands:
|
||||
|
||||
(defvar fuel-xref--word-history nil)
|
||||
|
||||
(defun fuel-show-callers (&optional arg)
|
||||
"Show a list of callers of word at point.
|
||||
With prefix argument, ask for word."
|
||||
(interactive "P")
|
||||
(let ((word (if arg (fuel-completion--read-word "Find callers for: "
|
||||
(fuel-syntax-symbol-at-point)
|
||||
fuel-xref--word-history)
|
||||
(fuel-syntax-symbol-at-point))))
|
||||
(when word
|
||||
(message "Looking up %s's callers ..." word)
|
||||
(fuel-xref--show-callers word))))
|
||||
|
||||
(defun fuel-show-callees (&optional arg)
|
||||
"Show a list of callers of word at point.
|
||||
With prefix argument, ask for word."
|
||||
(interactive "P")
|
||||
(let ((word (if arg (fuel-completion--read-word "Find callees for: "
|
||||
(fuel-syntax-symbol-at-point)
|
||||
fuel-xref--word-history)
|
||||
(fuel-syntax-symbol-at-point))))
|
||||
(when word
|
||||
(message "Looking up %s's callees ..." word)
|
||||
(fuel-xref--show-callees word))))
|
||||
|
||||
(defun fuel-apropos (str)
|
||||
"Show a list of words containing the given substring."
|
||||
(interactive "MFind words containing: ")
|
||||
(message "Looking up %s's references ..." str)
|
||||
(fuel-xref--apropos str))
|
||||
|
||||
(defun fuel-show-file-words (&optional arg)
|
||||
"Show a list of words in current file.
|
||||
With prefix argument, ask for the vocab."
|
||||
(interactive "P")
|
||||
(let ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
|
||||
(fuel-edit--read-vocabulary-name))))
|
||||
(when vocab
|
||||
(fuel-xref--show-vocab-words vocab
|
||||
(fuel-syntax--file-has-private)))))
|
||||
|
||||
|
||||
|
||||
;;; Xref mode:
|
||||
|
||||
|
@ -159,6 +219,7 @@ cursor at the first ocurrence of the used word."
|
|||
(kill-all-local-variables)
|
||||
(buffer-disable-undo)
|
||||
(use-local-map fuel-xref-mode-map)
|
||||
(set-syntax-table fuel-syntax--syntax-table)
|
||||
(setq mode-name "FUEL Xref")
|
||||
(setq major-mode 'fuel-xref-mode)
|
||||
(font-lock-add-keywords nil '(("(in \\(.+\\))" 1 'fuel-font-lock-xref-vocab)))
|
||||
|
|
Loading…
Reference in New Issue