diff --git a/basis/alarms/summary.txt b/basis/alarms/summary.txt new file mode 100644 index 0000000000..f6e12238fa --- /dev/null +++ b/basis/alarms/summary.txt @@ -0,0 +1 @@ +One-time and recurring events diff --git a/basis/alias/summary.txt b/basis/alias/summary.txt new file mode 100644 index 0000000000..15690a7b9b --- /dev/null +++ b/basis/alias/summary.txt @@ -0,0 +1 @@ +Defining multiple words with the same name diff --git a/basis/ascii/ascii-docs.factor b/basis/ascii/ascii-docs.factor index 75af8a7102..6af697cf89 100755 --- a/basis/ascii/ascii-docs.factor +++ b/basis/ascii/ascii-docs.factor @@ -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" diff --git a/basis/binary-search/summary.txt b/basis/binary-search/summary.txt new file mode 100644 index 0000000000..c4fd4f2774 --- /dev/null +++ b/basis/binary-search/summary.txt @@ -0,0 +1 @@ +Fast searching of sorted arrays diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 9284728a7a..f3f570b462 100755 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -26,7 +26,6 @@ IN: bootstrap.image "x86.32" "x86.64" "linux-ppc" "macosx-ppc" - ! "arm" } ; 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 ; diff --git a/basis/bootstrap/random/random.factor b/basis/bootstrap/random/random.factor index 3782d517cf..f6527cdda1 100755 --- a/basis/bootstrap/random/random.factor +++ b/basis/bootstrap/random/random.factor @@ -13,4 +13,4 @@ IN: bootstrap.random [ [ 32 random-bits ] with-system-random random-generator set-global -] "generator.random" add-init-hook +] "bootstrap.random" add-init-hook diff --git a/basis/boxes/summary.txt b/basis/boxes/summary.txt new file mode 100644 index 0000000000..44c1352e36 --- /dev/null +++ b/basis/boxes/summary.txt @@ -0,0 +1 @@ +An abstraction for enforcing a mutual-exclusion invariant diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 62ff4ad517..c3d84fc783 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -21,8 +21,8 @@ HELP: { $description "Returns a timestamp object representing the start of the specified day in your current timezone." } { $examples { $example "USING: calendar prettyprint ;" - "2010 12 25 ." - "T{ timestamp\n { year 2010 }\n { month 12 }\n { day 25 }\n { gmt-offset T{ duration { hour -5 } } }\n}" + "2010 12 25 >gmt midnight ." + "T{ timestamp { year 2010 } { month 12 } { day 25 } }" } } ; diff --git a/basis/calendar/format/format-tests.factor b/basis/calendar/format/format-tests.factor index c433a118c2..81930cdf49 100755 --- a/basis/calendar/format/format-tests.factor +++ b/basis/calendar/format/format-tests.factor @@ -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 diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index bfe438fae1..b15da42409 100755 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -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 diff --git a/basis/channels/channels-docs.factor b/basis/channels/channels-docs.factor index 521a4a4ae2..b6ddc299e5 100644 --- a/basis/channels/channels-docs.factor +++ b/basis/channels/channels-docs.factor @@ -33,3 +33,14 @@ HELP: from " It will block the calling thread until there is data in the channel." } { $see-also to } ; + +ARTICLE: "channels" "Channels" +"The " { $vocab-link "channels" } " vocabulary provides a simple abstraction to send and receive objects." $nl +"Opening a channel:" +{ $subsection } +"Sending a message:" +{ $subsection to } +"Receiving a message:" +{ $subsection from } ; + +ABOUT: "channels" diff --git a/basis/channels/remote/tags.txt b/basis/channels/remote/tags.txt index f4274299b1..ce745d18c6 100644 --- a/basis/channels/remote/tags.txt +++ b/basis/channels/remote/tags.txt @@ -1 +1 @@ -extensions +concurrency diff --git a/basis/channels/tags.txt b/basis/channels/tags.txt index f4274299b1..ce745d18c6 100644 --- a/basis/channels/tags.txt +++ b/basis/channels/tags.txt @@ -1 +1 @@ -extensions +concurrency diff --git a/basis/circular/circular-docs.factor b/basis/circular/circular-docs.factor new file mode 100644 index 0000000000..c7af57c1fe --- /dev/null +++ b/basis/circular/circular-docs.factor @@ -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: +{ $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: +{ $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: +{ $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 } +{ $subsection } +{ $subsection } +"Changing the start index:" +{ $subsection change-circular-start } +"Pushing new elements:" +{ $subsection push-circular } +{ $subsection push-growing-circular } ; + +ABOUT: "circular" diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index 5d2378120f..9f3a71f2a8 100755 --- a/basis/circular/circular.factor +++ b/basis/circular/circular.factor @@ -11,9 +11,11 @@ TUPLE: circular seq start ; : ( seq -- circular ) 0 circular boa ; +> + ] 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>> ; +> length ] bi = ; : set-peek ( elt seq -- ) [ length 1- ] keep set-nth ; +PRIVATE> : push-growing-circular ( elt circular -- ) dup full? [ push-circular ] diff --git a/basis/cocoa/cocoa-docs.factor b/basis/cocoa/cocoa-docs.factor index 01b0809f37..a971288251 100644 --- a/basis/cocoa/cocoa-docs.factor +++ b/basis/cocoa/cocoa-docs.factor @@ -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: -> } diff --git a/basis/colors/summary.txt b/basis/colors/summary.txt new file mode 100644 index 0000000000..a90b1aaf76 --- /dev/null +++ b/basis/colors/summary.txt @@ -0,0 +1 @@ +Colors as a first-class data type diff --git a/basis/columns/columns-docs.factor b/basis/columns/columns-docs.factor index 818ce2f752..27dc160812 100644 --- a/basis/columns/columns-docs.factor +++ b/basis/columns/columns-docs.factor @@ -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 } -"A utility word:" -{ $subsection } ; - 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 } "." } ; @@ -30,4 +23,11 @@ HELP: { $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 } +"A utility word:" +{ $subsection } ; + ABOUT: "columns" diff --git a/basis/combinators/short-circuit/short-circuit-docs.factor b/basis/combinators/short-circuit/short-circuit-docs.factor new file mode 100644 index 0000000000..54fc3aac43 --- /dev/null +++ b/basis/combinators/short-circuit/short-circuit-docs.factor @@ -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" diff --git a/basis/combinators/short-circuit/smart/smart-docs.factor b/basis/combinators/short-circuit/smart/smart-docs.factor new file mode 100644 index 0000000000..34abde15b6 --- /dev/null +++ b/basis/combinators/short-circuit/smart/smart-docs.factor @@ -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" diff --git a/basis/command-line/command-line-docs.factor b/basis/command-line/command-line-docs.factor index 440896deac..d1b18ab5da 100644 --- a/basis/command-line/command-line-docs.factor +++ b/basis/command-line/command-line-docs.factor @@ -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." } ; diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 80f0b4f515..b5b2be5095 100755 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -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 ; diff --git a/basis/compiler/generator/generator-docs.factor b/basis/compiler/generator/generator-docs.factor index 45238ab00a..5d485b13d4 100755 --- a/basis/compiler/generator/generator-docs.factor +++ b/basis/compiler/generator/generator-docs.factor @@ -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? } diff --git a/basis/compiler/intrinsics/intrinsics.factor b/basis/compiler/intrinsics/intrinsics.factor index b995e6d737..471c05ee59 100644 --- a/basis/compiler/intrinsics/intrinsics.factor +++ b/basis/compiler/intrinsics/intrinsics.factor @@ -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 diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 0891a6629c..5f8de4eb49 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -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>> \ eq? [ dup in-d>> peek node-value-info diff --git a/basis/concurrency/combinators/combinators.factor b/basis/concurrency/combinators/combinators.factor index eab0ed4cb4..ab3ca7ed4a 100755 --- a/basis/concurrency/combinators/combinators.factor +++ b/basis/concurrency/combinators/combinators.factor @@ -4,8 +4,10 @@ USING: concurrency.futures concurrency.count-downs sequences kernel ; IN: concurrency.combinators +r 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 + : parallel-map ( seq quot -- newseq ) [ curry future ] curry map future-values ; diff --git a/basis/concurrency/combinators/tags.txt b/basis/concurrency/combinators/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/combinators/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/conditions/tags.txt b/basis/concurrency/conditions/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/conditions/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/count-downs/count-downs.factor b/basis/concurrency/count-downs/count-downs.factor index 93cef250a1..c4bc92c688 100755 --- a/basis/concurrency/count-downs/count-downs.factor +++ b/basis/concurrency/count-downs/count-downs.factor @@ -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 ; + : ( n -- count-down ) - dup 0 < [ "Invalid count for count down" throw ] when + dup 0 < [ invalid-count-down-count ] when \ 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 -- ) diff --git a/basis/concurrency/count-downs/tags.txt b/basis/concurrency/count-downs/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/count-downs/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/distributed/tags.txt b/basis/concurrency/distributed/tags.txt index 50cfa263f6..b7861c6689 100644 --- a/basis/concurrency/distributed/tags.txt +++ b/basis/concurrency/distributed/tags.txt @@ -1,2 +1,2 @@ +concurrency enterprise -extensions diff --git a/basis/concurrency/exchangers/tags.txt b/basis/concurrency/exchangers/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/exchangers/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/flags/tags.txt b/basis/concurrency/flags/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/flags/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/futures/tags.txt b/basis/concurrency/futures/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/futures/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/locks/tags.txt b/basis/concurrency/locks/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/locks/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/mailboxes/tags.txt b/basis/concurrency/mailboxes/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/mailboxes/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor index 12b5d270d4..03d1304527 100755 --- a/basis/concurrency/messaging/messaging.factor +++ b/basis/concurrency/messaging/messaging.factor @@ -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 dup r> send [ synchronous-reply? ] curry receive-if diff --git a/basis/concurrency/messaging/tags.txt b/basis/concurrency/messaging/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/messaging/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/promises/promises.factor b/basis/concurrency/promises/promises.factor index 511decdf35..382697e04f 100755 --- a/basis/concurrency/promises/promises.factor +++ b/basis/concurrency/promises/promises.factor @@ -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 ; diff --git a/basis/concurrency/promises/tags.txt b/basis/concurrency/promises/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/promises/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/semaphores/tags.txt b/basis/concurrency/semaphores/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/semaphores/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index bb21391f0a..6bec4b23c0 100644 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -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 diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 5ffcafbbaf..e30cc2eb60 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -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 diff --git a/basis/core-foundation/run-loop/thread/thread.factor b/basis/core-foundation/run-loop/thread/thread.factor new file mode 100644 index 0000000000..326226ec0e --- /dev/null +++ b/basis/core-foundation/run-loop/thread/thread.factor @@ -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 diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index f8e3956b3e..74b72b8789 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -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" diff --git a/basis/db/db.factor b/basis/db/db.factor index eac22a2999..87bf21d261 100755 --- a/basis/db/db.factor +++ b/basis/db/db.factor @@ -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 -- ) diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index 38fa4cc715..28548d1260 100755 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -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 ( 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 ( 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 ; diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index 89c28b5262..f7809de578 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -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 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 ( 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 ( tuple table -- sql ) [ @@ -168,7 +172,7 @@ M: db ( 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 ( tuple class -- statement ) [ offset>> [ do-offset ] [ drop ] if* ] } 2cleave ; -M: db ( tuple class query -- tuple ) - [ ] dip make-query ; +M: db query>statement ( query -- tuple ) + [ tuple>> dup class ] keep + [ ] dip make-query* ; ! select ID, NAME, SCORE from EXAM limit 1 offset 3 @@ -194,11 +199,10 @@ M: db ( tuple class query -- tuple ) >r >r parse-sql 4drop r> r> maybe-make-retryable do-select ; -M: db ( tuple class groups -- statement ) - \ query new - swap >>group +M: db ( 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 -- ) [ diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 1eb9b566d3..aab1e5f40f 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -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 ; diff --git a/basis/db/tuples/tuples-docs.factor b/basis/db/tuples/tuples-docs.factor index 26ecec0365..d7ee3a5ad2 100644 --- a/basis/db/tuples/tuples-docs.factor +++ b/basis/db/tuples/tuples-docs.factor @@ -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" diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 67e46f9e18..6a5e78aa4b 100755 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -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 ; : ( 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 ] [ + + 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 ; diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor index 3c3bae3adc..7f567697d2 100755 --- a/basis/db/tuples/tuples.factor +++ b/basis/db/tuples/tuples.factor @@ -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 ; - + db ( class -- object ) HOOK: db ( class -- object ) HOOK: db ( tuple class -- object ) HOOK: db ( tuple class -- tuple ) -TUPLE: query group order offset limit ; -HOOK: db ( tuple class query -- statement' ) -HOOK: db ( tuple class groups -- n ) +HOOK: 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>> [ ] cache + [ bind-tuple ] 2keep insert-tuple-set-key ; + +: insert-user-assigned-statement ( tuple -- ) + dup class + db get insert-statements>> [ ] 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 new ; + +GENERIC: >query ( object -- query ) + +M: query >query clone ; + +M: tuple >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>> [ ] cache - [ bind-tuple ] 2keep insert-tuple* ; - -: insert-user-assigned-statement ( tuple -- ) - dup class - db get insert-statements>> [ ] 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 do-select ; - -: select-tuples ( tuple -- tuples ) - dup dup class do-select ; - -: select-tuple ( tuple -- tuple/f ) - dup dup class \ query new 1 >>limit 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> do-count +: count-tuples ( query/tuple -- n ) + >query [ tuple>> ] [ ] bi do-count dup length 1 = [ first first string>number ] [ [ first string>number ] map ] if ; diff --git a/basis/db/types/types-docs.factor b/basis/db/types/types-docs.factor index 9300a68f2e..401bbbc4d7 100644 --- a/basis/db/types/types-docs.factor +++ b/basis/db/types/types-docs.factor @@ -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: { $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" diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index 24344acbf7..bc33792e52 100755 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -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 -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 ; diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index b7fd34c5be..ec93a01c19 100755 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -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" ; diff --git a/basis/delegate/delegate-docs.factor b/basis/delegate/delegate-docs.factor index 93bf70b950..0d2f94c13d 100644 --- a/basis/delegate/delegate-docs.factor +++ b/basis/delegate/delegate-docs.factor @@ -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" } diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index 45cc214792..12860337ff 100755 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -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 diff --git a/basis/deques/deques-docs.factor b/basis/deques/deques-docs.factor index 5a4b33887b..58f077ed1e 100644 --- a/basis/deques/deques-docs.factor +++ b/basis/deques/deques-docs.factor @@ -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" diff --git a/basis/disjoint-sets/disjoint-sets-docs.factor b/basis/disjoint-sets/disjoint-sets-docs.factor index 40e14b7fca..cded25b48d 100644 --- a/basis/disjoint-sets/disjoint-sets-docs.factor +++ b/basis/disjoint-sets/disjoint-sets-docs.factor @@ -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 diff --git a/basis/editors/macvim/authors.txt b/basis/editors/macvim/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/basis/editors/macvim/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/basis/editors/macvim/macvim.factor b/basis/editors/macvim/macvim.factor new file mode 100755 index 0000000000..b5f864dcd0 --- /dev/null +++ b/basis/editors/macvim/macvim.factor @@ -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 + + diff --git a/basis/editors/macvim/summary.txt b/basis/editors/macvim/summary.txt new file mode 100644 index 0000000000..894d635b47 --- /dev/null +++ b/basis/editors/macvim/summary.txt @@ -0,0 +1 @@ +MacVim editor integration diff --git a/basis/editors/macvim/tags.txt b/basis/editors/macvim/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/macvim/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/textedit/authors.txt b/basis/editors/textedit/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/basis/editors/textedit/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/basis/editors/textedit/summary.txt b/basis/editors/textedit/summary.txt new file mode 100644 index 0000000000..1d72d10db0 --- /dev/null +++ b/basis/editors/textedit/summary.txt @@ -0,0 +1 @@ +TextEdit editor integration diff --git a/basis/editors/textedit/tags.txt b/basis/editors/textedit/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/textedit/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/textedit/textedit.factor b/basis/editors/textedit/textedit.factor new file mode 100755 index 0000000000..6942e24534 --- /dev/null +++ b/basis/editors/textedit/textedit.factor @@ -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 + + diff --git a/basis/eval/authors.txt b/basis/eval/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/eval/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/eval/summary.txt b/basis/eval/summary.txt new file mode 100644 index 0000000000..679f074e90 --- /dev/null +++ b/basis/eval/summary.txt @@ -0,0 +1 @@ +Ad-hoc evaluation of strings of code diff --git a/basis/farkup/farkup-docs.factor b/basis/farkup/farkup-docs.factor index f2d53d2362..8e7270cc01 100644 --- a/basis/farkup/farkup-docs.factor +++ b/basis/farkup/farkup-docs.factor @@ -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" } ; diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index e25fa34960..27911a8d13 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -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 [ "

a-b

" ] [ "a-b" convert-farkup ] unit-test @@ -37,22 +35,30 @@ link-no-follow? off [ "
  • foo
    • \n

bar\n

" ] [ "-foo\nbar\n" convert-farkup ] unit-test +[ "
  1. a-b
" ] [ "#a-b" convert-farkup ] unit-test +[ "
  1. foo
" ] [ "#foo" convert-farkup ] unit-test +[ "
  1. foo
    2. \n
" ] [ "#foo\n" convert-farkup ] unit-test +[ "
  1. foo
    2. \n
  2. bar
" ] [ "#foo\n#bar" convert-farkup ] unit-test +[ "
  1. foo
    2. \n
  2. bar
    3. \n
" ] [ "#foo\n#bar\n" convert-farkup ] unit-test + +[ "
  1. foo
    2. \n

bar\n

" ] [ "#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 -[ "

foo

bar

" ] [ "foo\n\nbar" convert-farkup ] unit-test -[ "

foo

bar

" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test -[ "

foo

bar

" ] [ "foo\r\rbar" convert-farkup ] unit-test -[ "

foo

bar

" ] [ "foo\r\r\nbar" convert-farkup ] unit-test +[ "

foo\n

bar

" ] [ "foo\n\nbar" convert-farkup ] unit-test +[ "

foo\n

bar

" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test +[ "

foo\n

bar

" ] [ "foo\r\rbar" convert-farkup ] unit-test +[ "

foo\n

bar

" ] [ "foo\r\r\nbar" convert-farkup ] unit-test [ "\n

bar\n

" ] [ "\nbar\n" convert-farkup ] unit-test [ "\n

bar\n

" ] [ "\rbar\r" convert-farkup ] unit-test [ "\n

bar\n

" ] [ "\r\nbar\r\n" convert-farkup ] unit-test -[ "

foo

bar

" ] [ "foo\n\n\nbar" convert-farkup ] unit-test +[ "

foo\n

bar

" ] [ "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 [ - "

Feature comparison:

aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes
" + "

Feature comparison:\n

aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes
" ] [ "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 [ "

a c

" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test + +[ "

C++

" ] [ "[[C++]]" convert-farkup ] unit-test + +[ "

<foo>

" ] [ "" convert-farkup ] unit-test + +[ "

asdf\n

  • lol
    • \n
  • haha

" ] [ "asdf\n-lol\n-haha" convert-farkup ] unit-test + +[ "

asdf\n

  • lol
    • \n
  • haha
" ] + [ "asdf\n\n-lol\n-haha" convert-farkup ] unit-test + +[ "
" ] [ "___" convert-farkup ] unit-test +[ "
\n" ] [ "___\n" convert-farkup ] unit-test + +[ "

before:\n

{ 1 2 3 } 1 tail\n

" ] +[ "before:\n[factor{{ 1 2 3 } 1 tail}]" convert-farkup ] unit-test + +[ "

Factor-rific!

" ] +[ "[[Factor]]-rific!" convert-farkup ] unit-test + +[ "

[ factor { 1 2 3 }]

" ] +[ "[ factor { 1 2 3 }]" convert-farkup ] unit-test + +[ "

paragraph\n

" ] +[ "paragraph\n___" convert-farkup ] unit-test + +[ "

paragraph\n a ___ b

" ] +[ "paragraph\n a ___ b" convert-farkup ] unit-test + +[ "\n
  • a
    • \n
" ] +[ "\n- a\n___" convert-farkup ] unit-test + +[ "

hello_world how are you today?\n

  • hello_world how are you today?

" ] +[ "hello_world how are you today?\n- hello_world how are you today?" convert-farkup ] unit-test diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index 4d6ac127ad..73b0cba4d0 100644 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -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 - [ ] + [ ] [ write ] bi* ; @@ -146,7 +177,7 @@ stand-alone "Images are not allowed" write ] [ escape-link - [ ] bi* + [ ] bi* ] if ; : render-code ( string mode -- string' ) @@ -161,31 +192,32 @@ GENERIC: (write-farkup) ( farkup -- ) : ( string -- ) write ; : ( string -- ) write ; : in-tag. ( obj quot string -- ) [ call ] keep ; 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
; 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 ; diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index cce098f208..7505b3c612 100755 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -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 ] 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 - + ] [ <400> ] if* exit-with ; diff --git a/basis/furnace/actions/authors.txt b/basis/furnace/actions/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/furnace/actions/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/furnace/actions/summary.txt b/basis/furnace/actions/summary.txt new file mode 100644 index 0000000000..53b775adda --- /dev/null +++ b/basis/furnace/actions/summary.txt @@ -0,0 +1 @@ +Actions and form validation diff --git a/basis/furnace/actions/tags.txt b/basis/furnace/actions/tags.txt new file mode 100644 index 0000000000..c0772185a0 --- /dev/null +++ b/basis/furnace/actions/tags.txt @@ -0,0 +1 @@ +web diff --git a/basis/furnace/alloy/alloy.factor b/basis/furnace/alloy/alloy.factor index 6f5f6fdbf6..decee690a3 100644 --- a/basis/furnace/alloy/alloy.factor +++ b/basis/furnace/alloy/alloy.factor @@ -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 -: ( responder db params -- responder' ) - '[ - - - _ _ - - ] call ; - -: state-classes { session conversation permit } ; inline +: state-classes { session aside conversation permit } ; inline : init-furnace-tables ( -- ) state-classes ensure-tables user ensure-table ; +: ( responder db params -- responder' ) + [ [ init-furnace-tables ] with-db ] + [ + [ + + + + ] 2dip + + + ] 2bi ; + : start-expiring ( db params -- ) '[ _ _ [ state-classes [ expire-state ] each ] with-db diff --git a/basis/furnace/alloy/authors.txt b/basis/furnace/alloy/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/furnace/alloy/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/furnace/alloy/summary.txt b/basis/furnace/alloy/summary.txt new file mode 100644 index 0000000000..7bad952903 --- /dev/null +++ b/basis/furnace/alloy/summary.txt @@ -0,0 +1 @@ +Convenience responder combines several features diff --git a/basis/furnace/alloy/tags.txt b/basis/furnace/alloy/tags.txt new file mode 100644 index 0000000000..c0772185a0 --- /dev/null +++ b/basis/furnace/alloy/tags.txt @@ -0,0 +1 @@ +web diff --git a/basis/furnace/asides/asides.factor b/basis/furnace/asides/asides.factor new file mode 100644 index 0000000000..6d4196cf0b --- /dev/null +++ b/basis/furnace/asides/asides.factor @@ -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 ; + +: