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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2008-09-08 22:09:25 -07:00
parent e7bf0c009d e2ba84ae6c
commit f63477d55a
66 changed files with 1644 additions and 515 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/bootstrap/stage2.factor
View File

@ -50,7 +50,7 @@ SYMBOL: bootstrap-time
default-image-name "output-image" set-global
"threads math compiler help io random tools ui ui.tools unicode handbook" "include" set-global
"math compiler threads help io tools ui ui.tools random unicode handbook" "include" set-global
"" "exclude" set-global
parse-command-line

5
basis/compiler/tree/branch-fusion/branch-fusion.factor
View File

@ -1,5 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.branch-fusion
: fuse-branches ( nodes -- nodes' ) ;

5
basis/compiler/tree/loop/inversion/inversion.factor
View File

@ -1,5 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.loop.inversion
: invert-loops ( nodes -- nodes' ) ;

19
basis/compiler/tree/optimizer/optimizer.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.tree.normalization
USING: kernel namespaces
compiler.tree.normalization
compiler.tree.propagation
compiler.tree.cleanup
compiler.tree.escape-analysis
@ -9,26 +10,24 @@ compiler.tree.def-use
compiler.tree.dead-code
compiler.tree.strength-reduction
compiler.tree.loop.detection
compiler.tree.loop.inversion
compiler.tree.branch-fusion
compiler.tree.finalization
compiler.tree.checker ;
IN: compiler.tree.optimizer
SYMBOL: check-optimizer?
: optimize-tree ( nodes -- nodes' )
normalize
propagate
cleanup
detect-loops
! invert-loops
! fuse-branches
escape-analysis
unbox-tuples
compute-def-use
remove-dead-code
finalize
! strength-reduce
! USE: kernel
! compute-def-use
! dup check-nodes
;
check-optimizer? get [
compute-def-use
dup check-nodes
] when
finalize ;

161
basis/db/db-docs.factor Normal file
View File

@ -0,0 +1,161 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes kernel help.markup help.syntax sequences
alien assocs strings math multiline ;
IN: db
HELP: db
{ $description "The " { $snippet "db" } " class is the superclass of all other database classes. It stores a " { $snippet "handle" } " to the database as well as insert, update, and delete queries." } ;
HELP: new-db
{ $values { "class" class } { "obj" object } }
{ $description "Creates a new database object from a given class." } ;
HELP: make-db*
{ $values { "seq" sequence } { "db" object } { "db" object } }
{ $description "Takes a sequence of parameters specific to each database and a class name of the database, and constructs a new database object." } ;
HELP: make-db
{ $values { "seq" sequence } { "class" class } { "db" db } }
{ $description "Takes a sequence of parameters specific to each database and a class name of the database, and constructs a new database object." } ;
HELP: db-open
{ $values { "db" db } { "db" db } }
{ $description "Opens a database using the configuration data stored in a " { $link db } " tuple." } ;
HELP: db-close
{ $values { "handle" alien } }
{ $description "Closes a database using the handle provided." } ;
HELP: dispose-statements
{ $values { "assoc" assoc } }
{ $description "Disposes an associative list of statements." } ;
HELP: db-dispose
{ $values { "db" db } }
{ $description "Disposes of all the statements stored in the " { $link db } " object." } ;
HELP: statement
{ $description "A " { $snippet "statement" } " stores the information about a statemen, such as the SQL statement text, the in/out parameters, and type information." } ;
HELP: simple-statement
{ $description } ;
HELP: prepared-statement
{ $description } ;
HELP: result-set
{ $description } ;
HELP: construct-statement
{ $values { "sql" string } { "in" sequence } { "out" sequence } { "class" class } { "statement" statement } }
{ $description "Makes a new statement object from the given parameters." } ;
HELP: <simple-statement>
{ $values { "string" string } { "in" sequence } { "out" sequence }
{ "statement" statement } }
{ $description "Makes a new simple statement object from the given parameters." } ;
HELP: <prepared-statement>
{ $values { "string" string } { "in" sequence } { "out" sequence }
{ "statement" statement } }
{ $description "Makes a new prepared statement object from the given parameters." } ;
HELP: prepare-statement
{ $values { "statement" statement } }
{ $description "For databases which implement a method on this generic, it does some internal processing to ready the statement for execution." } ;
HELP: bind-statement*
{ $values { "statement" statement } }
{ $description "" } ;
HELP: low-level-bind
{ $values { "statement" statement } }
{ $description "" } ;
HELP: bind-tuple
{ $values { "tuple" tuple } { "statement" statement } }
{ $description "" } ;
HELP: query-results
{ $values { "query" object }
{ "result-set" result-set }
}
{ $description "" } ;
HELP: #rows
{ $values { "result-set" result-set } { "n" integer } }
{ $description "Returns the number of rows in a result set." } ;
HELP: #columns
{ $values { "result-set" result-set } { "n" integer } }
{ $description "Returns the number of columns in a result set." } ;
HELP: row-column
{ $values { "result-set" result-set } { "column" integer }
{ "obj" object }
}
{ $description "" } ;
HELP: row-column-typed
{ $values { "result-set" result-set } { "column" integer }
{ "sql" "sql" } }
{ $description "" } ;
HELP: advance-row
{ $values { "result-set" result-set } }
;
HELP: more-rows?
{ $values { "result-set" result-set } { "?" "a boolean" } }
;
HELP: execute-statement*
{ $values { "statement" statement } { "type" object } }
{ $description } ;
HELP: execute-statement
{ $values { "statement" statement } }
{ $description } ;
ARTICLE: "db" "Low-level database library"
{ $subsection "db-custom-database-combinators" }
{ $subsection "db-protocol" }
{ $subsection "db-lowlevel-tutorial" }
"Higher-level database:"
{ $vocab-subsection "Database types" "db.types" }
{ $vocab-subsection "High-level tuple/database integration" "db.tuples" }
"Supported database backends:"
{ $vocab-subsection "SQLite" "db.sqlite" }
{ $vocab-subsection "PostgreSQL" "db.postgresql" }
"To add support for another database to Factor:"
{ $subsection "db-porting-the-library" }
;
ARTICLE: "db-protocol" "Low-level database protocol"
"The high-level protocol (see " { $vocab-link "db.tuples" } ") uses this low-level protocol for executing statements and queries."
;
ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial"
"Although Factor makes integrating a database with its object system easy (see " { $vocab-link "db.tuples" } "), sometimes you may want to write SQL directly and get the results back as arrays of strings, for instance, when interfacing with a legacy database that doesn't easily map to " { $snippet "tuples" } "."
;
ARTICLE: "db-porting-the-library" "Porting the database library"
"This section is not yet written."
;
ARTICLE: "db-custom-database-combinators" "Custom database combinators"
"Every database library requires some effort on the programmer's part to initialize and open a database. SQLite uses files on your harddisk, so a simple pathname is all the setup required. With PostgreSQL, you log in to a networked server as a user on a specfic port." $nl
"Make a " { $snippet "with-" } " word to open, close, and use your database."
{ $code <"
USING: db.sqlite db io.files ;
: with-my-database ( quot -- )
{ "my-database.db" temp-file } sqlite-db rot with-db ;
"> }
;
ABOUT: "db"

4
basis/db/db.factor
View File

@ -105,10 +105,10 @@ M: object execute-statement* ( statement type -- )
] if ; inline recursive
: query-map ( statement quot -- seq )
accumulator >r query-each r> { } like ; inline
accumulator [ query-each ] dip { } like ; inline
: with-db ( seq class quot -- )
>r make-db db-open db r>
[ make-db db-open db ] dip
[ db get swap [ drop ] prepose with-disposal ] curry with-variable ;
inline

36
basis/db/queries/queries.factor
View File

@ -2,15 +2,49 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math namespaces sequences random strings
math.parser math.intervals combinators math.bitwise nmake db
db.tuples db.types db.sql classes words shuffle arrays ;
db.tuples db.types db.sql classes words shuffle arrays destructors
continuations ;
IN: db.queries
GENERIC: where ( specs obj -- )
SINGLETON: retryable
: make-retryable ( obj -- obj' )
dup sequence? [
[ make-retryable ] map
] [
retryable >>type
10 >>retries
] if ;
: maybe-make-retryable ( statement -- statement )
dup in-params>> [ generator-bind? ] contains?
[ make-retryable ] when ;
: regenerate-params ( statement -- statement )
dup
[ bind-params>> ] [ in-params>> ] bi
[
dup generator-bind? [
generator-singleton>> eval-generator >>value
] [
drop
] if
] 2map >>bind-params ;
M: retryable execute-statement* ( statement type -- )
drop [ retries>> ] [
[
nip
[ query-results dispose t ]
[ ]
[ regenerate-params bind-statement* f ] cleanup
] curry
] bi attempt-all drop ;
: sql-props ( class -- columns table )
[ db-columns ] [ db-table ] bi ;
: query-make ( class quot -- )
>r sql-props r>
[ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake

155
basis/db/sql/sql.factor
View File

@ -1,6 +1,6 @@
USING: kernel parser quotations classes.tuple words math.order
nmake namespaces sequences arrays combinators
prettyprint strings math.parser math symbols ;
prettyprint strings math.parser math symbols db ;
IN: db.sql
SYMBOLS: insert update delete select distinct columns from as
@ -23,44 +23,142 @@ DEFER: sql%
: sql-function, ( seq function -- )
sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ;
: sql-where ( seq -- )
B
: sql-where, ( seq -- )
[
[ second 0, ]
[ first 0, ]
[ third 1, \ ? 0, ] tri
] each ;
USE: multiline
/*
HOOK: sql-create db ( object -- )
M: db sql-create ( object -- )
drop
"create table" sql% ;
HOOK: sql-drop db ( object -- )
M: db sql-drop ( object -- )
drop
"drop table" sql% ;
HOOK: sql-insert db ( object -- )
M: db sql-insert ( object -- )
drop
"insert into" sql% ;
HOOK: sql-update db ( object -- )
M: db sql-update ( object -- )
drop
"update" sql% ;
HOOK: sql-delete db ( object -- )
M: db sql-delete ( object -- )
drop
"delete" sql% ;
HOOK: sql-select db ( object -- )
M: db sql-select ( object -- )
"select" sql% "," (sql-interleave) ;
HOOK: sql-columns db ( object -- )
M: db sql-columns ( object -- )
"," (sql-interleave) ;
HOOK: sql-from db ( object -- )
M: db sql-from ( object -- )
"from" "," sql-interleave ;
HOOK: sql-where db ( object -- )
M: db sql-where ( object -- )
"where" 0, sql-where, ;
HOOK: sql-group-by db ( object -- )
M: db sql-group-by ( object -- )
"group by" "," sql-interleave ;
HOOK: sql-having db ( object -- )
M: db sql-having ( object -- )
"having" "," sql-interleave ;
HOOK: sql-order-by db ( object -- )
M: db sql-order-by ( object -- )
"order by" "," sql-interleave ;
HOOK: sql-offset db ( object -- )
M: db sql-offset ( object -- )
"offset" sql% sql% ;
HOOK: sql-limit db ( object -- )
M: db sql-limit ( object -- )
"limit" sql% sql% ;
! GENERIC: sql-subselect db ( object -- )
! M: db sql-subselectselect ( object -- )
! "(select" sql% sql% ")" sql% ;
GENERIC: sql-table db ( object -- )
M: db sql-table ( object -- )
sql% ;
GENERIC: sql-set db ( object -- )
M: db sql-set ( object -- )
"set" "," sql-interleave ;
GENERIC: sql-values db ( object -- )
M: db sql-values ( object -- )
"values(" sql% "," (sql-interleave) ")" sql% ;
GENERIC: sql-count db ( object -- )
M: db sql-count ( object -- )
"count" sql-function, ;
GENERIC: sql-sum db ( object -- )
M: db sql-sum ( object -- )
"sum" sql-function, ;
GENERIC: sql-avg db ( object -- )
M: db sql-avg ( object -- )
"avg" sql-function, ;
GENERIC: sql-min db ( object -- )
M: db sql-min ( object -- )
"min" sql-function, ;
GENERIC: sql-max db ( object -- )
M: db sql-max ( object -- )
"max" sql-function, ;
: sql-array% ( array -- )
B
unclip
{
{ \ create [ "create table" sql% ] }
{ \ drop [ "drop table" sql% ] }
{ \ insert [ "insert into" sql% ] }
{ \ update [ "update" sql% ] }
{ \ delete [ "delete" sql% ] }
{ \ select [ B "select" sql% "," (sql-interleave) ] }
{ \ columns [ "," (sql-interleave) ] }
{ \ from [ "from" "," sql-interleave ] }
{ \ where [ B "where" 0, sql-where ] }
{ \ group-by [ "group by" "," sql-interleave ] }
{ \ having [ "having" "," sql-interleave ] }
{ \ order-by [ "order by" "," sql-interleave ] }
{ \ offset [ "offset" sql% sql% ] }
{ \ limit [ "limit" sql% sql% ] }
{ \ select [ "(select" sql% sql% ")" sql% ] }
{ \ table [ sql% ] }
{ \ set [ "set" "," sql-interleave ] }
{ \ values [ "values(" sql% "," (sql-interleave) ")" sql% ] }
{ \ count [ "count" sql-function, ] }
{ \ sum [ "sum" sql-function, ] }
{ \ avg [ "avg" sql-function, ] }
{ \ min [ "min" sql-function, ] }
{ \ max [ "max" sql-function, ] }
{ \ create [ sql-create ] }
{ \ drop [ sql-drop ] }
{ \ insert [ sql-insert ] }
{ \ update [ sql-update ] }
{ \ delete [ sql-delete ] }
{ \ select [ sql-select ] }
{ \ columns [ sql-columns ] }
{ \ from [ sql-from ] }
{ \ where [ sql-where ] }
{ \ group-by [ sql-group-by ] }
{ \ having [ sql-having ] }
{ \ order-by [ sql-order-by ] }
{ \ offset [ sql-offset ] }
{ \ limit [ sql-limit ] }
{ \ table [ sql-table ] }
{ \ set [ sql-set ] }
{ \ values [ sql-values ] }
{ \ count [ sql-count ] }
{ \ sum [ sql-sum ] }
{ \ avg [ sql-avg ] }
{ \ min [ sql-min ] }
{ \ max [ sql-max ] }
[ sql% [ sql% ] each ]
} case ;
*/
: sql-array% ( array -- ) drop ;
ERROR: no-sql-match ;
: sql% ( obj -- )
{
@ -74,4 +172,5 @@ ERROR: no-sql-match ;
} cond ;
: parse-sql ( obj -- sql in-spec out-spec in out )
[ [ sql% ] each ] { { } { } { } } nmake ;
[ [ sql% ] each ] { { } { } { } } nmake
[ " " join ] 2dip ;

191
basis/db/tuples/tuples-docs.factor Normal file
View File

@ -0,0 +1,191 @@
! 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 ;
IN: db.tuples
HELP: define-persistent
{ $values
{ "class" class } { "table" string } { "columns" "an array of slot specifiers" } }
{ $description "Defines a relation from a Factor " { $snippet "tuple class" } " to a SQL database table name. The format for the slot specifiers is as follows:"
{ $list
{ "a slot name from the " { $snippet "tuple class" } }
{ "the name of a database column that maps to the slot" } { "a database type (see " { $link "db.types" } ")" }
} } ;
HELP: create-table
{ $values
{ "class" class } }
{ $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If the table already exists, the database will likely throw an error." } ;
HELP: ensure-table
{ $values
{ "class" class } }
{ $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If the table already exists, the error is silently ignored." } ;
HELP: ensure-tables
{ $values
{ "classes" null } }
{ $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If a table already exists, the error is silently ignored." } ;
HELP: recreate-table
{ $values
{ "class" class } }
{ $description "Drops an existing table and re-creates it from a mapping defined by " { $link define-persistent } ". If the table does not exist the error is silently ignored." }
{ $warning { $emphasis "THIS WORD WILL DELETE YOUR DATA." } $nl
" Use " { $link ensure-table } " unless you want to delete the data in this table." } ;
{ create-table ensure-table ensure-tables recreate-table } related-words
HELP: drop-table
{ $values
{ "class" class } }
{ $description "Drops an existing table which deletes all of the data. The database will probably throw an error if the table does not exist." }
{ $warning { $emphasis "THIS WORD WILL DELETE YOUR DATA." } } ;
HELP: insert-tuple
{ $values
{ "tuple" tuple } }
{ $description "Inserts a tuple into a database if a relation has been defined with " { $link define-persistent } ". If a mapping states that the database assigns a primary key to the tuple, this value will be set after this word runs." }
{ $notes "Objects should only be inserted into a database once per object. To store the object after the initial insert, call " { $link update-tuple } "." } ;
HELP: update-tuple
{ $values
{ "tuple" tuple } }
{ $description "Updates a tuple that has already been inserted into a database. The tuple must have a primary key that has been set by " { $link insert-tuple } " or that is user-defined." } ;
HELP: delete-tuples
{ $values
{ "tuple" tuple } }
{ $description "Uses the " { $snippet "tuple" } " as an exemplar object and deletes any objects that have the same slots set. If a slot is not " { $link f } ", then it is used to generate a SQL statement that deletes tuples." }
{ $warning "This word will delete your data." } ;
{ insert-tuple update-tuple delete-tuples } related-words
HELP: select-tuple
{ $values
{ "tuple" tuple }
{ "tuple/f" "a tuple or f" } }
{ $description "A SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". Returns a single tuple from the database if it matches the query constructed from the exemplar tuple." } ;
HELP: select-tuples
{ $values
{ "tuple" tuple }
{ "tuples" "an array of tuples" } }
{ $description "A SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". Returns a multiple tuples from the database that match the query constructed from the exemplar tuple." } ;
HELP: count-tuples
{ $values
{ "tuple" tuple } { "groups" "an array of slots to group by" }
{ "n" integer } }
{ $description "" } ;
HELP: query
{ $values
{ "tuple" tuple } { "query" query }
{ "tuples" "a sequence of tuples" } }
{ $description "Allows for queries with group by, order by, limit, and offset clauses. " } ;
{ select-tuple select-tuples count-tuples query } related-words
ARTICLE: "db-tuples" "High-level tuple/database integration"
"Start with a tutorial:"
{ $subsection "db-tuples-tutorial" }
"Useful words:"
{ $subsection "db-tuples-words" }
;
ARTICLE: "db-tuples-words" "High-level tuple/database words"
"Making tuples work with a database:"
{ $subsection define-persistent }
"Creating tables:"
{ $subsection create-table }
{ $subsection ensure-table }
{ $subsection ensure-tables }
{ $subsection recreate-table }
"Dropping tables:"
{ $subsection drop-table }
"Inserting a tuple:"
{ $subsection insert-tuple }
"Updating a tuple:"
{ $subsection update-tuple }
"Deleting tuples:"
{ $subsection delete-tuples }
"Querying tuples:"
{ $subsection select-tuple }
{ $subsection select-tuples }
{ $subsection count-tuples }
"Advanced querying of tuples:"
{ $subsection query } ;
ARTICLE: "db-tuples-protocol" "High-level tuple/database protocol"
;
ARTICLE: "db-tuples-tutorial" "Tuple database tutorial"
"Let's make a tuple and store it in a database. To follow along, click on each code example and run it in the listener. If you forget to run an example, just start at the top and run them all again in order." $nl
"We're going to store books in this tutorial."
{ $code "TUPLE: book id title author date-published edition cover-price condition ;" }
"The title, author, and publisher should be strings; the date-published a timestamp; the edition an integer; the cover-price a float. These are the Factor types for which we will need to look up the corresponding " { $link "db.types" } ". " $nl
"To actually bind the tuple slots to the database types, we'll use " { $link define-persistent } "."
{ $code
<" USING: db.tuples db.types ;
book "BOOK"
{
{ "id" "ID" +db-assigned-id+ }
{ "title" "TITLE" VARCHAR }
{ "author" "AUTHOR" VARCHAR }
{ "date-published" "DATE_PUBLISHED" TIMESTAMP }
{ "edition" "EDITION" INTEGER }
{ "cover-price" "COVER_PRICE" DOUBLE }
{ "condition" "CONDITION" VARCHAR }
} define-persistent "> }
"That's all we'll have to do with the database for this tutorial. Now let's make a book."
{ $code <" USING: calendar namespaces ;
T{ book
{ title "Factor for Sheeple" }
{ author "Mister Stacky Pants" }
{ date-published T{ timestamp { year 2009 } { month 3 } { day 3 } } }
{ edition 1 }
{ cover-price 13.37 }
} book set
"> }
"Now we've created a book. Let's save it to the database."
{ $code <" USING: db db.sqlite fry io.files ;
: with-book-tutorial ( quot -- )
'[ "book-tutorial.db" temp-file sqlite-db , with-db ] call ;
[
book recreate-table
book get insert-tuple
] with-book-tutorial
"> }
"Is it really there?"
{ $code <" [
T{ book { title "Factor for Sheeple" } } select-tuples .
] with-book-tutorial "> }
"Oops, we spilled some orange juice on the book cover."
{ $code <" book get "Small orange juice stain on cover" >>condition "> }
"Now let's save the modified book."
{ $code <" [
book get update-tuple
] with-book-tutorial "> }
"And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "."
{ $code <" [
T{ book { title "Factor for Sheeple" } } select-tuples
] with-book-tutorial "> }
"Let's drop the table because we're done."
{ $code <" [
book drop-table
] with-book-tutorial "> }
"To summarize, the steps for using Factor's tuple database are:"
{ $list
"Make a new tuple to represent your data"
{ "Map the Factor types to the database types with " { $link define-persistent } }
{ "Make a " { $link "db-custom-database-combinators" } " to open your database and run a " { $snippet "quotation" } }
{ "Create a table with " { $link create-table } ", " { $link ensure-table } ", or " { $link recreate-table } }
{ "Start making and storing objects with " { $link insert-tuple } ", " { $link update-tuple } ", " { $link delete-tuples } ", and " { $link select-tuples } }
} ;
ABOUT: "db-tuples"

41
basis/db/tuples/tuples.factor
View File

@ -49,41 +49,11 @@ HOOK: <count-statement> db ( tuple class groups -- n )
HOOK: insert-tuple* db ( tuple statement -- )
GENERIC: eval-generator ( singleton -- obj )
SINGLETON: retryable
: make-retryable ( obj -- obj' )
dup sequence? [
[ make-retryable ] map
] [
retryable >>type
10 >>retries
] if ;
: regenerate-params ( statement -- statement )
dup
[ bind-params>> ] [ in-params>> ] bi
[
dup generator-bind? [
generator-singleton>> eval-generator >>value
] [
drop
] if
] 2map >>bind-params ;
M: retryable execute-statement* ( statement type -- )
drop [ retries>> ] [
[
nip
[ query-results dispose t ]
[ ]
[ regenerate-params bind-statement* f ] cleanup
] curry
] bi attempt-all drop ;
: resulting-tuple ( class row out-params -- tuple )
: resulting-tuple ( exemplar-tuple row out-params -- tuple )
rot class new [
[
>r slot-name>> r> set-slot-named
[ slot-name>> ] dip set-slot-named
] curry 2each
] keep ;
@ -95,12 +65,9 @@ M: retryable execute-statement* ( statement type -- )
: query-modify-tuple ( tuple statement -- )
[ query-results [ sql-row-typed ] with-disposal ] keep
out-params>> rot [
>r slot-name>> r> set-slot-named
[ slot-name>> ] dip set-slot-named
] curry 2each ;
: sql-props ( class -- columns table )
[ db-columns ] [ db-table ] bi ;
: with-disposals ( seq quot -- )
over sequence? [
[ with-disposal ] curry each
@ -154,7 +121,7 @@ M: retryable execute-statement* ( statement type -- )
[ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
: query ( tuple query -- tuples )
>r dup dup class r> <query> do-select ;
[ dup dup class ] dip <query> do-select ;
: select-tuples ( tuple -- tuples )
dup dup class <select-by-slots-statement> do-select ;

330
basis/db/types/types-docs.factor Normal file
View File

@ -0,0 +1,330 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes hashtables help.markup help.syntax io.streams.string kernel sequences strings ;
IN: db.types
HELP: (lookup-type)
{ $values
{ "obj" object }
{ "string" string } }
{ $description "" } ;
HELP: +autoincrement+
{ $description "" } ;
HELP: +db-assigned-id+
{ $description "The database assigns a primary key to the object. The primary key is most likely a big integer, but is database-dependent." } ;
HELP: +default+
{ $description "" } ;
HELP: +foreign-id+
{ $description "" } ;
HELP: +has-many+
{ $description "" } ;
HELP: +not-null+
{ $description "" } ;
HELP: +null+
{ $description "" } ;
HELP: +primary-key+
{ $description "" } ;
HELP: +random-id+
{ $description "Factor chooses a random number and tries to insert the tuple into the database with this number as its primary key. The default number of retries to find a unique random number is 10, though in practice it will almost certainly succeed on the first try." } ;
HELP: +serial+
{ $description "" } ;
HELP: +unique+
{ $description "" } ;
HELP: +user-assigned-id+
{ $description "The user is responsible for choosing a primary key for tuples inserted with this database type. Keys must be unique or else the database will throw an error. Usually it is better to use a " { $link +db-assigned-id+ } "." } ;
HELP: <generator-bind>
{ $description "" } ;
HELP: <literal-bind>
{ $description "" } ;
HELP: <low-level-binding>
{ $description "" } ;
HELP: BIG-INTEGER
{ $description "A 64-bit integer." } ;
HELP: BLOB
{ $description "A serialized Factor object. The database library automatically serializes the object for a SQL insert or update and deserializes it on a tuple query." } ;
HELP: BOOLEAN
{ $description "Either true or false." } ;
HELP: DATE
{ $description "A date without a time component." } ;
HELP: DATETIME
{ $description "A date and a time." } ;
HELP: DOUBLE
{ $description "Corresponds to Factor's 64bit floating-point numbers." } ;
HELP: FACTOR-BLOB
{ $description "" } ;
HELP: INTEGER
{ $description "" } ;
HELP: NULL
{ $description "" } ;
HELP: REAL
{ $description "" } ;
HELP: SIGNED-BIG-INTEGER
{ $description "For portability, if a number is known to be 64bit and signed, then this datatype may be used. Some databases, like SQLite, cannot store arbitrary bignums as BIGINT types. If storing arbitrary bignums, use " { $link FACTOR-BLOB } "." } ;
HELP: TEXT
{ $description "" } ;
HELP: TIME
{ $description "" } ;
HELP: TIMESTAMP
{ $description "" } ;
HELP: UNSIGNED-BIG-INTEGER
{ $description "" } ;
HELP: URL
{ $description "" } ;
HELP: VARCHAR
{ $description "" } ;
HELP: assigned-id-spec?
{ $values
{ "spec" null }
{ "?" "a boolean" } }
{ $description "" } ;
HELP: bind#
{ $values
{ "spec" null } { "obj" object } }
{ $description "" } ;
HELP: bind%
{ $values
{ "spec" null } }
{ $description "" } ;
HELP: compound
{ $values
{ "string" string } { "obj" object }
{ "hash" hashtable } }
{ $description "" } ;
HELP: db-assigned-id-spec?
{ $values
{ "spec" null }
{ "?" "a boolean" } }
{ $description "" } ;
HELP: double-quote
{ $values
{ "string" string }
{ "new-string" null } }
{ $description "" } ;
HELP: find-primary-key
{ $values
{ "specs" null }
{ "obj" object } }
{ $description "" } ;
HELP: find-random-generator
{ $values
{ "seq" sequence }
{ "obj" object } }
{ $description "" } ;
HELP: generator-bind
{ $description "" } ;
HELP: get-slot-named
{ $values
{ "name" null } { "obj" object }
{ "value" null } }
{ $description "" } ;
HELP: join-space
{ $values
{ "string1" string } { "string2" string }
{ "new-string" null } }
{ $description "" } ;
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" null }
{ "string" string } }
{ $description "" } ;
HELP: no-sql-type
{ $description "" } ;
HELP: normalize-spec
{ $values
{ "spec" null } }
{ $description "" } ;
HELP: number>string*
{ $values
{ "n/string" null }
{ "string" string } }
{ $description "" } ;
HELP: offset-of-slot
{ $values
{ "string" string } { "obj" object }
{ "n" null } }
{ $description "" } ;
HELP: paren
{ $values
{ "string" string }
{ "new-string" null } }
{ $description "" } ;
HELP: persistent-table
{ $values
{ "hash" hashtable } }
{ $description "" } ;
HELP: primary-key?
{ $values
{ "spec" null }
{ "?" "a boolean" } }
{ $description "" } ;
HELP: random-id-generator
{ $description "" } ;
HELP: relation?
{ $values
{ "spec" null }
{ "?" "a boolean" } }
{ $description "" } ;
HELP: remove-db-assigned-id
{ $values
{ "specs" null }
{ "obj" object } }
{ $description "" } ;
HELP: remove-id
{ $values
{ "specs" null }
{ "obj" object } }
{ $description "" } ;
HELP: remove-relations
{ $values
{ "specs" null }
{ "newcolumns" null } }
{ $description "" } ;
HELP: set-slot-named
{ $values
{ "value" null } { "name" null } { "obj" object } }
{ $description "" } ;
HELP: single-quote
{ $values
{ "string" string }
{ "new-string" null } }
{ $description "" } ;
HELP: spec>tuple
{ $values
{ "class" class } { "spec" null }
{ "tuple" null } }
{ $description "" } ;
HELP: sql-spec
{ $description "" } ;
HELP: tuple>filled-slots
{ $values
{ "tuple" null }
{ "alist" "an array of key/value pairs" } }
{ $description "" } ;
HELP: tuple>params
{ $values
{ "specs" null } { "tuple" null }
{ "obj" object } }
{ $description "" } ;
HELP: unknown-modifier
{ $description "" } ;
ARTICLE: "db.types" "Database types"
"The " { $vocab-link "db.types" } " vocabulary maps Factor types to database types." $nl
"Primary keys:"
{ $subsection +db-assigned-id+ }
{ $subsection +user-assigned-id+ }
{ $subsection +random-id+ }
"Null and boolean types:"
{ $subsection NULL }
{ $subsection BOOLEAN }
"Text types:"
{ $subsection VARCHAR }
{ $subsection TEXT }
"Number types:"
{ $subsection INTEGER }
{ $subsection BIG-INTEGER }
{ $subsection SIGNED-BIG-INTEGER }
{ $subsection UNSIGNED-BIG-INTEGER }
{ $subsection DOUBLE }
{ $subsection REAL }
"Calendar types:"
{ $subsection DATE }
{ $subsection DATETIME }
{ $subsection TIME }
{ $subsection TIMESTAMP }
"Arbitrary Factor objects:"
{ $subsection BLOB }
{ $subsection FACTOR-BLOB }
"Factor URLs:"
{ $subsection URL }
;
ABOUT: "db.types"

13
basis/farkup/farkup-tests.factor
View File

@ -3,6 +3,10 @@
USING: farkup kernel peg peg.ebnf tools.test namespaces ;
IN: farkup.tests
relative-link-prefix off
disable-images? off
link-no-follow? off
[ "Baz" ] [ "Foo/Bar/Baz" simple-link-title ] unit-test
[ "Baz" ] [ "Baz" simple-link-title ] unit-test
@ -105,3 +109,12 @@ IN: farkup.tests
[
"<p>Feature comparison:</p><table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table>"
] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
[
"<p>This wiki is written in <a href='Factor'>Factor</a> and is hosted on a <a href='http://linode.com'>http://linode.com</a> virtual server.</p>"
] [
"This wiki is written in [[Factor]] and is hosted on a [[http://linode.com|http://linode.com]] virtual server."
convert-farkup
] unit-test
[ "<p><a href='a'>a</a> <a href='b'>c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test

10
basis/farkup/farkup.factor
View File

@ -67,15 +67,17 @@ inline-code = "%" (!("%" | nl).)+ "%"
escaped-char = "\" . => [[ second ]]
image-link = "[[image:" (!("|") .)+ "|" (!("]]").)+ "]]"
link-content = (!("|"|"]").)+
image-link = "[[image:" link-content "|" link-content "]]"
=> [[ [ second >string ] [ fourth >string ] bi image boa ]]
| "[[image:" (!("]").)+ "]]"
| "[[image:" link-content "]]"
=> [[ second >string f image boa ]]
simple-link = "[[" (!("|]" | "]]") .)+ "]]"
simple-link = "[[" link-content "]]"
=> [[ second >string dup simple-link-title link boa ]]
labelled-link = "[[" (!("|") .)+ "|" (!("]]").)+ "]]"
labelled-link = "[[" link-content "|" link-content "]]"
=> [[ [ second >string ] [ fourth >string ] bi link boa ]]
link = image-link | labelled-link | simple-link

27
basis/furnace/auth/auth.factor
View File

@ -134,22 +134,21 @@ TUPLE: protected < filter-responder description capabilities ;
swap >>responder ;
: have-capabilities? ( capabilities -- ? )
logged-in-user get {
{ [ dup not ] [ 2drop f ] }
{ [ dup deleted>> 1 = ] [ 2drop f ] }
[ capabilities>> subset? ]
} cond ;
realm get secure>> secure-connection? not and [ drop f ] [
logged-in-user get {
{ [ dup not ] [ 2drop f ] }
{ [ dup deleted>> 1 = ] [ 2drop f ] }
[ capabilities>> subset? ]
} cond
] if ;
M: protected call-responder* ( path responder -- response )
'[
, ,
dup protected set
dup capabilities>> have-capabilities?
[ call-next-method ] [
[ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
realm get login-required*
] if
] if-secure-realm ;
dup protected set
dup capabilities>> have-capabilities?
[ call-next-method ] [
[ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
realm get login-required*
] if ;
: <auth-boilerplate> ( responder -- responder' )
<boilerplate> { realm "boilerplate" } >>template ;

3
basis/furnace/auth/features/registration/registration.factor
View File

@ -36,7 +36,8 @@ IN: furnace.auth.features.registration
URL" $realm" <redirect>
] >>submit
<auth-boilerplate> ;
<auth-boilerplate>
<secure-realm-only> ;
: allow-registration ( login -- login )
<register-action> "register" add-responder ;

19
basis/furnace/chloe-tags/chloe-tags-tests.factor Normal file
View File

@ -0,0 +1,19 @@
USING: html.forms furnace.chloe-tags tools.test ;
IN: furnace.chloe-tags.tests
[ f ] [ f parse-query-attr ] unit-test
[ f ] [ "" parse-query-attr ] unit-test
[ H{ { "a" "b" } } ] [
begin-form
"b" "a" set-value
"a" parse-query-attr
] unit-test
[ H{ { "a" "b" } { "c" "d" } } ] [
begin-form
"b" "a" set-value
"d" "c" set-value
"a,c" parse-query-attr
] unit-test

126
basis/furnace/chloe-tags/chloe-tags.factor Normal file
View File

@ -0,0 +1,126 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel combinators assocs
namespaces sequences splitting words
fry urls multiline present qualified
xml
xml.data
xml.entities
xml.writer
xml.utilities
html.components
html.elements
html.forms
html.templates
html.templates.chloe
html.templates.chloe.compiler
html.templates.chloe.syntax
http
http.server
http.server.redirection
http.server.responses
furnace ;
QUALIFIED-WITH: assocs a
IN: furnace.chloe-tags
! Chloe tags
: parse-query-attr ( string -- assoc )
[ f ] [ "," split [ dup value ] H{ } map>assoc ] if-empty ;
: a-url-path ( href rest -- string )
dup [ value ] when
[ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
: a-url ( href rest query value-name -- url )
dup [ >r 3drop r> value ] [
drop
<url>
swap parse-query-attr >>query
-rot a-url-path >>path
adjust-url relative-to-request
] if ;
: compile-a-url ( tag -- )
{
[ "href" required-attr compile-attr ]
[ "rest" optional-attr compile-attr ]
[ "query" optional-attr compile-attr ]
[ "value" optional-attr compile-attr ]
} cleave [ a-url ] [code] ;
CHLOE: atom
[ compile-children>string ] [ compile-a-url ] bi
[ add-atom-feed ] [code] ;
CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
: compile-link-attrs ( tag -- )
#! Side-effects current namespace.
attrs>> '[ [ , _ link-attr ] each-responder ] [code] ;
: a-start-tag ( tag -- )
[ compile-link-attrs ] [ compile-a-url ] bi
[ <a =href a> ] [code] ;
: a-end-tag ( tag -- )
drop [ </a> ] [code] ;
CHLOE: a
[
[ a-start-tag ] [ compile-children ] [ a-end-tag ] tri
] compile-with-scope ;
: compile-hidden-form-fields ( for -- )
'[
, [ "," split [ hidden render ] each ] when*
nested-forms get " " join f like nested-forms-key hidden-form-field
[ modify-form ] each-responder
] [code] ;
: compile-form-attrs ( method action attrs -- )
[ <form ] [code]
[ compile-attr [ =method ] [code] ]
[ compile-attr [ resolve-base-path =action ] [code] ]
[ compile-attrs ]
tri*
[ form> ] [code] ;
: form-start-tag ( tag -- )
[
[ "method" optional-attr "post" or ]
[ "action" required-attr ]
[ attrs>> non-chloe-attrs-only ] tri
compile-form-attrs
]
[ "for" optional-attr compile-hidden-form-fields ] bi ;
: form-end-tag ( tag -- )
drop [ </form> ] [code] ;
CHLOE: form
[
{
[ compile-link-attrs ]
[ form-start-tag ]
[ compile-children ]
[ form-end-tag ]
} cleave
] compile-with-scope ;
STRING: button-tag-markup
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
<button type="submit"></button>
</t:form>
;
: add-tag-attrs ( attrs tag -- )
attrs>> swap update ;
CHLOE: button
button-tag-markup string>xml body>>
{
[ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
[ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
[ [ children>> ] dip "button" tag-named (>>children) ]
[ nip ]
} 2cleave compile-chloe-tag ;

3
basis/furnace/conversations/conversations.factor
View File

@ -130,7 +130,8 @@ M: conversations call-responder*
over post-data>> >>post-data
over url>> >>url
] change
url>> path>> split-path
[ url>> url set ]
[ url>> path>> split-path ] bi
conversations get responder>> call-responder ;
\ end-aside-post DEBUG add-input-logging

141
basis/furnace/furnace.factor
View File

@ -1,30 +1,14 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel combinators assocs
continuations namespaces sequences splitting words
vocabs.loader classes strings
fry urls multiline present
xml
xml.data
xml.entities
xml.writer
html.components
html.elements
html.forms
html.templates
html.templates.chloe
html.templates.chloe.syntax
http
http.server
http.server.redirection
http.server.responses
qualified ;
QUALIFIED-WITH: assocs a
EXCLUDE: xml.utilities => children>string ;
USING: namespaces assocs sequences kernel classes splitting
vocabs.loader accessors strings combinators arrays
continuations present fry
urls html.elements
http http.server http.server.redirection ;
IN: furnace
: nested-responders ( -- seq )
responder-nesting get a:values ;
responder-nesting get values ;
: each-responder ( quot -- )
nested-responders swap each ; inline
@ -63,10 +47,25 @@ M: url adjust-url
M: string adjust-url ;
GENERIC: link-attr ( tag responder -- )
M: object link-attr 2drop ;
GENERIC: modify-form ( responder -- )
M: object modify-form drop ;
: hidden-form-field ( value name -- )
over [
<input
"hidden" =type
=name
present =value
input/>
] [ 2drop ] if ;
: nested-forms-key "__n" ;
: request-params ( request -- assoc )
dup method>> {
{ "GET" [ url>> query>> ] }
@ -110,98 +109,4 @@ SYMBOL: exit-continuation
: with-exit-continuation ( quot -- )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
! Chloe tags
: parse-query-attr ( string -- assoc )
[ f ] [ "," split [ dup value ] H{ } map>assoc ] if-empty ;
: a-url-path ( tag -- string )
[ "href" required-attr ]
[ "rest" optional-attr dup [ value ] when ] bi
[ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
: a-url ( tag -- url )
dup "value" optional-attr
[ value ] [
<url>
swap
[ a-url-path >>path ]
[ "query" optional-attr parse-query-attr >>query ]
bi
adjust-url relative-to-request
] ?if ;
CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ;
CHLOE: write-atom drop write-atom-feeds ;
GENERIC: link-attr ( tag responder -- )
M: object link-attr 2drop ;
: link-attrs ( tag -- )
#! Side-effects current namespace.
'[ , _ link-attr ] each-responder ;
: a-start-tag ( tag -- )
[ <a [ link-attrs ] [ a-url =href ] bi a> ] with-scope ;
CHLOE: a
[ a-start-tag ]
[ process-tag-children ]
[ drop </a> ]
tri ;
: hidden-form-field ( value name -- )
over [
<input
"hidden" =type
=name
present =value
input/>
] [ 2drop ] if ;
: nested-forms-key "__n" ;
: form-magic ( tag -- )
[ modify-form ] each-responder
nested-forms get " " join f like nested-forms-key hidden-form-field
"for" optional-attr [ "," split [ hidden render ] each ] when* ;
: form-start-tag ( tag -- )
[
[
<form
{
[ link-attrs ]
[ "method" optional-attr "post" or =method ]
[ "action" required-attr resolve-base-path =action ]
[ attrs>> non-chloe-attrs-only print-attrs ]
} cleave
form>
]
[ form-magic ] bi
] with-scope ;
CHLOE: form
[ form-start-tag ]
[ process-tag-children ]
[ drop </form> ]
tri ;
STRING: button-tag-markup
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
<button type="submit"></button>
</t:form>
;
: add-tag-attrs ( attrs tag -- )
attrs>> swap update ;
CHLOE: button
button-tag-markup string>xml body>>
{
[ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
[ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
[ [ children>string 1array ] dip "button" tag-named (>>children) ]
[ nip ]
} 2cleave process-chloe-tag ;
"furnace.chloe-tags" require

18
basis/furnace/redirection/redirection.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators namespaces fry
io.servers.connection urls
http http.server http.server.redirection http.server.filters
furnace ;
io.servers.connection urls http http.server
http.server.redirection http.server.responses
http.server.filters furnace ;
IN: furnace.redirection
: <redirect> ( url -- response )
@ -32,10 +32,14 @@ TUPLE: secure-only < filter-responder ;
C: <secure-only> secure-only
: if-secure ( quot -- )
>r url get protocol>> "http" =
[ url get <secure-redirect> ]
r> if ; inline
: secure-connection? ( -- ? ) url get protocol>> "https" = ;
: if-secure ( quot -- response )
{
{ [ secure-connection? ] [ call ] }
{ [ request get method>> "POST" = ] [ drop <400> ] }
[ drop url get <secure-redirect> ]
} cond ; inline
M: secure-only call-responder*
'[ , , call-next-method ] if-secure ;

13
basis/help/cookbook/cookbook.factor
View File

@ -182,6 +182,7 @@ $nl
ARTICLE: "cookbook-io" "Input and output cookbook"
"Ask the user for their age, and print it back:"
{ $code
"USING: io math.parser ;"
": ask-age ( -- ) \"How old are you?\" print ;"
": read-age ( -- n ) readln string>number ;"
": print-age ( n -- )"
@ -193,22 +194,26 @@ ARTICLE: "cookbook-io" "Input and output cookbook"
}
"Print the lines of a file in sorted order:"
{ $code
"utf8 \"lines.txt\" file-lines natural-sort [ print ] each"
"USING: io io.encodings.utf8 io.files sequences sorting ;"
"\"lines.txt\" utf8 file-lines natural-sort [ print ] each"
}
"Read 1024 bytes from a file:"
{ $code
"USING: io io.encodings.binary io.files ;"
"\"data.bin\" binary [ 1024 read ] with-file-reader"
}
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
{ $code
"USING: accessors grouping io.files io.mmap kernel sequences ;"
"\"mydata.dat\" dup file-info size>> ["
" 4 <sliced-groups> [ reverse-here ] change-each"
"] with-mapped-file"
}
"Send some bytes to a remote host:"
{ $code
"\"myhost\" 1033 <inet>"
"[ { 12 17 102 } >string write ] with-client"
"USING: io io.encodings.ascii io.sockets strings ;"
"\"myhost\" 1033 <inet> ascii"
"[ B{ 12 17 102 } write ] with-client"
}
{ $references
{ }
@ -244,7 +249,7 @@ ARTICLE: "cookbook-application" "Application cookbook"
}
"See " { $link POSTPONE: MAIN: } " for details. The " { $link run } " word loads a vocabulary if necessary, and calls its main entry point; try the following, it's fun:"
{ $code "\"tetris\" run" }
"On Mac OS X and Windows, stand-alone applications can also be deployed; these are genuine, 100% native code double-clickable executables:"
"Factor can deploy stand-alone executables; they do not have any external dependencies and consist entirely of compiled native machine code:"
{ $code "\"tetris\" deploy-tool" }
{ $references
{ }

17
basis/html/templates/chloe/chloe-tests.factor
View File

@ -4,22 +4,7 @@ namespaces xml html.components html.forms
splitting unicode.categories furnace accessors ;
IN: html.templates.chloe.tests
[ f ] [ f parse-query-attr ] unit-test
[ f ] [ "" parse-query-attr ] unit-test
[ H{ { "a" "b" } } ] [
begin-form
"b" "a" set-value
"a" parse-query-attr
] unit-test
[ H{ { "a" "b" } { "c" "d" } } ] [
begin-form
"b" "a" set-value
"d" "c" set-value
"a,c" parse-query-attr
] unit-test
reset-templates
: run-template
with-string-writer [ "\r\n\t" member? not ] filter

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

@ -1,78 +1,53 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize
io io.files io.encodings.utf8 io.streams.string
unicode.case mirrors fry math urls present
multiline xml xml.data xml.writer xml.utilities
USING: accessors kernel sequences combinators kernel fry
namespaces classes.tuple assocs splitting words arrays memoize
io io.files io.encodings.utf8 io.streams.string unicode.case
mirrors math urls present multiline quotations xml xml.data
html.forms
html.elements
html.components
html.templates
html.templates.chloe.compiler
html.templates.chloe.components
html.templates.chloe.syntax ;
IN: html.templates.chloe
! Chloe is Ed's favorite web designer
SYMBOL: tag-stack
TUPLE: chloe path ;
C: <chloe> chloe
DEFER: process-template
CHLOE: chloe compile-children ;
: chloe-attrs-only ( assoc -- assoc' )
[ drop url>> chloe-ns = ] assoc-filter ;
: non-chloe-attrs-only ( assoc -- assoc' )
[ drop url>> chloe-ns = not ] assoc-filter ;
: chloe-tag? ( tag -- ? )
dup xml? [ body>> ] when
{
{ [ dup tag? not ] [ f ] }
{ [ dup url>> chloe-ns = not ] [ f ] }
[ t ]
} cond nip ;
: process-tag-children ( tag -- )
[ process-template ] each ;
CHLOE: chloe process-tag-children ;
: children>string ( tag -- string )
[ process-tag-children ] with-string-writer ;
CHLOE: title children>string set-title ;
CHLOE: title compile-children>string [ set-title ] [code] ;
CHLOE: write-title
drop
"head" tag-stack get member?
"title" tag-stack get member? not and
[ <title> write-title </title> ] [ write-title ] if ;
[ <title> write-title </title> ] [ write-title ] ? [code] ;
CHLOE: style
dup "include" optional-attr dup [
swap children>string empty? [
"style tag cannot have both an include attribute and a body" throw
] unless
utf8 file-contents
dup "include" optional-attr [
utf8 file-contents [ add-style ] [code-with]
] [
drop children>string
] if add-style ;
compile-children>string [ add-style ] [code]
] ?if ;
CHLOE: write-style
drop <style> write-style </style> ;
drop [ <style> write-style </style> ] [code] ;
CHLOE: even "index" value even? [ process-tag-children ] [ drop ] if ;
CHLOE: even
[ "index" value even? swap when ] process-children ;
CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ;
CHLOE: odd
[ "index" value odd? swap when ] process-children ;
: (bind-tag) ( tag quot -- )
[
[ "name" required-attr ] keep
'[ , process-tag-children ]
] dip call ; inline
[ "name" required-attr compile-attr ] keep
] dip process-children ; inline
CHLOE: each [ with-each-value ] (bind-tag) ;
@ -80,22 +55,23 @@ CHLOE: bind-each [ with-each-object ] (bind-tag) ;
CHLOE: bind [ with-form ] (bind-tag) ;
: error-message-tag ( tag -- )
children>string render-error ;
CHLOE: comment drop ;
CHLOE: call-next-template drop call-next-template ;
CHLOE: call-next-template
drop reset-buffer \ call-next-template , ;
: attr>word ( value -- word/f )
":" split1 swap lookup ;
: if-satisfied? ( tag -- ? )
[ "code" optional-attr [ attr>word dup [ execute ] when ] [ t ] if* ]
[ "value" optional-attr [ value ] [ t ] if* ]
bi and ;
: if>quot ( tag -- quot )
[
[ "code" optional-attr [ attr>word [ , ] [ f , ] if* ] [ t , ] if* ]
[ "value" optional-attr [ , \ value , ] [ t , ] if* ]
bi
\ and ,
] [ ] make ;
CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
CHLOE: if dup if>quot [ swap when ] append process-children ;
CHLOE-SINGLETON: label
CHLOE-SINGLETON: link
@ -112,51 +88,21 @@ CHLOE-TUPLE: choice
CHLOE-TUPLE: checkbox
CHLOE-TUPLE: code
: process-chloe-tag ( tag -- )
dup main>> dup tags get at
[ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
: read-template ( chloe -- xml )
path>> ".xml" append utf8 <file-reader> read-xml ;
: process-tag ( tag -- )
{
[ main>> >lower tag-stack get push ]
[ write-start-tag ]
[ process-tag-children ]
[ write-end-tag ]
[ drop tag-stack get pop* ]
} cleave ;
MEMO: template-quot ( chloe -- quot )
read-template compile-template ;
: expand-attrs ( tag -- tag )
dup [ tag? ] [ xml? ] bi or [
clone [
[ "@" ?head [ value present ] when ] assoc-map
] change-attrs
] when ;
MEMO: nested-template-quot ( chloe -- quot )
read-template compile-nested-template ;
: process-template ( xml -- )
expand-attrs
{
{ [ dup chloe-tag? ] [ process-chloe-tag ] }
{ [ dup [ tag? ] [ xml? ] bi or ] [ process-tag ] }
{ [ t ] [ write-item ] }
} cond ;
: process-chloe ( xml -- )
[
V{ } clone tag-stack set
nested-template? get [
process-template
] [
{
[ prolog>> write-prolog ]
[ before>> write-chunk ]
[ process-template ]
[ after>> write-chunk ]
} cleave
] if
] with-scope ;
: reset-templates ( -- )
{ template-quot nested-template-quot } [ reset-memoized ] each ;
M: chloe call-template*
path>> ".xml" append utf8 <file-reader> read-xml process-chloe ;
nested-template? get
[ nested-template-quot ] [ template-quot ] if
assert-depth ;
INSTANCE: chloe template

131
basis/html/templates/chloe/compiler/compiler.factor Normal file
View File

@ -0,0 +1,131 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs namespaces kernel sequences accessors combinators
strings splitting io io.streams.string present xml.writer
xml.data xml.entities html.forms html.templates.chloe.syntax ;
IN: html.templates.chloe.compiler
: chloe-attrs-only ( assoc -- assoc' )
[ drop url>> chloe-ns = ] assoc-filter ;
: non-chloe-attrs-only ( assoc -- assoc' )
[ drop url>> chloe-ns = not ] assoc-filter ;
: chloe-tag? ( tag -- ? )
dup xml? [ body>> ] when
{
{ [ dup tag? not ] [ f ] }
{ [ dup url>> chloe-ns = not ] [ f ] }
[ t ]
} cond nip ;
SYMBOL: string-buffer
SYMBOL: tag-stack
DEFER: compile-element
: compile-children ( tag -- )
[ compile-element ] each ;
: [write] ( string -- ) string-buffer get push-all ;
: reset-buffer ( -- )
string-buffer get [
[ >string , \ write , ] [ delete-all ] bi
] unless-empty ;
: [code] ( quot -- )
reset-buffer % ;
: [code-with] ( obj quot -- )
reset-buffer [ , ] [ % ] bi* ;
: expand-attr ( value -- )
[ value present write ] [code-with] ;
: compile-attr ( value -- )
reset-buffer "@" ?head [ , [ value present ] % ] [ , ] if ;
: compile-attrs ( assoc -- )
[
" " [write]
swap name>string [write]
"=\"" [write]
"@" ?head [ expand-attr ] [ escape-quoted-string [write] ] if
"\"" [write]
] assoc-each ;
: compile-start-tag ( tag -- )
"<" [write]
[ name>string [write] ] [ compile-attrs ] bi
">" [write] ;
: compile-end-tag ( tag -- )
"</" [write]
name>string [write]
">" [write] ;
: compile-tag ( tag -- )
{
[ main>> tag-stack get push ]
[ compile-start-tag ]
[ compile-children ]
[ compile-end-tag ]
[ drop tag-stack get pop* ]
} cleave ;
: compile-chloe-tag ( tag -- )
! "Unknown chloe tag: " prepend throw
dup main>> dup tags get at
[ curry assert-depth ] [ 2drop ] ?if ;
: compile-element ( element -- )
{
{ [ dup chloe-tag? ] [ compile-chloe-tag ] }
{ [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] }
{ [ dup string? ] [ escape-string [write] ] }
{ [ dup comment? ] [ drop ] }
[ [ write-item ] [code-with] ]
} cond ;
: with-compiler ( quot -- quot' )
[
SBUF" " string-buffer set
V{ } clone tag-stack set
call
reset-buffer
] [ ] make ; inline
: compile-nested-template ( xml -- quot )
[ compile-element ] with-compiler ;
: compile-chunk ( seq -- )
[ compile-element ] each ;
: compile-quot ( quot -- )
reset-buffer
[
SBUF" " string-buffer set
call
reset-buffer
] [ ] make , ; inline
: process-children ( tag quot -- )
[ [ compile-children ] compile-quot ] [ % ] bi* ; inline
: compile-children>string ( tag -- )
[ with-string-writer ] process-children ;
: compile-with-scope ( quot -- )
compile-quot [ with-scope ] [code] ; inline
: compile-template ( xml -- quot )
[
{
[ prolog>> [ write-prolog ] [code-with] ]
[ before>> compile-chunk ]
[ compile-element ]
[ after>> compile-chunk ]
} cleave
] with-compiler ;

35
basis/html/templates/chloe/components/components.factor Normal file
View File

@ -0,0 +1,35 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences kernel parser fry quotations
classes.tuple
html.components
html.templates.chloe.compiler
html.templates.chloe.syntax ;
IN: html.templates.chloe.components
: singleton-component-tag ( tag class -- )
[ "name" required-attr compile-attr ]
[ literalize [ render ] [code-with] ]
bi* ;
: CHLOE-SINGLETON:
scan-word
[ name>> ] [ '[ , singleton-component-tag ] ] bi
define-chloe-tag ;
parsing
: compile-component-attrs ( tag class -- )
[ attrs>> [ drop main>> "name" = not ] assoc-filter ] dip
[ all-slots swap '[ name>> , at compile-attr ] each ]
[ [ boa ] [code-with] ]
bi ;
: tuple-component-tag ( tag class -- )
[ drop "name" required-attr compile-attr ] [ compile-component-attrs ] 2bi
[ render ] [code] ;
: CHLOE-TUPLE:
scan-word
[ name>> ] [ '[ , tuple-component-tag ] ] bi
define-chloe-tag ;
parsing

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

@ -21,7 +21,7 @@ tags global [ H{ } clone or ] change-at
: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
MEMO: chloe-name ( string -- name )
: chloe-name ( string -- name )
name new
swap >>main
chloe-ns >>url ;
@ -32,30 +32,3 @@ MEMO: chloe-name ( string -- name )
: optional-attr ( tag name -- value )
chloe-name swap at ;
: singleton-component-tag ( tag class -- )
[ "name" required-attr ] dip render ;
: CHLOE-SINGLETON:
scan-word
[ name>> ] [ '[ , singleton-component-tag ] ] bi
define-chloe-tag ;
parsing
: attrs>slots ( tag tuple -- )
[ attrs>> ] [ <mirror> ] bi*
'[
swap main>> dup "name" =
[ 2drop ] [ , set-at ] if
] assoc-each ;
: tuple-component-tag ( tag class -- )
[ drop "name" required-attr ]
[ new [ attrs>slots ] keep ]
2bi render ;
: CHLOE-TUPLE:
scan-word
[ name>> ] [ '[ , tuple-component-tag ] ] bi
define-chloe-tag ;
parsing

2
basis/http/http.factor
View File

@ -113,7 +113,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
{ [ dup real? ] [ number>string ] }
[ ]
} cond
check-cookie-string "=" swap check-cookie-string 3append ,
[ check-cookie-string ] bi@ "=" swap 3append ,
]
} case ;

2
basis/io/servers/connection/connection.factor
View File

@ -73,7 +73,7 @@ M: threaded-server handle-client* handler>> call ;
] with-stream ;
: thread-name ( server-name addrspec -- string )
unparse " connection from " swap 3append ;
unparse-short " connection from " swap 3append ;
: accept-connection ( threaded-server -- )
[ accept ] [ addr>> ] bi

14
basis/locals/locals-tests.factor
View File

@ -316,3 +316,17 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
! [ f ] [ 3 wlet-&&-test ] unit-test
! [ f ] [ 8 wlet-&&-test ] unit-test
! [ t ] [ 12 wlet-&&-test ] unit-test
[ { 10 } ] [ 10 [| a | { a } ] call ] unit-test
[ { 10 20 } ] [ 10 20 [| a b | { a b } ] call ] unit-test
[ { 10 20 30 } ] [ 10 20 30 [| a b c | { a b c } ] call ] unit-test
[ { 10 20 30 } ] [ [let | a [ 10 ] b [ 20 ] c [ 30 ] | { a b c } ] ] unit-test
[ V{ 10 20 30 } ] [ 10 20 30 [| a b c | V{ a b c } ] call ] unit-test
[ H{ { 10 "a" } { 20 "b" } { 30 "c" } } ]
[ 10 20 30 [| a b c | H{ { a "a" } { b "b" } { c "c" } } ] call ] unit-test
[ T{ slice f 0 3 "abc" } ]
[ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test

11
basis/persistent/heaps/heaps.factor
View File

@ -1,4 +1,4 @@
USING: kernel accessors multi-methods locals combinators math arrays
USING: kernel accessors locals combinators math arrays
assocs namespaces sequences ;
IN: persistent.heaps
! These are minheaps
@ -36,14 +36,15 @@ PRIVATE>
GENERIC: sift-down ( value prio left right -- heap )
METHOD: sift-down { empty-heap empty-heap } <branch> ;
METHOD: sift-down { singleton-heap empty-heap }
: singleton-sift-down ( value prio singleton empty -- heap )
3dup drop prio>> <= [ <branch> ] [
drop -rot [ [ value>> ] [ prio>> ] bi ] 2dip
<singleton-heap> <persistent-heap> <branch>
] if ;
M: empty-heap sift-down
over singleton-heap? [ singleton-sift-down ] [ <branch> ] if ;
:: reroot-left ( value prio left right -- heap )
left value>> left prio>>
value prio left left>> left right>> sift-down
@ -54,7 +55,7 @@ METHOD: sift-down { singleton-heap empty-heap }
value prio right left>> right right>> sift-down
<branch> ;
METHOD: sift-down { branch branch }
M: branch sift-down ! both arguments are branches
3dup [ prio>> <= ] both-with? [ <branch> ] [
2dup [ prio>> ] bi@ <= [ reroot-left ] [ reroot-right ] if
] if ;

3
basis/prettyprint/backend/backend.factor
View File

@ -191,7 +191,8 @@ M: wrapper >pprint-sequence wrapped>> 1array ;
M: callstack >pprint-sequence callstack>array ;
M: tuple >pprint-sequence
[ class f 2array ] [ tuple-slots ] bi append ;
[ class ] [ tuple-slots ] bi
[ 1array ] [ [ f 2array ] dip append ] if-empty ;
GENERIC: pprint-narrow? ( obj -- ? )

2
basis/tools/deploy/backend/backend.factor
View File

@ -42,9 +42,9 @@ IN: tools.deploy.backend
: bootstrap-profile ( -- profile )
{
{ "threads" deploy-threads? }
{ "math" deploy-math? }
{ "compiler" deploy-compiler? }
{ "threads" deploy-threads? }
{ "ui" deploy-ui? }
{ "random" deploy-random? }
} [ nip get ] assoc-filter keys

8
basis/tools/deploy/deploy-tests.factor
View File

@ -26,7 +26,7 @@ namespaces continuations layouts accessors ;
[ t ] [ 1300000 small-enough? ] unit-test
[ "staging.threads-math-compiler-ui-strip.image" ] [
[ "staging.math-compiler-threads-ui-strip.image" ] [
"hello-ui" deploy-config
[ bootstrap-profile staging-image-name file-name ] bind
] unit-test
@ -39,9 +39,9 @@ namespaces continuations layouts accessors ;
!
! [ t ] [ 1500000 small-enough? ] unit-test
!
! [ ] [ "bunny" shake-and-bake ] unit-test
!
! [ t ] [ 2500000 small-enough? ] unit-test
[ ] [ "bunny" shake-and-bake ] unit-test
[ t ] [ 2500000 small-enough? ] unit-test
{
"tools.deploy.test.1"

16
basis/tools/deploy/test/1/deploy.factor
View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-c-types? f }
{ deploy-name "tools.deploy.test.1" }
{ deploy-io 2 }
{ deploy-random? f }
{ deploy-math? t }
{ deploy-compiler? t }
{ deploy-reflection 2 }
{ "stop-after-last-window?" t }
{ deploy-threads? t }
{ deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-name "tools.deploy.test.1" }
{ deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
}

14
basis/tools/deploy/test/2/deploy.factor
View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-io 2 }
{ deploy-ui? f }
{ deploy-threads? t }
{ deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-name "tools.deploy.test.2" }
{ deploy-compiler? t }
{ deploy-word-props? f }
{ deploy-reflection 2 }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
{ deploy-random? f }
{ deploy-math? t }
}

14
basis/tools/deploy/test/3/deploy.factor
View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-io 3 }
{ deploy-ui? f }
{ deploy-threads? t }
{ deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-math? t }
{ deploy-io 3 }
{ deploy-name "tools.deploy.test.3" }
{ deploy-compiler? t }
{ deploy-word-props? f }
{ deploy-reflection 2 }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
{ deploy-random? f }
{ deploy-math? t }
}

14
basis/tools/deploy/test/4/deploy.factor
View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-io 2 }
{ deploy-ui? f }
{ deploy-threads? t }
{ deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-name "tools.deploy.test.4" }
{ deploy-compiler? t }
{ deploy-word-props? f }
{ deploy-reflection 2 }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
{ deploy-random? f }
{ deploy-math? t }
}

14
basis/tools/deploy/test/5/deploy.factor
View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-io 3 }
{ deploy-ui? f }
{ deploy-threads? t }
{ deploy-random? f }
{ deploy-c-types? f }
{ deploy-ui? f }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-math? t }
{ deploy-io 3 }
{ deploy-name "tools.deploy.test.5" }
{ deploy-compiler? t }
{ deploy-word-props? f }
{ deploy-reflection 2 }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
{ deploy-random? f }
{ deploy-math? t }
}

2
basis/tools/scaffold/scaffold.factor
View File

@ -119,7 +119,7 @@ ERROR: no-vocab vocab ;
{ "assoc3" assoc } { "newassoc" assoc }
{ "alist" "an array of key/value pairs" }
{ "keys" sequence } { "values" sequence }
{ "class" class }
{ "class" class } { "tuple" tuple }
} at* ;
: add-using ( object -- )

4
basis/xml/generator/generator-tests.factor
View File

@ -1,3 +1,3 @@
USING: tools.test io.streams.string xml.generator xml.writer ;
USING: tools.test io.streams.string xml.generator xml.writer accessors ;
[ "<html><body><a href=\"blah\"/></body></html>" ]
[ "html" [ "body" [ "a" { { "href" "blah" } } contained*, ] tag, ] make-xml [ write-item ] with-string-writer ] unit-test
[ "html" [ "body" [ "a" { { "href" "blah" } } contained*, ] tag, ] make-xml [ body>> write-item ] with-string-writer ] unit-test

5
basis/xml/writer/writer-tests.factor Normal file
View File

@ -0,0 +1,5 @@
IN: xml.writer.tests
USING: xml.data xml.writer tools.test ;
[ "foo" ] [ T{ name { main "foo" } } name>string ] unit-test
[ "ns:foo" ] [ T{ name { space "ns" } { main "foo" } } name>string ] unit-test

7
basis/xml/writer/writer.factor
View File

@ -37,10 +37,11 @@ SYMBOL: indenter
[ [ empty? ] [ string? ] bi and not ] filter
] when ;
: name>string ( name -- string )
[ main>> ] [ space>> ] bi [ ":" rot 3append ] unless-empty ;
: print-name ( name -- )
dup space>> f like
[ write CHAR: : write1 ] when*
main>> write ;
name>string write ;
: print-attrs ( assoc -- )
[

4
core/sequences/sequences-docs.factor
View File

@ -338,7 +338,7 @@ HELP: if-empty
HELP: when-empty
{ $values
{ "seq" sequence } { "quot" "the first quotation of an " { $link if-empty } } }
{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and the " { $snippet "quot1" } " is called." }
{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and the " { $snippet "quot" } " is called." }
{ $examples "This word is equivalent to " { $link if-empty } " with an empty second quotation:"
{ $example
"USING: sequences prettyprint ;"
@ -355,7 +355,7 @@ HELP: when-empty
HELP: unless-empty
{ $values
{ "seq" sequence } { "quot" "the second quotation of an " { $link if-empty } } }
{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped. Otherwise, the " { $snippet "quot2" } " is called on the sequence." }
{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped. Otherwise, the " { $snippet "quot" } " is called on the sequence." }
{ $examples "This word is equivalent to " { $link if-empty } " with an empty first quotation:"
{ $example
"USING: sequences prettyprint ;"

2
extra/lisp/parser/parser.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings
USING: kernel peg peg.ebnf math.parser sequences arrays strings
combinators.lib math fry accessors lists combinators.short-circuit ;
IN: lisp.parser

20
extra/project-euler/001/001.factor
View File

@ -19,8 +19,17 @@ IN: project-euler.001
! Inclusion-exclusion principle
<PRIVATE
: sum-divisible-by ( target n -- m )
[ /i dup 1+ * ] keep * 2 /i ;
PRIVATE>
: euler001 ( -- answer )
0 999 3 <range> sum 0 999 5 <range> sum + 0 999 15 <range> sum - ;
999 3 sum-divisible-by
999 5 sum-divisible-by +
999 15 sum-divisible-by - ;
! [ euler001 ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
@ -30,9 +39,16 @@ IN: project-euler.001
! -------------------
: euler001a ( -- answer )
1000 [ dup 5 mod swap 3 mod [ zero? ] either? ] filter sum ;
0 999 3 <range> sum 0 999 5 <range> sum + 0 999 15 <range> sum - ;
! [ euler001a ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
: euler001b ( -- answer )
1000 [ dup 5 mod swap 3 mod [ zero? ] either? ] filter sum ;
! [ euler001b ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
MAIN: euler001

4
extra/project-euler/014/014.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators.lib kernel math math.ranges namespaces sequences
sorting combinators.short-circuit ;
USING: arrays combinators.lib combinators.short-circuit kernel math math.ranges
namespaces sequences sorting ;
IN: project-euler.014
! http://projecteuler.net/index.php?section=problems&id=14

5
extra/project-euler/021/021.factor
View File

@ -1,8 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.functions math.ranges namespaces
project-euler.common sequences sequences.lib
combinators.short-circuit ;
USING: combinators.lib combinators.short-circuit kernel math math.functions
math.ranges namespaces project-euler.common sequences sequences.lib ;
IN: project-euler.021
! http://projecteuler.net/index.php?section=problems&id=21

4
extra/project-euler/036/036.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math.parser math.ranges project-euler.common
sequences combinators.short-circuit ;
USING: combinators.lib combinators.short-circuit kernel math.parser math.ranges
project-euler.common sequences ;
IN: project-euler.036
! http://projecteuler.net/index.php?section=problems&id=36

6
extra/project-euler/043/043.factor
View File

@ -1,8 +1,8 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib hashtables kernel math math.combinatorics math.parser
math.ranges project-euler.common sequences sequences.lib sorting
sets combinators.short-circuit ;
USING: combinators.lib combinators.short-circuit hashtables kernel math
math.combinatorics math.parser math.ranges project-euler.common sequences
sequences.lib sorting sets ;
IN: project-euler.043
! http://projecteuler.net/index.php?section=problems&id=43

4
extra/project-euler/052/052.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math project-euler.common sequences
sorting combinators.short-circuit ;
USING: combinators.lib combinators.short-circuit kernel math
project-euler.common sequences sorting ;
IN: project-euler.052
! http://projecteuler.net/index.php?section=problems&id=52

18
extra/project-euler/076/076.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2008 Eric Mertens
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators kernel math sequences
math.order math.ranges locals ;
USING: arrays assocs combinators kernel locals math math.order math.ranges
sequences ;
IN: project-euler.076
! http://projecteuler.net/index.php?section=problems&id=76
@ -12,6 +12,7 @@ IN: project-euler.076
! How many different ways can one hundred be written as a
! sum of at least two positive integers?
! SOLUTION
! --------
@ -43,12 +44,17 @@ IN: project-euler.076
:: each-subproblem ( n quot -- )
n [1,b] [ dup [1,b] quot with each ] each ; inline
PRIVATE>
: (euler076) ( n -- m )
dup init
[ [ ways ] curry each-subproblem ]
[ [ dup 2array ] dip at 1- ] 2bi ;
: euler076 ( -- m )
PRIVATE>
: euler076 ( -- answer )
100 (euler076) ;
! [ euler076 ] 100 ave-time
! 704 ms run time - 100 trials
MAIN: euler076

33
extra/project-euler/100/100.factor
View File

@ -1,7 +1,36 @@
USING: kernel sequences math.functions math ;
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions sequences ;
IN: project-euler.100
: euler100 ( -- n )
! http://projecteuler.net/index.php?section=problems&id=100
! DESCRIPTION
! -----------
! If a box contains twenty-one coloured discs, composed of fifteen blue discs
! and six red discs, and two discs were taken at random, it can be seen that
! the probability of taking two blue discs, P(BB) = (15/21)*(14/20) = 1/2.
! The next such arrangement, for which there is exactly 50% chance of taking
! two blue discs at random, is a box containing eighty-five blue discs and
! thirty-five red discs.
! By finding the first arrangement to contain over 10^12 = 1,000,000,000,000
! discs in total, determine the number of blue discs that the box would contain.
! SOLUTION
! --------
: euler100 ( -- answer )
1 1
[ dup dup 1- * 2 * 10 24 ^ <= ]
[ tuck 6 * swap - 2 - ] [ ] while nip ;
! TODO: solution is incredibly slow (>30 minutes) and needs generalization
! [ euler100 ] time
! ? ms run time
MAIN: euler100

15
extra/project-euler/116/116.factor
View File

@ -1,7 +1,6 @@
! Copyright (c) 2008 Eric Mertens
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.ranges sequences sequences.lib ;
IN: project-euler.116
! http://projecteuler.net/index.php?section=problems&id=116
@ -24,6 +23,7 @@ IN: project-euler.116
! length be replaced if colours cannot be mixed and at least one coloured tile
! must be used?
! SOLUTION
! --------
@ -46,10 +46,15 @@ IN: project-euler.116
: ways ( length colortile -- permutations )
V{ 1 } clone [ [ next ] 2curry times ] keep peek 1- ;
PRIVATE>
: (euler116) ( length -- permutations )
3 [1,b] [ ways ] with sigma ;
: euler116 ( -- permutations )
PRIVATE>
: euler116 ( -- answer )
50 (euler116) ;
! [ euler116 ] 100 ave-time
! 0 ms run time - 100 trials
MAIN: euler116

19
extra/project-euler/117/117.factor
View File

@ -1,7 +1,6 @@
! Copyright (c) 2008 Eric Mertens
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order splitting sequences ;
USING: kernel math math.order sequences splitting ;
IN: project-euler.117
! http://projecteuler.net/index.php?section=problems&id=117
@ -14,7 +13,8 @@ IN: project-euler.117
! units, and blue tiles measuring four units, it is possible to tile a
! row measuring five units in length in exactly fifteen different ways.
! How many ways can a row measuring fifty units in length be tiled?
! How many ways can a row measuring fifty units in length be tiled?
! SOLUTION
! --------
@ -33,10 +33,15 @@ IN: project-euler.117
: next ( seq -- )
[ 4 short tail* sum ] keep push ;
PRIVATE>
: (euler117) ( n -- m )
V{ 1 } clone tuck [ next ] curry times peek ;
: euler117 ( -- m )
PRIVATE>
: euler117 ( -- answer )
50 (euler117) ;
! [ euler117 ] 100 ave-time
! 0 ms run time - 100 trials
MAIN: euler117

40
extra/project-euler/148/148.factor
View File

@ -1,9 +1,34 @@
! Copyright (c) 2008 Eric Mertens
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions sequences sequences.lib ;
IN: project-euler.148
! http://projecteuler.net/index.php?section=problems&id=148
! DESCRIPTION
! -----------
! We can easily verify that none of the entries in the first seven rows of
! Pascal's triangle are divisible by 7:
! 1
! 1 1
! 1 2 1
! 1 3 3 1
! 1 4 6 4 1
! 1 5 10 10 5 1
! 1 6 15 20 15 6 1
! However, if we check the first one hundred rows, we will find that only 2361
! of the 5050 entries are not divisible by 7.
! Find the number of entries which are not divisible by 7 in the first one
! billion (10^9) rows of Pascal's triangle.
! SOLUTION
! --------
<PRIVATE
: sum-1toN ( n -- sum )
@ -15,10 +40,15 @@ IN: project-euler.148
: (use-digit) ( prev x index -- next )
[ [ 1+ * ] [ sum-1toN 7 sum-1toN ] bi ] dip ^ * + ;
PRIVATE>
: (euler148) ( x -- y )
>base7 0 [ (use-digit) ] reduce-index ;
: euler148 ( -- y )
PRIVATE>
: euler148 ( -- answer )
10 9 ^ (euler148) ;
! [ euler148 ] 100 ave-time
! 0 ms run time - 100 trials
MAIN: euler148

44
extra/project-euler/150/150.factor
View File

@ -1,9 +1,33 @@
! Copyright (c) 2008 Eric Mertens
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order sequences sequences.private
locals hints ;
USING: hints kernel locals math math.order sequences sequences.private ;
IN: project-euler.150
! http://projecteuler.net/index.php?section=problems&id=150
! DESCRIPTION
! -----------
! In a triangular array of positive and negative integers, we wish to find a
! sub-triangle such that the sum of the numbers it contains is the smallest
! possible.
! In the example below, it can be easily verified that the marked triangle
! satisfies this condition having a sum of -42.
! We wish to make such a triangular array with one thousand rows, so we
! generate 500500 pseudo-random numbers sk in the range +/-2^19, using a type of
! random number generator (known as a Linear Congruential Generator) as
! follows:
! ...
! Find the smallest possible sub-triangle sum.
! SOLUTION
! --------
<PRIVATE
! sequence helper functions
@ -20,16 +44,13 @@ IN: project-euler.150
: map-infimum ( seq quot -- min )
[ min ] compose 0 swap reduce ; inline
! triangle generator functions
: next ( t -- new-t s )
615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
: sums-triangle ( -- seq )
0 1000 [ 1+ [ next ] replicate partial-sums ] map nip ;
PRIVATE>
0 1000 [ 1+ [ next ] replicate partial-sums ] map nip ;
:: (euler150) ( m -- n )
[let | table [ sums-triangle ] |
@ -46,5 +67,12 @@ PRIVATE>
HINTS: (euler150) fixnum ;
: euler150 ( -- n )
PRIVATE>
: euler150 ( -- answer )
1000 (euler150) ;
! [ euler150 ] 10 ave-time
! 32858 ms run time - 10 trials
MAIN: euler150

47
extra/project-euler/151/151.factor
View File

@ -1,9 +1,41 @@
! Copyright (c) 2008 Eric Mertens
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences combinators kernel sequences.lib math math.order
assocs namespaces ;
USING: assocs combinators kernel math math.order namespaces sequences
sequences.lib ;
IN: project-euler.151
! http://projecteuler.net/index.php?section=problems&id=151
! DESCRIPTION
! -----------
! A printing shop runs 16 batches (jobs) every week and each batch requires a
! sheet of special colour-proofing paper of size A5.
! Every Monday morning, the foreman opens a new envelope, containing a large
! sheet of the special paper with size A1.
! He proceeds to cut it in half, thus getting two sheets of size A2. Then he
! cuts one of them in half to get two sheets of size A3 and so on until he
! obtains the A5-size sheet needed for the first batch of the week.
! All the unused sheets are placed back in the envelope.
! At the beginning of each subsequent batch, he takes from the envelope one
! sheet of paper at random. If it is of size A5, he uses it. If it is larger,
! he repeats the 'cut-in-half' procedure until he has what he needs and any
! remaining sheets are always placed back in the envelope.
! Excluding the first and last batch of the week, find the expected number of
! times (during each week) that the foreman finds a single sheet of paper in
! the envelope.
! Give your answer rounded to six decimal places using the format x.xxxxxx .
! SOLUTION
! --------
SYMBOL: table
: (pick-sheet) ( seq i -- newseq )
@ -34,8 +66,15 @@ DEFER: (euler151)
[ [ dup length [ pick-sheet ] with map sum ] [ sum ] bi / ]
} case ] cache ;
: euler151 ( -- n )
: euler151 ( -- answer )
[
H{ } clone table set
{ 1 1 1 1 } (euler151)
] with-scope ;
! TODO: doesn't work currently, problem in area of 'with map' in (euler151)
! [ euler151 ] 100 ave-time
! ? ms run time - 100 trials
MAIN: euler151

11
extra/project-euler/164/164.factor
View File

@ -1,7 +1,6 @@
! Copyright (c) 2008 Eric Mertens
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math math.ranges sequences ;
IN: project-euler.164
! http://projecteuler.net/index.php?section=problems&id=164
@ -12,6 +11,7 @@ IN: project-euler.164
! How many 20 digit numbers n (without any leading zero) exist such
! that no three consecutive digits of n have a sum greater than 9?
! SOLUTION
! --------
@ -29,5 +29,10 @@ IN: project-euler.164
PRIVATE>
: euler164 ( -- n )
: euler164 ( -- answer )
init-table 19 [ next-table ] times values sum ;
! [ euler164 ] 100 ave-time
! 8 ms run time - 100 trials
MAIN: euler164

16
extra/project-euler/190/190.factor
View File

@ -1,13 +1,13 @@
! Copyright (c) 2008 Eric Mertens
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.lib math math.functions math.ranges locals ;
IN: project-euler.190
! PROBLEM
! -------
! http://projecteuler.net/index.php?section=problems&id=190
! DESCRIPTION
! -----------
! Let Sm = (x1, x2, ... , xm) be the m-tuple of positive real numbers
! with x1 + x2 + ... + xm = m for which Pm = x1 * x22 * ... * xmm is
! maximised.
@ -17,6 +17,7 @@ IN: project-euler.190
! Find Σ[Pm] for 2 ≤ m ≤ 15.
! SOLUTION
! --------
@ -44,5 +45,10 @@ PRIVATE>
:: P_m ( m -- P_m )
m [1,b] [| i | 2 i * m 1+ / i ^ ] PI ;
: euler190 ( -- n )
: euler190 ( -- answer )
2 15 [a,b] [ P_m truncate ] sigma ;
! [ euler150 ] 100 ave-time
! 7 ms run time - 100 trials
MAIN: euler190

25
extra/project-euler/ave-time/ave-time-docs.factor
View File

@ -1,22 +1,31 @@
USING: arrays help.markup help.syntax math memory quotations sequences system tools.time ;
USING: arrays help.markup help.syntax math math.parser memory quotations
sequences system tools.time ;
IN: project-euler.ave-time
HELP: collect-benchmarks
{ $values { "quot" quotation } { "n" integer } { "seq" sequence } }
{ $description "Runs a quotation " { $snippet "n" } " times, collecting the wall clock time and the time spent in the garbage collector into pairs inside of a sequence." }
{ $notes "The stack effect of " { $snippet "quot" } " is inferred and only one set of outputs will remain on the stack no matter how many trials are run."
{ $description "Runs a quotation " { $snippet "n" } " times, collecting the wall clock time inside of a sequence." }
{ $notes "The stack effect of " { $snippet "quot" } " is accounted for and only one set of outputs will remain on the stack no matter how many trials are run."
$nl
"A nicer word for interactive use is " { $link ave-time } "." } ;
HELP: nth-place
{ $values { "x" float } { "n" integer } { "y" float } }
{ $description "Rounds a floating point number to " { $snippet "n" } " decimal places." }
{ $examples
"This word is useful for display purposes when showing 15 decimal places is not desired:"
{ $unchecked-example "3.141592653589793 3 nth-place number>string" "\"3.142\"" }
} ;
HELP: ave-time
{ $values { "quot" quotation } { "n" integer } }
{ $description "Runs a quotation " { $snippet "n" } " times, then prints the average run time and the average time spent in the garbage collector." }
{ $notes "The stack effect of " { $snippet "quot" } " is inferred and only one set of outputs will remain on the stack no matter how many trials are run." }
{ $description "Runs a quotation " { $snippet "n" } " times, then prints the average run time and standard deviation." }
{ $notes "The stack effect of " { $snippet "quot" } " is accounted for and only one set of outputs will remain on the stack no matter how many trials are run." }
{ $examples
"This word can be used to compare performance of the non-optimizing and optimizing compilers."
$nl
"First, we time a quotation directly; quotations are compiled by the non-optimizing quotation compiler:"
{ $unchecked-example "[ 1000000 0 [ + ] reduce drop ] 10 ave-time" "1116 ms run time - 10 trials" }
"Now we define a word and compile it with the optimizing word compiler. This results is faster execution:"
{ $unchecked-example ": foo 1000000 0 [ + ] reduce ;" "\\ foo compile" "[ foo drop ] 10 ave-time" "202 ms run time - 10 trials" }
{ $unchecked-example "[ 1000000 0 [ + ] reduce drop ] 10 ave-time" "465 ms ave run time - 13.37 SD (10 trials)" }
"Now we define a word and compile it with the optimizing word compiler. This results in faster execution:"
{ $unchecked-example ": foo 1000000 0 [ + ] reduce ;" "\\ foo compile" "[ foo drop ] 10 ave-time" "202 ms ave run time - 22.73 SD (10 trials)" }
} ;

14
extra/project-euler/ave-time/ave-time.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators io kernel math math.functions math.parser
math.statistics namespaces sequences tools.time continuations ;
USING: continuations io kernel math math.functions math.parser math.statistics
namespaces tools.time ;
IN: project-euler.ave-time
: collect-benchmarks ( quot n -- seq )
@ -10,7 +10,11 @@ IN: project-euler.ave-time
[ with-datastack drop ] 2curry r> swap times call
] { } make ;
: nth-place ( x n -- y )
10 swap ^ [ * round ] keep / ;
: ave-time ( quot n -- )
[ collect-benchmarks ] keep swap mean round [
# " ms run time - " % # " trials" %
[ collect-benchmarks ] keep
swap [ std 2 nth-place ] [ mean round ] bi [
# " ms ave run time - " % # " SD (" % # " trials)" %
] "" make print flush ; inline

6
extra/project-euler/project-euler.factor
View File

@ -16,8 +16,10 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time
project-euler.045 project-euler.046 project-euler.047 project-euler.048
project-euler.052 project-euler.053 project-euler.056 project-euler.059
project-euler.067 project-euler.075 project-euler.079 project-euler.092
project-euler.097 project-euler.134 project-euler.169 project-euler.173
project-euler.175 combinators.short-circuit ;
project-euler.097 project-euler.100 project-euler.116 project-euler.117
project-euler.134 project-euler.148 project-euler.150 project-euler.151
project-euler.164 project-euler.169 project-euler.173 project-euler.175
project-euler.186 project-euler.190 ;
IN: project-euler
<PRIVATE

2
extra/webapps/wiki/view.xml
View File

@ -5,7 +5,7 @@
<t:title><t:label t:name="title" /></t:title>
<div class="description">
<t:farkup t:name="content" />
<t:html t:name="html" />
</div>
<p>

4
extra/webapps/wiki/wiki-common.xml
View File

@ -41,7 +41,7 @@
</t:a>
</h2>
<t:farkup t:name="content" />
<t:html t:name="html" />
</t:bind>
</td>
</t:if>
@ -52,7 +52,7 @@
<td>
<t:bind t:name="footer">
<small>
<t:farkup t:name="content" />
<t:html t:name="html" />
</small>
</t:bind>
</td>

12
extra/webapps/wiki/wiki.factor
View File

@ -3,7 +3,7 @@
USING: accessors kernel hashtables calendar random assocs
namespaces splitting sequences sorting math.order present
io.files io.encodings.ascii
syndication
syndication farkup
html.components html.forms
http.server
http.server.dispatchers
@ -47,7 +47,7 @@ article "ARTICLES" {
: <article> ( title -- article ) article new swap >>title ;
TUPLE: revision id title author date content description ;
TUPLE: revision id title author date content html description ;
revision "REVISIONS" {
{ "id" "ID" INTEGER +db-assigned-id+ }
@ -55,6 +55,7 @@ revision "REVISIONS" {
{ "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid
{ "date" "DATE" TIMESTAMP +not-null+ }
{ "content" "CONTENT" TEXT +not-null+ }
{ "html" "HTML" TEXT +not-null+ } ! Farkup converted to HTML
{ "description" "DESCRIPTION" TEXT }
} define-persistent
@ -71,6 +72,9 @@ M: revision feed-entry-url id>> revision-url ;
: <revision> ( id -- revision )
revision new swap >>id ;
: compute-html ( revision -- )
dup content>> convert-farkup >>html drop ;
: validate-title ( -- )
{ { "title" [ v-one-line ] } } validate-params ;
@ -144,11 +148,13 @@ M: revision feed-entry-url id>> revision-url ;
[ title>> ] [ id>> ] bi article boa insert-tuple ;
: add-revision ( revision -- )
[ compute-html ]
[ insert-tuple ]
[
dup title>> <article> select-tuple
[ amend-article ] [ add-article ] if*
] bi ;
]
tri ;
: <edit-article-action> ( -- action )
<page-action>

2
extra/websites/concatenative/concatenative.factor
View File

@ -4,6 +4,7 @@ USING: accessors kernel sequences assocs io.files io.sockets
io.sockets.secure io.servers.connection
namespaces db db.tuples db.sqlite smtp urls
logging.insomniac
html.templates.chloe
http.server
http.server.dispatchers
http.server.redirection
@ -68,6 +69,7 @@ SYMBOL: key-file
SYMBOL: dh-file
: common-configuration ( -- )
reset-templates
"concatenative.org" 25 <inet> smtp-server set-global
"noreply@concatenative.org" lost-password-from set-global
"website@concatenative.org" insomniac-sender set-global