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

db4
Joe Groff 2008-09-30 18:22:41 -07:00
commit 52a12c2387
546 changed files with 13192 additions and 3483 deletions

1
basis/alarms/summary.txt Normal file
View File

@ -0,0 +1 @@
One-time and recurring events

1
basis/alias/summary.txt Normal file
View File

@ -0,0 +1 @@
Defining multiple words with the same name

View File

@ -46,6 +46,6 @@ ARTICLE: "ascii" "ASCII character classes"
{ $subsection printable? }
{ $subsection control? }
{ $subsection quotable? }
"Modern applications should use Unicode 5.0 instead (" { $vocab-link "unicode" } ")." ;
"Modern applications should use Unicode 5.0 instead (" { $vocab-link "unicode.categories" } ")." ;
ABOUT: "ascii"

View File

@ -0,0 +1 @@
Fast searching of sorted arrays

View File

@ -26,7 +26,6 @@ IN: bootstrap.image
"x86.32"
"x86.64"
"linux-ppc" "macosx-ppc"
! "arm"
} ;
<PRIVATE
@ -412,14 +411,14 @@ M: quotation '
all-words [ emit-word ] each ;
: emit-global ( -- )
[
{
dictionary source-files builtins
update-map implementors-map class<=-cache
class-not-cache classes-intersect-cache class-and-cache
class-or-cache
} [ dup get swap bootstrap-word set ] each
] H{ } make-assoc
{
dictionary source-files builtins
update-map implementors-map
} [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
{
class<=-cache class-not-cache classes-intersect-cache
class-and-cache class-or-cache
} [ H{ } clone ] H{ } map>assoc assoc-union
bootstrap-global set
bootstrap-global emit-userenv ;

View File

@ -13,4 +13,4 @@ IN: bootstrap.random
[
[ 32 random-bits ] with-system-random
<mersenne-twister> random-generator set-global
] "generator.random" add-init-hook
] "bootstrap.random" add-init-hook

1
basis/boxes/summary.txt Normal file
View File

@ -0,0 +1 @@
An abstraction for enforcing a mutual-exclusion invariant

View File

@ -21,8 +21,8 @@ HELP: <date>
{ $description "Returns a timestamp object representing the start of the specified day in your current timezone." }
{ $examples
{ $example "USING: calendar prettyprint ;"
"2010 12 25 <date> ."
"T{ timestamp\n { year 2010 }\n { month 12 }\n { day 25 }\n { gmt-offset T{ duration { hour -5 } } }\n}"
"2010 12 25 <date> >gmt midnight ."
"T{ timestamp { year 2010 } { month 12 } { day 25 } }"
}
} ;

View File

@ -62,3 +62,15 @@ IN: calendar.format.tests
T{ duration f 0 0 0 -5 0 0 }
}
] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test
[
T{ timestamp
{ year 2008 }
{ month 10 }
{ day 2 }
{ hour 23 }
{ minute 59 }
{ second 59 }
{ gmt-offset T{ duration f 0 0 0 0 0 0 } }
}
] [ "Thursday, 02-Oct-2008 23:59:59 GMT" cookie-string>timestamp ] unit-test

View File

@ -201,9 +201,13 @@ ERROR: invalid-timestamp-format ;
: rfc822>timestamp ( str -- timestamp )
[ (rfc822>timestamp) ] with-string-reader ;
: check-day-name ( str -- )
[ day-abbreviations3 member? ] [ day-names member? ] bi or
check-timestamp drop ;
: (cookie-string>timestamp-1) ( -- timestamp )
timestamp new
"," read-token day-abbreviations3 member? check-timestamp drop
"," read-token check-day-name
read1 CHAR: \s assert=
"-" read-token checked-number >>day
"-" read-token month-abbreviations index 1+ check-timestamp >>month
@ -218,7 +222,7 @@ ERROR: invalid-timestamp-format ;
: (cookie-string>timestamp-2) ( -- timestamp )
timestamp new
read-sp day-abbreviations3 member? check-timestamp drop
read-sp check-day-name
read-sp month-abbreviations index 1+ check-timestamp >>month
read-sp checked-number >>day
":" read-token checked-number >>hour

View File

@ -33,3 +33,14 @@ HELP: from
" It will block the calling thread until there is data in the channel."
}
{ $see-also <channel> to } ;
ARTICLE: "channels" "Channels"
"The " { $vocab-link "channels" } " vocabulary provides a simple abstraction to send and receive objects." $nl
"Opening a channel:"
{ $subsection <channel> }
"Sending a message:"
{ $subsection to }
"Receiving a message:"
{ $subsection from } ;
ABOUT: "channels"

View File

@ -1 +1 @@
extensions
concurrency

View File

@ -1 +1 @@
extensions
concurrency

View File

@ -0,0 +1,58 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string sequences
math kernel ;
IN: circular
HELP: <circular-string>
{ $values
{ "n" integer }
{ "circular" circular } }
{ $description "Creates a new circular string object. A circular string is a string object that can be accessed out of bounds and the index will wrap around to the start of the string." } ;
HELP: <circular>
{ $values
{ "seq" sequence }
{ "circular" circular } }
{ $description "Creates a new " { $link circular } " object that wraps an existing sequence. By default, the index is set to zero." } ;
HELP: <growing-circular>
{ $values
{ "capacity" integer }
{ "growing-circular" growing-circular } }
{ $description "Creates a new growing-circular object." } ;
HELP: change-circular-start
{ $values
{ "n" integer } { "circular" circular } }
{ $description "Changes the start index of a circular object." } ;
HELP: circular
{ $description "A tuple class that stores a sequence and its start index." } ;
HELP: growing-circular
{ $description "A circular sequence that is growable." } ;
HELP: push-circular
{ $values
{ "elt" object } { "circular" circular } }
{ $description "Pushes an element to a " { $link circular } " object." } ;
HELP: push-growing-circular
{ $values
{ "elt" object } { "circular" circular } }
{ $description "Pushes an element onto a " { $link growing-circular } " object." } ;
ARTICLE: "circular" "Circular sequences"
"The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl
"Creating a new circular object:"
{ $subsection <circular> }
{ $subsection <circular-string> }
{ $subsection <growing-circular> }
"Changing the start index:"
{ $subsection change-circular-start }
"Pushing new elements:"
{ $subsection push-circular }
{ $subsection push-growing-circular } ;
ABOUT: "circular"

View File

@ -11,9 +11,11 @@ TUPLE: circular seq start ;
: <circular> ( seq -- circular )
0 circular boa ;
<PRIVATE
: circular-wrap ( n circular -- n circular )
[ start>> + ] keep
[ seq>> length rem ] keep ; inline
PRIVATE>
M: circular length seq>> length ;
@ -37,11 +39,13 @@ TUPLE: growing-circular < circular length ;
M: growing-circular length length>> ;
<PRIVATE
: full? ( circular -- ? )
[ length ] [ seq>> length ] bi = ;
: set-peek ( elt seq -- )
[ length 1- ] keep set-nth ;
PRIVATE>
: push-growing-circular ( elt circular -- )
dup full? [ push-circular ]

View File

@ -19,7 +19,7 @@ HELP: SUPER->
ARTICLE: "objc-calling" "Calling Objective C code"
"Before an Objective C class can be used, it must be imported; by default, a small set of common classes are imported automatically, but additional classes can be imported as needed."
{ $subsection import-objc-class }
"Every imported Objective C class has as corresponding class word in the " { $vocab-link "objc-classes" } " vocabulary. Class words push the class object in the stack, allowing class methods to be invoked."
"Every imported Objective C class has as corresponding class word in the " { $vocab-link "cocoa.classes" } " vocabulary. Class words push the class object in the stack, allowing class methods to be invoked."
$nl
"Messages can be sent to classes and instances using a pair of parsing words:"
{ $subsection POSTPONE: -> }

1
basis/colors/summary.txt Normal file
View File

@ -0,0 +1 @@
Colors as a first-class data type

View File

@ -1,13 +1,6 @@
USING: help.markup help.syntax sequences ;
IN: columns
ARTICLE: "columns" "Column sequences"
"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:"
{ $subsection column }
{ $subsection <column> }
"A utility word:"
{ $subsection <flipped> } ;
HELP: column
{ $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link <column> } "." } ;
@ -30,4 +23,11 @@ HELP: <flipped>
{ $description "Outputs a new virtual sequence which presents the transpose of " { $snippet "seq" } "." }
{ $notes "This is the virtual sequence equivalent of " { $link flip } "." } ;
ARTICLE: "columns" "Column sequences"
"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:"
{ $subsection column }
{ $subsection <column> }
"A utility word:"
{ $subsection <flipped> } ;
ABOUT: "columns"

View File

@ -0,0 +1,84 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string quotations
math ;
IN: combinators.short-circuit
HELP: 0&&
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if every quotation in the sequence of quotations returns true." } ;
HELP: 0||
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if any quotation in the sequence returns true." } ;
HELP: 1&&
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same element from the datastack and must output a boolean." } ;
HELP: 1||
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same element from the datastack and must return a boolean." } ;
HELP: 2&&
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same two elements from the datastack and must output a boolean." } ;
HELP: 2||
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same two elements from the datastack and must return a boolean." } ;
HELP: 3&&
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same three elements from the datastack and must output a boolean." } ;
HELP: 3||
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ;
HELP: n&&-rewrite
{ $values
{ "quots" "a sequence of quotations" } { "N" integer }
{ "quot" quotation } }
{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each AND quotation." } ;
HELP: n||-rewrite
{ $values
{ "quots" "a sequence of quotations" } { "N" integer }
{ "quot" quotation } }
{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each OR quotation." } ;
ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
"The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl
"AND combinators:"
{ $subsection 0&& }
{ $subsection 1&& }
{ $subsection 2&& }
{ $subsection 3&& }
"OR combinators:"
{ $subsection 0|| }
{ $subsection 1|| }
{ $subsection 2|| }
{ $subsection 3|| }
"Generalized combinators:"
{ $subsection n&&-rewrite }
{ $subsection n||-rewrite }
;
ABOUT: "combinators.short-circuit"

View File

@ -0,0 +1,38 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string quotations ;
IN: combinators.short-circuit.smart
HELP: &&
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Infers the number of arguments that each quotation takes from the stack. Eacn quotation must take the same number of arguments. Returns true if every quotation yields true, and stops early if one yields false." }
{ $examples "Smart combinators will infer the two inputs:"
{ $example "USING: prettyprint kernel math combinators.short-circuit.smart ;"
"2 3 { [ + 5 = ] [ - -1 = ] } && ."
"t"
}
} ;
HELP: ||
{ $values
{ "quots" "a sequence of quotations" }
{ "quot" quotation } }
{ $description "Infers the number of arguments that each quotation takes from the stack. Eacn quotation must take the same number of arguments. Returns true if any quotation yields true, and stops early when one yields true." }
{ $examples "Smart combinators will infer the two inputs:"
{ $example "USING: prettyprint kernel math combinators.short-circuit.smart ;"
"2 3 { [ - 1 = ] [ + 5 = ] } || ."
"t"
}
} ;
ARTICLE: "combinators.short-circuit.smart" "Smart short-circuit combinators"
"The " { $vocab-link "combinators.short-circuit.smart" } " vocabulary is similar to " { $vocab-link "combinators.short-circuit" } " except the combinators here infer the number of inputs that the sequence of quotations takes."
$nl
"Generalized AND:"
{ $subsection && }
"Generalized OR:"
{ $subsection || } ;
ABOUT: "combinators.short-circuit.smart"

View File

@ -1,6 +1,43 @@
USING: help.markup help.syntax parser vocabs.loader strings ;
IN: command-line
HELP: run-bootstrap-init
{ $description "Runs the " { $snippet ".factor-boot-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
HELP: run-user-init
{ $description "Runs the " { $snippet ".factor-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
HELP: cli-param
{ $values { "param" string } }
{ $description "Process a command-line switch."
$nl
"If the parameter contains " { $snippet "=" } ", the global variable named by the string before the equals sign is set to the string after the equals sign."
$nl
"If the parameter begins with " { $snippet "no-" } ", sets the global variable named by the parameter with the prefix removed to " { $link f } "."
$nl
"Otherwise, sets the global variable named by the parameter to " { $link t } "." } ;
HELP: cli-args
{ $values { "args" "a sequence of strings" } }
{ $description "Outputs the command line parameters which were passed to the Factor VM on startup." } ;
HELP: main-vocab-hook
{ $var-description "Global variable holding a quotation which outputs a vocabulary name. UI backends set this so that the UI can automatically start if the prerequisites are met (for example, " { $snippet "$DISPLAY" } " being set on X11)." } ;
HELP: main-vocab
{ $values { "vocab" string } }
{ $description "Outputs the name of the vocabulary which is to be run on startup using the " { $link run } " word. The " { $snippet "-run" } " command line switch overrides this setting." } ;
HELP: default-cli-args
{ $description "Sets global variables corresponding to default command line arguments." } ;
HELP: ignore-cli-args?
{ $values { "?" "a boolean" } }
{ $description "On Mac OS X, source files to run are supplied by the Cocoa API, so to avoid running them twice the startup code has to call this word." } ;
HELP: parse-command-line
{ $description "Called on startup to process command line arguments. This sets global variables with " { $link cli-param } ", runs source files, and evaluates the string given by the " { $snippet "-e" } " switch, if there is one." } ;
ARTICLE: "runtime-cli-args" "Command line switches for the VM"
"A handful of command line switches are processed by the VM and not the library. They control low-level features."
{ $table
@ -77,40 +114,3 @@ $nl
{ $subsection main-vocab-hook } ;
ABOUT: "cli"
HELP: run-bootstrap-init
{ $description "Runs the " { $snippet ".factor-boot-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
HELP: run-user-init
{ $description "Runs the " { $snippet ".factor-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
HELP: cli-param
{ $values { "param" string } }
{ $description "Process a command-line switch."
$nl
"If the parameter contains " { $snippet "=" } ", the global variable named by the string before the equals sign is set to the string after the equals sign."
$nl
"If the parameter begins with " { $snippet "no-" } ", sets the global variable named by the parameter with the prefix removed to " { $link f } "."
$nl
"Otherwise, sets the global variable named by the parameter to " { $link t } "." } ;
HELP: cli-args
{ $values { "args" "a sequence of strings" } }
{ $description "Outputs the command line parameters which were passed to the Factor VM on startup." } ;
HELP: main-vocab-hook
{ $var-description "Global variable holding a quotation which outputs a vocabulary name. UI backends set this so that the UI can automatically start if the prerequisites are met (for example, " { $snippet "$DISPLAY" } " being set on X11)." } ;
HELP: main-vocab
{ $values { "vocab" string } }
{ $description "Outputs the name of the vocabulary which is to be run on startup using the " { $link run } " word. The " { $snippet "-run" } " command line switch overrides this setting." } ;
HELP: default-cli-args
{ $description "Sets global variables corresponding to default command line arguments." } ;
HELP: ignore-cli-args?
{ $values { "?" "a boolean" } }
{ $description "On Mac OS X, source files to run are supplied by the Cocoa API, so to avoid running them twice the startup code has to call this word." } ;
HELP: parse-command-line
{ $description "Called on startup to process command line arguments. This sets global variables with " { $link cli-param } ", runs source files, and evaluates the string given by the " { $snippet "-e" } " switch, if there is one." } ;

View File

@ -23,3 +23,30 @@ IN: compiler.constants
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
: compiled-header-size ( -- n ) 4 bootstrap-cells ;
! Relocation classes
: rc-absolute-cell 0 ;
: rc-absolute 1 ;
: rc-relative 2 ;
: rc-absolute-ppc-2/2 3 ;
: rc-relative-ppc-2 4 ;
: rc-relative-ppc-3 5 ;
: rc-relative-arm-3 6 ;
: rc-indirect-arm 7 ;
: rc-indirect-arm-pc 8 ;
! Relocation types
: rt-primitive 0 ;
: rt-dlsym 1 ;
: rt-literal 2 ;
: rt-dispatch 3 ;
: rt-xt 4 ;
: rt-here 5 ;
: rt-label 6 ;
: rt-immediate 7 ;
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]
[ rc-absolute-cell = ]
[ rc-absolute = ]
tri or or ;

View File

@ -4,7 +4,7 @@ kernel vectors arrays effects sequences ;
IN: compiler.generator
ARTICLE: "generator" "Compiled code generator"
"Most of the words in the " { $vocab-link "generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
"Most of the words in the " { $vocab-link "compiler.generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
$nl
"Debugging information can be enabled or disabled; this hook is used by " { $link "tools.deploy" } ":"
{ $subsection compiled-stack-traces? }

View File

@ -4,20 +4,42 @@ USING: kernel classes.tuple classes.tuple.private math arrays
byte-arrays words stack-checker.known-words ;
IN: compiler.intrinsics
: (tuple) ( layout -- tuple )
"BUG: missing (tuple) intrinsic" throw ;
ERROR: missing-intrinsic ;
: (tuple) ( n -- tuple ) missing-intrinsic ;
\ (tuple) { tuple-layout } { tuple } define-primitive
\ (tuple) make-flushable
: (array) ( n -- array )
"BUG: missing (array) intrinsic" throw ;
: (array) ( n -- array ) missing-intrinsic ;
\ (array) { integer } { array } define-primitive
\ (array) make-flushable
: (byte-array) ( n -- byte-array )
"BUG: missing (byte-array) intrinsic" throw ;
: (byte-array) ( n -- byte-array ) missing-intrinsic ;
\ (byte-array) { integer } { byte-array } define-primitive
\ (byte-array) make-flushable
: (ratio) ( -- ratio ) missing-intrinsic ;
\ (ratio) { } { ratio } define-primitive
\ (ratio) make-flushable
: (complex) ( -- complex ) missing-intrinsic ;
\ (complex) { } { complex } define-primitive
\ (complex) make-flushable
: (wrapper) ( -- wrapper ) missing-intrinsic ;
\ (wrapper) { } { wrapper } define-primitive
\ (wrapper) make-flushable
: (set-slot) ( val obj n -- ) missing-intrinsic ;
\ (set-slot) { object object fixnum } { } define-primitive
: (write-barrier) ( obj -- ) missing-intrinsic ;
\ (write-barrier) { object } { } define-primitive

View File

@ -298,6 +298,12 @@ SYMBOL: value-infos
: node-output-infos ( node -- seq )
dup out-d>> [ node-value-info ] with map ;
: first-literal ( #call -- obj )
dup in-d>> first node-value-info literal>> ;
: last-literal ( #call -- obj )
dup out-d>> peek node-value-info literal>> ;
: immutable-tuple-boa? ( #call -- ? )
dup word>> \ <tuple-boa> eq? [
dup in-d>> peek node-value-info

View File

@ -4,8 +4,10 @@ USING: concurrency.futures concurrency.count-downs sequences
kernel ;
IN: concurrency.combinators
<PRIVATE
: (parallel-each) ( n quot -- )
>r <count-down> r> keep await ; inline
PRIVATE>
: parallel-each ( seq quot -- )
over length [
@ -20,7 +22,9 @@ IN: concurrency.combinators
: parallel-filter ( seq quot -- newseq )
over >r pusher >r each r> r> like ; inline
<PRIVATE
: future-values dup [ ?future ] change-each ; inline
PRIVATE>
: parallel-map ( seq quot -- newseq )
[ curry future ] curry map future-values ;

View File

@ -0,0 +1 @@
concurrency

View File

@ -0,0 +1 @@
concurrency

View File

@ -11,14 +11,18 @@ TUPLE: count-down n promise ;
: count-down-check ( count-down -- )
dup n>> zero? [ t swap promise>> fulfill ] [ drop ] if ;
ERROR: invalid-count-down-count count ;
: <count-down> ( n -- count-down )
dup 0 < [ "Invalid count for count down" throw ] when
dup 0 < [ invalid-count-down-count ] when
<promise> \ count-down boa
dup count-down-check ;
ERROR: count-down-already-done ;
: count-down ( count-down -- )
dup n>> dup zero?
[ "Count down already done" throw ]
[ count-down-already-done ]
[ 1- >>n count-down-check ] if ;
: await-timeout ( count-down timeout -- )

View File

@ -0,0 +1 @@
concurrency

View File

@ -1,2 +1,2 @@
concurrency
enterprise
extensions

View File

@ -0,0 +1 @@
concurrency

View File

@ -0,0 +1 @@
concurrency

View File

@ -0,0 +1 @@
concurrency

View File

@ -0,0 +1 @@
concurrency

View File

@ -0,0 +1 @@
concurrency

View File

@ -4,7 +4,7 @@
! Concurrency library for Factor, based on Erlang/Termite style
! concurrency.
USING: kernel threads concurrency.mailboxes continuations
namespaces assocs random accessors ;
namespaces assocs random accessors summary ;
IN: concurrency.messaging
GENERIC: send ( message thread -- )
@ -52,9 +52,14 @@ TUPLE: reply data tag ;
[ >r tag>> r> tag>> = ]
[ 2drop f ] if ;
ERROR: cannot-send-synchronous-to-self message thread ;
M: cannot-send-synchronous-to-self summary
drop "Cannot synchronous send to myself" ;
: send-synchronous ( message thread -- reply )
dup self eq? [
"Cannot synchronous send to myself" throw
cannot-send-synchronous-to-self
] [
>r <synchronous> dup r> send
[ synchronous-reply? ] curry receive-if

View File

@ -0,0 +1 @@
concurrency

View File

@ -11,9 +11,10 @@ TUPLE: promise mailbox ;
: promise-fulfilled? ( promise -- ? )
mailbox>> mailbox-empty? not ;
ERROR: promise-already-fulfilled promise ;
: fulfill ( value promise -- )
dup promise-fulfilled? [
"Promise already fulfilled" throw
promise-already-fulfilled
] [
mailbox>> mailbox-put
] if ;

View File

@ -0,0 +1 @@
concurrency

View File

@ -0,0 +1 @@
concurrency

View File

@ -3,13 +3,10 @@
USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences namespaces make assocs init accessors
continuations combinators core-foundation
core-foundation.run-loop io.encodings.utf8 destructors ;
core-foundation.run-loop core-foundation.run-loop.thread
io.encodings.utf8 destructors ;
IN: core-foundation.fsevents
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! FSEventStream API, Leopard only !
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
: kFSEventStreamCreateFlagUseCFTypes 2 ; inline
: kFSEventStreamCreateFlagWatchRoot 4 ; inline

View File

@ -35,5 +35,3 @@ FUNCTION: SInt32 CFRunLoopRunInMode (
: start-run-loop-thread ( -- )
[ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
[ start-run-loop-thread ] "core-foundation.run-loop" add-init-hook

View File

@ -0,0 +1,8 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: init core-foundation.run-loop ;
IN: core-foundation.run-loop.thread
! Load this vocabulary if you need a run loop running.
[ start-run-loop-thread ] "core-foundation.run-loop.thread" add-init-hook

View File

@ -1,7 +1,7 @@
! 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 ;
alien assocs strings math multiline quotations ;
IN: db
HELP: db
@ -45,7 +45,22 @@ HELP: prepared-statement
{ $description } ;
HELP: result-set
{ $description } ;
{ $description "An object encapsulating a raw SQL result object. There are two ways in which a result set can be accessed, but they are specific to the database backend in use."
{ $subsection "db-random-access-result-set" }
{ $subsection "db-sequential-result-set" }
} ;
HELP: init-result-set
{ $values
{ "result-set" result-set } }
{ $description "" } ;
HELP: new-result-set
{ $values
{ "query" "a query" } { "handle" alien } { "class" class }
{ "result-set" result-set } }
{ $description "Creates a new " { $link result-set } " object of type " { $snippet "class" } "." } ;
HELP: new-statement
{ $values { "sql" string } { "in" sequence } { "out" sequence } { "class" class } { "statement" statement } }
@ -81,7 +96,7 @@ HELP: query-results
{ $values { "query" object }
{ "result-set" result-set }
}
{ $description "" } ;
{ $description "Returns a " { $link result-set } " object representing the reults of a SQL query." } ;
HELP: #rows
{ $values { "result-set" result-set } { "n" integer } }
@ -95,36 +110,126 @@ HELP: row-column
{ $values { "result-set" result-set } { "column" integer }
{ "obj" object }
}
{ $description "" } ;
{ $description "Returns the value indexed by " { $snippet "column" } " in the current row of a " { $link result-set } "." } ;
HELP: row-column-typed
{ $values { "result-set" result-set } { "column" integer }
{ "sql" "sql" } }
{ $description "" } ;
{ $description "Returns the value indexed by " { $snippet "column" } " in the current row of a " { $link result-set } " and converts the result based on a type stored in the " { $link result-set } "'s " { $slot "out-params" } "." } ;
HELP: advance-row
{ $values { "result-set" result-set } }
;
{ $description "Advanced the pointer to an underlying SQL result set stored in a " { $link result-set } " object." } ;
HELP: more-rows?
{ $values { "result-set" result-set } { "?" "a boolean" } }
;
{ $description "Returns true if the " { $link result-set } " has more rows to traverse." } ;
HELP: execute-statement*
{ $values { "statement" statement } { "type" object } }
{ $description } ;
HELP: execute-one-statement
{ $values
{ "statement" null } }
{ $description "" } ;
HELP: execute-statement
{ $values { "statement" statement } }
{ $description } ;
{ $description "" } ;
ARTICLE: "db" "Low-level database library"
HELP: begin-transaction
{ $description "Begins a new transaction. User code should make use of the " { $link with-transaction } " combinator." } ;
HELP: bind-statement
{ $values
{ "obj" object } { "statement" null } }
{ $description "" } ;
HELP: commit-transaction
{ $description "Commits a transaction. User code should make use of the " { $link with-transaction } " combinator." } ;
HELP: default-query
{ $values
{ "query" null }
{ "result-set" null } }
{ $description "" } ;
HELP: in-transaction
{ $description "A variable that is set true when a transaction is in progress." } ;
HELP: in-transaction?
{ $values
{ "?" "a boolean" } }
{ $description "Returns true if there is currently a transaction in progress in this scope." } ;
HELP: query-each
{ $values
{ "statement" null } { "quot" quotation } }
{ $description "" } ;
HELP: query-map
{ $values
{ "statement" null } { "quot" quotation }
{ "seq" sequence } }
{ $description "" } ;
HELP: rollback-transaction
{ $description "Rolls back a transaction; no data is committed to the database. User code should make use of the " { $link with-transaction } " combinator." } ;
HELP: sql-command
{ $values
{ "sql" string } }
{ $description "Executes a SQL string using the databse in the " { $link db } " symbol." } ;
HELP: sql-query
{ $values
{ "sql" string }
{ "rows" "an array of arrays of strings" } }
{ $description "Runs a SQL query of raw text in the database in the " { $link db } " symbol. Each row is returned as an array of strings; no type-conversions are done on the resulting data." } ;
{ sql-command sql-query } related-words
HELP: sql-row
{ $values
{ "result-set" result-set }
{ "seq" sequence } }
{ $description "Returns the current row in a " { $link result-set } " as an array of strings." } ;
HELP: sql-row-typed
{ $values
{ "result-set" result-set }
{ "seq" sequence } }
{ $description "Returns the current row in a " { $link result-set } " as an array of typed Factor objects." } ;
{ sql-row sql-row-typed } related-words
HELP: with-db
{ $values
{ "seq" sequence } { "class" class } { "quot" quotation } }
{ $description "Calls the quotation with a database bound to the " { $link db } " symbol. The database called is based on the " { $snippet "class" } " with the " } ;
HELP: with-transaction
{ $values
{ "quot" quotation } }
{ $description "" } ;
ARTICLE: "db" "Database library"
{ $subsection "db-custom-database-combinators" }
{ $subsection "db-protocol" }
{ $subsection "db-result-sets" }
{ $subsection "db-lowlevel-tutorial" }
"Higher-level database:"
{ $vocab-subsection "Database types" "db.types" }
{ $vocab-subsection "High-level tuple/database integration" "db.tuples" }
! { $subsection "db-tuples" }
! { $subsection "db-tuples-protocol" }
! { $subsection "db-tuples-tutorial" }
"Supported database backends:"
{ $vocab-subsection "SQLite" "db.sqlite" }
{ $vocab-subsection "PostgreSQL" "db.postgresql" }
@ -132,6 +237,40 @@ ARTICLE: "db" "Low-level database library"
{ $subsection "db-porting-the-library" }
;
ARTICLE: "db-random-access-result-set" "Random access result sets"
"Random-access result sets do not have to be traversed in order. For instance, PostgreSQL's result set object can be accessed as a matrix with i,j coordinates."
$nl
"Databases which work in this way must provide methods for the following traversal words:"
{ $subsection #rows }
{ $subsection #columns }
{ $subsection row-column }
{ $subsection row-column-typed } ;
ARTICLE: "db-sequential-result-set" "Sequential result sets"
"Sequential result sets can be iterated one element after the next. SQLite's result sets offer this method of traversal."
$nl
"Databases which work in this way must provide methods for the following traversal words:"
{ $subsection more-rows? }
{ $subsection advance-row }
{ $subsection row-column }
{ $subsection row-column-typed } ;
ARTICLE: "db-result-sets" "Result sets"
"Result sets are the encapsulated, database-specific results from a SQL query."
$nl
"Two possible protocols for iterating over result sets exist:"
{ $subsection "db-random-access-result-set" }
{ $subsection "db-sequential-result-set" }
"Query the number of rows or columns:"
{ $subsection #rows }
{ $subsection #columns }
"Traversing a result set:"
{ $subsection advance-row }
{ $subsection more-rows? }
"Pulling out a single row of results:"
{ $subsection row-column }
{ $subsection row-column-typed } ;
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."
;
@ -144,7 +283,6 @@ 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
@ -155,7 +293,6 @@ USING: db.sqlite db io.files ;
{ "my-database.db" temp-file } sqlite-db rot with-db ;
"> }
;
ABOUT: "db"

View File

@ -80,11 +80,14 @@ GENERIC: execute-statement* ( statement type -- )
M: object execute-statement* ( statement type -- )
drop query-results dispose ;
: execute-one-statement ( statement -- )
dup type>> execute-statement* ;
: execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each
[ execute-one-statement ] each
] [
dup type>> execute-statement*
execute-one-statement
] if ;
: bind-statement ( obj statement -- )

View File

@ -5,7 +5,7 @@ kernel math math.parser namespaces make prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators classes locals words tools.walker
nmake accessors random db.queries destructors ;
nmake accessors random db.queries destructors db.tuples.private ;
USE: tools.walker
IN: db.postgresql
@ -37,8 +37,7 @@ M: postgresql-db db-open ( db -- db )
M: postgresql-db dispose ( db -- )
handle>> PQfinish ;
M: postgresql-statement bind-statement* ( statement -- )
drop ;
M: postgresql-statement bind-statement* ( statement -- ) drop ;
GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding )
@ -67,11 +66,11 @@ M: postgresql-result-set #columns ( result-set -- n )
[ handle>> ] [ n>> ] bi ;
M: postgresql-result-set row-column ( result-set column -- object )
>r result-handle-n r> pq-get-string ;
[ result-handle-n ] dip pq-get-string ;
M: postgresql-result-set row-column-typed ( result-set column -- object )
dup pick out-params>> nth type>>
>r >r result-handle-n r> r> postgresql-column-typed ;
[ result-handle-n ] 2dip postgresql-column-typed ;
M: postgresql-statement query-results ( query -- result-set )
dup bind-params>> [
@ -126,13 +125,20 @@ M: postgresql-db bind# ( spec object -- )
: create-table-sql ( class -- statement )
[
dupd
"create table " 0% 0%
"(" 0% [ ", " 0% ] [
dup column-name>> 0%
" " 0%
dup type>> lookup-create-type 0%
modifiers 0%
] interleave ");" 0%
] interleave
", " 0%
find-primary-key
"primary key(" 0%
[ "," 0% ] [ column-name>> 0% ] interleave
"));" 0%
] query-make ;
: create-function-sql ( class -- statement )
@ -160,8 +166,7 @@ M: postgresql-db bind# ( spec object -- )
M: postgresql-db create-sql-statement ( class -- seq )
[
[ create-table-sql , ] keep
dup db-columns find-primary-key db-assigned-id-spec?
[ create-function-sql , ] [ drop ] if
dup db-assigned? [ create-function-sql , ] [ drop ] if
] { } make ;
: drop-function-sql ( class -- statement )
@ -181,15 +186,14 @@ M: postgresql-db create-sql-statement ( class -- seq )
M: postgresql-db drop-sql-statement ( class -- seq )
[
[ drop-table-sql , ] keep
dup db-columns find-primary-key db-assigned-id-spec?
[ drop-function-sql , ] [ drop ] if
dup db-assigned? [ drop-function-sql , ] [ drop ] if
] { } make ;
M: postgresql-db <insert-db-assigned-statement> ( class -- statement )
[
"select add_" 0% 0%
"(" 0%
dup find-primary-key 2,
dup find-primary-key first 2,
remove-id
[ ", " 0% ] [ bind% ] interleave
");" 0%
@ -218,14 +222,23 @@ M: postgresql-db <insert-user-assigned-statement> ( class -- statement )
");" 0%
] query-make ;
M: postgresql-db insert-tuple* ( tuple statement -- )
M: postgresql-db insert-tuple-set-key ( tuple statement -- )
query-modify-tuple ;
M: postgresql-db persistent-table ( -- hashtable )
H{
{ +db-assigned-id+ { "integer" "serial primary key" f } }
{ +user-assigned-id+ { f f "primary key" } }
{ +random-id+ { "bigint" "bigint primary key" f } }
{ +db-assigned-id+ { "integer" "serial" f } }
{ +user-assigned-id+ { f f f } }
{ +random-id+ { "bigint" "bigint" f } }
{ +foreign-id+ { f f "references" } }
{ +on-delete+ { f f "on delete" } }
{ +restrict+ { f f "restrict" } }
{ +cascade+ { f f "cascade" } }
{ +set-null+ { f f "set null" } }
{ +set-default+ { f f "set default" } }
{ TEXT { "text" "text" f } }
{ VARCHAR { "varchar" "varchar" f } }
{ INTEGER { "integer" "integer" f } }
@ -240,7 +253,6 @@ M: postgresql-db persistent-table ( -- hashtable )
{ BLOB { "bytea" "bytea" f } }
{ FACTOR-BLOB { "bytea" "bytea" f } }
{ URL { "varchar" "varchar" f } }
{ +foreign-id+ { f f "references" } }
{ +autoincrement+ { f f "autoincrement" } }
{ +unique+ { f f "unique" } }
{ +default+ { f f "default" } }
@ -256,10 +268,6 @@ M: postgresql-db compound ( string object -- string' )
over {
{ "default" [ first number>string join-space ] }
{ "varchar" [ first number>string paren append ] }
{ "references" [
first2 >r [ unparse join-space ] keep db-columns r>
swap [ slot-name>> = ] with find nip
column-name>> paren append
] }
{ "references" [ >reference-string ] }
[ drop no-compound-found ]
} case ;

View File

@ -3,7 +3,7 @@
USING: accessors kernel math namespaces make sequences random
strings math.parser math.intervals combinators math.bitwise
nmake db db.tuples db.types db.sql classes words shuffle arrays
destructors continuations ;
destructors continuations db.tuples.private ;
IN: db.queries
GENERIC: where ( specs obj -- )
@ -46,13 +46,18 @@ M: retryable execute-statement* ( statement type -- )
[ db-columns ] [ db-table ] bi ;
: query-make ( class quot -- )
>r sql-props r>
[ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake
[ sql-props ] dip
[ 0 sql-counter rot with-variable ] curry
{ "" { } { } } nmake
<simple-statement> maybe-make-retryable ; inline
: where-primary-key% ( specs -- )
" where " 0%
find-primary-key dup column-name>> 0% " = " 0% bind% ;
find-primary-key [
" and " 0%
] [
dup column-name>> 0% " = " 0% bind%
] interleave ;
M: db <update-tuple-statement> ( class -- statement )
[
@ -121,16 +126,15 @@ M: string where ( spec obj -- ) object-where ;
dup double-infinite-interval? [ drop f ] when
] with filter ;
: where-clause ( tuple specs -- )
dupd filter-slots [
drop
: many-where ( tuple seq -- )
" where " 0% [
" and " 0%
] [
" where " 0% [
" and " 0%
] [
2dup slot-name>> swap get-slot-named where
] interleave drop
] if-empty ;
2dup slot-name>> swap get-slot-named where
] interleave drop ;
: where-clause ( tuple specs -- )
dupd filter-slots [ drop ] [ many-where ] if-empty ;
M: db <delete-tuples-statement> ( tuple table -- sql )
[
@ -168,7 +172,7 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
number>string " limit " swap 3append
] curry change-sql drop ;
: make-query ( tuple query -- tuple' )
: make-query* ( tuple query -- tuple' )
dupd
{
[ group>> [ drop ] [ do-group ] if-empty ]
@ -177,8 +181,9 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
[ offset>> [ do-offset ] [ drop ] if* ]
} 2cleave ;
M: db <query> ( tuple class query -- tuple )
[ <select-by-slots-statement> ] dip make-query ;
M: db query>statement ( query -- tuple )
[ tuple>> dup class ] keep
[ <select-by-slots-statement> ] dip make-query* ;
! select ID, NAME, SCORE from EXAM limit 1 offset 3
@ -194,11 +199,10 @@ M: db <query> ( tuple class query -- tuple )
>r >r parse-sql 4drop r> r>
<simple-statement> maybe-make-retryable do-select ;
M: db <count-statement> ( tuple class groups -- statement )
\ query new
swap >>group
M: db <count-statement> ( query -- statement )
[ tuple>> dup class ] keep
[ [ "select count(*) from " 0% 0% where-clause ] query-make ]
dip make-query ;
dip make-query* ;
: create-index ( index-name table-name columns -- )
[

View File

@ -5,7 +5,7 @@ io.files kernel math math.parser namespaces prettyprint
sequences strings classes.tuple alien.c-types continuations
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
math.intervals io nmake accessors vectors math.ranges random
math.bitwise db.queries destructors ;
math.bitwise db.queries destructors db.tuples.private ;
IN: db.sqlite
TUPLE: sqlite-db < db path ;
@ -88,7 +88,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- )
db get handle>> sqlite3_last_insert_rowid
dup zero? [ "last-id failed" throw ] when ;
M: sqlite-db insert-tuple* ( tuple statement -- )
M: sqlite-db insert-tuple-set-key ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ;
M: sqlite-result-set #columns ( result-set -- n )
@ -114,13 +114,20 @@ M: sqlite-statement query-results ( query -- result-set )
M: sqlite-db create-sql-statement ( class -- statement )
[
dupd
"create table " 0% 0%
"(" 0% [ ", " 0% ] [
dup column-name>> 0%
" " 0%
dup type>> lookup-create-type 0%
modifiers 0%
] interleave ");" 0%
] interleave
", " 0%
find-primary-key
"primary key(" 0%
[ "," 0% ] [ column-name>> 0% ] interleave
"));" 0%
] query-make ;
M: sqlite-db drop-sql-statement ( class -- statement )
@ -161,23 +168,31 @@ M: sqlite-db bind% ( spec -- )
M: sqlite-db persistent-table ( -- assoc )
H{
{ +db-assigned-id+ { "integer primary key" "integer primary key" "primary key" } }
{ +user-assigned-id+ { f f "primary key" } }
{ +random-id+ { "integer primary key" "integer primary key" "primary key" } }
{ INTEGER { "integer" "integer" "primary key" } }
{ BIG-INTEGER { "bigint" "bigint" } }
{ SIGNED-BIG-INTEGER { "bigint" "bigint" } }
{ UNSIGNED-BIG-INTEGER { "bigint" "bigint" } }
{ TEXT { "text" "text" } }
{ VARCHAR { "text" "text" } }
{ DATE { "date" "date" } }
{ TIME { "time" "time" } }
{ DATETIME { "datetime" "datetime" } }
{ TIMESTAMP { "timestamp" "timestamp" } }
{ DOUBLE { "real" "real" } }
{ BLOB { "blob" "blob" } }
{ FACTOR-BLOB { "blob" "blob" } }
{ URL { "text" "text" } }
{ +db-assigned-id+ { "integer" "integer" f } }
{ +user-assigned-id+ { f f f } }
{ +random-id+ { "integer" "integer" f } }
{ +foreign-id+ { "integer" "integer" "references" } }
{ +on-delete+ { f f "on delete" } }
{ +restrict+ { f f "restrict" } }
{ +cascade+ { f f "cascade" } }
{ +set-null+ { f f "set null" } }
{ +set-default+ { f f "set default" } }
{ INTEGER { "integer" "integer" f } }
{ BIG-INTEGER { "bigint" "bigint" f } }
{ SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
{ UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
{ TEXT { "text" "text" f } }
{ VARCHAR { "text" "text" f } }
{ DATE { "date" "date" f } }
{ TIME { "time" "time" f } }
{ DATETIME { "datetime" "datetime" f } }
{ TIMESTAMP { "timestamp" "timestamp" f } }
{ DOUBLE { "real" "real" f } }
{ BLOB { "blob" "blob" f } }
{ FACTOR-BLOB { "blob" "blob" f } }
{ URL { "text" "text" f } }
{ +autoincrement+ { f f "autoincrement" } }
{ +unique+ { f f "unique" } }
{ +default+ { f f "default" } }
@ -188,8 +203,9 @@ M: sqlite-db persistent-table ( -- assoc )
{ random-generator { f f f } }
} ;
M: sqlite-db compound ( str seq -- str' )
M: sqlite-db compound ( string seq -- new-string )
over {
{ "default" [ first number>string join-space ] }
[ 2drop ]
{ "references" [ >reference-string ] }
[ 2drop ]
} case ;

View File

@ -1,7 +1,7 @@
! 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 ;
quotations sequences strings multiline math db.types ;
IN: db.tuples
HELP: define-persistent
@ -11,7 +11,18 @@ HELP: define-persistent
{ $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" } ")" }
} } ;
} "Throws an error if the slot name (column one from each row) is not a slot in the tuple or its superclases." }
{ $examples
{ $unchecked-example "USING: db.tuples db.types ;"
"TUPLE: boat id year name ;"
"boat \"BOAT\" {"
" { \"id\" \"ID\" +db-assigned-id+ }"
" { \"year\" \"YEAR\" INTEGER }"
" { \"name\" \"NAME\" TEXT }"
"} define-persistent"
""
}
} ;
HELP: create-table
{ $values
@ -64,36 +75,35 @@ HELP: delete-tuples
HELP: select-tuple
{ $values
{ "tuple" tuple }
{ "query/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 }
{ "query/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" }
{ "query/tuple" tuple }
{ "n" integer } }
{ $description "" } ;
{ $description "Returns the number of items that would be returned if the query were a select query. Counting the tuples with this word is more efficient than calling " { $link length } " on the result of " { $link select-tuples } "." } ;
{ select-tuple select-tuples count-tuples } related-words
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" }
"Database types supported:"
{ $subsection "db.types" }
"Useful words:"
{ $subsection "db-tuples-words" }
"For porting db.tuples to other databases:"
{ $subsection "db-tuples-protocol" }
;
ARTICLE: "db-tuples-words" "High-level tuple/database words"
@ -115,12 +125,9 @@ ARTICLE: "db-tuples-words" "High-level tuple/database words"
"Querying tuples:"
{ $subsection select-tuple }
{ $subsection select-tuples }
{ $subsection count-tuples }
"Advanced querying of tuples:"
{ $subsection query } ;
{ $subsection count-tuples } ;
ARTICLE: "db-tuples-protocol" "High-level tuple/database protocol"
ARTICLE: "db-tuples-protocol" "Tuple database protocol"
;
ARTICLE: "db-tuples-tutorial" "Tuple database tutorial"

View File

@ -4,9 +4,20 @@ USING: io.files kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals
db.postgresql accessors random math.bitwise
math.ranges strings urls fry ;
math.ranges strings urls fry db.tuples.private ;
IN: db.tuples.tests
: test-sqlite ( quot -- )
[ ] swap '[
"tuples-test.db" temp-file sqlite-db _ with-db
] unit-test ;
: test-postgresql ( quot -- )
[ ] swap '[
{ "localhost" "postgres" "foob" "factor-test" }
postgresql-db _ with-db
] unit-test ;
TUPLE: person the-id the-name the-number the-real
ts date time blob factor-blob url ;
@ -177,34 +188,55 @@ TUPLE: annotation n paste-id summary author mode contents ;
{ "channel" "CHANNEL" TEXT }
{ "mode" "MODE" TEXT }
{ "contents" "CONTENTS" TEXT }
{ "date" "DATE" TIMESTAMP }
{ "timestamp" "DATE" TIMESTAMP }
{ "annotations" { +has-many+ annotation } }
} define-persistent
annotation "ANNOTATION"
{
{ "n" "ID" +db-assigned-id+ }
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } }
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" }
+on-delete+ +cascade+ }
{ "summary" "SUMMARY" TEXT }
{ "author" "AUTHOR" TEXT }
{ "mode" "MODE" TEXT }
{ "contents" "CONTENTS" TEXT }
} define-persistent ;
! { "localhost" "postgres" "" "factor-test" } postgresql-db [
! [ paste drop-table ] [ drop ] recover
! [ annotation drop-table ] [ drop ] recover
! [ paste drop-table ] [ drop ] recover
! [ annotation drop-table ] [ drop ] recover
! [ ] [ paste create-table ] unit-test
! [ ] [ annotation create-table ] unit-test
! ] with-db
: test-paste-schema ( -- )
[ ] [ db-assigned-paste-schema ] unit-test
[ ] [ paste ensure-table ] unit-test
[ ] [ annotation ensure-table ] unit-test
[ ] [ annotation drop-table ] unit-test
[ ] [ paste drop-table ] unit-test
[ ] [ paste create-table ] unit-test
[ ] [ annotation create-table ] unit-test
: test-sqlite ( quot -- )
[ ] swap '[ "tuples-test.db" temp-file sqlite-db _ with-db ] unit-test ;
[ ] [
paste new
"summary1" >>summary
"erg" >>author
"#lol" >>channel
"contents1" >>contents
now >>timestamp
insert-tuple
] unit-test
: test-postgresql ( quot -- )
[ ] swap '[ { "localhost" "postgres" "foob" "factor-test" } postgresql-db _ with-db ] unit-test ;
[ ] [
annotation new
1 >>paste-id
"annotation1" >>summary
"erg" >>author
"annotation contents" >>contents
insert-tuple
] unit-test
[ ] [
] unit-test
;
[ test-paste-schema ] test-sqlite
[ test-paste-schema ] test-postgresql
: test-repeated-insert
[ ] [ person ensure-table ] unit-test
@ -236,6 +268,17 @@ TUPLE: exam id name score ;
exam boa ;
: test-intervals ( -- )
[
exam "EXAM"
{
{ "idd" "ID" +db-assigned-id+ }
{ "named" "NAME" TEXT }
{ "score" "SCORE" INTEGER }
} define-persistent
] [
seq>> { "idd" "named" } =
] must-fail-with
exam "EXAM"
{
{ "id" "ID" +db-assigned-id+ }
@ -346,7 +389,7 @@ TUPLE: exam id name score ;
T{ exam } select-tuples
] unit-test
[ 4 ] [ T{ exam } f count-tuples ] unit-test ;
[ 4 ] [ T{ exam } count-tuples ] unit-test ;
TUPLE: bignum-test id m n o ;
: <bignum-test> ( m n o -- obj )
@ -499,3 +542,42 @@ string-encoding-test "STRING_ENCODING_TEST" {
\ ensure-table must-infer
\ create-table must-infer
\ drop-table must-infer
: test-queries ( -- )
[ ] [ exam ensure-table ] unit-test
[ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test
[ 5 ] [
<query>
T{ exam { score T{ interval { from { 0 t } } { to { 100 t } } } } }
>>tuple
5 >>limit select-tuples length
] unit-test ;
TUPLE: compound-foo a b c ;
compound-foo "COMPOUND_FOO"
{
{ "a" "A" INTEGER +user-assigned-id+ }
{ "b" "B" INTEGER +user-assigned-id+ }
{ "c" "C" INTEGER }
} define-persistent
: test-compound-primary-key ( -- )
[ ] [ compound-foo ensure-table ] unit-test
[ ] [ compound-foo drop-table ] unit-test
[ ] [ compound-foo create-table ] unit-test
[ ] [ 1 2 3 compound-foo boa insert-tuple ] unit-test
[ 1 2 3 compound-foo boa insert-tuple ] must-fail
[ ] [ 2 3 4 compound-foo boa insert-tuple ] unit-test
[ T{ compound-foo { a 2 } { b 3 } { c 4 } } ]
[ compound-foo new 4 >>c select-tuple ] unit-test ;
[ test-compound-primary-key ] test-sqlite
[ test-compound-primary-key ] test-postgresql
: sqlite-test-db ( -- )
"tuples-test.db" temp-file sqlite-db make-db db-open db set ;
: postgresql-test-db ( -- )
{ "localhost" "postgres" "foob" "factor-test" } postgresql-db
make-db db-open db set ;

View File

@ -3,36 +3,10 @@
USING: arrays assocs classes db kernel namespaces
classes.tuple words sequences slots math accessors
math.parser io prettyprint db.types continuations
destructors mirrors ;
destructors mirrors sets db.types ;
IN: db.tuples
: define-persistent ( class table columns -- )
>r dupd "db-table" set-word-prop dup r>
[ relation? ] partition swapd
dupd [ spec>tuple ] with map
"db-columns" set-word-prop
"db-relations" set-word-prop ;
ERROR: not-persistent class ;
: db-table ( class -- object )
dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
: db-columns ( class -- object )
superclasses [ "db-columns" word-prop ] map concat ;
: db-relations ( class -- object )
"db-relations" word-prop ;
: set-primary-key ( key tuple -- )
[
class db-columns find-primary-key slot-name>>
] keep set-slot-named ;
SYMBOL: sql-counter
: next-sql-counter ( -- str )
sql-counter [ inc ] [ get ] bi number>string ;
<PRIVATE
! returns a sequence of prepared-statements
HOOK: create-sql-statement db ( class -- object )
HOOK: drop-sql-statement db ( class -- object )
@ -42,19 +16,20 @@ HOOK: <insert-user-assigned-statement> db ( class -- object )
HOOK: <update-tuple-statement> db ( class -- object )
HOOK: <delete-tuples-statement> db ( tuple class -- object )
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
TUPLE: query group order offset limit ;
HOOK: <query> db ( tuple class query -- statement' )
HOOK: <count-statement> db ( tuple class groups -- n )
HOOK: <count-statement> db ( query -- statement )
HOOK: query>statement db ( query -- statement )
HOOK: insert-tuple* db ( tuple statement -- )
HOOK: insert-tuple-set-key db ( tuple statement -- )
SYMBOL: sql-counter
: next-sql-counter ( -- str )
sql-counter [ inc ] [ get ] bi number>string ;
GENERIC: eval-generator ( singleton -- object )
: resulting-tuple ( exemplar-tuple row out-params -- tuple )
rot class new [
[
[ slot-name>> ] dip set-slot-named
] curry 2each
[ [ slot-name>> ] dip set-slot-named ] curry 2each
] keep ;
: query-tuples ( exemplar-tuple statement -- seq )
@ -75,6 +50,51 @@ GENERIC: eval-generator ( singleton -- object )
with-disposal
] if ; inline
: insert-db-assigned-statement ( tuple -- )
dup class
db get insert-statements>> [ <insert-db-assigned-statement> ] cache
[ bind-tuple ] 2keep insert-tuple-set-key ;
: insert-user-assigned-statement ( tuple -- )
dup class
db get insert-statements>> [ <insert-user-assigned-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: do-select ( exemplar-tuple statement -- tuples )
[ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
: do-count ( exemplar-tuple statement -- tuples )
[ [ bind-tuple ] [ nip default-query ] 2bi ] with-disposal ;
PRIVATE>
! High level
ERROR: no-slots-named class seq ;
: check-columns ( class columns -- )
tuck
[ [ first ] map ]
[ all-slots [ name>> ] map ] bi* diff
[ drop ] [ no-slots-named ] if-empty ;
: define-persistent ( class table columns -- )
pick dupd
check-columns
[ dupd "db-table" set-word-prop dup ] dip
[ relation? ] partition swapd
dupd [ spec>tuple ] with map
"db-columns" set-word-prop
"db-relations" set-word-prop ;
TUPLE: query tuple group order offset limit ;
: <query> ( -- query ) \ query new ;
GENERIC: >query ( object -- query )
M: query >query clone ;
M: tuple >query <query> swap >>tuple ;
: create-table ( class -- )
create-sql-statement [ execute-statement ] with-disposals ;
@ -87,21 +107,9 @@ GENERIC: eval-generator ( singleton -- object )
] curry ignore-errors
] [ create-table ] bi ;
: ensure-table ( class -- )
[ create-table ] curry ignore-errors ;
: ensure-table ( class -- ) [ create-table ] curry ignore-errors ;
: ensure-tables ( classes -- )
[ ensure-table ] each ;
: insert-db-assigned-statement ( tuple -- )
dup class
db get insert-statements>> [ <insert-db-assigned-statement> ] cache
[ bind-tuple ] 2keep insert-tuple* ;
: insert-user-assigned-statement ( tuple -- )
dup class
db get insert-statements>> [ <insert-user-assigned-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: ensure-tables ( classes -- ) [ ensure-table ] each ;
: insert-tuple ( tuple -- )
dup class db-columns find-primary-key db-assigned-id-spec?
@ -117,25 +125,14 @@ GENERIC: eval-generator ( singleton -- object )
[ bind-tuple ] keep execute-statement
] with-disposal ;
: do-select ( exemplar-tuple statement -- tuples )
[ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
: select-tuples ( query/tuple -- tuples )
>query [ tuple>> ] [ query>statement ] bi do-select ;
: query ( tuple query -- tuples )
[ dup dup class ] dip <query> do-select ;
: select-tuples ( tuple -- tuples )
dup dup class <select-by-slots-statement> do-select ;
: select-tuple ( tuple -- tuple/f )
dup dup class \ query new 1 >>limit <query> do-select
: select-tuple ( query/tuple -- tuple/f )
>query 1 >>limit [ tuple>> ] [ query>statement ] bi do-select
[ f ] [ first ] if-empty ;
: do-count ( exemplar-tuple statement -- tuples )
[
[ bind-tuple ] [ nip default-query ] 2bi
] with-disposal ;
: count-tuples ( tuple groups -- n )
>r dup dup class r> <count-statement> do-count
: count-tuples ( query/tuple -- n )
>query [ tuple>> ] [ <count-statement> ] bi do-count
dup length 1 =
[ first first string>number ] [ [ first string>number ] map ] if ;

View File

@ -1,14 +1,9 @@
! 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 ;
USING: classes hashtables help.markup help.syntax io.streams.string
kernel sequences strings math ;
IN: db.types
HELP: (lookup-type)
{ $values
{ "obj" object }
{ "string" string } }
{ $description "" } ;
HELP: +autoincrement+
{ $description "" } ;
@ -55,7 +50,7 @@ HELP: <low-level-binding>
{ $description "" } ;
HELP: BIG-INTEGER
{ $description "A 64-bit integer." } ;
{ $description "A 64-bit integer. Whether this number is signed or unsigned depends on the database backend." } ;
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." } ;
@ -73,13 +68,13 @@ HELP: DOUBLE
{ $description "Corresponds to Factor's 64bit floating-point numbers." } ;
HELP: FACTOR-BLOB
{ $description "" } ;
{ $description "A serialized Factor object." } ;
HELP: INTEGER
{ $description "" } ;
{ $description "A small integer, at least 32 bits in length. Whether this number is signed or unsigned depends on the database backend." } ;
HELP: NULL
{ $description "" } ;
{ $description "The SQL null type." } ;
HELP: REAL
{ $description "" } ;
@ -94,22 +89,24 @@ HELP: TIME
{ $description "" } ;
HELP: TIMESTAMP
{ $description "" } ;
{ $description "A Factor timestamp." } ;
HELP: UNSIGNED-BIG-INTEGER
{ $description "" } ;
{ $description "For portability, if a number is known to be 64bit, 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 } "." } ;
{ INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER } related-words
HELP: URL
{ $description "" } ;
{ $description "A Factor " { $link "urls" } " object." } ;
HELP: VARCHAR
{ $description "" } ;
{ $description "The SQL varchar type. This type can take an integer as an argument." } ;
HELP: assigned-id-spec?
HELP: user-assigned-id-spec?
{ $values
{ "spec" null }
{ "specs" "a sequence of sql specs" }
{ "?" "a boolean" } }
{ $description "" } ;
{ $description "Tests if any of the sql specs has the type " { $link +user-assigned-id+ } "." } ;
HELP: bind#
{ $values
@ -129,24 +126,25 @@ HELP: compound
HELP: db-assigned-id-spec?
{ $values
{ "spec" null }
{ "specs" "a sequence of sql specs" }
{ "?" "a boolean" } }
{ $description "" } ;
{ $description "Tests if any of the sql specs has the type " { $link +db-assigned-id+ } "." } ;
HELP: find-primary-key
{ $values
{ "specs" null }
{ "obj" object } }
{ $description "" } ;
{ "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" null } { "obj" object }
{ "value" null } }
{ $description "" } ;
{ "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: join-space
{ $values
@ -185,30 +183,20 @@ HELP: modifiers
{ $description "" } ;
HELP: no-sql-type
{ $description "" } ;
{ $values
{ "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" 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 "" } ;
{ "string" string } { "tuple" tuple }
{ "n" integer } }
{ $description "Returns the offset of a tuple slot accessed by name." } ;
HELP: persistent-table
{ $values
@ -264,7 +252,8 @@ HELP: sql-spec
{ $description "" } ;
HELP: unknown-modifier
{ $description "" } ;
{ $values { "modifier" string } }
{ $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
@ -294,7 +283,6 @@ ARTICLE: "db.types" "Database types"
{ $subsection BLOB }
{ $subsection FACTOR-BLOB }
"Factor URLs:"
{ $subsection URL }
;
{ $subsection URL } ;
ABOUT: "db.types"

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs db kernel math math.parser
sequences continuations sequences.deep
sequences continuations sequences.deep prettyprint
words namespaces slots slots.private classes mirrors
classes.tuple combinators calendar.format symbols
classes.singleton accessors quotations random ;
@ -22,22 +22,51 @@ SINGLETON: random-id-generator
TUPLE: low-level-binding value ;
C: <low-level-binding> low-level-binding
SINGLETON: +db-assigned-id+
SINGLETON: +user-assigned-id+
SINGLETON: +random-id+
SINGLETONS: +db-assigned-id+ +user-assigned-id+ +random-id+ ;
UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
+foreign-id+ +has-many+ ;
+foreign-id+ +has-many+ +on-delete+ +restrict+ +cascade+ +set-null+
+set-default+ ;
: offset-of-slot ( string tuple -- n )
class superclasses [ "slots" word-prop ] map concat
slot-named offset>> ;
: get-slot-named ( name tuple -- value )
tuck offset-of-slot slot ;
: set-slot-named ( value name obj -- )
tuck offset-of-slot set-slot ;
ERROR: not-persistent class ;
: db-table ( class -- object )
dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
: db-columns ( class -- object )
superclasses [ "db-columns" word-prop ] map concat ;
: db-relations ( class -- object )
"db-relations" word-prop ;
: find-primary-key ( specs -- seq )
[ primary-key>> ] filter ;
: set-primary-key ( value tuple -- )
[
class db-columns
find-primary-key first slot-name>>
] keep set-slot-named ;
: primary-key? ( spec -- ? )
primary-key>> +primary-key+? ;
: db-assigned-id-spec? ( spec -- ? )
primary-key>> +db-assigned-id+? ;
: db-assigned-id-spec? ( specs -- ? )
[ primary-key>> +db-assigned-id+? ] contains? ;
: assigned-id-spec? ( spec -- ? )
primary-key>> +user-assigned-id+? ;
: user-assigned-id-spec? ( specs -- ? )
[ primary-key>> +user-assigned-id+? ] contains? ;
: normalize-spec ( spec -- )
dup type>> dup +primary-key+? [
@ -49,8 +78,8 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
[ >>primary-key drop ] [ drop ] if*
] if ;
: find-primary-key ( specs -- obj )
[ primary-key>> ] find nip ;
: db-assigned? ( class -- ? )
db-columns find-primary-key db-assigned-id-spec? ;
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
@ -86,18 +115,22 @@ FACTOR-BLOB NULL URL ;
! PostgreSQL Types:
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
ERROR: unknown-modifier ;
: ?at ( obj assoc -- value/obj ? )
dupd at* [ [ nip ] [ drop ] if ] keep ;
ERROR: unknown-modifier modifier ;
: lookup-modifier ( obj -- string )
{
{ [ dup array? ] [ unclip lookup-modifier swap compound ] }
[ persistent-table at* [ unknown-modifier ] unless third ]
[ persistent-table ?at [ unknown-modifier ] unless third ]
} cond ;
ERROR: no-sql-type ;
ERROR: no-sql-type type ;
: (lookup-type) ( obj -- string )
persistent-table at* [ no-sql-type ] unless ;
persistent-table ?at [ no-sql-type ] unless ;
: lookup-type ( obj -- string )
dup array? [
@ -113,25 +146,21 @@ ERROR: no-sql-type ;
(lookup-type) second
] if ;
: paren ( string -- new-string )
"(" swap ")" 3append ;
: join-space ( string1 string2 -- new-string )
" " swap 3append ;
: modifiers ( spec -- string )
modifiers>> [ lookup-modifier ] map " " join
[ "" ] [ " " prepend ] if-empty ;
: join-space ( string1 string2 -- new-string )
" " swap 3append ;
: paren ( string -- new-string )
"(" swap ")" 3append ;
HOOK: bind% db ( spec -- )
HOOK: bind# db ( spec obj -- )
: offset-of-slot ( string obj -- n )
class superclasses [ "slots" word-prop ] map concat
slot-named offset>> ;
: get-slot-named ( name obj -- value )
tuck offset-of-slot slot ;
: set-slot-named ( value name obj -- )
tuck offset-of-slot set-slot ;
: >reference-string ( string pair -- string )
first2
[ [ unparse join-space ] [ db-columns ] bi ] dip
swap [ slot-name>> = ] with find nip
column-name>> paren append ;

View File

@ -22,6 +22,9 @@ M: tuple error-help class ;
M: string error. print ;
: :error ( -- )
error get error. ;
: :s ( -- )
error-continuation get data>> stack. ;
@ -323,3 +326,5 @@ M: bad-effect summary
drop "Bad stack effect declaration" ;
M: bad-escape summary drop "Bad escape code" ;
M: bad-literal-tuple summary drop "Bad literal tuple" ;

View File

@ -45,5 +45,4 @@ $nl
{ $subsection define-consult }
"The " { $vocab-link "delegate.protocols" } " vocabulary defines formal protocols for the various informal protocols used in the Factor core, such as " { $link "sequence-protocol" } ", " { $link "assocs-protocol" } " or " { $link "stream-protocol" } ;
IN: delegate
ABOUT: { "delegate" "intro" }

View File

@ -62,7 +62,7 @@ M: tuple-class group-words
protocol-consult keys ;
: lost-words ( protocol wordlist -- lost-words )
>r protocol-words r> diff ;
[ protocol-words ] dip diff ;
: forget-old-definitions ( protocol new-wordlist -- )
[ drop protocol-users ] [ lost-words ] 2bi

View File

@ -1,45 +1,29 @@
USING: help.markup help.syntax kernel math sequences
quotations ;
IN: deques
USING: help.markup help.syntax kernel ;
ARTICLE: "deques" "Dequeues"
"A deque is a data structure with constant-time insertion and removal of elements at both ends. Dequeue operations are defined in the " { $vocab-link "deques" } " vocabulary."
$nl
"Dequeues must be instances of a mixin class:"
{ $subsection deque }
"Dequeues must implement a protocol."
$nl
"Querying the deque:"
{ $subsection peek-front }
{ $subsection peek-back }
{ $subsection deque-length }
{ $subsection deque-member? }
"Adding and removing elements:"
{ $subsection push-front* }
{ $subsection push-back* }
{ $subsection pop-front* }
{ $subsection pop-back* }
{ $subsection clear-deque }
"Working with node objects output by " { $link push-front* } " and " { $link push-back* } ":"
{ $subsection delete-node }
{ $subsection node-value }
"Utility operations built in terms of the above:"
{ $subsection deque-empty? }
{ $subsection push-front }
{ $subsection push-all-front }
{ $subsection push-back }
{ $subsection push-all-back }
{ $subsection pop-front }
{ $subsection pop-back }
{ $subsection slurp-deque }
"When using a deque as a queue, the convention is to queue elements with " { $link push-front } " and deque them with " { $link pop-back } "." ;
ABOUT: "deques"
HELP: deque-empty?
{ $values { "deque" { $link deque } } { "?" "a boolean" } }
{ $values { "deque" deque } { "?" "a boolean" } }
{ $description "Returns true if a deque is empty." }
{ $notes "This operation is O(1)." } ;
HELP: clear-deque
{ $values
{ "deque" deque } }
{ $description "Removes all elements from a deque." } ;
HELP: deque-length
{ $values
{ "deque" deque }
{ "n" integer } }
{ $description "Returns the number of elements in a deque." } ;
HELP: deque-member?
{ $values
{ "value" object } { "deque" deque }
{ "?" "a boolean" } }
{ $description "Returns true if the " { $snippet "value" } " is found in the deque." } ;
HELP: push-front
{ $values { "obj" object } { "deque" deque } }
{ $description "Push the object onto the front of the deque." }
@ -60,6 +44,16 @@ HELP: push-back*
{ $description "Push the object onto the back of the deque and return the newly created node." }
{ $notes "This operation is O(1)." } ;
HELP: push-all-back
{ $values
{ "seq" sequence } { "deque" deque } }
{ $description "Pushes a sequence of elements onto the back of a deque." } ;
HELP: push-all-front
{ $values
{ "seq" sequence } { "deque" deque } }
{ $description "Pushes a sequence of elements onto the front of a deque." } ;
HELP: peek-front
{ $values { "deque" deque } { "obj" object } }
{ $description "Returns the object at the front of the deque." } ;
@ -87,3 +81,56 @@ HELP: pop-back*
{ $values { "deque" deque } }
{ $description "Pop the object off the back of the deque." }
{ $notes "This operation is O(1)." } ;
HELP: delete-node
{ $values
{ "node" object } { "deque" deque } }
{ $description "Deletes the node from the deque." } ;
HELP: deque
{ $description "A data structure that has constant-time insertion and removal of elements at both ends." } ;
HELP: node-value
{ $values
{ "node" object }
{ "value" object } }
{ $description "Accesses the value stored at a node." } ;
HELP: slurp-deque
{ $values
{ "deque" deque } { "quot" quotation } }
{ $description "Pops off the back element of the deque and calls the quotation in a loop until the deque is empty." } ;
ARTICLE: "deques" "Deques"
"The " { $vocab-link "deques" } " vocabulary implements the deque data structure which has constant-time insertion and removal of elements at both ends."
$nl
"Deques must be instances of a mixin class:"
{ $subsection deque }
"Deques must implement a protocol."
$nl
"Querying the deque:"
{ $subsection peek-front }
{ $subsection peek-back }
{ $subsection deque-length }
{ $subsection deque-member? }
"Adding and removing elements:"
{ $subsection push-front* }
{ $subsection push-back* }
{ $subsection pop-front* }
{ $subsection pop-back* }
{ $subsection clear-deque }
"Working with node objects output by " { $link push-front* } " and " { $link push-back* } ":"
{ $subsection delete-node }
{ $subsection node-value }
"Utility operations built in terms of the above:"
{ $subsection deque-empty? }
{ $subsection push-front }
{ $subsection push-all-front }
{ $subsection push-back }
{ $subsection push-all-back }
{ $subsection pop-front }
{ $subsection pop-back }
{ $subsection slurp-deque }
"When using a deque as a queue, the convention is to queue elements with " { $link push-front } " and deque them with " { $link pop-back } "." ;
ABOUT: "deques"

View File

@ -37,7 +37,7 @@ HELP: assoc>disjoint-set
} ;
ARTICLE: "disjoint-sets" "Disjoint sets"
"The " { $emphasis "disjoint set" } " data structure, also known as " { $emphasis "union-find" } " (after the two main operations which it supports) represents a set of elements partitioned into disjoint equivalence classes, or alternatively, an equivalence relation on a set."
"The " { $vocab-link "disjoint-sets" } " vocabulary implements the " { $emphasis "disjoint set" } " data structure (also known as " { $emphasis "union-find" } ", after the two main operations which it supports) that represents a set of elements partitioned into disjoint equivalence classes, or alternatively, an equivalence relation on a set."
$nl
"The two main supported operations are equating two elements, which joins their equivalence classes, and checking if two elements belong to the same equivalence class. Both operations have the time complexity of the inverse Ackermann function, which for all intents and purposes is constant time."
$nl

View File

@ -0,0 +1 @@
John Benediktsson

View File

@ -0,0 +1,13 @@
USING: definitions io.launcher kernel math math.parser parser
namespaces prettyprint editors make ;
IN: editors.macvim
: macvim-location ( file line -- )
drop
[ "open" , "-a" , "MacVim", , ] { } make
try-process ;
[ macvim-location ] edit-hook set-global

View File

@ -0,0 +1 @@
MacVim editor integration

View File

@ -0,0 +1 @@
unportable

View File

@ -0,0 +1 @@
John Benediktsson

View File

@ -0,0 +1 @@
TextEdit editor integration

View File

@ -0,0 +1 @@
unportable

View File

@ -0,0 +1,13 @@
USING: definitions io.launcher kernel math math.parser parser
namespaces prettyprint editors make ;
IN: editors.textedit
: textedit-location ( file line -- )
drop
[ "open" , "-a" , "TextEdit", , ] { } make
try-process ;
[ textedit-location ] edit-hook set-global

1
basis/eval/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/eval/summary.txt Normal file
View File

@ -0,0 +1 @@
Ad-hoc evaluation of strings of code

View File

@ -9,7 +9,7 @@ HELP: write-farkup
{ $values { "string" string } }
{ $description "Parse a Farkup string and writes the resulting HTML to " { $link output-stream } "." } ;
HELP: farkup ( string -- farkup )
HELP: parse-farkup ( string -- farkup )
{ $values { "string" string } { "farkup" "a Farkup syntax tree node" } }
{ $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ;
@ -18,7 +18,7 @@ HELP: (write-farkup)
{ $description "Writes a Farkup syntax tree as HTML on " { $link output-stream } "." } ;
ARTICLE: "farkup-ast" "Farkup syntax tree nodes"
"The " { $link farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."
"The " { $link parse-farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."
{ $subsection heading1 }
{ $subsection heading2 }
{ $subsection heading3 }
@ -30,7 +30,8 @@ ARTICLE: "farkup-ast" "Farkup syntax tree nodes"
{ $subsection inline-code }
{ $subsection paragraph }
{ $subsection list-item }
{ $subsection list }
{ $subsection unordered-list }
{ $subsection ordered-list }
{ $subsection table }
{ $subsection table-row }
{ $subsection link }
@ -44,7 +45,7 @@ $nl
{ $subsection convert-farkup }
{ $subsection write-farkup }
"The syntax tree of a piece of Farkup can also be inspected and modified:"
{ $subsection farkup }
{ $subsection parse-farkup }
{ $subsection (write-farkup) }
{ $subsection "farkup-ast" } ;

View File

@ -11,13 +11,11 @@ link-no-follow? off
[ "Baz" ] [ "Baz" simple-link-title ] unit-test
[ ] [
"abcd-*strong*\nasdifj\nweouh23ouh23"
"paragraph" \ farkup rule parse drop
"abcd-*strong*\nasdifj\nweouh23ouh23" parse-farkup drop
] unit-test
[ ] [
"abcd-*strong*\nasdifj\nweouh23ouh23\n"
"paragraph" \ farkup rule parse drop
"abcd-*strong*\nasdifj\nweouh23ouh23\n" parse-farkup drop
] unit-test
[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
@ -37,22 +35,30 @@ link-no-follow? off
[ "<ul><li>foo</li>\n</ul><p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
[ "<ol><li>a-b</li></ol>" ] [ "#a-b" convert-farkup ] unit-test
[ "<ol><li>foo</li></ol>" ] [ "#foo" convert-farkup ] unit-test
[ "<ol><li>foo</li>\n</ol>" ] [ "#foo\n" convert-farkup ] unit-test
[ "<ol><li>foo</li>\n<li>bar</li></ol>" ] [ "#foo\n#bar" convert-farkup ] unit-test
[ "<ol><li>foo</li>\n<li>bar</li>\n</ol>" ] [ "#foo\n#bar\n" convert-farkup ] unit-test
[ "<ol><li>foo</li>\n</ol><p>bar\n</p>" ] [ "#foo\nbar\n" convert-farkup ] unit-test
[ "\n\n" ] [ "\n\n" convert-farkup ] unit-test
[ "\n\n" ] [ "\r\n\r\n" convert-farkup ] unit-test
[ "\n\n\n\n" ] [ "\r\r\r\r" convert-farkup ] unit-test
[ "\n\n\n" ] [ "\r\r\r" convert-farkup ] unit-test
[ "\n\n\n" ] [ "\n\n\n" convert-farkup ] unit-test
[ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
[ "<p>foo</p><p>bar</p>" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
[ "<p>foo</p><p>bar</p>" ] [ "foo\r\rbar" convert-farkup ] unit-test
[ "<p>foo</p><p>bar</p>" ] [ "foo\r\r\nbar" convert-farkup ] unit-test
[ "<p>foo\n</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
[ "<p>foo\n</p><p>bar</p>" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
[ "<p>foo\n</p><p>bar</p>" ] [ "foo\r\rbar" convert-farkup ] unit-test
[ "<p>foo\n</p><p>bar</p>" ] [ "foo\r\r\nbar" convert-farkup ] unit-test
[ "\n<p>bar\n</p>" ] [ "\nbar\n" convert-farkup ] unit-test
[ "\n<p>bar\n</p>" ] [ "\rbar\r" convert-farkup ] unit-test
[ "\n<p>bar\n</p>" ] [ "\r\nbar\r\n" convert-farkup ] unit-test
[ "<p>foo</p><p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
[ "<p>foo\n</p><p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
[ "" ] [ "" convert-farkup ] unit-test
@ -107,7 +113,7 @@ link-no-follow? off
] [ "Feature comparison:\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>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>"
"<p>Feature comparison:\n</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
[
@ -118,3 +124,36 @@ link-no-follow? off
] unit-test
[ "<p><a href='a'>a</a> <a href='b'>c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test
[ "<p><a href='C%2b%2b'>C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
[ "<p>&lt;foo&gt;</p>" ] [ "<foo>" convert-farkup ] unit-test
[ "<p>asdf\n<ul><li>lol</li>\n<li>haha</li></ul></p>" ] [ "asdf\n-lol\n-haha" convert-farkup ] unit-test
[ "<p>asdf\n</p><ul><li>lol</li>\n<li>haha</li></ul>" ]
[ "asdf\n\n-lol\n-haha" convert-farkup ] unit-test
[ "<hr/>" ] [ "___" convert-farkup ] unit-test
[ "<hr/>\n" ] [ "___\n" convert-farkup ] unit-test
[ "<p>before:\n<pre><span class='OPERATOR'>{</span> <span class='DIGIT'>1</span> <span class='DIGIT'>2</span> <span class='DIGIT'>3</span> <span class='OPERATOR'>}</span> <span class='DIGIT'>1</span> tail\n</pre></p>" ]
[ "before:\n[factor{{ 1 2 3 } 1 tail}]" convert-farkup ] unit-test
[ "<p><a href='Factor'>Factor</a>-rific!</p>" ]
[ "[[Factor]]-rific!" convert-farkup ] unit-test
[ "<p>[ factor { 1 2 3 }]</p>" ]
[ "[ factor { 1 2 3 }]" convert-farkup ] unit-test
[ "<p>paragraph\n<hr/></p>" ]
[ "paragraph\n___" convert-farkup ] unit-test
[ "<p>paragraph\n a ___ b</p>" ]
[ "paragraph\n a ___ b" convert-farkup ] unit-test
[ "\n<ul><li> a</li>\n</ul><hr/>" ]
[ "\n- a\n___" convert-farkup ] unit-test
[ "<p>hello_world how are you today?\n<ul><li> hello_world how are you today?</li></ul></p>" ]
[ "hello_world how are you today?\n- hello_world how are you today?" convert-farkup ] unit-test

View File

@ -1,32 +1,34 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators html.elements io io.streams.string
kernel math memoize namespaces peg peg.ebnf prettyprint
sequences sequences.deep strings xml.entities vectors splitting
xmode.code2html ;
USING: accessors arrays combinators html.elements io
io.streams.string kernel math namespaces peg peg.ebnf
sequences sequences.deep strings xml.entities
vectors splitting xmode.code2html urls.encoding ;
IN: farkup
SYMBOL: relative-link-prefix
SYMBOL: disable-images?
SYMBOL: link-no-follow?
TUPLE: heading1 obj ;
TUPLE: heading2 obj ;
TUPLE: heading3 obj ;
TUPLE: heading4 obj ;
TUPLE: strong obj ;
TUPLE: emphasis obj ;
TUPLE: superscript obj ;
TUPLE: subscript obj ;
TUPLE: inline-code obj ;
TUPLE: paragraph obj ;
TUPLE: list-item obj ;
TUPLE: list obj ;
TUPLE: table obj ;
TUPLE: table-row obj ;
TUPLE: heading1 child ;
TUPLE: heading2 child ;
TUPLE: heading3 child ;
TUPLE: heading4 child ;
TUPLE: strong child ;
TUPLE: emphasis child ;
TUPLE: superscript child ;
TUPLE: subscript child ;
TUPLE: inline-code child ;
TUPLE: paragraph child ;
TUPLE: list-item child ;
TUPLE: unordered-list child ;
TUPLE: ordered-list child ;
TUPLE: table child ;
TUPLE: table-row child ;
TUPLE: link href text ;
TUPLE: image href text ;
TUPLE: code mode string ;
TUPLE: line ;
: absolute-url? ( string -- ? )
{ "http://" "https://" "ftp://" } [ head? ] with contains? ;
@ -34,9 +36,9 @@ TUPLE: code mode string ;
: simple-link-title ( string -- string' )
dup absolute-url? [ "/" last-split1 swap or ] unless ;
EBNF: farkup
EBNF: parse-farkup
nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
2nl = nl nl
whitespace = " " | "\t" | nl
heading1 = "=" (!("=" | nl).)+ "="
=> [[ second >string heading1 boa ]]
@ -50,6 +52,10 @@ heading3 = "===" (!("=" | nl).)+ "==="
heading4 = "====" (!("=" | nl).)+ "===="
=> [[ second >string heading4 boa ]]
heading = heading4 | heading3 | heading2 | heading1
strong = "*" (!("*" | nl).)+ "*"
=> [[ second >string strong boa ]]
@ -65,8 +71,6 @@ subscript = "~" (!("~" | nl).)+ "~"
inline-code = "%" (!("%" | nl).)+ "%"
=> [[ second >string inline-code boa ]]
escaped-char = "\" . => [[ second ]]
link-content = (!("|"|"]").)+
image-link = "[[image:" link-content "|" link-content "]]"
@ -82,44 +86,71 @@ labelled-link = "[[" link-content "|" link-content "]]"
link = image-link | labelled-link | simple-link
heading = heading4 | heading3 | heading2 | heading1
escaped-char = "\" .
=> [[ second 1string ]]
inline-tag = strong | emphasis | superscript | subscript | inline-code
| link | escaped-char
inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '['
table-column = (list | (!(nl | inline-delimiter | '|').)+ | inline-tag | inline-delimiter ) '|'
cell = (!(inline-delimiter | '|' | nl).)+
=> [[ >string ]]
table-column = (list | cell | inline-tag | inline-delimiter ) '|'
=> [[ first ]]
table-row = "|" (table-column)+
=> [[ second table-row boa ]]
table = ((table-row nl => [[ first ]] )+ table-row? | table-row)
=> [[ table boa ]]
paragraph-item = ( table | (!(nl | code | heading | inline-delimiter | table ).) | inline-tag | inline-delimiter)+
paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]]
| (paragraph-item nl)+ paragraph-item?
text = (!(nl | code | heading | inline-delimiter | table ).)+
=> [[ >string ]]
paragraph-nl-item = nl (list | line)?
paragraph-item = (table | code | text | inline-tag | inline-delimiter)+
paragraph = ((paragraph-item paragraph-nl-item)+ nl+ => [[ first ]]
| (paragraph-item paragraph-nl-item)+ paragraph-item?
| paragraph-item)
=> [[ paragraph boa ]]
list-item = '-' ((!(inline-delimiter | nl).)+ | inline-tag)*
=> [[ second list-item boa ]]
list = ((list-item nl)+ list-item? | list-item)
=> [[ list boa ]]
code = '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]"
list-item = (cell | inline-tag | inline-delimiter)*
ordered-list-item = '#' list-item
=> [[ second list-item boa ]]
ordered-list = ((ordered-list-item nl)+ ordered-list-item? | ordered-list-item)
=> [[ ordered-list boa ]]
unordered-list-item = '-' list-item
=> [[ second list-item boa ]]
unordered-list = ((unordered-list-item nl)+ unordered-list-item? | unordered-list-item)
=> [[ unordered-list boa ]]
list = ordered-list | unordered-list
line = '___'
=> [[ drop line new ]]
named-code
= '[' (!('{' | whitespace | '[').)+ '{' (!("}]").)+ "}]"
=> [[ [ second >string ] [ fourth >string ] bi code boa ]]
simple-code
= "[{" (!("}]").)+ "}]"
=> [[ second f swap code boa ]]
code = named-code | simple-code
stand-alone
= (code | simple-code | heading | list | table | paragraph | nl)*
= (line | code | heading | list | table | paragraph | nl)*
;EBNF
: invalid-url "javascript:alert('Invalid URL in farkup');" ;
: check-url ( href -- href' )
@ -136,7 +167,7 @@ stand-alone
: write-link ( href text -- )
escape-link
[ <a =href link-no-follow? get [ "true" =nofollow ] when a> ]
[ <a url-encode =href link-no-follow? get [ "true" =nofollow ] when a> ]
[ write </a> ]
bi* ;
@ -146,7 +177,7 @@ stand-alone
<strong> "Images are not allowed" write </strong>
] [
escape-link
[ <img =src ] [ [ =alt ] unless-empty img/> ] bi*
[ <img url-encode =src ] [ [ =alt ] unless-empty img/> ] bi*
] if ;
: render-code ( string mode -- string' )
@ -161,31 +192,32 @@ GENERIC: (write-farkup) ( farkup -- )
: <foo.> ( string -- ) <foo> write ;
: </foo.> ( string -- ) </foo> write ;
: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
M: heading1 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h1" in-tag. ;
M: heading2 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h2" in-tag. ;
M: heading3 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h3" in-tag. ;
M: heading4 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h4" in-tag. ;
M: strong (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "strong" in-tag. ;
M: emphasis (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "em" in-tag. ;
M: superscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sup" in-tag. ;
M: subscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sub" in-tag. ;
M: inline-code (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "code" in-tag. ;
M: list-item (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "li" in-tag. ;
M: list (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "ul" in-tag. ;
M: paragraph (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "p" in-tag. ;
M: link (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-link ;
M: image (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
M: code (write-farkup) ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
M: heading1 (write-farkup) [ child>> (write-farkup) ] "h1" in-tag. ;
M: heading2 (write-farkup) [ child>> (write-farkup) ] "h2" in-tag. ;
M: heading3 (write-farkup) [ child>> (write-farkup) ] "h3" in-tag. ;
M: heading4 (write-farkup) [ child>> (write-farkup) ] "h4" in-tag. ;
M: strong (write-farkup) [ child>> (write-farkup) ] "strong" in-tag. ;
M: emphasis (write-farkup) [ child>> (write-farkup) ] "em" in-tag. ;
M: superscript (write-farkup) [ child>> (write-farkup) ] "sup" in-tag. ;
M: subscript (write-farkup) [ child>> (write-farkup) ] "sub" in-tag. ;
M: inline-code (write-farkup) [ child>> (write-farkup) ] "code" in-tag. ;
M: list-item (write-farkup) [ child>> (write-farkup) ] "li" in-tag. ;
M: unordered-list (write-farkup) [ child>> (write-farkup) ] "ul" in-tag. ;
M: ordered-list (write-farkup) [ child>> (write-farkup) ] "ol" in-tag. ;
M: paragraph (write-farkup) [ child>> (write-farkup) ] "p" in-tag. ;
M: link (write-farkup) [ href>> ] [ text>> ] bi write-link ;
M: image (write-farkup) [ href>> ] [ text>> ] bi write-image-link ;
M: code (write-farkup) [ string>> ] [ mode>> ] bi render-code ;
M: line (write-farkup) drop <hr/> ;
M: table-row (write-farkup) ( obj -- )
obj>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
M: table (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "table" in-tag. ;
M: fixnum (write-farkup) ( obj -- ) write1 ;
M: string (write-farkup) ( obj -- ) write ;
M: vector (write-farkup) ( obj -- ) [ (write-farkup) ] each ;
M: f (write-farkup) ( obj -- ) drop ;
child>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
M: table (write-farkup) [ child>> (write-farkup) ] "table" in-tag. ;
M: string (write-farkup) escape-string write ;
M: vector (write-farkup) [ (write-farkup) ] each ;
M: f (write-farkup) drop ;
: write-farkup ( string -- )
farkup (write-farkup) ;
parse-farkup (write-farkup) ;
: convert-farkup ( string -- string' )
farkup [ (write-farkup) ] with-string-writer ;
parse-farkup [ (write-farkup) ] with-string-writer ;

View File

@ -14,7 +14,8 @@ html.elements
html.components
html.components
html.templates.chloe
html.templates.chloe.syntax ;
html.templates.chloe.syntax
html.templates.chloe.compiler ;
IN: furnace.actions
SYMBOL: params
@ -29,7 +30,8 @@ SYMBOL: rest
</ul>
] unless-empty ;
CHLOE: validation-messages drop render-validation-messages ;
CHLOE: validation-messages
drop [ render-validation-messages ] [code] ;
TUPLE: action rest authorize init display validate submit ;
@ -77,14 +79,14 @@ TUPLE: action rest authorize init display validate submit ;
: revalidate-url ( -- url/f )
revalidate-url-key param
dup [ >url [ same-host? ] keep and ] when ;
dup [ >url ensure-port [ same-host? ] keep and ] when ;
: validation-failed ( -- * )
post-request? revalidate-url and [
begin-conversation
nested-forms-key param " " split harvest nested-forms cset
form get form cset
<redirect>
<continue-conversation>
] [ <400> ] if*
exit-with ;

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1 @@
Actions and form validation

View File

@ -0,0 +1 @@
web

View File

@ -3,6 +3,7 @@
USING: kernel sequences db.tuples alarms calendar db fry
furnace.db
furnace.cache
furnace.asides
furnace.referrer
furnace.sessions
furnace.conversations
@ -10,20 +11,24 @@ furnace.auth.providers
furnace.auth.login.permits ;
IN: furnace.alloy
: <alloy> ( responder db params -- responder' )
'[
<conversations>
<sessions>
_ _ <db-persistence>
<check-form-submissions>
] call ;
: state-classes { session conversation permit } ; inline
: state-classes { session aside conversation permit } ; inline
: init-furnace-tables ( -- )
state-classes ensure-tables
user ensure-table ;
: <alloy> ( responder db params -- responder' )
[ [ init-furnace-tables ] with-db ]
[
[
<asides>
<conversations>
<sessions>
] 2dip
<db-persistence>
<check-form-submissions>
] 2bi ;
: start-expiring ( db params -- )
'[
_ _ [ state-classes [ expire-state ] each ] with-db

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1 @@
Convenience responder combines several features

View File

@ -0,0 +1 @@
web

View File

@ -0,0 +1,111 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs kernel sequences accessors hashtables
urls db.types db.tuples math.parser fry logging combinators
html.templates.chloe.syntax
http http.server http.server.filters http.server.redirection
furnace
furnace.cache
furnace.sessions
furnace.redirection ;
IN: furnace.asides
TUPLE: aside < server-state
session method url post-data ;
: <aside> ( id -- aside )
aside new-server-state ;
aside "ASIDES" {
{ "session" "SESSION" BIG-INTEGER +not-null+ }
{ "method" "METHOD" { VARCHAR 10 } }
{ "url" "URL" URL }
{ "post-data" "POST_DATA" FACTOR-BLOB }
} define-persistent
: aside-id-key "__a" ;
TUPLE: asides < server-state-manager ;
: <asides> ( responder -- responder' )
asides new-server-state-manager ;
SYMBOL: aside-id
: get-aside ( id -- aside )
dup [ aside get-state ] when check-session ;
: request-aside-id ( request -- id )
aside-id-key swap request-params at string>number ;
: request-aside ( request -- aside )
request-aside-id get-aside ;
: set-aside ( aside -- )
[ id>> aside-id set ] when* ;
: init-asides ( asides -- )
asides set
request get request-aside-id
get-aside
set-aside ;
M: asides call-responder*
[ init-asides ] [ asides set ] [ call-next-method ] tri ;
: touch-aside ( aside -- )
asides get touch-state ;
: begin-aside ( url -- )
f <aside>
swap >>url
session get id>> >>session
request get method>> >>method
request get post-data>> >>post-data
[ touch-aside ] [ insert-tuple ] [ set-aside ] tri ;
: end-aside-post ( aside -- response )
[ url>> ] [ post-data>> ] bi
request [
clone
swap >>post-data
over >>url
] change
[ url set ] [ path>> split-path ] bi
asides get responder>> call-responder ;
\ end-aside-post DEBUG add-input-logging
ERROR: end-aside-in-get-error ;
: move-on ( id -- response )
post-request? [ end-aside-in-get-error ] unless
dup method>> {
{ "GET" [ url>> <redirect> ] }
{ "HEAD" [ url>> <redirect> ] }
{ "POST" [ end-aside-post ] }
} case ;
: end-aside ( default -- response )
aside-id get aside-id off get-aside [ move-on ] [ <redirect> ] ?if ;
M: asides link-attr ( tag -- )
drop
"aside" optional-attr {
{ "none" [ aside-id off ] }
{ "begin" [ url get begin-aside ] }
{ "current" [ ] }
{ f [ ] }
} case ;
M: asides modify-query ( query asides -- query' )
drop
aside-id get [
aside-id-key associate assoc-union
] when* ;
M: asides modify-form ( asides -- )
drop
aside-id get
aside-id-key
hidden-form-field ;

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1 @@
Asides start an interaction which can return to the original page

View File

@ -0,0 +1 @@
web

View File

@ -3,7 +3,7 @@
USING: accessors assocs namespaces kernel sequences sets
destructors combinators fry logging
io.encodings.utf8 io.encodings.string io.binary random
checksums checksums.sha2
checksums checksums.sha2 urls
html.forms
http.server
http.server.filters
@ -60,6 +60,10 @@ TUPLE: realm < dispatcher name users checksum secure ;
GENERIC: login-required* ( description capabilities realm -- response )
GENERIC: user-registered ( user realm -- response )
M: object user-registered 2drop URL" $realm" <redirect> ;
GENERIC: init-realm ( realm -- )
GENERIC: logged-in-username ( realm -- username )

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1 @@
Basic client authentication

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs namespaces accessors db db.tuples urls
http.server.dispatchers
furnace.conversations
furnace.asides
furnace.actions
furnace.auth
furnace.auth.providers ;

View File

@ -0,0 +1 @@
Allow users to deactivate their accounts

View File

@ -0,0 +1 @@
web

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -3,8 +3,8 @@
USING: kernel accessors namespaces sequences assocs
validators urls html.forms http.server.dispatchers
furnace.auth
furnace.actions
furnace.conversations ;
furnace.asides
furnace.actions ;
IN: furnace.auth.features.edit-profile
: <edit-profile-action> ( -- action )

View File

@ -4,7 +4,7 @@
<t:title>Edit Profile</t:title>
<t:form t:action="$realm/edit-profile">
<t:form t:action="$realm/edit-profile" autocomplete="off">
<table>
@ -61,7 +61,7 @@
</table>
<p>
<input type="submit" value="Update" />
<button>Update</button>
<t:validation-messages />
</p>

View File

@ -0,0 +1 @@
Allow users to edit account info

View File

@ -0,0 +1 @@
web

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -32,7 +32,7 @@
</table>
<input type="submit" value="Recover password" />
<button>Recover password</button>
</t:form>

View File

@ -31,7 +31,7 @@
</table>
<p>
<input type="submit" value="Set password" />
<button>Set password</button>
<t:validation-messages />
</p>

View File

@ -19,7 +19,7 @@ SYMBOL: lost-password-from
[ username>> "username" set-query-param ]
[ ticket>> "ticket" set-query-param ]
bi
adjust-url relative-to-request ;
adjust-url ;
: password-email ( user -- email )
<email>

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