steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into experimental

db4
Alex Chapman 2009-02-03 11:57:36 +11:00
parent a04d8aaf17 346a61f497
commit ec811be0a0
215 changed files with 19972 additions and 1880 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -22,3 +22,4 @@ work
build-support/wordsize
*.bak
.#*
*.swo

6
basis/alien/structs/structs.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generic hashtables kernel kernel.private
math namespaces parser sequences strings words libc fry
alien.c-types alien.structs.fields cpu.architecture ;
alien.c-types alien.structs.fields cpu.architecture math.order ;
IN: alien.structs
TUPLE: struct-type size align fields ;
@ -47,7 +47,7 @@ M: struct-type stack-size
[ first2 <field-spec> ] with with map ;
: compute-struct-align ( types -- n )
[ c-type-align ] map supremum ;
[ c-type-align ] [ max ] map-reduce ;
: define-struct ( name vocab fields -- )
[
@ -59,5 +59,5 @@ M: struct-type stack-size
: define-union ( name members -- )
[ expand-constants ] map
[ [ heap-size ] map supremum ] keep
[ [ heap-size ] [ max ] map-reduce ] keep
compute-struct-align f (define-struct) ;

13
basis/biassocs/biassocs-docs.factor
View File

@ -16,13 +16,22 @@ HELP: once-at
{ $values { "value" object } { "key" object } { "assoc" assoc } }
{ $description "If the assoc does not contain the given key, adds the key/value pair to the assoc, otherwise does nothing." } ;
HELP: >biassoc
{ $values { "assoc" assoc } { "biassoc" biassoc } }
{ $description "Costructs a new biassoc with the same key/value pairs as the given assoc." } ;
ARTICLE: "biassocs" "Bidirectional assocs"
"A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc opeartions (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time."
$nl
"Bidirectional assocs implement the entire assoc protocol with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with."
"Bidirectional assocs implement the entire " { $link "assocs-protocol" } " with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with."
$nl
"The class of biassocs:"
{ $subsection biassoc }
{ $subsection biassoc? }
"Creating new biassocs:"
{ $subsection <biassoc> }
{ $subsection <bihash> } ;
{ $subsection <bihash> }
"Converting existing assocs to biassocs:"
{ $subsection >biassoc } ;
ABOUT: "biassocs"

10
basis/biassocs/biassocs-tests.factor
View File

@ -20,3 +20,13 @@ USING: biassocs assocs namespaces tools.test ;
[ 2 ] [ 1 "h" get value-at ] unit-test
[ 2 ] [ "h" get assoc-size ] unit-test
H{ { "a" "A" } { "b" "B" } } "a" set
[ ] [ "a" get >biassoc "b" set ] unit-test
[ t ] [ "b" get biassoc? ] unit-test
[ "A" ] [ "a" "b" get at ] unit-test
[ "a" ] [ "A" "b" get value-at ] unit-test

10
basis/biassocs/biassocs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs accessors summary ;
USING: kernel assocs accessors summary hashtables ;
IN: biassocs
TUPLE: biassoc from to ;
@ -37,4 +37,10 @@ M: biassoc >alist
M: biassoc clear-assoc
[ from>> clear-assoc ] [ to>> clear-assoc ] bi ;
M: biassoc new-assoc
drop [ <hashtable> ] [ <hashtable> ] bi biassoc boa ;
INSTANCE: biassoc assoc
: >biassoc ( assoc -- biassoc )
T{ biassoc } assoc-clone-like ;

4
basis/compiler/tree/normalization/introductions/introductions.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences accessors math kernel
compiler.tree ;
compiler.tree math.order ;
IN: compiler.tree.normalization.introductions
SYMBOL: introductions
@ -25,7 +25,7 @@ M: #introduce count-introductions*
M: #branch count-introductions*
children>>
[ count-introductions ] map supremum
[ count-introductions ] [ max ] map-reduce
introductions+ ;
M: #recursive count-introductions*

4
basis/compiler/tree/normalization/normalization.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry namespaces sequences math accessors kernel arrays
USING: fry namespaces sequences math math.order accessors kernel arrays
combinators compiler.utilities assocs
stack-checker.backend
stack-checker.branches
@ -54,7 +54,7 @@ M: #branch normalize*
] map unzip swap
] change-children swap
[ remaining-introductions set ]
[ [ length ] map infimum introduction-stack [ swap head ] change ]
[ [ length ] [ min ] map-reduce introduction-stack [ swap head ] change ]
bi ;
: eliminate-phi-introductions ( introductions seq terminated -- seq' )

48
basis/csv/csv-docs.factor
View File

@ -1,28 +1,52 @@
USING: help.syntax help.markup kernel prettyprint sequences ;
USING: help.syntax help.markup kernel prettyprint sequences
io.pathnames ;
IN: csv
HELP: csv
{ $values { "stream" "an input stream" }
{ "rows" "an array of arrays of fields" } }
{ $description "parses a csv stream into an array of row arrays"
} ;
{ $description "Parses a csv stream into an array of row arrays." } ;
HELP: file>csv
{ $values
{ "path" pathname } { "encoding" "an encoding descriptor" }
{ "csv" "csv" }
}
{ $description "Opens a file and parses it into a sequence of comma-separated-value fields." } ;
HELP: csv>file
{ $values
{ "rows" "a sequence of sequences of strings" }
{ "path" pathname } { "encoding" "an encoding descriptor" }
}
{ $description "Writes a comma-separated-value structure to a file." } ;
HELP: csv-row
{ $values { "stream" "an input stream" }
{ "row" "an array of fields" } }
{ $description "parses a row from a csv stream"
} ;
{ $description "parses a row from a csv stream" } ;
HELP: write-csv
{ $values { "rows" "an sequence of sequences of strings" }
{ $values { "rows" "a sequence of sequences of strings" }
{ "stream" "an output stream" } }
{ $description "writes csv to the output stream, escaping where necessary"
} ;
{ $description "Writes a sequence of sequences of comma-separated-values to the output stream, escaping where necessary." } ;
HELP: with-delimiter
{ $values { "char" "field delimiter (e.g. CHAR: \t)" }
{ $values { "ch" "field delimiter (e.g. CHAR: \t)" }
{ "quot" "a quotation" } }
{ $description "Sets the field delimiter for csv or csv-row words "
} ;
{ $description "Sets the field delimiter for csv or csv-row words." } ;
ARTICLE: "csv" "Comma-separated-values parsing and writing"
"The " { $vocab-link "csv" } " vocabulary can read and write CSV (comma-separated-value) files." $nl
"Reading a csv file:"
{ $subsection file>csv }
"Writing a csv file:"
{ $subsection csv>file }
"Changing the delimiter from a comma:"
{ $subsection with-delimiter }
"Reading from a stream:"
{ $subsection csv }
"Writing to a stream:"
{ $subsection write-csv } ;
ABOUT: "csv"

16
basis/csv/csv-tests.factor
View File

@ -1,5 +1,7 @@
USING: io.streams.string csv tools.test shuffle kernel strings
io.pathnames io.files.unique io.encodings.utf8 io.files
io.directories ;
IN: csv.tests
USING: io.streams.string csv tools.test shuffle kernel strings ;
! I like to name my unit tests
: named-unit-test ( name output input -- )
@ -76,3 +78,15 @@ USING: io.streams.string csv tools.test shuffle kernel strings ;
"escapes quotes commas and newlines when writing"
[ "\"fo\"\"o1\",bar1\n\"fo\no2\",\"b,ar2\"\n" ]
[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } <string-writer> tuck write-csv >string ] named-unit-test ! "
[ { { "writing" "some" "csv" "tests" } } ]
[
"writing,some,csv,tests"
"csv-test1-" unique-file utf8
[ set-file-contents ] [ file>csv ] [ drop delete-file ] 2tri
] unit-test
[ t ] [
{ { "writing,some,csv,tests" } } dup "csv-test2-"
unique-file utf8 [ csv>file ] [ file>csv ] 2bi =
] unit-test

95
basis/csv/csv.factor
View File

@ -1,89 +1,100 @@
! Copyright (C) 2007, 2008 Phil Dawes
! See http://factorcode.org/license.txt for BSD license.
! Simple CSV Parser
! Phil Dawes phil@phildawes.net
USING: kernel sequences io namespaces make
combinators unicode.categories ;
USING: kernel sequences io namespaces make combinators
unicode.categories io.files combinators.short-circuit ;
IN: csv
SYMBOL: delimiter
CHAR: , delimiter set-global
<PRIVATE
: delimiter> ( -- delimiter ) delimiter get ; inline
DEFER: quoted-field ( -- endchar )
! trims whitespace from either end of string
: trim-whitespace ( str -- str )
[ blank? ] trim ; inline
[ blank? ] trim ; inline
: skip-to-field-end ( -- endchar )
"\n" delimiter> suffix read-until nip ; inline
: not-quoted-field ( -- endchar )
"\"\n" delimiter> suffix read-until ! "
dup
{ { CHAR: " [ drop drop quoted-field ] } ! "
{ delimiter> [ swap trim-whitespace % ] }
{ CHAR: \n [ swap trim-whitespace % ] }
{ f [ swap trim-whitespace % ] } ! eof
} case ;
"\"\n" delimiter> suffix read-until
dup {
{ CHAR: " [ 2drop quoted-field ] }
{ delimiter> [ swap trim-whitespace % ] }
{ CHAR: \n [ swap trim-whitespace % ] }
{ f [ swap trim-whitespace % ] }
} case ;
: maybe-escaped-quote ( -- endchar )
read1 dup
{ { CHAR: " [ , quoted-field ] } ! " is an escaped quote
{ delimiter> [ ] } ! end of quoted field
{ CHAR: \n [ ] }
[ 2drop skip-to-field-end ] ! end of quoted field + padding
} case ;
read1 dup {
{ CHAR: " [ , quoted-field ] }
{ delimiter> [ ] }
{ CHAR: \n [ ] }
[ 2drop skip-to-field-end ]
} case ;
: quoted-field ( -- endchar )
"\"" read-until ! "
drop % maybe-escaped-quote ;
"\"" read-until
drop % maybe-escaped-quote ;
: field ( -- sep string )
[ not-quoted-field ] "" make ; ! trim-whitespace
[ not-quoted-field ] "" make ;
: (row) ( -- sep )
field ,
dup delimiter get = [ drop (row) ] when ;
field ,
dup delimiter get = [ drop (row) ] when ;
: row ( -- eof? array[string] )
[ (row) ] { } make ;
: append-if-row-not-empty ( row -- )
dup { "" } = [ drop ] [ , ] if ;
[ (row) ] { } make ;
: (csv) ( -- )
row append-if-row-not-empty
[ (csv) ] when ;
row harvest [ , ] unless-empty [ (csv) ] when ;
PRIVATE>
: csv-row ( stream -- row )
[ row nip ] with-input-stream ;
[ row nip ] with-input-stream ;
: csv ( stream -- rows )
[ [ (csv) ] { } make ] with-input-stream ;
[ [ (csv) ] { } make ] with-input-stream ;
: with-delimiter ( char quot -- )
delimiter swap with-variable ; inline
: file>csv ( path encoding -- csv )
<file-reader> csv ;
: with-delimiter ( ch quot -- )
[ delimiter ] dip with-variable ; inline
<PRIVATE
: needs-escaping? ( cell -- ? )
[ [ "\n\"" member? ] [ delimiter get = ] bi or ] any? ; inline
[ { [ "\n\"" member? ] [ delimiter get = ] } 1|| ] any? ; inline
: escape-quotes ( cell -- cell' )
[ [ dup , CHAR: " = [ CHAR: " , ] when ] each ] "" make ; inline
[
[
[ , ]
[ dup CHAR: " = [ , ] [ drop ] if ] bi
] each
] "" make ; inline
: enclose-in-quotes ( cell -- cell' )
CHAR: " [ prefix ] [ suffix ] bi ; inline ! "
"\"" dup surround ; inline
: escape-if-required ( cell -- cell' )
dup needs-escaping? [ escape-quotes enclose-in-quotes ] when ; inline
dup needs-escaping?
[ escape-quotes enclose-in-quotes ] when ; inline
PRIVATE>
: write-row ( row -- )
[ delimiter get write1 ] [ escape-if-required write ] interleave nl ; inline
[ delimiter get write1 ]
[ escape-if-required write ] interleave nl ; inline
: write-csv ( rows stream -- )
[ [ write-row ] each ] with-output-stream ;
[ [ write-row ] each ] with-output-stream ;
: csv>file ( rows path encoding -- ) <file-writer> write-csv ;

2
basis/db/db-docs.factor
View File

@ -173,7 +173,7 @@ HELP: with-db
HELP: with-transaction
{ $values
{ "quot" quotation } }
{ $description "" } ;
{ $description "Calls the quotation inside a database transaction and commits the result to the database after the quotation finishes. If the quotation throws an error, the transaction is aborted." } ;
ARTICLE: "db" "Database library"
"Accessing a database:"

6
basis/db/tuples/tuples-docs.factor
View File

@ -1,9 +1,13 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes help.markup help.syntax io.streams.string kernel
quotations sequences strings multiline math db.types db ;
quotations sequences strings multiline math db.types
db.tuples.private db ;
IN: db.tuples
HELP: random-id-generator
{ $description "Used to tell " { $link eval-generator } " to generate a random number for use as a key." } ;
HELP: create-sql-statement
{ $values
{ "class" class }

122
basis/db/types/types-docs.factor
View File

@ -27,15 +27,11 @@ HELP: +user-assigned-id+
HELP: <generator-bind>
{ $values { "slot-name" object } { "key" object } { "generator-singleton" object } { "type" object } { "generator-bind" generator-bind } }
{ $description "" } ;
{ $description "An internal constructor for creating objects containing parameters used for binding generated values to a tuple query." } ;
HELP: <literal-bind>
{ $values { "key" object } { "type" object } { "value" object } { "literal-bind" literal-bind } }
{ $description "" } ;
HELP: <low-level-binding>
{ $values { "value" object } { "low-level-binding" low-level-binding } }
{ $description "" } ;
{ $description "An internal constructor for creating objects containing parameters used for binding literal values to a tuple query." } ;
HELP: BIG-INTEGER
{ $description "A 64-bit integer. Whether this number is signed or unsigned depends on the database backend." } ;
@ -93,87 +89,48 @@ HELP: VARCHAR
HELP: user-assigned-id-spec?
{ $values
{ "specs" "a sequence of sql specs" }
{ "specs" "a sequence of SQL specs" }
{ "?" "a boolean" } }
{ $description "Tests if any of the sql specs has the type " { $link +user-assigned-id+ } "." } ;
{ $description "Tests if any of the SQL specs has the type " { $link +user-assigned-id+ } "." } ;
HELP: bind#
{ $values
{ "spec" "a sql spec" } { "obj" object } }
{ $description "" } ;
{ "spec" "a SQL spec" } { "obj" object } }
{ $description "A generic word that lets a database construct a literal binding." } ;
HELP: bind%
{ $values
{ "spec" "a sql spec" } }
{ $description "" } ;
HELP: compound
{ $values
{ "string" string } { "obj" object }
{ "hash" hashtable } }
{ $description "" } ;
{ "spec" "a SQL spec" } }
{ $description "A generic word that lets a database output a binding." } ;
HELP: db-assigned-id-spec?
{ $values
{ "specs" "a sequence of sql specs" }
{ "specs" "a sequence of SQL specs" }
{ "?" "a boolean" } }
{ $description "Tests if any of the sql specs has the type " { $link +db-assigned-id+ } "." } ;
{ $description "Tests if any of the SQL specs has the type " { $link +db-assigned-id+ } "." } ;
HELP: find-primary-key
{ $values
{ "specs" "a sequence of sql-specs" }
{ "seq" "a sequence of sql-specs" } }
{ $description "Returns the rows from the sql-specs array that are part of the primary key. Composite primary keys are supported, so this word must return a sequence." }
{ "specs" "a sequence of SQL specs" }
{ "seq" "a sequence of SQL specs" } }
{ $description "Returns the rows from the SQL specs array that are part of the primary key. Composite primary keys are supported, so this word must return a sequence." }
{ $notes "This is a low-level word." } ;
HELP: generator-bind
{ $description "" } ;
HELP: get-slot-named
{ $values
{ "name" "a slot name" } { "tuple" tuple }
{ "value" "the value stored in the slot" } }
{ $description "Returns the value stored in a tuple slot, where the tuple slot is a string." } ;
HELP: literal-bind
{ $description "" } ;
HELP: lookup-create-type
{ $values
{ "obj" object }
{ "string" string } }
{ $description "" } ;
HELP: lookup-modifier
{ $values
{ "obj" object }
{ "string" string } }
{ $description "" } ;
HELP: lookup-type
{ $values
{ "obj" object }
{ "string" string } }
{ $description "" } ;
HELP: low-level-binding
{ $description "" } ;
HELP: modifiers
{ $values
{ "spec" "a sql spec" }
{ "string" string } }
{ $description "" } ;
HELP: no-sql-type
{ $values
{ "type" "a sql type" } }
{ $description "Throws an error containing a sql type that is unsupported or the result of a typo." } ;
{ "type" "a SQL type" } }
{ $description "Throws an error containing a SQL type that is unsupported or the result of a typo." } ;
HELP: normalize-spec
{ $values
{ "spec" "a sql spec" } }
{ $description "" } ;
{ "spec" "a SQL spec" } }
{ $description "Normalizes a SQL spec." } ;
HELP: offset-of-slot
{ $values
@ -181,56 +138,21 @@ HELP: offset-of-slot
{ "n" integer } }
{ $description "Returns the offset of a tuple slot accessed by name." } ;
HELP: persistent-table
{ $values
{ "hash" hashtable } }
{ $description "" } ;
HELP: primary-key?
{ $values
{ "spec" "a sql spec" }
{ "spec" "a SQL spec" }
{ "?" "a boolean" } }
{ $description "" } ;
HELP: random-id-generator
{ $description "" } ;
{ $description "Returns true if a SQL spec is a primary key." } ;
HELP: relation?
{ $values
{ "spec" "a sql spec" }
{ "spec" "a SQL spec" }
{ "?" "a boolean" } }
{ $description "" } ;
HELP: remove-db-assigned-id
{ $values
{ "specs" "a sequence of sql specs" }
{ "obj" object } }
{ $description "" } ;
HELP: remove-id
{ $values
{ "specs" "a sequence of sql specs" }
{ "obj" object } }
{ $description "" } ;
HELP: set-slot-named
{ $values
{ "value" object } { "name" string } { "obj" object } }
{ $description "" } ;
HELP: spec>tuple
{ $values
{ "class" class } { "spec" "a sql spec" }
{ "tuple" tuple } }
{ $description "" } ;
HELP: sql-spec
{ $description "" } ;
{ $description "Returns true if a SQL spec is a relation." } ;
HELP: unknown-modifier
{ $values { "modifier" string } }
{ $description "Throws an error containing an unknown sql modifier." } ;
{ $description "Throws an error containing an unknown SQL modifier." } ;
ARTICLE: "db.types" "Database types"
"The " { $vocab-link "db.types" } " vocabulary maps Factor types to database types." $nl

6
basis/environment/environment-docs.factor
View File

@ -7,12 +7,14 @@ HELP: (os-envs)
{ $values
{ "seq" sequence } }
{ $description "" } ;
{ $description "Returns a sequence of key/value pairs from the operating system." }
{ $notes "In most cases, use " { $link os-envs } " instead." } ;
HELP: (set-os-envs)
{ $values
{ "seq" sequence } }
{ $description "" } ;
{ $description "Low-level word for replacing the current set of environment variables." }
{ $notes "In most cases, use " { $link set-os-envs } " instead." } ;
HELP: os-env ( key -- value )

4
basis/farkup/farkup.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators html.elements io
USING: accessors arrays combinators io
io.streams.string kernel math namespaces peg peg.ebnf
sequences sequences.deep strings xml.entities xml.interpolate
sequences sequences.deep strings xml.entities xml.literals
vectors splitting xmode.code2html urls.encoding xml.data
xml.writer ;
IN: farkup

32
basis/formatting/formatting-docs.factor
View File

@ -12,17 +12,19 @@ HELP: printf
"specifying attributes for the result string, including such things as maximum width, "
"padding, and decimals.\n"
{ $table
{ "%%" "Single %" "" }
{ "%P.Ds" "String format" "string" }
{ "%P.DS" "String format uppercase" "string" }
{ "%c" "Character format" "char" }
{ "%C" "Character format uppercase" "char" }
{ "%+Pd" "Integer format" "fixnum" }
{ "%+P.De" "Scientific notation" "fixnum, float" }
{ "%+P.DE" "Scientific notation" "fixnum, float" }
{ "%+P.Df" "Fixed format" "fixnum, float" }
{ "%+Px" "Hexadecimal" "hex" }
{ "%+PX" "Hexadecimal uppercase" "hex" }
{ "%%" "Single %" "" }
{ "%P.Ds" "String format" "string" }
{ "%P.DS" "String format uppercase" "string" }
{ "%c" "Character format" "char" }
{ "%C" "Character format uppercase" "char" }
{ "%+Pd" "Integer format" "fixnum" }
{ "%+P.De" "Scientific notation" "fixnum, float" }
{ "%+P.DE" "Scientific notation" "fixnum, float" }
{ "%+P.Df" "Fixed format" "fixnum, float" }
{ "%+Px" "Hexadecimal" "hex" }
{ "%+PX" "Hexadecimal uppercase" "hex" }
{ "%[%?, %]" "Sequence format" "sequence" }
{ "%[%?: %? %]" "Assocs format" "assocs" }
}
$nl
"A plus sign ('+') is used to optionally specify that the number should be "
@ -72,6 +74,14 @@ HELP: printf
"USING: formatting ;"
"1234 \"%+d\" printf"
"+1234" }
{ $example
"USING: formatting ;"
"{ 1 2 3 } \"%[%d, %]\" printf"
"{ 1, 2, 3 }" }
{ $example
"USING: formatting ;"
"H{ { 1 2 } { 3 4 } } \"%[%d: %d %]\" printf"
"{ 1:2, 3:4 }" }
} ;
HELP: sprintf

14
basis/formatting/formatting.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: accessors arrays ascii calendar combinators fry kernel
USING: accessors arrays ascii assocs calendar combinators fry kernel
generalizations io io.encodings.ascii io.files io.streams.string
macros math math.functions math.parser peg.ebnf quotations
sequences splitting strings unicode.case vectors ;
@ -75,8 +75,8 @@ digits = (digits_)? => [[ 6 or ]]
fmt-% = "%" => [[ [ "%" ] ]]
fmt-c = "c" => [[ [ 1string ] ]]
fmt-C = "C" => [[ [ 1string >upper ] ]]
fmt-s = "s" => [[ [ ] ]]
fmt-S = "S" => [[ [ >upper ] ]]
fmt-s = "s" => [[ [ dup number? [ number>string ] when ] ]]
fmt-S = "S" => [[ [ dup number? [ number>string ] when >upper ] ]]
fmt-d = "d" => [[ [ >fixnum number>string ] ]]
fmt-e = digits "e" => [[ first '[ >exp _ exp>string ] ]]
fmt-E = digits "E" => [[ first '[ >exp _ exp>string >upper ] ]]
@ -91,7 +91,13 @@ strings = pad width strings_ => [[ reverse compose-all ]]
numbers_ = fmt-d|fmt-e|fmt-E|fmt-f|fmt-x|fmt-X
numbers = sign pad numbers_ => [[ unclip-last prefix compose-all [ fix-sign ] append ]]
formats = "%" (strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]]
types = strings|numbers
lists = "[%" types ", %]" => [[ second '[ _ map ", " join "{ " prepend " }" append ] ]]
assocs = "[%" types ": %" types " %]" => [[ [ second ] [ fourth ] bi '[ unzip [ _ map ] dip _ map zip [ ":" join ] map ", " join "{ " prepend " }" append ] ]]
formats = "%" (types|fmt-%|lists|assocs|unknown) => [[ second '[ _ dip ] ]]
plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]

1
basis/furnace/actions/actions.factor
View File

@ -10,7 +10,6 @@ furnace.utilities
furnace.redirection
furnace.conversations
html.forms
html.elements
html.components
html.components
html.templates.chloe

3
basis/furnace/auth/auth-docs.factor
View File

@ -105,9 +105,8 @@ ARTICLE: "furnace.auth.realm-config" "Authentication realm configuration"
"Instances of subclasses of " { $link realm } " have the following slots which may be set:"
{ $table
{ { $slot "name" } "A string identifying the realm for user interface purposes" }
{ { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } ". By default, the " { $link users-in-db } " provider is used." } }
{ { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } "). By default, the " { $link users-in-db } " provider is used." } }
{ { $slot "checksum" } { "An implementation of the checksum protocol used for verifying passwords (see " { $link "checksums" } "). The " { $link sha-256 } " checksum is used by default." } }
{ { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } } }
{ { $slot "secure" } { "A boolean, that when set to a true value, forces the client to access the authentication realm via HTTPS. An attempt to access the realm via HTTP results in a redirect to the corresponding HTTPS URL. On by default." } }
} ;

19
basis/furnace/chloe-tags/chloe-tags.factor
View File

@ -8,6 +8,7 @@ xml.data
xml.entities
xml.writer
xml.utilities
xml.literals
html.components
html.elements
html.forms
@ -20,7 +21,6 @@ http.server
http.server.redirection
http.server.responses
furnace.utilities ;
QUALIFIED-WITH: assocs a
IN: furnace.chloe-tags
! Chloe tags
@ -56,11 +56,11 @@ CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
: compile-link-attrs ( tag -- )
#! Side-effects current namespace.
attrs>> '[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
'[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
: a-start-tag ( tag -- )
[ <a ] [code]
[ non-chloe-attrs-only compile-attrs ]
[ attrs>> non-chloe-attrs-only compile-attrs ]
[ compile-link-attrs ]
[ compile-a-url ]
tri
@ -116,17 +116,18 @@ CHLOE: form
} cleave
] compile-with-scope ;
STRING: button-tag-markup
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
<div style="display: inline;"><button type="submit"></button></div>
</t:form>
;
: button-tag-markup ( -- xml )
<XML
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
<div style="display: inline;"><button type="submit"></button></div>
</t:form>
XML> ;
: add-tag-attrs ( attrs tag -- )
attrs>> swap update ;
CHLOE: button
button-tag-markup string>xml body>>
button-tag-markup body>>
{
[ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
[ [ attrs>> non-chloe-attrs-only ] dip "button" deep-tag-named add-tag-attrs ]

8
basis/furnace/utilities/utilities-docs.factor
View File

@ -57,7 +57,7 @@ HELP: modify-redirect-query
HELP: nested-responders
{ $values { "seq" "a sequence of responders" } }
{ $description "" } ;
{ $description "Outputs a sequence of responders which participated in the processing of the current request, with the main responder first and the innermost responder last." } ;
HELP: referrer
{ $values { "referrer/f" { $maybe string } } }
@ -69,11 +69,11 @@ HELP: request-params
HELP: resolve-base-path
{ $values { "string" string } { "string'" string } }
{ $description "" } ;
{ $description "Resolves a responder-relative URL." } ;
HELP: resolve-template-path
{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } }
{ $description "" } ;
{ $description "Resolves a responder-relative template path." } ;
HELP: same-host?
{ $values { "url" url } { "?" "a boolean" } }
@ -85,7 +85,7 @@ HELP: user-agent
HELP: vocab-path
{ $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } }
{ $description "" } ;
{ $description "Outputs the full pathname of the vocabulary's source directory." } ;
HELP: exit-with
{ $values { "value" object } }

10
basis/generalizations/generalizations-docs.factor
View File

@ -139,15 +139,6 @@ HELP: -nrot
}
} ;
HELP: nrev
{ $values { "n" integer } }
{ $description "A generalization of " { $link spin } " that reverses any number of items at the top of the stack."
}
{ $examples
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrev .s" "4\n3\n2\n1" }
"The " { $link spin } " word is equivalent to " { $snippet "3 nrev" } "."
} ;
HELP: ndip
{ $values { "quot" quotation } { "n" integer } }
{ $description "A generalization of " { $link dip } " that can work "
@ -327,7 +318,6 @@ $nl
{ $subsection nnip }
{ $subsection ndrop }
{ $subsection ntuck }
{ $subsection nrev }
{ $subsection mnswap }
"Generalized combinators:"
{ $subsection ndip }

7
basis/generalizations/generalizations.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo
! Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private math math.ranges
combinators macros quotations fry macros locals ;
USING: kernel sequences sequences.private math combinators
macros quotations fry ;
IN: generalizations
<<
@ -51,9 +51,6 @@ MACRO: nnip ( n -- )
MACRO: ntuck ( n -- )
2 + '[ dup _ -nrot ] ;
MACRO: nrev ( n -- )
1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ;
MACRO: ndip ( quot n -- )
[ '[ _ dip ] ] times ;

5
basis/help/html/html-tests.factor
View File

@ -1,5 +1,4 @@
IN: help.html.tests
USING: html.streams classes.predicate help.topics help.markup
io.streams.string accessors prettyprint kernel tools.test ;
USING: help.html tools.test help.topics kernel ;
[ ] [ [ [ \ predicate-instance? def>> . ] with-html-writer ] with-string-writer drop ] unit-test
[ ] [ "xml" >link help>html drop ] unit-test

30
basis/help/html/html.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary
io.files io.files.temp io.directories html.streams html.elements help kernel
io.files io.files.temp io.directories html.streams help kernel
assocs sequences make words accessors arrays help.topics vocabs
tools.vocabs tools.vocabs.browser namespaces prettyprint io
vocabs.loader serialize fry memoize unicode.case math.order
sorting debugger ;
sorting debugger html xml.literals xml.writer ;
IN: help.html
: escape-char ( ch -- )
@ -51,17 +51,21 @@ M: f topic>filename* drop \ f topic>filename* ;
] "" make
] [ 2drop f ] if ;
M: topic browser-link-href topic>filename ;
M: topic url-of topic>filename ;
: help-stylesheet ( -- )
"resource:basis/help/html/stylesheet.css" ascii file-contents write ;
: help-stylesheet ( -- string )
"resource:basis/help/html/stylesheet.css" ascii file-contents
[XML <style><-></style> XML] ;
: help>html ( topic -- )
dup topic>filename utf8 [
dup article-title
[ <style> help-stylesheet </style> ]
[ [ help ] with-html-writer ] simple-page
] with-file-writer ;
: help>html ( topic -- xml )
[ article-title ]
[ drop help-stylesheet ]
[ [ help ] with-html-writer ]
tri simple-page ;
: generate-help-file ( topic -- )
dup .
dup topic>filename utf8 [ help>html write-xml ] with-file-writer ;
: all-vocabs-really ( -- seq )
#! Hack.
@ -87,7 +91,7 @@ M: topic browser-link-href topic>filename ;
all-vocabs-really [ dup vocab-name ] { } map>assoc "vocabs.idx" serialize-index ;
: generate-help-files ( -- )
all-topics [ '[ _ help>html ] try ] each ;
all-topics [ '[ _ generate-help-file ] try ] each ;
: generate-help ( -- )
"docs" temp-file

1
basis/html/components/authors.txt
View File

@ -1 +1,2 @@
Slava Pestov
Daniel Ehrenberg

4
basis/html/components/components-docs.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Your name.
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string kernel strings
urls lcs inspector present io ;
@ -100,6 +100,6 @@ $nl
{ $subsection farkup }
"Creating custom components:"
{ $subsection render* }
"Custom components can emit HTML using the " { $vocab-link "html.elements" } " vocabulary." ;
"Custom components can emit HTML using the " { $vocab-link "xml.literals" } " vocabulary." ;
ABOUT: "html.components"

18
basis/html/components/components-tests.factor
View File

@ -1,7 +1,8 @@
IN: html.components.tests
USING: tools.test kernel io.streams.string
io.streams.null accessors inspector html.streams
html.elements html.components html.forms namespaces ;
html.components html.forms namespaces
xml.writer ;
[ ] [ begin-form ] unit-test
@ -31,6 +32,11 @@ TUPLE: color red green blue ;
] with-string-writer
] unit-test
[ "<input value=\"&lt;jimmy>\" name=\"red\" type=\"hidden\"/>" ] [
[
"red" hidden render
] with-string-writer
] unit-test
[ "<input value=\"&lt;jimmy>\" name=\"red\" type=\"hidden\"/>" ] [
[
"red" hidden render
@ -163,9 +169,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ t ] [
[ "object" inspector render ] with-string-writer
USING: splitting sequences ;
"\"" split "'" join ! replace " with ' for now
[ "object" value [ describe ] with-html-writer ] with-string-writer
"object" value [ describe ] with-html-writer xml>string
=
] unit-test
@ -185,3 +189,9 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
}
}
] [ values ] unit-test
[ ] [ "error" "blah" <validation-error> "error" set-value ] unit-test
[ ] [
"error" hidden render
] unit-test

25
basis/html/components/components.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2008 Slava Pestov
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces io math.parser assocs classes
classes.tuple words arrays sequences splitting mirrors
hashtables combinators continuations math strings inspector
fry locals calendar calendar.format xml.entities xml.data
validators urls present xml.writer xml.interpolate xml
validators urls present xml.writer xml.literals xml
xmode.code2html lcs.diff2html farkup io.streams.string
html.elements html.streams html.forms ;
html html.streams html.forms ;
IN: html.components
GENERIC: render* ( value name renderer -- xml )
@ -15,19 +15,12 @@ GENERIC: render* ( value name renderer -- xml )
prepare-value
[
dup validation-error?
[ [ message>> ] [ value>> ] bi ]
[ [ message>> render-error ] [ value>> ] bi ]
[ f swap ]
if
] 2dip
render* write-xml
[ render-error ] when* ;
<PRIVATE
: render-input ( value name type -- xml )
[XML <input value=<-> name=<-> type=<->/> XML] ;
PRIVATE>
render*
swap 2array write-xml ;
SINGLETON: label
@ -37,7 +30,7 @@ M: label render*
SINGLETON: hidden
M: hidden render*
drop "hidden" render-input ;
drop [XML <input value=<-> name=<-> type="hidden"/> XML] ;
: render-field ( value name size type -- xml )
[XML <input value=<-> name=<-> size=<-> type=<->/> XML] ;
@ -163,9 +156,7 @@ M: farkup render*
SINGLETON: inspector
M: inspector render*
2drop [
[ describe ] with-html-writer
] with-string-writer <unescaped> ;
2drop [ describe ] with-html-writer ;
! Diff component
SINGLETON: comparison

8
basis/html/elements/elements-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax io present html ;
IN: html.elements
USING: help.markup help.syntax io present ;
ARTICLE: "html.elements" "HTML elements"
"The " { $vocab-link "html.elements" } " vocabulary provides words for writing HTML tags to the " { $link output-stream } " with a familiar look and feel in the code."
@ -20,10 +20,6 @@ $nl
$nl
"Writing unescaped HTML to " { $vocab-link "html.streams" } ":"
{ $subsection write-html }
{ $subsection print-html }
"Writing some common HTML patterns:"
{ $subsection xhtml-preamble }
{ $subsection simple-page }
{ $subsection render-error } ;
{ $subsection print-html } ;
ABOUT: "html.elements"

26
basis/html/elements/elements.factor
View File

@ -2,9 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io io.styles kernel namespaces prettyprint quotations
sequences strings words xml.entities compiler.units effects
xml.data xml.interpolate urls math math.parser combinators
present fry io.streams.string xml.writer ;
xml.data xml.literals urls math math.parser combinators
present fry io.streams.string xml.writer html ;
IN: html.elements
SYMBOL: html
@ -127,24 +126,3 @@ SYMBOL: html
] [ define-attribute-word ] each
>>
: xhtml-preamble ( -- )
"<?xml version=\"1.0\"?>" write-html
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" write-html ;
: simple-page ( title head-quot body-quot -- )
[ with-string-writer <unescaped> ] bi@
<XML
<?xml version="1.0"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
<title><-></title>
<->
</head>
<body><-></body>
</html>
XML> write-xml ; inline
: render-error ( message -- )
[XML <span class="error"><-></span> XML] write-xml ;

9
basis/html/forms/forms.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors strings namespaces assocs hashtables io
mirrors math fry sequences words continuations html.elements
xml.entities ;
mirrors math fry sequences words continuations
xml.entities xml.writer xml.literals ;
IN: html.forms
TUPLE: form errors values validation-failed ;
@ -109,7 +109,6 @@ C: <validation-error> validation-error
: render-validation-errors ( -- )
form get errors>>
[
<ul "errors" =class ul>
[ <li> escape-string write </li> ] each
</ul>
[ [XML <li><-></li> XML] ] map
[XML <ul class="errors"><-></ul> XML] write-xml
] unless-empty ;

24
basis/html/html.factor Normal file
View File

@ -0,0 +1,24 @@
! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel xml.data xml.writer xml.literals urls.encoding ;
IN: html
: simple-page ( title head body -- xml )
<XML
<?xml version="1.0"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
<title><-></title>
<->
</head>
<body><-></body>
</html>
XML> ; inline
: render-error ( message -- xml )
[XML <span class="error"><-></span> XML] ;
: simple-link ( xml url -- xml' )
url-encode swap [XML <a href=<->><-></a> XML] ;

34
basis/html/streams/streams-docs.factor
View File

@ -1,33 +1,33 @@
IN: html.streams
USING: help.markup help.syntax kernel strings io io.styles
quotations ;
quotations xml.data ;
HELP: browser-link-href
{ $values { "presented" object } { "href" string } }
{ $contract "Outputs a link to a page displaying a presentation of the given object. This word is called when " { $link write-object } " is called on " { $link html-stream } " instances." } ;
HELP: url-of
{ $values { "object" object } { "url" string } }
{ $contract "Outputs a link to a page displaying a presentation of the given object. This word is called when " { $link write-object } " is called on " { $link html-writer } " instances." } ;
HELP: html-stream
{ $class-description "A formatted output stream which emits HTML markup." } ;
HELP: html-writer
{ $class-description "A formatted output stream which accumulates HTML markup as " { $vocab-link "xml.data" } " types. The " { $slot "data" } " slot contains a sequence with all markup so far." } ;
HELP: <html-stream>
{ $values { "stream" "an output stream" } { "html-stream" html-stream } }
{ $description "Creates a new formatted output stream which emits HTML markup on " { $snippet "stream" } "." } ;
HELP: <html-writer>
{ $values { "html-writer" html-writer } }
{ $description "Creates a new formatted output stream which accumulates HTML markup in its " { $snippet "data" } " slot." } ;
HELP: with-html-writer
{ $values { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an " { $link html-stream } " wrapping the current " { $link output-stream } "." }
{ $values { "quot" quotation } { "xml" xml-chunk } }
{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an " { $link html-writer } ". When the quotation returns, outputs the accumulated HTML markup." }
{ $examples
{ $example
"USING: io io.styles html.streams ;"
"[ \"Hello\" { { font-style bold } } format nl ] with-html-writer"
"<span style='font-style: normal; font-weight: bold; '>Hello</span><br/>"
"USING: io io.styles html.streams xml.writer ;"
"[ \"Hello\" { { font-style bold } } format nl ] with-html-writer write-xml"
"<span style=\"font-style: normal; font-weight: bold; \">Hello</span><br/>"
}
} ;
ARTICLE: "html.streams" "HTML streams"
"The " { $vocab-link "html.streams" } " vocabulary provides a stream which implements " { $link "styles" } " by writing HTML markup to the wrapped stream."
{ $subsection html-stream }
{ $subsection <html-stream> }
"The " { $vocab-link "html.streams" } " vocabulary provides a stream which implements " { $link "io.styles" } " by constructing HTML markup in the form of " { $vocab-link "xml.data" } " types."
{ $subsection html-writer }
{ $subsection <html-writer> }
{ $subsection with-html-writer } ;
ABOUT: "html.streams"

34
basis/html/streams/streams-tests.factor
View File

@ -1,17 +1,14 @@
USING: html.streams html.streams.private accessors io
io.streams.string io.styles kernel namespaces tools.test
xml.writer sbufs sequences inspector colors ;
xml.writer sbufs sequences inspector colors xml.writer
classes.predicate prettyprint ;
IN: html.streams.tests
: make-html-string
[ with-html-writer ] with-string-writer ; inline
: make-html-string ( quot -- string )
[ with-html-writer write-xml ] with-string-writer ; inline
[ [ ] make-html-string ] must-infer
[ ] [
512 <sbuf> <html-stream> drop
] unit-test
[ "" ] [
[ "" write ] make-html-string
] unit-test
@ -24,22 +21,17 @@ IN: html.streams.tests
[ "<" write ] make-html-string
] unit-test
[ "<" ] [
[ "<" H{ } output-stream get format-html-span ] make-html-string
] unit-test
TUPLE: funky town ;
M: funky browser-link-href
"http://www.funky-town.com/" swap town>> append ;
M: funky url-of "http://www.funky-town.com/" swap town>> append ;
[ "<a href='http://www.funky-town.com/austin'>&lt;</a>" ] [
[ "<a href=\"http://www.funky-town.com/austin\">&lt;</a>" ] [
[
"<" "austin" funky boa write-object
] make-html-string
] unit-test
[ "<span style='font-family: monospace; '>car</span>" ]
[ "<span style=\"font-family: monospace; \">car</span>" ]
[
[
"car"
@ -48,7 +40,7 @@ M: funky browser-link-href
] make-html-string
] unit-test
[ "<span style='color: #ff00ff; '>car</span>" ]
[ "<span style=\"color: #ff00ff; \">car</span>" ]
[
[
"car"
@ -57,7 +49,7 @@ M: funky browser-link-href
] make-html-string
] unit-test
[ "<div style='background-color: #ff00ff; white-space: pre; font-family: monospace; '>cdr</div>" ]
[ "<div style=\"background-color: #ff00ff; white-space: pre; font-family: monospace;\">cdr</div>" ]
[
[
H{ { page-color T{ rgba f 1 0 1 1 } } }
@ -65,10 +57,10 @@ M: funky browser-link-href
] make-html-string
] unit-test
[
"<div style='white-space: pre; font-family: monospace; '></div>"
] [
[ "<div style=\"white-space: pre; font-family: monospace;\"></div>" ] [
[ H{ } [ ] with-nesting nl ] make-html-string
] unit-test
[ ] [ [ { 1 2 3 } describe ] with-html-writer ] unit-test
[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test
[ ] [ [ \ predicate-instance? def>> . ] with-html-writer drop ] unit-test

182
basis/html/streams/streams.factor
View File

@ -1,17 +1,17 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators generic assocs help http io io.styles
io.files continuations io.streams.string kernel math math.order
math.parser namespaces make quotations assocs sequences strings
words html.elements xml.entities sbufs continuations destructors
accessors arrays urls.encoding ;
USING: accessors kernel assocs io io.styles math math.order math.parser
sequences strings make words combinators macros xml.literals html fry
destructors ;
IN: html.streams
GENERIC: browser-link-href ( presented -- href )
GENERIC: url-of ( object -- url )
M: object browser-link-href drop f ;
M: object url-of drop f ;
TUPLE: html-stream stream last-div ;
TUPLE: html-writer data last-div ;
<PRIVATE
! stream-nl after with-nesting or tabular-output is
! ignored, so that HTML stream output looks like
@ -25,37 +25,28 @@ TUPLE: html-stream stream last-div ;
: a-div ( stream -- stream )
t >>last-div ; inline
: <html-stream> ( stream -- html-stream )
f html-stream boa ;
: new-html-writer ( class -- html-writer )
new V{ } clone >>data ; inline
<PRIVATE
TUPLE: html-sub-stream < html-stream style parent ;
TUPLE: html-sub-stream < html-writer style parent ;
: new-html-sub-stream ( style stream class -- stream )
new
512 <sbuf> >>stream
new-html-writer
swap >>parent
swap >>style ; inline
: end-sub-stream ( substream -- string style stream )
[ stream>> >string ] [ style>> ] [ parent>> ] tri ;
[ data>> ] [ style>> ] [ parent>> ] tri ;
: object-link-tag ( style quot -- )
presented pick at [
browser-link-href [
<a url-encode =href a> call </a>
] [ call ] if*
] [ call ] if* ; inline
: object-link-tag ( xml style -- xml )
presented swap at [ url-of [ simple-link ] when* ] when* ;
: href-link-tag ( style quot -- )
href pick at [
<a url-encode =href a> call </a>
] [ call ] if* ; inline
: href-link-tag ( xml style -- xml )
href swap at [ simple-link ] when* ;
: hex-color, ( color -- )
[ red>> ] [ green>> ] [ blue>> ] tri
[ 255 * >fixnum >hex 2 CHAR: 0 pad-head % ] tri@ ;
[ 255 * >integer >hex 2 CHAR: 0 pad-head % ] tri@ ;
: fg-css, ( color -- )
"color: #" % hex-color, "; " % ;
@ -76,32 +67,29 @@ TUPLE: html-sub-stream < html-stream style parent ;
: font-css, ( font -- )
"font-family: " % % "; " % ;
: apply-style ( style key quot -- style gadget )
[ over at ] dip when* ; inline
: make-css ( style quot -- str )
"" make nip ; inline
MACRO: make-css ( pairs -- str )
[ '[ _ swap at [ _ execute ] when* ] ] { } assoc>map
'[ [ _ cleave ] "" make ] ;
: span-css-style ( style -- str )
[
foreground [ fg-css, ] apply-style
background [ bg-css, ] apply-style
font [ font-css, ] apply-style
font-style [ style-css, ] apply-style
font-size [ size-css, ] apply-style
] make-css ;
{
{ foreground fg-css, }
{ background bg-css, }
{ font font-css, }
{ font-style style-css, }
{ font-size size-css, }
} make-css ;
: span-tag ( style quot -- )
over span-css-style [
call
] [
<span =style span> call </span>
] if-empty ; inline
: span-tag ( xml style -- xml )
span-css-style
[ swap [XML <span style=<->><-></span> XML] ] unless-empty ; inline
: emit-html ( quot stream -- )
dip data>> push ; inline
: format-html-span ( string style stream -- )
stream>> [
[ [ [ drop write ] span-tag ] href-link-tag ] object-link-tag
] with-output-stream* ;
[ [ span-tag ] [ href-link-tag ] [ object-link-tag ] tri ]
emit-html ;
TUPLE: html-span-stream < html-sub-stream ;
@ -113,28 +101,26 @@ M: html-span-stream dispose
: padding-css, ( padding -- ) "padding: " % # "px; " % ;
: pre-css, ( margin -- )
[ "white-space: pre; font-family: monospace; " % ] unless ;
CONSTANT: pre-css "white-space: pre; font-family: monospace;"
: div-css-style ( style -- str )
[
page-color [ bg-css, ] apply-style
border-color [ border-css, ] apply-style
border-width [ padding-css, ] apply-style
wrap-margin over at pre-css,
] make-css ;
: div-tag ( style quot -- )
swap div-css-style [
call
{
{ page-color bg-css, }
{ border-color border-css, }
{ border-width padding-css, }
} make-css
] [
<div =style div> call </div>
] if-empty ; inline
wrap-margin swap at
[ pre-css append ] unless
] bi ;
: div-tag ( xml style -- xml' )
div-css-style
[ swap [XML <div style=<->><-></div> XML] ] unless-empty ;
: format-html-div ( string style stream -- )
stream>> [
[ [ write ] div-tag ] object-link-tag
] with-output-stream* ;
[ [ div-tag ] [ object-link-tag ] bi ] emit-html ;
TUPLE: html-block-stream < html-sub-stream ;
@ -145,57 +131,51 @@ M: html-block-stream dispose ( quot style stream -- )
"padding: " % first2 max 2 /i # "px; " % ;
: table-style ( style -- str )
[
table-border [ border-css, ] apply-style
table-gap [ border-spacing-css, ] apply-style
] make-css ;
: table-attrs ( style -- )
table-style " border-collapse: collapse;" append =style ;
: do-escaping ( string style -- string )
html swap at [ escape-string ] unless ;
{
{ table-border border-css, }
{ table-gap border-spacing-css, }
} make-css
" border-collapse: collapse;" append ;
PRIVATE>
! Stream protocol
M: html-stream stream-flush
stream>> stream-flush ;
M: html-writer stream-flush drop ;
M: html-stream stream-write1
[ 1string ] dip stream-write ;
M: html-writer stream-write1
not-a-div [ 1string ] emit-html ;
M: html-stream stream-write
not-a-div [ escape-string ] dip stream>> stream-write ;
M: html-writer stream-write
not-a-div [ ] emit-html ;
M: html-stream stream-format
[ html over at [ [ escape-string ] dip ] unless ] dip
M: html-writer stream-format
format-html-span ;
M: html-stream stream-nl
dup last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
M: html-writer stream-nl
dup last-div? [ drop ] [ [ [XML <br/> XML] ] emit-html ] if ;
M: html-stream make-span-stream
M: html-writer make-span-stream
html-span-stream new-html-sub-stream ;
M: html-stream make-block-stream
M: html-writer make-block-stream
html-block-stream new-html-sub-stream ;
M: html-stream make-cell-stream
M: html-writer make-cell-stream
html-sub-stream new-html-sub-stream ;
M: html-stream stream-write-table
a-div stream>> [
<table dup table-attrs table> swap [
<tr> [
<td "top" =valign swap table-style =style td>
stream>> >string write
</td>
] with each </tr>
] with each </table>
] with-output-stream* ;
M: html-writer stream-write-table
a-div [
table-style swap [
[ data>> [XML <td valign="top" style=<->><-></td> XML] ] with map
[XML <tr><-></tr> XML]
] with map
[XML <table><-></table> XML]
] emit-html ;
M: html-stream dispose stream>> dispose ;
M: html-writer dispose drop ;
: with-html-writer ( quot -- )
output-stream get <html-stream> swap with-output-stream* ; inline
: <html-writer> ( -- html-writer )
html-writer new-html-writer ;
: with-html-writer ( quot -- xml )
<html-writer> [ swap with-output-stream* ] keep data>> ; inline

4
basis/html/templates/chloe/chloe.factor
View File

@ -5,8 +5,9 @@ namespaces make classes.tuple assocs splitting words arrays io
io.files io.files.info io.encodings.utf8 io.streams.string
unicode.case mirrors math urls present multiline quotations xml
logging continuations
xml.data
xml.data xml.writer xml.literals strings
html.forms
html
html.elements
html.components
html.templates
@ -15,7 +16,6 @@ html.templates.chloe.components
html.templates.chloe.syntax ;
IN: html.templates.chloe
! Chloe is Ed's favorite web designer
TUPLE: chloe path ;
C: <chloe> chloe

6
basis/html/templates/chloe/compiler/compiler.factor
View File

@ -73,8 +73,8 @@ DEFER: compile-element
[ compile-start-tag ]
[ compile-children ]
[ compile-end-tag ]
[ drop tag-stack get pop* ]
} cleave ;
} cleave
tag-stack get pop* ;
ERROR: unknown-chloe-tag tag ;
@ -116,7 +116,7 @@ ERROR: unknown-chloe-tag tag ;
[ [ compile-children ] compile-quot ] [ % ] bi* ; inline
: compile-children>string ( tag -- )
[ with-string-writer ] process-children ;
[ with-string-writer ] process-children ;
: compile-with-scope ( quot -- )
compile-quot [ with-scope ] [code] ; inline

3
basis/html/templates/chloe/components/components.factor
View File

@ -21,7 +21,8 @@ M: singleton-class component-tag ( tag class -- )
bi ;
M: tuple-class component-tag ( tag class -- )
[ drop "name" required-attr compile-attr ] [ compile-component-attrs ] 2bi
[ drop "name" required-attr compile-attr ]
[ compile-component-attrs ] 2bi
[ render ] [code] ;
: COMPONENT:

1
basis/html/templates/chloe/syntax/syntax.factor
View File

@ -6,7 +6,6 @@ classes.tuple assocs splitting words arrays memoize parser lexer
io io.files io.encodings.utf8 io.streams.string
unicode.case mirrors fry math urls
multiline xml xml.data xml.writer xml.utilities
html.elements
html.components
html.templates ;

14
basis/html/templates/fhtml/fhtml.factor
View File

@ -1,12 +1,10 @@
! Copyright (C) 2005 Alex Chapman
! Copyright (C) 2006, 2008 Slava Pestov
! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: continuations sequences kernel namespaces debugger
combinators math quotations generic strings splitting
accessors assocs fry vocabs.parser
parser lexer io io.files io.streams.string io.encodings.utf8
html.elements
html.templates ;
combinators math quotations generic strings splitting accessors
assocs fry vocabs.parser parser lexer io io.files
io.streams.string io.encodings.utf8 html.templates ;
IN: html.templates.fhtml
! We use a custom lexer so that %> ends a token even if not
@ -34,13 +32,13 @@ DEFER: <% delimiter
[
over line-text>>
[ column>> ] 2dip subseq parsed
\ write-html parsed
\ write parsed
] 2keep 2 + >>column drop ;
: still-looking ( accum lexer -- accum )
[
[ line-text>> ] [ column>> ] bi tail
parsed \ print-html parsed
parsed \ print parsed
] keep next-line ;
: parse-%> ( accum lexer -- accum )

16
basis/html/templates/templates.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel fry io io.encodings.utf8 io.files
debugger prettyprint continuations namespaces boxes sequences
arrays strings html.elements io.streams.string
quotations xml.data xml.writer ;
arrays strings html io.streams.string
quotations xml.data xml.writer xml.literals ;
IN: html.templates
MIXIN: template
@ -53,9 +53,13 @@ SYMBOL: atom-feeds
: write-atom-feeds ( -- )
atom-feeds get [
<link "alternate" =rel "application/atom+xml" =type
first2 [ =title ] [ =href ] bi*
link/>
first2 [XML
<link
rel="alternate"
type="application/atom+xml"
title=<->
href=<->/>
XML] write-xml
] each ;
SYMBOL: nested-template?
@ -63,7 +67,7 @@ SYMBOL: nested-template?
SYMBOL: next-template
: call-next-template ( -- )
next-template get write-html ;
next-template get write ;
M: f call-template* drop call-next-template ;

7
basis/http/http-tests.factor
View File

@ -298,7 +298,7 @@ test-db [
[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
USING: html.components html.elements html.forms
USING: html.components html.forms
xml xml.utilities validators
furnace furnace.conversations ;
@ -308,7 +308,7 @@ SYMBOL: a
<dispatcher>
<action>
[ a get-global "a" set-value ] >>init
[ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
[ [ "<html>" write "a" <field> render "</html>" write ] "text/html" <content> ] >>display
[ { { "a" [ v-integer ] } } validate-params ] >>validate
[ "a" value a set-global URL" " <redirect> ] >>submit
<conversations>
@ -322,7 +322,8 @@ SYMBOL: a
3 a set-global
: test-a string>xml "input" tag-named "value" attr ;
: test-a ( xml -- value )
string>xml body>> "input" deep-tag-named "value" attr ;
[ "3" ] [
"http://localhost/" add-port http-get

1
basis/http/server/dispatchers/dispatchers-tests.factor
View File

@ -4,7 +4,6 @@ assocs arrays classes words urls ;
IN: http.server.dispatchers.tests
\ find-responder must-infer
\ http-error. must-infer
TUPLE: mock-responder path ;

14
basis/http/server/responses/responses.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: html.elements math.parser http accessors kernel
USING: math.parser http accessors kernel xml.literals xml.writer
io io.streams.string io.encodings.utf8 ;
IN: http.server.responses
@ -13,11 +13,13 @@ IN: http.server.responses
swap >>body ;
: trivial-response-body ( code message -- )
<html>
<body>
<h1> [ number>string write bl ] [ write ] bi* </h1>
</body>
</html> ;
<XML
<html>
<body>
<h1><-> <-></h1>
</body>
</html>
XML> write-xml ;
: <trivial-response> ( code message -- response )
2dup [ trivial-response-body ] with-string-writer

2
basis/http/server/server-tests.factor
View File

@ -2,3 +2,5 @@ USING: http http.server math sequences continuations tools.test ;
IN: http.server.tests
[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
\ make-http-error must-infer

18
basis/http/server/server.factor
View File

@ -24,8 +24,9 @@ http.parsers
http.server.responses
http.server.remapping
html.templates
html.elements
html.streams ;
html.streams
html
xml.writer ;
IN: http.server
: check-absolute ( url -- url )
@ -173,14 +174,14 @@ main-responder global [ <404> <trivial-responder> or ] change-at
: call-responder ( path responder -- response )
[ add-responder-nesting ] [ call-responder* ] 2bi ;
: http-error. ( error -- )
"Internal server error" [ ] [
[ print-error nl :c ] with-html-writer
] simple-page ;
: make-http-error ( error -- xml )
[ "Internal server error" f ] dip
[ print-error nl :c ] with-html-writer
simple-page ;
: <500> ( error -- response )
500 "Internal server error" <trivial-response>
swap development? get [ '[ _ http-error. ] >>body ] [ drop ] if ;
swap development? get [ make-http-error >>body ] [ drop ] if ;
: do-response ( response -- )
[ request get swap write-full-response ]
@ -189,7 +190,8 @@ main-responder global [ <404> <trivial-responder> or ] change-at
[
utf8 [
development? get
[ http-error. ] [ drop "Response error" write ] if
[ make-http-error ] [ drop "Response error" ] if
write-xml
] with-encoded-output
] bi
] recover ;

4
basis/http/server/static/static-tests.factor Normal file
View File

@ -0,0 +1,4 @@
IN: http.server.static.tests
USING: http.server.static tools.test xml.writer ;
[ ] [ "resource:basis" directory>html write-xml ] unit-test

27
basis/http/server/static/static.factor
View File

@ -4,9 +4,9 @@ USING: calendar kernel math math.order math.parser namespaces
parser sequences strings assocs hashtables debugger mime.types
sorting logging calendar.format accessors splitting io io.files
io.files.info io.directories io.pathnames io.encodings.binary
fry xml.entities destructors urls html.elements
fry xml.entities destructors urls html xml.literals
html.templates.fhtml http http.server http.server.responses
http.server.redirection ;
http.server.redirection xml.writer ;
IN: http.server.static
TUPLE: file-responder root hook special allow-listings ;
@ -56,23 +56,22 @@ TUPLE: file-responder root hook special allow-listings ;
\ serve-file NOTICE add-input-logging
: file. ( name -- )
: file>html ( name -- xml )
dup link-info directory? [ "/" append ] when
dup <a =href a> escape-string write </a> ;
dup [XML <li><a href=<->><-></a></li> XML] ;
: directory. ( path -- )
dup file-name [ ] [
[ <h1> file-name escape-string write </h1> ]
[
<ul>
directory-files [ <li> file. </li> ] each
</ul>
] bi
] simple-page ;
: directory>html ( path -- xml )
[ file-name ]
[ drop f ]
[
[ file-name ] [ [ [ file>html ] map ] with-directory-files ] bi
[XML <h1><-></h1> <ul><-></ul> XML]
] tri
simple-page ;
: list-directory ( directory -- response )
file-responder get allow-listings>> [
'[ _ directory. ] "text/html" <content>
directory>html "text/html" <content>
] [
drop <403>
] if ;

2
basis/io/encodings/8-bit/8-bit.factor
View File

@ -45,7 +45,7 @@ IN: io.encodings.8-bit
: ch>byte ( assoc -- newassoc )
[ swap ] assoc-map >hashtable ;
: parse-file ( path -- byte>ch ch>byte )
: parse-file ( stream -- byte>ch ch>byte )
lines process-contents
[ byte>ch ] [ ch>byte ] bi ;

7998
basis/io/encodings/japanese/CP932.txt Normal file
View File

File diff suppressed because it is too large Load Diff

1
basis/io/encodings/japanese/authors.txt Normal file
View File

@ -0,0 +1 @@
Daniel Ehrenberg

19
basis/io/encodings/japanese/japanese-docs.factor Normal file
View File

@ -0,0 +1,19 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax ;
IN: io.encodings.japanese
ARTICLE: "io.encodings.japanese" "Japanese text encodings"
"Several encodings are used for Japanese text besides the standard UTF encodings for Unicode strings. These are mostly based on the character set defined in the JIS X 208 standard. Current coverage of encodings is incomplete."
{ $subsection shift-jis }
{ $subsection windows-31j } ;
ABOUT: "io.encodings.japanese"
HELP: windows-31j
{ $class-description "The encoding descriptor Windows-31J, which is sometimes informally called Shift JIS. This is based on Code Page 932." }
{ $see-also "encodings-introduction" shift-jis } ;
HELP: shift-jis
{ $class-description "The encoding descriptor for Shift JIS, or JIS X 208:1997 Appendix 1. Microsoft extensions are not included." }
{ $see-also "encodings-introduction" windows-31j } ;

17
basis/io/encodings/japanese/japanese-tests.factor Normal file
View File

@ -0,0 +1,17 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings.japanese tools.test io.encodings.string arrays strings ;
IN: io.encodings.japanese.tests
[ { CHAR: replacement-character } ] [ { 141 } shift-jis decode >array ] unit-test
[ "" ] [ "" shift-jis decode >string ] unit-test
[ "" ] [ "" shift-jis encode >string ] unit-test
[ { CHAR: replacement-character } shift-jis encode ] must-fail
[ "ab¥ｨ" ] [ { CHAR: a CHAR: b HEX: 5C HEX: A8 } shift-jis decode ] unit-test
[ { CHAR: a CHAR: b HEX: 5C HEX: A8 } ] [ "ab¥ｨ" shift-jis encode >array ] unit-test
[ "ab\\ｨ" ] [ { CHAR: a CHAR: b HEX: 5C HEX: A8 } windows-31j decode ] unit-test
[ { CHAR: a CHAR: b HEX: 5C HEX: A8 } ] [ "ab\\ｨ" windows-31j encode >array ] unit-test
[ "\u000081\u0000c8" ] [ CHAR: logical-and 1string windows-31j encode >string ] unit-test
[ "\u000081\u0000c8" ] [ CHAR: logical-and 1string shift-jis encode >string ] unit-test
[ { CHAR: logical-and } ] [ "\u000081\u0000c8" windows-31j decode >array ] unit-test
[ { CHAR: logical-and } ] [ "\u000081\u0000c8" shift-jis decode >array ] unit-test

61
basis/io/encodings/japanese/japanese.factor Normal file
View File

@ -0,0 +1,61 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel io io.files combinators.short-circuit
math.order values assocs io.encodings io.binary fry strings
math io.encodings.ascii arrays accessors splitting math.parser
biassocs ;
IN: io.encodings.japanese
VALUE: shift-jis
VALUE: windows-31j
<PRIVATE
TUPLE: jis assoc ;
: <jis> ( assoc -- jis )
[ nip ] assoc-filter H{ } assoc-like
>biassoc jis boa ;
: ch>jis ( ch tuple -- jis ) assoc>> value-at [ encode-error ] unless* ;
: jis>ch ( jis tuple -- string ) assoc>> at replacement-char or ;
: process-jis ( lines -- assoc )
[ "#" split1 drop ] map harvest [
"\t" split 2 head
[ 2 short tail hex> ] map
] map ;
: make-jis ( filename -- jis )
ascii file-lines process-jis <jis> ;
"resource:basis/io/encodings/japanese/CP932.txt"
make-jis to: windows-31j
"resource:basis/io/encodings/japanese/sjis-0208-1997-std.txt"
make-jis to: shift-jis
: small? ( char -- ? )
! ASCII range or single-byte halfwidth katakana
{ [ 0 HEX: 7F between? ] [ HEX: A1 HEX: DF between? ] } 1|| ;
: write-halfword ( stream halfword -- )
h>b/b swap B{ } 2sequence swap stream-write ;
M: jis encode-char
swapd ch>jis
dup small?
[ swap stream-write1 ]
[ write-halfword ] if ;
M: jis decode-char
swap dup stream-read1 [
dup small? [ nip swap jis>ch ] [
swap stream-read1
[ 2array be> swap jis>ch ]
[ 2drop replacement-char ] if*
] if
] [ 2drop f ] if* ;
PRIVATE>

9066
basis/io/encodings/japanese/sjis-0208-1997-std.txt Normal file
View File

File diff suppressed because it is too large Load Diff

1
basis/io/encodings/japanese/summary.txt Normal file
View File

@ -0,0 +1 @@
Japanese text encodings

1
basis/io/encodings/japanese/tags.txt Normal file
View File

@ -0,0 +1 @@
text

2
basis/io/encodings/utf16/utf16-docs.factor
View File

@ -1,3 +1,5 @@
! Copyright (C) 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.encodings strings ;
IN: io.encodings.utf16

4
basis/io/encodings/utf16/utf16-tests.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test io.encodings.utf16 arrays sbufs
io.streams.byte-array sequences io.encodings io
bootstrap.unicode
io.encodings.string alien.c-types alien.strings accessors classes ;
IN: io.encodings.utf16.tests
@ -15,7 +16,6 @@ IN: io.encodings.utf16.tests
[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode >array ] unit-test
[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode >array ] unit-test
[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode >array ] unit-test

8
basis/io/encodings/utf16/utf16.factor
View File

@ -101,13 +101,9 @@ M: utf16le encode-char ( char stream encoding -- )
! UTF-16
: bom-le B{ HEX: ff HEX: fe } ; inline
CONSTANT: bom-le B{ HEX: ff HEX: fe }
: bom-be B{ HEX: fe HEX: ff } ; inline
: start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
: start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
CONSTANT: bom-be B{ HEX: fe HEX: ff }
: bom>le/be ( bom -- le/be )
dup bom-le sequence= [ drop utf16le ] [

1
basis/io/encodings/utf32/authors.txt Normal file
View File

@ -0,0 +1 @@
Daniel Ehrenberg

1
basis/io/encodings/utf32/summary.txt Normal file
View File

@ -0,0 +1 @@
UTF32 encoding/decoding

1
basis/io/encodings/utf32/tags.txt Normal file
View File

@ -0,0 +1 @@
text

27
basis/io/encodings/utf32/utf32-docs.factor Normal file
View File

@ -0,0 +1,27 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.encodings strings ;
IN: io.encodings.utf32
ARTICLE: "io.encodings.utf32" "UTF-32 encoding"
"The UTF-32 encoding is a fixed-width encoding. Unicode code points are encoded as 4 byte sequences. There are three encoding descriptor classes for working with UTF-32, depending on endianness or the presence of a BOM:"
{ $subsection utf32 }
{ $subsection utf32le }
{ $subsection utf32be } ;
ABOUT: "io.encodings.utf32"
HELP: utf32le
{ $class-description "The encoding descriptor for UTF-32LE, that is, UTF-32 in little endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
{ $see-also "encodings-introduction" } ;
HELP: utf32be
{ $class-description "The encoding descriptor for UTF-32BE, that is, UTF-32 in big endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
{ $see-also "encodings-introduction" } ;
HELP: utf32
{ $class-description "The encoding descriptor for UTF-32, that is, UTF-32 with a byte order mark. This is the most useful for general input and output in UTF-32. Streams can be made which read or write wth this encoding." }
{ $see-also "encodings-introduction" } ;
{ utf32 utf32le utf32be } related-words

30
basis/io/encodings/utf32/utf32-tests.factor Normal file
View File

@ -0,0 +1,30 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test io.encodings.utf32 arrays sbufs
io.streams.byte-array sequences io.encodings io
io.encodings.string alien.c-types alien.strings accessors classes ;
IN: io.encodings.utf32.tests
[ { CHAR: x } ] [ { 0 0 0 CHAR: x } utf32be decode >array ] unit-test
[ { HEX: 1D11E } ] [ { 0 1 HEX: D1 HEX: 1E } utf32be decode >array ] unit-test
[ { CHAR: replacement-character } ] [ { 0 1 HEX: D1 } utf32be decode >array ] unit-test
[ { CHAR: replacement-character } ] [ { 0 1 } utf32be decode >array ] unit-test
[ { CHAR: replacement-character } ] [ { 0 } utf32be decode >array ] unit-test
[ { } ] [ { } utf32be decode >array ] unit-test
[ { 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } utf32be encode >array ] unit-test
[ { CHAR: x } ] [ { CHAR: x 0 0 0 } utf32le decode >array ] unit-test
[ { HEX: 1d11e } ] [ { HEX: 1e HEX: d1 1 0 } utf32le decode >array ] unit-test
[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 1 } utf32le decode >array ] unit-test
[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 } utf32le decode >array ] unit-test
[ { CHAR: replacement-character } ] [ { HEX: 1e } utf32le decode >array ] unit-test
[ { } ] [ { } utf32le decode >array ] unit-test
[ { 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32le encode >array ] unit-test
[ { CHAR: x } ] [ { HEX: ff HEX: fe 0 0 CHAR: x 0 0 0 } utf32 decode >array ] unit-test
[ { CHAR: x } ] [ { 0 0 HEX: fe HEX: ff 0 0 0 CHAR: x } utf32 decode >array ] unit-test
[ { HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32 encode >array ] unit-test

56
basis/io/encodings/utf32/utf32.factor Normal file
View File

@ -0,0 +1,56 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel io.encodings combinators io io.encodings.utf16
sequences io.binary ;
IN: io.encodings.utf32
SINGLETON: utf32be
SINGLETON: utf32le
SINGLETON: utf32
<PRIVATE
! Decoding
: char> ( stream encoding quot -- ch )
nip swap 4 swap stream-read dup length {
{ 0 [ 2drop f ] }
{ 4 [ swap call ] }
[ 3drop replacement-char ]
} case ; inline
M: utf32be decode-char
[ be> ] char> ;
M: utf32le decode-char
[ le> ] char> ;
! Encoding
: >char ( char stream encoding quot -- )
nip 4 swap curry dip stream-write ; inline
M: utf32be encode-char
[ >be ] >char ;
M: utf32le encode-char
[ >le ] >char ;
! UTF-32
CONSTANT: bom-le B{ HEX: ff HEX: fe 0 0 }
CONSTANT: bom-be B{ 0 0 HEX: fe HEX: ff }
: bom>le/be ( bom -- le/be )
dup bom-le sequence= [ drop utf32le ] [
bom-be sequence= [ utf32be ] [ missing-bom ] if
] if ;
M: utf32 <decoder> ( stream utf32 -- decoder )
drop 4 over stream-read bom>le/be <decoder> ;
M: utf32 <encoder> ( stream utf32 -- encoder )
drop bom-le over stream-write utf32le <encoder> ;

2
basis/lcs/diff2html/diff2html.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: lcs xml.interpolate xml.writer kernel strings ;
USING: lcs xml.literals xml.writer kernel strings ;
FROM: accessors => item>> ;
FROM: io => write ;
FROM: sequences => each if-empty when-empty map ;

2
basis/math/bitwise/bitwise-docs.factor
View File

@ -242,7 +242,7 @@ HELP: shift-mod
{ "n" integer } { "s" integer } { "w" integer }
{ "n" integer }
}
{ $description "" } ;
{ $description "Calls " { $link shift } " on " { $snippet "n" } " and " { $snippet "s" } ", wrapping the result to " { $snippet "w" } " bits." } ;
HELP: unmask
{ $values

47
basis/math/blas/cblas/cblas.factor
View File

@ -1,36 +1,51 @@
USING: alien alien.c-types alien.syntax kernel system combinators ;
USING: alien alien.c-types alien.syntax kernel system
combinators ;
IN: math.blas.cblas
<< "cblas" {
<<
: load-atlas ( -- )
"atlas" "libatlas.so" "cdecl" add-library ;
: load-fortran ( -- )
"I77" "libI77.so" "cdecl" add-library
"F77" "libF77.so" "cdecl" add-library ;
: load-blas ( -- )
"blas" "libblas.so" "cdecl" add-library ;
"cblas" {
{ [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] }
{ [ os windows? ] [ "blas.dll" "cdecl" add-library ] }
{ [ os openbsd? ] [ "libcblas.so" "cdecl" add-library ] }
{ [ os freebsd? ] [ "libcblas.so" "cdecl" add-library ] }
{ [ os openbsd? ] [ "libcblas.so" "cdecl" add-library load-blas ] }
{ [ os netbsd? ] [
load-fortran load-blas
"/usr/local/lib/libcblas.so" "cdecl" add-library
] }
{ [ os freebsd? ] [ "libcblas.so" "cdecl" add-library load-atlas ] }
[ "libblas.so" "cdecl" add-library ]
} cond >>
} cond
>>
LIBRARY: cblas
TYPEDEF: int CBLAS_ORDER
: CblasRowMajor 101 ; inline
: CblasColMajor 102 ; inline
CONSTANT: CblasRowMajor 101
CONSTANT: CblasColMajor 102
TYPEDEF: int CBLAS_TRANSPOSE
: CblasNoTrans 111 ; inline
: CblasTrans 112 ; inline
: CblasConjTrans 113 ; inline
CONSTANT: CblasNoTrans 111
CONSTANT: CblasTrans 112
CONSTANT: CblasConjTrans 113
TYPEDEF: int CBLAS_UPLO
: CblasUpper 121 ; inline
: CblasLower 122 ; inline
CONSTANT: CblasUpper 121
CONSTANT: CblasLower 122
TYPEDEF: int CBLAS_DIAG
: CblasNonUnit 131 ; inline
: CblasUnit 132 ; inline
CONSTANT: CblasNonUnit 131
CONSTANT: CblasUnit 132
TYPEDEF: int CBLAS_SIDE
: CblasLeft 141 ; inline
: CblasRight 142 ; inline
CONSTANT: CblasLeft 141
CONSTANT: CblasRight 142
TYPEDEF: int CBLAS_INDEX

52
basis/math/blas/matrices/matrices-docs.factor
View File

@ -1,4 +1,4 @@
USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings ;
USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings multiline ;
IN: math.blas.matrices
ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
@ -21,8 +21,6 @@ ARTICLE: "math.blas-types" "BLAS interface types"
{ $subsection double-blas-matrix }
{ $subsection float-complex-blas-matrix }
{ $subsection double-complex-blas-matrix }
"Syntax words are provided for constructing literal vectors and matrices in the " { $vocab-link "math.blas.syntax" } " vocabulary:"
{ $subsection "math.blas.syntax" }
"There are BOA constructors for all vector and matrix types, which provide the most flexibility in specifying memory layout:"
{ $subsection <float-blas-vector> }
{ $subsection <double-blas-vector> }
@ -74,7 +72,13 @@ ARTICLE: "math.blas.matrices" "BLAS interface matrix operations"
{ $subsection n*M! }
{ $subsection n*M }
{ $subsection M*n }
{ $subsection M/n } ;
{ $subsection M/n }
"Literal syntax:"
{ $subsection POSTPONE: smatrix{ }
{ $subsection POSTPONE: dmatrix{ }
{ $subsection POSTPONE: cmatrix{ }
{ $subsection POSTPONE: zmatrix{ } ;
ABOUT: "math.blas.matrices"
@ -243,3 +247,43 @@ HELP: <empty-vector>
{ $values { "length" "The length of the new vector" } { "exemplar" blas-vector-base blas-matrix-base } { "vector" blas-vector-base } }
{ $description "Return a vector of zeros with the given " { $snippet "length" } " and the same element type as " { $snippet "v" } "." } ;
HELP: smatrix{
{ $syntax <" smatrix{
{ 1.0 0.0 0.0 1.0 }
{ 0.0 1.0 0.0 2.0 }
{ 0.0 0.0 1.0 3.0 }
{ 0.0 0.0 0.0 1.0 }
} "> }
{ $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
HELP: dmatrix{
{ $syntax <" dmatrix{
{ 1.0 0.0 0.0 1.0 }
{ 0.0 1.0 0.0 2.0 }
{ 0.0 0.0 1.0 3.0 }
{ 0.0 0.0 0.0 1.0 }
} "> }
{ $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
HELP: cmatrix{
{ $syntax <" cmatrix{
{ 1.0 0.0 0.0 1.0 }
{ 0.0 C{ 0.0 1.0 } 0.0 2.0 }
{ 0.0 0.0 -1.0 3.0 }
{ 0.0 0.0 0.0 C{ 0.0 -1.0 } }
} "> }
{ $description "Construct a literal " { $link float-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
HELP: zmatrix{
{ $syntax <" zmatrix{
{ 1.0 0.0 0.0 1.0 }
{ 0.0 C{ 0.0 1.0 } 0.0 2.0 }
{ 0.0 0.0 -1.0 3.0 }
{ 0.0 0.0 0.0 C{ 0.0 -1.0 } }
} "> }
{ $description "Construct a literal " { $link double-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
{
POSTPONE: smatrix{ POSTPONE: dmatrix{
POSTPONE: cmatrix{ POSTPONE: zmatrix{
} related-words

2
basis/math/blas/matrices/matrices-tests.factor
View File

@ -1,4 +1,4 @@
USING: kernel math.blas.matrices math.blas.vectors math.blas.syntax
USING: kernel math.blas.matrices math.blas.vectors
sequences tools.test ;
IN: math.blas.matrices.tests

12
basis/math/blas/matrices/matrices.factor
View File

@ -4,7 +4,8 @@ math math.blas.cblas math.blas.vectors math.blas.vectors.private
math.complex math.functions math.order functors words
sequences sequences.merged sequences.private shuffle
specialized-arrays.direct.float specialized-arrays.direct.double
specialized-arrays.float specialized-arrays.double ;
specialized-arrays.float specialized-arrays.double
parser prettyprint.backend prettyprint.custom ;
IN: math.blas.matrices
TUPLE: blas-matrix-base underlying ld rows cols transpose ;
@ -258,6 +259,7 @@ XGERC IS cblas_${T}ger${C}
MATRIX DEFINES ${TYPE}-blas-matrix
<MATRIX> DEFINES <${TYPE}-blas-matrix>
>MATRIX DEFINES >${TYPE}-blas-matrix
XMATRIX{ DEFINES ${T}matrix{
WHERE
@ -291,6 +293,11 @@ M: MATRIX n*V(*)Vconj+M!
[ TYPE>ARG ] (prepare-ger)
[ XGERC ] dip ;
: XMATRIX{ \ } [ >MATRIX ] parse-literal ; parsing
M: MATRIX pprint-delims
drop \ XMATRIX{ \ } ;
;FUNCTOR
@ -305,3 +312,6 @@ M: MATRIX n*V(*)Vconj+M!
"double-complex" "z" define-complex-blas-matrix
>>
M: blas-matrix-base >pprint-sequence Mrows ;
M: blas-matrix-base pprint* pprint-object ;

1
basis/math/blas/syntax/summary.txt
View File

@ -1 +0,0 @@
Literal syntax for BLAS vectors and matrices

78
basis/math/blas/syntax/syntax-docs.factor
View File

@ -1,78 +0,0 @@
USING: help.markup help.syntax math.blas.matrices math.blas.vectors multiline ;
IN: math.blas.syntax
ARTICLE: "math.blas.syntax" "BLAS interface literal syntax"
"Vectors:"
{ $subsection POSTPONE: svector{ }
{ $subsection POSTPONE: dvector{ }
{ $subsection POSTPONE: cvector{ }
{ $subsection POSTPONE: zvector{ }
"Matrices:"
{ $subsection POSTPONE: smatrix{ }
{ $subsection POSTPONE: dmatrix{ }
{ $subsection POSTPONE: cmatrix{ }
{ $subsection POSTPONE: zmatrix{ } ;
ABOUT: "math.blas.syntax"
HELP: svector{
{ $syntax "svector{ 1.0 -2.0 3.0 }" }
{ $description "Construct a literal " { $link float-blas-vector } "." } ;
HELP: dvector{
{ $syntax "dvector{ 1.0 -2.0 3.0 }" }
{ $description "Construct a literal " { $link double-blas-vector } "." } ;
HELP: cvector{
{ $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ;
HELP: zvector{
{ $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ;
{
POSTPONE: svector{ POSTPONE: dvector{
POSTPONE: cvector{ POSTPONE: zvector{
} related-words
HELP: smatrix{
{ $syntax <" smatrix{
{ 1.0 0.0 0.0 1.0 }
{ 0.0 1.0 0.0 2.0 }
{ 0.0 0.0 1.0 3.0 }
{ 0.0 0.0 0.0 1.0 }
} "> }
{ $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
HELP: dmatrix{
{ $syntax <" dmatrix{
{ 1.0 0.0 0.0 1.0 }
{ 0.0 1.0 0.0 2.0 }
{ 0.0 0.0 1.0 3.0 }
{ 0.0 0.0 0.0 1.0 }
} "> }
{ $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
HELP: cmatrix{
{ $syntax <" cmatrix{
{ 1.0 0.0 0.0 1.0 }
{ 0.0 C{ 0.0 1.0 } 0.0 2.0 }
{ 0.0 0.0 -1.0 3.0 }
{ 0.0 0.0 0.0 C{ 0.0 -1.0 } }
} "> }
{ $description "Construct a literal " { $link float-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
HELP: zmatrix{
{ $syntax <" zmatrix{
{ 1.0 0.0 0.0 1.0 }
{ 0.0 C{ 0.0 1.0 } 0.0 2.0 }
{ 0.0 0.0 -1.0 3.0 }
{ 0.0 0.0 0.0 C{ 0.0 -1.0 } }
} "> }
{ $description "Construct a literal " { $link double-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
{
POSTPONE: smatrix{ POSTPONE: dmatrix{
POSTPONE: cmatrix{ POSTPONE: zmatrix{
} related-words

44
basis/math/blas/syntax/syntax.factor
View File

@ -1,44 +0,0 @@
USING: kernel math.blas.vectors math.blas.matrices parser
arrays prettyprint.backend prettyprint.custom sequences ;
IN: math.blas.syntax
: svector{
\ } [ >float-blas-vector ] parse-literal ; parsing
: dvector{
\ } [ >double-blas-vector ] parse-literal ; parsing
: cvector{
\ } [ >float-complex-blas-vector ] parse-literal ; parsing
: zvector{
\ } [ >double-complex-blas-vector ] parse-literal ; parsing
: smatrix{
\ } [ >float-blas-matrix ] parse-literal ; parsing
: dmatrix{
\ } [ >double-blas-matrix ] parse-literal ; parsing
: cmatrix{
\ } [ >float-complex-blas-matrix ] parse-literal ; parsing
: zmatrix{
\ } [ >double-complex-blas-matrix ] parse-literal ; parsing
M: float-blas-vector pprint-delims
drop \ svector{ \ } ;
M: double-blas-vector pprint-delims
drop \ dvector{ \ } ;
M: float-complex-blas-vector pprint-delims
drop \ cvector{ \ } ;
M: double-complex-blas-vector pprint-delims
drop \ zvector{ \ } ;
M: float-blas-matrix pprint-delims
drop \ smatrix{ \ } ;
M: double-blas-matrix pprint-delims
drop \ dmatrix{ \ } ;
M: float-complex-blas-matrix pprint-delims
drop \ cmatrix{ \ } ;
M: double-complex-blas-matrix pprint-delims
drop \ zmatrix{ \ } ;
M: blas-vector-base >pprint-sequence ;
M: blas-vector-base pprint* pprint-object ;
M: blas-matrix-base >pprint-sequence Mrows ;
M: blas-matrix-base pprint* pprint-object ;

29
basis/math/blas/vectors/vectors-docs.factor
View File

@ -23,7 +23,12 @@ ARTICLE: "math.blas.vectors" "BLAS interface vector operations"
{ $subsection V- }
"Vector inner products:"
{ $subsection V. }
{ $subsection V.conj } ;
{ $subsection V.conj }
"Literal syntax:"
{ $subsection POSTPONE: svector{ }
{ $subsection POSTPONE: dvector{ }
{ $subsection POSTPONE: cvector{ }
{ $subsection POSTPONE: zvector{ } ;
ABOUT: "math.blas.vectors"
@ -129,3 +134,25 @@ HELP: V/n
HELP: Vsub
{ $values { "v" blas-vector-base } { "start" integer } { "length" integer } { "sub" blas-vector-base } }
{ $description "Slice a subvector out of " { $snippet "v" } " starting at " { $snippet "start" } " with the given " { $snippet "length" } ". The subvector will share storage with the parent vector." } ;
HELP: svector{
{ $syntax "svector{ 1.0 -2.0 3.0 }" }
{ $description "Construct a literal " { $link float-blas-vector } "." } ;
HELP: dvector{
{ $syntax "dvector{ 1.0 -2.0 3.0 }" }
{ $description "Construct a literal " { $link double-blas-vector } "." } ;
HELP: cvector{
{ $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ;
HELP: zvector{
{ $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ;
{
POSTPONE: svector{ POSTPONE: dvector{
POSTPONE: cvector{ POSTPONE: zvector{
} related-words

2
basis/math/blas/vectors/vectors-tests.factor
View File

@ -1,4 +1,4 @@
USING: kernel math.blas.vectors math.blas.syntax sequences tools.test ;
USING: kernel math.blas.vectors sequences tools.test ;
IN: math.blas.vectors.tests
! clone

11
basis/math/blas/vectors/vectors.factor
View File

@ -2,7 +2,7 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators
combinators.short-circuit fry kernel math math.blas.cblas
math.complex math.functions math.order sequences.complex
sequences.complex-components sequences sequences.private
functors words locals
functors words locals parser prettyprint.backend prettyprint.custom
specialized-arrays.float specialized-arrays.double
specialized-arrays.direct.float specialized-arrays.direct.double ;
IN: math.blas.vectors
@ -138,6 +138,8 @@ VECTOR DEFINES ${TYPE}-blas-vector
<VECTOR> DEFINES <${TYPE}-blas-vector>
>VECTOR DEFINES >${TYPE}-blas-vector
XVECTOR{ DEFINES ${T}vector{
WHERE
TUPLE: VECTOR < blas-vector-base ;
@ -165,6 +167,11 @@ M: VECTOR (blas-direct-array)
[ [ length>> ] [ inc>> ] bi * ] bi
<DIRECT-ARRAY> ;
: XVECTOR{ \ } [ >VECTOR ] parse-literal ; parsing
M: VECTOR pprint-delims
drop \ XVECTOR{ \ } ;
;FUNCTOR
@ -270,3 +277,5 @@ M: VECTOR n*V!
>>
M: blas-vector-base >pprint-sequence ;
M: blas-vector-base pprint* pprint-object ;

2
basis/math/libm/libm-docs.factor
View File

@ -6,7 +6,7 @@ ARTICLE: "math.libm" "C standard library math functions"
$nl
"They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
{ $example "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" }
{ $example "USE: math.libm" "2 facos ." "0.0/0.0" }
{ $unchecked-example "USE: math.libm" "2 facos ." "0.0/0.0" }
"Trigonometric functions:"
{ $subsection fcos }
{ $subsection fsin }

2
basis/memoize/memoize.factor
View File

@ -35,7 +35,7 @@ M: too-many-arguments summary
drop "There must be no more than 4 input and 4 output arguments" ;
: check-memoized ( word -- )
dup #in 4 > swap #out 4 > or [ too-many-arguments ] when ;
[ #in ] [ #out ] bi [ 4 > ] either? [ too-many-arguments ] when ;
: define-memoized ( word quot -- )
over check-memoized

4
basis/stack-checker/branches/branches.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry vectors sequences assocs math accessors kernel
USING: fry vectors sequences assocs math math.order accessors kernel
combinators quotations namespaces grouping stack-checker.state
stack-checker.backend stack-checker.errors stack-checker.visitor
stack-checker.values stack-checker.recursive-state ;
@ -16,7 +16,7 @@ SYMBOL: +bottom+
: pad-with-bottom ( seq -- newseq )
dup empty? [
dup [ length ] map supremum
dup [ length ] [ max ] map-reduce
'[ _ +bottom+ pad-head ] map
] unless ;

2
basis/syndication/syndication.factor
View File

@ -4,7 +4,7 @@
USING: xml.utilities kernel assocs math.order
strings sequences xml.data xml.writer
io.streams.string combinators xml xml.entities.html io.files io
http.client namespaces make xml.interpolate hashtables
http.client namespaces make xml.literals hashtables
calendar.format accessors continuations urls present ;
IN: syndication

5
basis/tools/disassembler/udis/udis.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: tools.disassembler namespaces combinators
alien alien.syntax alien.c-types lexer parser kernel
sequences layouts math math.parser system make fry arrays ;
sequences layouts math math.order
math.parser system make fry arrays ;
IN: tools.disassembler.udis
<<
@ -56,7 +57,7 @@ SINGLETON: udis-disassembler
: buf/len ( from to -- buf len ) [ drop <alien> ] [ swap - ] 2bi ;
: format-disassembly ( lines -- lines' )
dup [ second length ] map supremum
dup [ second length ] [ max ] map-reduce
'[
[
[ first >hex cell 2 * CHAR: 0 pad-head % ": " % ]

31
basis/unix/stat/netbsd/netbsd.factor
View File

@ -5,3 +5,34 @@ cell-bits {
{ 32 [ "unix.stat.netbsd.32" require ] }
{ 64 [ "unix.stat.netbsd.64" require ] }
} case
: _VFS_NAMELEN 32 ; inline
: _VFS_MNAMELEN 1024 ; inline
C-STRUCT: statvfs
{ "ulong" "f_flag" }
{ "ulong" "f_bsize" }
{ "ulong" "f_frsize" }
{ "ulong" "f_iosize" }
{ "fsblkcnt_t" "f_blocks" }
{ "fsblkcnt_t" "f_bfree" }
{ "fsblkcnt_t" "f_bavail" }
{ "fsblkcnt_t" "f_bresvd" }
{ "fsfilcnt_t" "f_files" }
{ "fsfilcnt_t" "f_ffree" }
{ "fsfilcnt_t" "f_favail" }
{ "fsfilcnt_t" "f_fresvd" }
{ "uint64_t" "f_syncreads" }
{ "uint64_t" "f_syncwrites" }
{ "uint64_t" "f_asyncreads" }
{ "uint64_t" "f_asyncwrites" }
{ "fsid_t" "f_fsidx" }
{ "ulong" "f_fsid" }
{ "ulong" "f_namemax" }
{ "uid_t" "f_owner" }
{ { "uint32_t" 4 } "f_spare" }
{ { "char" _VFS_NAMELEN } "f_fstypename" }
{ { "char" _VFS_NAMELEN } "f_mntonname" }
{ { "char" _VFS_NAMELEN } "f_mntfromname" } ;
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;

5
basis/uuid/uuid.factor
View File

@ -52,13 +52,10 @@ IN: uuid
: string>uuid ( string -- n )
[ CHAR: - = not ] filter 16 base> ;
: uuid>byte-array ( n -- byte-array )
16 >be ;
PRIVATE>
: uuid-parse ( string -- byte-array )
string>uuid uuid>byte-array ;
string>uuid 16 >be ;
: uuid-unparse ( byte-array -- string )
be> uuid>string ;

48
basis/wrap/wrap-tests.factor Normal file
View File

@ -0,0 +1,48 @@
IN: wrap.tests
USING: tools.test wrap multiline sequences ;
[
{
{
T{ word f 1 10 f }
T{ word f 2 10 f }
T{ word f 3 2 t }
}
{
T{ word f 4 10 f }
T{ word f 5 10 f }
}
}
] [
{
T{ word f 1 10 f }
T{ word f 2 10 f }
T{ word f 3 2 t }
T{ word f 4 10 f }
T{ word f 5 10 f }
} 35 wrap [ { } like ] map
] unit-test
[
<" This is a
long piece
of text
that we
wish to
word wrap.">
] [
<" This is a long piece of text that we wish to word wrap."> 10
wrap-string
] unit-test
[
<" This is a
long piece
of text
that we
wish to
word wrap.">
] [
<" This is a long piece of text that we wish to word wrap."> 12
" " wrap-indented-string
] unit-test

66
basis/wrap/wrap.factor
View File

@ -1,32 +1,60 @@
USING: sequences kernel namespaces make splitting math math.order ;
USING: sequences kernel namespaces make splitting
math math.order fry assocs accessors ;
IN: wrap
! Very stupid word wrapping/line breaking
! This will be replaced by a Unicode-aware method,
! which works with variable-width fonts
! Word wrapping/line breaking -- not Unicode-aware
TUPLE: word key width break? ;
C: <word> word
<PRIVATE
SYMBOL: width
: line-chunks ( string -- words-lines )
"\n" split [ " \t" split harvest ] map ;
: break-here? ( column word -- ? )
break?>> not [ width get > ] [ drop f ] if ;
: (split-chunk) ( words -- )
-1 over [ length + 1+ dup width get > ] find drop nip
[ 1 max cut-slice swap , (split-chunk) ] [ , ] if* ;
: find-optimal-break ( words -- n )
[ 0 ] dip [ [ width>> + dup ] keep break-here? ] find drop nip ;
: split-chunk ( words -- lines )
[ (split-chunk) ] { } make ;
: (wrap) ( words -- )
dup find-optimal-break
[ 1 max cut-slice [ , ] [ (wrap) ] bi* ] [ , ] if* ;
: join-spaces ( words-seqs -- lines )
[ [ " " join ] map ] map concat ;
: intersperse ( seq elt -- seq' )
[ '[ _ , ] [ , ] interleave ] { } make ;
: broken-lines ( string width -- lines )
: split-lines ( string -- words-lines )
string-lines [
" \t" split harvest
[ dup length f <word> ] map
" " 1 t <word> intersperse
] map ;
: join-words ( wrapped-lines -- lines )
[
[ break?>> ]
[ trim-head-slice ]
[ trim-tail-slice ] bi
[ key>> ] map concat
] map ;
: join-lines ( strings -- string )
"\n" join ;
PRIVATE>
: wrap ( words width -- lines )
width [
line-chunks [ split-chunk ] map join-spaces
[ (wrap) ] { } make
] with-variable ;
: line-break ( string width -- newstring )
broken-lines "\n" join ;
: wrap-lines ( lines width -- newlines )
[ split-lines ] dip '[ _ wrap join-words ] map concat ;
: indented-break ( string width indent -- newstring )
[ length - broken-lines ] keep [ prepend ] curry map "\n" join ;
: wrap-string ( string width -- newstring )
wrap-lines join-lines ;
: wrap-indented-string ( string width indent -- newstring )
[ length - wrap-lines ] keep '[ _ prepend ] map join-lines ;

4
basis/xml-rpc/xml-rpc.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel xml arrays math generic http.client
combinators hashtables namespaces io base64 sequences strings
calendar xml.data xml.writer xml.utilities assocs math.parser
debugger calendar.format math.order xml.interpolate xml.dispatch ;
debugger calendar.format math.order xml.literals xml.dispatch ;
IN: xml-rpc
! * Sending RPC requests

21
basis/xml/autoencoding/autoencoding.factor
View File

@ -6,11 +6,14 @@ io.encodings.string io.encodings combinators accessors
xml.data io.encodings.iana ;
IN: xml.autoencoding
: decode-stream ( encoding -- )
spot get [ swap re-decode ] change-stream drop ;
: continue-make-tag ( str -- tag )
parse-name-starting middle-tag end-tag ;
: start-utf16le ( -- tag )
utf16le decode-input
utf16le decode-stream
"?\0" expect
check instruct ;
@ -22,25 +25,25 @@ IN: xml.autoencoding
! that the first letter of the document is < and second is
! not ASCII
ascii?
[ utf8 decode-input next make-tag ] [
[ utf8 decode-stream next make-tag ] [
next
[ get-next 10xxxxxx? not ] take-until
get-char suffix utf8 decode
utf8 decode-input next
utf8 decode-stream next
continue-make-tag
] if ;
: prolog-encoding ( prolog -- )
encoding>> dup "UTF-16" =
[ drop ] [ name>encoding [ decode-input ] when* ] if ;
[ drop ] [ name>encoding [ decode-stream ] when* ] if ;
: instruct-encoding ( instruct/prolog -- )
dup prolog?
[ prolog-encoding ]
[ drop utf8 decode-input ] if ;
[ drop utf8 decode-stream ] if ;
: go-utf8 ( -- )
check utf8 decode-input next next ;
check utf8 decode-stream next next ;
: start< ( -- tag )
! What if first letter of processing instruction is non-ASCII?
@ -52,11 +55,11 @@ IN: xml.autoencoding
} case ;
: skip-utf8-bom ( -- tag )
"\u0000bb\u0000bf" expect utf8 decode-input
"\u0000bb\u0000bf" expect utf8 decode-stream
"<" expect check make-tag ;
: decode-expecting ( encoding string -- tag )
[ decode-input next ] [ expect ] bi* check make-tag ;
[ decode-stream next ] [ expect ] bi* check make-tag ;
: start-utf16be ( -- tag )
utf16be "<" decode-expecting ;
@ -74,6 +77,6 @@ IN: xml.autoencoding
{ HEX: EF [ skip-utf8-bom ] }
{ HEX: FF [ skip-utf16le-bom ] }
{ HEX: FE [ skip-utf16be-bom ] }
[ drop utf8 decode-input check f ]
[ drop utf8 decode-stream check f ]
} case ;

7
basis/xml/char-classes/char-classes.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2005, 2007 Daniel Ehrenberg
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences unicode.syntax math math.order combinators ;
USING: kernel sequences unicode.syntax math math.order combinators
hints ;
IN: xml.char-classes
CATEGORY: 1.0name-start* Ll Lu Lo Lt Nl \u000559\u0006E5\u0006E6_: ;
@ -31,3 +32,5 @@ CATEGORY: 1.1name-char Ll Lu Lo Lm Ln Nl Mc Mn Nd Pc Cf _-.\u0000b7: ;
{ [ dup HEX: E000 < ] [ drop f ] }
[ { HEX: FFFE HEX: FFFF } member? not ]
} cond ;
HINTS: text? { object fixnum } ;

14
basis/xml/errors/errors-tests.factor
View File

@ -6,11 +6,11 @@ IN: xml.errors.tests
'[ _ string>xml ] swap '[ _ = ] must-fail-with ;
T{ no-entity f 1 10 "nbsp" } "<x>&nbsp;</x>" xml-error-test
T{ mismatched f 1 8 T{ name f "" "x" "" } T{ name f "" "y" "" } }
T{ mismatched f 1 7 T{ name f "" "x" "" } T{ name f "" "y" "" } }
"<x></y>" xml-error-test
T{ unclosed f 1 4 V{ T{ name f "" "x" "" } } } "<x>" xml-error-test
T{ unclosed f 1 3 V{ T{ name f "" "x" "" } } } "<x>" xml-error-test
T{ nonexist-ns f 1 5 "x" } "<x:y/>" xml-error-test
T{ unopened f 1 5 } "</x>" xml-error-test
T{ unopened f 1 4 } "</x>" xml-error-test
T{ not-yes/no f 1 41 "maybe" }
"<?xml version='1.0' standalone='maybe'?><x/>" xml-error-test
T{ extra-attrs f 1 32 V{ T{ name f "" "foo" f } }
@ -19,13 +19,13 @@ T{ bad-version f 1 28 "5 million" }
"<?xml version='5 million'?><x/>" xml-error-test
T{ notags f } "" xml-error-test
T{ multitags } "<x/><y/>" xml-error-test
T{ bad-prolog f 1 26 T{ prolog f "1.0" "UTF-8" f } }
T{ bad-prolog f 1 25 T{ prolog f "1.0" "UTF-8" f } }
"<x/><?xml version='1.0'?>" xml-error-test
T{ capitalized-prolog f 1 6 "XmL" } "<?XmL version='1.0'?><x/>"
xml-error-test
T{ pre/post-content f "x" t } "x<y/>" xml-error-test
T{ versionless-prolog f 1 8 } "<?xml?><x/>" xml-error-test
T{ unclosed-quote f 1 13 } "<x value='/>" xml-error-test
T{ unclosed-quote f 1 12 } "<x value='/>" xml-error-test
T{ bad-name f 1 3 "-" } "<-/>" xml-error-test
T{ quoteless-attr f 1 12 } "<x value=<->/>" xml-error-test
T{ quoteless-attr f 1 10 } "<x value=3/>" xml-error-test
@ -37,6 +37,6 @@ T{ bad-cdata f 1 7 } "<x/><![CDATA[]]>" xml-error-test
T{ pre/post-content f "&" t } "&#32;<x/>" xml-error-test
T{ bad-doctype f 1 17 "a" } "<!DOCTYPE foo [ a ]><x/>" xml-error-test
T{ bad-doctype f 1 22 T{ opener { name T{ name f "" "foo" "" } } { attrs T{ attrs } } } } "<!DOCTYPE foo [ <foo> ]><x/>" xml-error-test
T{ disallowed-char f 1 3 1 } "<x>\u000001</x>" xml-error-test
T{ missing-close f 1 9 } "<!-- foo" xml-error-test
T{ disallowed-char f 1 4 1 } "<x>\u000001</x>" xml-error-test
T{ missing-close f 1 8 } "<!-- foo" xml-error-test
T{ misplaced-directive f 1 9 "ENTITY" } "<!ENTITY foo 'bar'><x/>" xml-error-test

0
basis/xml/interpolate/authors.txt → basis/xml/literals/authors.txt
View File

24
basis/xml/interpolate/interpolate-docs.factor → basis/xml/literals/literals-docs.factor
View File

@ -1,29 +1,29 @@
USING: help.markup help.syntax present multiline ;
IN: xml.interpolate
USING: help.markup help.syntax present multiline xml.data ;
IN: xml.literals
ABOUT: "xml.interpolate"
ABOUT: "xml.literals"
ARTICLE: "xml.interpolate" "XML literal interpolation"
"The " { $vocab-link "xml.interpolate" } " vocabulary provides a convenient syntax for generating XML documents and chunks. It defines the following parsing words:"
ARTICLE: "xml.literals" "XML literals"
"The " { $vocab-link "xml.literals" } " vocabulary provides a convenient syntax for generating XML documents and chunks. It defines the following parsing words:"
{ $subsection POSTPONE: <XML }
{ $subsection POSTPONE: [XML }
"For a description of the common syntax of these two, see"
{ $subsection { "xml.interpolate" "in-depth" } } ;
"These can be used for creating an XML literal, which can be used with variables or a fry-like syntax to interpolate data into XML."
{ $subsection { "xml.literals" "interpolation" } } ;
HELP: <XML
{ $syntax "<XML <?xml version=\"1.0\"?><document>...</document> XML>" }
{ $description "This syntax allows the interpolation of XML documents. When evaluated, there is an XML document on the stack. For more information about XML interpolation, see " { $link { "xml.interpolate" "in-depth" } } "." } ;
{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML document (" { $link xml } ") on the stack. It can be used for interpolation as well, if interpolation slots are used. For more information about XML interpolation, see " { $link { "xml.literals" "interpolation" } } "." } ;
HELP: [XML
{ $syntax "[XML foo <x>...</x> bar <y>...</y> baz XML]" }
{ $description "This syntax allows the interpolation of XML chunks. When evaluated, there is a sequence of XML elements (tags, strings, comments, etc) on the stack. For more information about XML interpolation, see " { $link { "xml.interpolate" "in-depth" } } "." } ;
{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML chunk (" { $link xml-chunk } ") on the stack. For more information about XML interpolation, see " { $link { "xml.literals" "interpolation" } } "." } ;
ARTICLE: { "xml.interpolate" "in-depth" } "XML interpolation syntax"
ARTICLE: { "xml.literals" "interpolation" } "XML interpolation syntax"
"XML interpolation has two forms for each of the words " { $link POSTPONE: <XML } " and " { $link POSTPONE: [XML } ": a fry-like form and a locals form. To splice locals in, use the syntax " { $snippet "<-variable->" } ". To splice something in from the stack, in the style of " { $vocab-link "fry" } ", use the syntax " { $snippet "<->" } ". An XML interpolation form may only use one of these styles."
$nl
"These forms can be used where a tag might go, as in " { $snippet "[XML <foo><-></foo> XML]" } " or where an attribute might go, as in " { $snippet "[XML <foo bar=<->/> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:"
{ $example
{" USING: splitting sequences xml.writer xml.interpolate ;
{" USING: splitting sequences xml.writer xml.literals ;
"one two three" " " split
[ [XML <item><-></item> XML] ] map
<XML <doc><-></doc> XML> pprint-xml"}
@ -41,7 +41,7 @@ $nl
</doc>"} }
"Here is an example of the locals version:"
{ $example
{" USING: locals urls xml.interpolate xml.writer ;
{" USING: locals urls xml.literals xml.writer ;
[let |
number [ 3 ]
false [ f ]

6
basis/xml/interpolate/interpolate-tests.factor → basis/xml/literals/literals-tests.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test xml.interpolate multiline kernel assocs
sequences accessors xml.writer xml.interpolate.private
USING: tools.test xml.literals multiline kernel assocs
sequences accessors xml.writer xml.literals.private
locals splitting urls xml.data classes ;
IN: xml.interpolate.tests
IN: xml.literals.tests
[ "a" "c" { "a" "c" f } ] [
"<?xml version='1.0'?><x><-a-><b val=<-c->/><-></x>"

2
basis/xml/interpolate/interpolate.factor → basis/xml/literals/literals.factor
View File

@ -4,7 +4,7 @@ USING: xml xml.state kernel sequences fry assocs xml.data
accessors strings make multiline parser namespaces macros
sequences.deep generalizations words combinators
math present arrays unicode.categories ;
IN: xml.interpolate
IN: xml.literals
<PRIVATE

0
basis/xml/interpolate/summary.txt → basis/xml/literals/summary.txt
View File

0
basis/xml/interpolate/tags.txt → basis/xml/literals/tags.txt
View File

5
basis/xml/state/state.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces io ;
USING: accessors kernel namespaces io math ;
IN: xml.state
TUPLE: spot char line column next check version-1.0? ;
TUPLE: spot
char line column next check version-1.0? stream ;
C: <spot> spot

2
basis/xml/tests/state-parser-tests.factor
View File

@ -11,7 +11,7 @@ IN: xml.test.state
1string take-to ;
[ "hello" ] [ "hello" [ take-rest ] string-parse ] unit-test
[ 2 4 ] [ "12\n123" [ take-rest drop get-line get-column ] string-parse ] unit-test
[ 2 3 ] [ "12\n123" [ take-rest drop get-line get-column ] string-parse ] unit-test
[ "hi" " how are you?" ] [ "hi how are you?" [ [ get-char blank? ] take-until take-rest ] string-parse ] unit-test
[ "foo" ";bar" ] [ "foo;bar" [ CHAR: ; take-char take-rest ] string-parse ] unit-test
[ "foo " " bar" ] [ "foo and bar" [ "and" take-string take-rest ] string-parse ] unit-test

Some files were not shown because too many files have changed in this diff Show More