From ff9610f99aa4b2cd8bcd0fb4a173930cfdfbb55d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 29 Sep 2008 20:19:47 -0500 Subject: [PATCH 01/11] moved sql to unfinished --- unfinished/sql/sql-tests.factor | 42 ++++++++ unfinished/sql/sql.factor | 172 ++++++++++++++++++++++++++++++++ 2 files changed, 214 insertions(+) create mode 100644 unfinished/sql/sql-tests.factor create mode 100755 unfinished/sql/sql.factor diff --git a/unfinished/sql/sql-tests.factor b/unfinished/sql/sql-tests.factor new file mode 100644 index 0000000000..0b57c2d8fa --- /dev/null +++ b/unfinished/sql/sql-tests.factor @@ -0,0 +1,42 @@ +USING: kernel namespaces db.sql sequences math ; +IN: db.sql.tests + +! TUPLE: person name age ; +: insert-1 + { insert + { + { table "person" } + { columns "name" "age" } + { values "erg" 26 } + } + } ; + +: update-1 + { update "person" + { set { "name" "erg" } + { "age" 6 } } + { where { "age" 6 } } + } ; + +: select-1 + { select + { columns + "branchno" + { count "staffno" as "mycount" } + { sum "salary" as "mysum" } } + { from "staff" "lol" } + { where + { "salary" > all + { select + { columns "salary" } + { from "staff" } + { where { "branchno" = "b003" } } + } + } + { "branchno" > 3 } } + { group-by "branchno" "lol2" } + { having { count "staffno" > 1 } } + { order-by "branchno" } + { offset 40 } + { limit 20 } + } ; diff --git a/unfinished/sql/sql.factor b/unfinished/sql/sql.factor new file mode 100755 index 0000000000..ba0673ae24 --- /dev/null +++ b/unfinished/sql/sql.factor @@ -0,0 +1,172 @@ +USING: kernel parser quotations classes.tuple words math.order +nmake namespaces sequences arrays combinators +prettyprint strings math.parser math symbols db ; +IN: db.sql + +SYMBOLS: insert update delete select distinct columns from as +where group-by having order-by limit offset is-null desc all +any count avg table values ; + +: input-spec, ( obj -- ) 1, ; +: output-spec, ( obj -- ) 2, ; +: input, ( obj -- ) 3, ; +: output, ( obj -- ) 4, ; + +DEFER: sql% + +: (sql-interleave) ( seq sep -- ) + [ sql% ] curry [ sql% ] interleave ; + +: sql-interleave ( seq str sep -- ) + swap sql% (sql-interleave) ; + +: sql-function, ( seq function -- ) + sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ; + +: sql-where, ( seq -- ) + [ + [ second 0, ] + [ first 0, ] + [ third 1, \ ? 0, ] tri + ] each ; + +HOOK: sql-create db ( object -- ) +M: db sql-create ( object -- ) + drop + "create table" sql% ; + +HOOK: sql-drop db ( object -- ) +M: db sql-drop ( object -- ) + drop + "drop table" sql% ; + +HOOK: sql-insert db ( object -- ) +M: db sql-insert ( object -- ) + drop + "insert into" sql% ; + +HOOK: sql-update db ( object -- ) +M: db sql-update ( object -- ) + drop + "update" sql% ; + +HOOK: sql-delete db ( object -- ) +M: db sql-delete ( object -- ) + drop + "delete" sql% ; + +HOOK: sql-select db ( object -- ) +M: db sql-select ( object -- ) + "select" sql% "," (sql-interleave) ; + +HOOK: sql-columns db ( object -- ) +M: db sql-columns ( object -- ) + "," (sql-interleave) ; + +HOOK: sql-from db ( object -- ) +M: db sql-from ( object -- ) + "from" "," sql-interleave ; + +HOOK: sql-where db ( object -- ) +M: db sql-where ( object -- ) + "where" 0, sql-where, ; + +HOOK: sql-group-by db ( object -- ) +M: db sql-group-by ( object -- ) + "group by" "," sql-interleave ; + +HOOK: sql-having db ( object -- ) +M: db sql-having ( object -- ) + "having" "," sql-interleave ; + +HOOK: sql-order-by db ( object -- ) +M: db sql-order-by ( object -- ) + "order by" "," sql-interleave ; + +HOOK: sql-offset db ( object -- ) +M: db sql-offset ( object -- ) + "offset" sql% sql% ; + +HOOK: sql-limit db ( object -- ) +M: db sql-limit ( object -- ) + "limit" sql% sql% ; + +! GENERIC: sql-subselect db ( object -- ) +! M: db sql-subselectselect ( object -- ) + ! "(select" sql% sql% ")" sql% ; + +HOOK: sql-table db ( object -- ) +M: db sql-table ( object -- ) + sql% ; + +HOOK: sql-set db ( object -- ) +M: db sql-set ( object -- ) + "set" "," sql-interleave ; + +HOOK: sql-values db ( object -- ) +M: db sql-values ( object -- ) + "values(" sql% "," (sql-interleave) ")" sql% ; + +HOOK: sql-count db ( object -- ) +M: db sql-count ( object -- ) + "count" sql-function, ; + +HOOK: sql-sum db ( object -- ) +M: db sql-sum ( object -- ) + "sum" sql-function, ; + +HOOK: sql-avg db ( object -- ) +M: db sql-avg ( object -- ) + "avg" sql-function, ; + +HOOK: sql-min db ( object -- ) +M: db sql-min ( object -- ) + "min" sql-function, ; + +HOOK: sql-max db ( object -- ) +M: db sql-max ( object -- ) + "max" sql-function, ; + +: sql-array% ( array -- ) + unclip + { + { \ create [ sql-create ] } + { \ drop [ sql-drop ] } + { \ insert [ sql-insert ] } + { \ update [ sql-update ] } + { \ delete [ sql-delete ] } + { \ select [ sql-select ] } + { \ columns [ sql-columns ] } + { \ from [ sql-from ] } + { \ where [ sql-where ] } + { \ group-by [ sql-group-by ] } + { \ having [ sql-having ] } + { \ order-by [ sql-order-by ] } + { \ offset [ sql-offset ] } + { \ limit [ sql-limit ] } + { \ table [ sql-table ] } + { \ set [ sql-set ] } + { \ values [ sql-values ] } + { \ count [ sql-count ] } + { \ sum [ sql-sum ] } + { \ avg [ sql-avg ] } + { \ min [ sql-min ] } + { \ max [ sql-max ] } + [ sql% [ sql% ] each ] + } case ; + +ERROR: no-sql-match ; +: sql% ( obj -- ) + { + { [ dup string? ] [ 0, ] } + { [ dup array? ] [ sql-array% ] } + { [ dup number? ] [ number>string sql% ] } + { [ dup symbol? ] [ unparse sql% ] } + { [ dup word? ] [ unparse sql% ] } + { [ dup quotation? ] [ call ] } + [ no-sql-match ] + } cond ; + +: parse-sql ( obj -- sql in-spec out-spec in out ) + [ [ sql% ] each ] { { } { } { } } nmake + [ " " join ] 2dip ; From 932d59747dc4cdbe7c0c18fafe0fca6173636814 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 29 Sep 2008 20:20:43 -0500 Subject: [PATCH 02/11] fix typo --- basis/locals/locals-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index 748c206cc0..c07255547f 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -85,7 +85,7 @@ HELP: MEMO:: { POSTPONE: MEMO: POSTPONE: MEMO:: } related-words ARTICLE: "locals-mutable" "Mutable locals" -"In the list of bindings supplied to " { $link POSTPONE: :: } ", " { $link POSTPONE: [let } ", " { $link POSTPONE: [let* } " or " { $link POSTPONE: [| } ", a mutable binding may be introduced by suffixing its named with " { $snippet "!" } ". Mutable bindings are read by giving their name as usual; the suffix is not part of the binding's name. To write to a mutable binding, use the binding's with the " { $snippet "!" } " suffix." +"In the list of bindings supplied to " { $link POSTPONE: :: } ", " { $link POSTPONE: [let } ", " { $link POSTPONE: [let* } " or " { $link POSTPONE: [| } ", a mutable binding may be introduced by suffixing its named with " { $snippet "!" } ". Mutable bindings are read by giving their name as usual; the suffix is not part of the binding's name. To write to a mutable binding, use the binding's name with the " { $snippet "!" } " suffix." $nl "Here is a example word which outputs a pair of quotations which increment and decrement an internal counter, and then return the new value. The quotations are closed over the counter and each invocation of the word yields new quotations with their unique internal counter:" { $code From 908d41a305c03507e12b5e22d4169293925e5836 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 29 Sep 2008 20:21:12 -0500 Subject: [PATCH 03/11] minor change --- extra/html/parser/analyzer/analyzer.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 47cd4dbbc6..273b39e714 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -8,8 +8,8 @@ IN: html.parser.analyzer TUPLE: link attributes clickable ; -: scrape-html ( url -- vector ) - http-get nip parse-html ; +: scrape-html ( url -- headers vector ) + http-get parse-html ; : find-all ( seq quot -- alist ) [ >alist ] [ '[ second @ ] ] bi* filter ; inline From 34ce3e13e4696a911beaae93b66c8c4ca93acabc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 29 Sep 2008 23:43:34 -0500 Subject: [PATCH 04/11] add foreign key integrity to sqlite --- basis/db/queries/queries.factor | 32 +++--- basis/db/sql/sql-tests.factor | 42 ------- basis/db/sql/sql.factor | 172 ---------------------------- basis/db/sqlite/sqlite.factor | 109 +++++++++++++++++- basis/db/tuples/tuples-tests.factor | 97 ++++++++++++---- basis/db/types/types.factor | 15 ++- 6 files changed, 208 insertions(+), 259 deletions(-) delete mode 100644 basis/db/sql/sql-tests.factor delete mode 100755 basis/db/sql/sql.factor diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index f7809de578..e3322ada44 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 db.tuples.private ; +destructors continuations db.tuples.private prettyprint ; IN: db.queries GENERIC: where ( specs obj -- ) @@ -45,11 +45,16 @@ M: retryable execute-statement* ( statement type -- ) : sql-props ( class -- columns table ) [ db-columns ] [ db-table ] bi ; -: query-make ( class quot -- ) +: query-make ( class quot -- statements ) + #! query, input, outputs, secondary queries + over unparse "table" set [ sql-props ] dip [ 0 sql-counter rot with-variable ] curry - { "" { } { } } nmake - maybe-make-retryable ; inline + { "" { } { } { } } nmake + [ maybe-make-retryable ] dip + [ + [ 1array ] dip append + ] unless-empty ; inline : where-primary-key% ( specs -- ) " where " 0% @@ -152,25 +157,20 @@ M: db ( tuple class -- statement ) where-clause ] query-make ; +: splice ( string1 string2 string3 -- string ) + swap 3append ; + : do-group ( tuple groups -- ) - [ - ", " join " group by " swap 3append - ] curry change-sql drop ; + [ ", " join " group by " splice ] curry change-sql drop ; : do-order ( tuple order -- ) - [ - ", " join " order by " swap 3append - ] curry change-sql drop ; + [ ", " join " order by " splice ] curry change-sql drop ; : do-offset ( tuple n -- ) - [ - number>string " offset " swap 3append - ] curry change-sql drop ; + [ number>string " offset " splice ] curry change-sql drop ; : do-limit ( tuple n -- ) - [ - number>string " limit " swap 3append - ] curry change-sql drop ; + [ number>string " limit " splice ] curry change-sql drop ; : make-query* ( tuple query -- tuple' ) dupd diff --git a/basis/db/sql/sql-tests.factor b/basis/db/sql/sql-tests.factor deleted file mode 100644 index 0b57c2d8fa..0000000000 --- a/basis/db/sql/sql-tests.factor +++ /dev/null @@ -1,42 +0,0 @@ -USING: kernel namespaces db.sql sequences math ; -IN: db.sql.tests - -! TUPLE: person name age ; -: insert-1 - { insert - { - { table "person" } - { columns "name" "age" } - { values "erg" 26 } - } - } ; - -: update-1 - { update "person" - { set { "name" "erg" } - { "age" 6 } } - { where { "age" 6 } } - } ; - -: select-1 - { select - { columns - "branchno" - { count "staffno" as "mycount" } - { sum "salary" as "mysum" } } - { from "staff" "lol" } - { where - { "salary" > all - { select - { columns "salary" } - { from "staff" } - { where { "branchno" = "b003" } } - } - } - { "branchno" > 3 } } - { group-by "branchno" "lol2" } - { having { count "staffno" > 1 } } - { order-by "branchno" } - { offset 40 } - { limit 20 } - } ; diff --git a/basis/db/sql/sql.factor b/basis/db/sql/sql.factor deleted file mode 100755 index ba0673ae24..0000000000 --- a/basis/db/sql/sql.factor +++ /dev/null @@ -1,172 +0,0 @@ -USING: kernel parser quotations classes.tuple words math.order -nmake namespaces sequences arrays combinators -prettyprint strings math.parser math symbols db ; -IN: db.sql - -SYMBOLS: insert update delete select distinct columns from as -where group-by having order-by limit offset is-null desc all -any count avg table values ; - -: input-spec, ( obj -- ) 1, ; -: output-spec, ( obj -- ) 2, ; -: input, ( obj -- ) 3, ; -: output, ( obj -- ) 4, ; - -DEFER: sql% - -: (sql-interleave) ( seq sep -- ) - [ sql% ] curry [ sql% ] interleave ; - -: sql-interleave ( seq str sep -- ) - swap sql% (sql-interleave) ; - -: sql-function, ( seq function -- ) - sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ; - -: sql-where, ( seq -- ) - [ - [ second 0, ] - [ first 0, ] - [ third 1, \ ? 0, ] tri - ] each ; - -HOOK: sql-create db ( object -- ) -M: db sql-create ( object -- ) - drop - "create table" sql% ; - -HOOK: sql-drop db ( object -- ) -M: db sql-drop ( object -- ) - drop - "drop table" sql% ; - -HOOK: sql-insert db ( object -- ) -M: db sql-insert ( object -- ) - drop - "insert into" sql% ; - -HOOK: sql-update db ( object -- ) -M: db sql-update ( object -- ) - drop - "update" sql% ; - -HOOK: sql-delete db ( object -- ) -M: db sql-delete ( object -- ) - drop - "delete" sql% ; - -HOOK: sql-select db ( object -- ) -M: db sql-select ( object -- ) - "select" sql% "," (sql-interleave) ; - -HOOK: sql-columns db ( object -- ) -M: db sql-columns ( object -- ) - "," (sql-interleave) ; - -HOOK: sql-from db ( object -- ) -M: db sql-from ( object -- ) - "from" "," sql-interleave ; - -HOOK: sql-where db ( object -- ) -M: db sql-where ( object -- ) - "where" 0, sql-where, ; - -HOOK: sql-group-by db ( object -- ) -M: db sql-group-by ( object -- ) - "group by" "," sql-interleave ; - -HOOK: sql-having db ( object -- ) -M: db sql-having ( object -- ) - "having" "," sql-interleave ; - -HOOK: sql-order-by db ( object -- ) -M: db sql-order-by ( object -- ) - "order by" "," sql-interleave ; - -HOOK: sql-offset db ( object -- ) -M: db sql-offset ( object -- ) - "offset" sql% sql% ; - -HOOK: sql-limit db ( object -- ) -M: db sql-limit ( object -- ) - "limit" sql% sql% ; - -! GENERIC: sql-subselect db ( object -- ) -! M: db sql-subselectselect ( object -- ) - ! "(select" sql% sql% ")" sql% ; - -HOOK: sql-table db ( object -- ) -M: db sql-table ( object -- ) - sql% ; - -HOOK: sql-set db ( object -- ) -M: db sql-set ( object -- ) - "set" "," sql-interleave ; - -HOOK: sql-values db ( object -- ) -M: db sql-values ( object -- ) - "values(" sql% "," (sql-interleave) ")" sql% ; - -HOOK: sql-count db ( object -- ) -M: db sql-count ( object -- ) - "count" sql-function, ; - -HOOK: sql-sum db ( object -- ) -M: db sql-sum ( object -- ) - "sum" sql-function, ; - -HOOK: sql-avg db ( object -- ) -M: db sql-avg ( object -- ) - "avg" sql-function, ; - -HOOK: sql-min db ( object -- ) -M: db sql-min ( object -- ) - "min" sql-function, ; - -HOOK: sql-max db ( object -- ) -M: db sql-max ( object -- ) - "max" sql-function, ; - -: sql-array% ( array -- ) - unclip - { - { \ create [ sql-create ] } - { \ drop [ sql-drop ] } - { \ insert [ sql-insert ] } - { \ update [ sql-update ] } - { \ delete [ sql-delete ] } - { \ select [ sql-select ] } - { \ columns [ sql-columns ] } - { \ from [ sql-from ] } - { \ where [ sql-where ] } - { \ group-by [ sql-group-by ] } - { \ having [ sql-having ] } - { \ order-by [ sql-order-by ] } - { \ offset [ sql-offset ] } - { \ limit [ sql-limit ] } - { \ table [ sql-table ] } - { \ set [ sql-set ] } - { \ values [ sql-values ] } - { \ count [ sql-count ] } - { \ sum [ sql-sum ] } - { \ avg [ sql-avg ] } - { \ min [ sql-min ] } - { \ max [ sql-max ] } - [ sql% [ sql% ] each ] - } case ; - -ERROR: no-sql-match ; -: sql% ( obj -- ) - { - { [ dup string? ] [ 0, ] } - { [ dup array? ] [ sql-array% ] } - { [ dup number? ] [ number>string sql% ] } - { [ dup symbol? ] [ unparse sql% ] } - { [ dup word? ] [ unparse sql% ] } - { [ dup quotation? ] [ call ] } - [ no-sql-match ] - } cond ; - -: parse-sql ( obj -- sql in-spec out-spec in out ) - [ [ sql% ] each ] { { } { } { } } nmake - [ " " join ] 2dip ; diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index aab1e5f40f..4fc3dbb227 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -5,7 +5,8 @@ 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 db.tuples.private ; +math.bitwise db.queries destructors db.tuples.private interpolate +io.streams.string multiline make ; IN: db.sqlite TUPLE: sqlite-db < db path ; @@ -117,7 +118,8 @@ M: sqlite-db create-sql-statement ( class -- statement ) dupd "create table " 0% 0% "(" 0% [ ", " 0% ] [ - dup column-name>> 0% + dup "sql-spec" set + dup column-name>> [ "table-id" set ] [ 0% ] bi " " 0% dup type>> lookup-create-type 0% modifiers 0% @@ -203,9 +205,110 @@ M: sqlite-db persistent-table ( -- assoc ) { random-generator { f f f } } } ; +: insert-trigger ( -- string ) + [ + <" + CREATE TRIGGER fki_${table}_${foreign-table}_id + BEFORE INSERT ON ${table} + FOR EACH ROW BEGIN + SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') + WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + END; + "> interpolate + ] with-string-writer ; + +: insert-trigger-not-null ( -- string ) + [ + <" + CREATE TRIGGER fki_${table}_${foreign-table}_id + BEFORE INSERT ON ${table} + FOR EACH ROW BEGIN + SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') + WHERE NEW.${foreign-table-id} IS NOT NULL + AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + END; + "> interpolate + ] with-string-writer ; + +: update-trigger ( -- string ) + [ + <" + CREATE TRIGGER fku_${table}_${foreign-table}_id + BEFORE UPDATE ON ${table} + FOR EACH ROW BEGIN + SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') + WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + END; + "> interpolate + ] with-string-writer ; + +: update-trigger-not-null ( -- string ) + [ + <" + CREATE TRIGGER fku_${table}_${foreign-table}_id + BEFORE UPDATE ON ${table} + FOR EACH ROW BEGIN + SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') + WHERE NEW.${foreign-table-id} IS NOT NULL + AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + END; + "> interpolate + ] with-string-writer ; + +: delete-trigger-restrict ( -- string ) + [ + <" + CREATE TRIGGER fkd_${table}_${foreign-table}_id + BEFORE DELETE ON ${foreign-table} + FOR EACH ROW BEGIN + SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"') + WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL; + END; + "> interpolate + ] with-string-writer ; + +: delete-trigger-cascade ( -- string ) + [ + <" + CREATE TRIGGER fkd_${table}_${foreign-table}_id + BEFORE DELETE ON ${foreign-table} + FOR EACH ROW BEGIN + DELETE from ${table} WHERE ${table-id} = OLD.${foreign-table-id}; + END; + "> interpolate + ] with-string-writer ; + +: can-be-null? ( -- ? ) + "sql-spec" get modifiers>> [ +not-null+ = ] contains? not ; + +: delete-cascade? ( -- ? ) + "sql-spec" get modifiers>> [ +cascade+ = ] contains? ; + +: sqlite-trigger, ( string -- ) + { } { } 3, ; + +: create-sqlite-triggers ( -- ) + can-be-null? [ + insert-trigger sqlite-trigger, + update-trigger sqlite-trigger, + ] [ + insert-trigger-not-null sqlite-trigger, + update-trigger-not-null sqlite-trigger, + ] if + delete-cascade? [ + delete-trigger-cascade sqlite-trigger, + ] [ + delete-trigger-restrict sqlite-trigger, + ] if ; + M: sqlite-db compound ( string seq -- new-string ) over { { "default" [ first number>string join-space ] } - { "references" [ >reference-string ] } + { "references" [ + [ >reference-string ] keep + first2 [ "foreign-table" set ] + [ "foreign-table-id" set ] bi* + create-sqlite-triggers + ] } [ 2drop ] } case ; diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 6a5e78aa4b..9550ea1cd8 100755 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -176,26 +176,49 @@ SYMBOL: person4 T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } } f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" person4 set ; + TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: annotation n paste-id summary author mode contents ; -: db-assigned-paste-schema ( -- ) - paste "PASTE" - { - { "n" "ID" +db-assigned-id+ } - { "summary" "SUMMARY" TEXT } - { "author" "AUTHOR" TEXT } - { "channel" "CHANNEL" TEXT } - { "mode" "MODE" TEXT } - { "contents" "CONTENTS" TEXT } - { "timestamp" "DATE" TIMESTAMP } - { "annotations" { +has-many+ annotation } } - } define-persistent +paste "PASTE" +{ + { "n" "ID" +db-assigned-id+ } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "channel" "CHANNEL" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + { "timestamp" "DATE" TIMESTAMP } + { "annotations" { +has-many+ annotation } } +} define-persistent +: annotation-schema-foreign-key ( -- ) annotation "ANNOTATION" { { "n" "ID" +db-assigned-id+ } - { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } + { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + } define-persistent ; + +: annotation-schema-foreign-key-not-null ( -- ) + annotation "ANNOTATION" + { + { "n" "ID" +db-assigned-id+ } + { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } +not-null+ } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + } define-persistent ; + +: annotation-schema-cascade ( -- ) + annotation "ANNOTATION" + { + { "n" "ID" +db-assigned-id+ } + { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } +on-delete+ +cascade+ } { "summary" "SUMMARY" TEXT } { "author" "AUTHOR" TEXT } @@ -203,8 +226,18 @@ TUPLE: annotation n paste-id summary author mode contents ; { "contents" "CONTENTS" TEXT } } define-persistent ; +: annotation-schema-restrict ( -- ) + annotation "ANNOTATION" + { + { "n" "ID" +db-assigned-id+ } + { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + } define-persistent ; + : test-paste-schema ( -- ) - [ ] [ db-assigned-paste-schema ] unit-test [ ] [ paste ensure-table ] unit-test [ ] [ annotation ensure-table ] unit-test [ ] [ annotation drop-table ] unit-test @@ -229,14 +262,38 @@ TUPLE: annotation n paste-id summary author mode contents ; "erg" >>author "annotation contents" >>contents insert-tuple - ] unit-test + ] unit-test ; - [ ] [ - ] unit-test - ; +: test-foreign-key ( -- ) + [ ] [ annotation-schema-foreign-key ] unit-test + test-paste-schema + [ paste new 1 >>n delete-tuples ] must-fail ; -[ test-paste-schema ] test-sqlite -[ test-paste-schema ] test-postgresql +: test-foreign-key-not-null ( -- ) + [ ] [ annotation-schema-foreign-key-not-null ] unit-test + test-paste-schema + [ paste new 1 >>n delete-tuples ] must-fail ; + +: test-cascade ( -- ) + [ ] [ annotation-schema-cascade ] unit-test + test-paste-schema + [ ] [ paste new 1 >>n delete-tuples ] unit-test + [ 0 ] [ paste new select-tuples length ] unit-test ; + +: test-restrict ( -- ) + [ ] [ annotation-schema-restrict ] unit-test + test-paste-schema + [ paste new 1 >>n delete-tuples ] must-fail ; + +[ test-foreign-key ] test-sqlite +[ test-foreign-key-not-null ] test-sqlite +[ test-cascade ] test-sqlite +[ test-restrict ] test-sqlite + +[ test-foreign-key ] test-postgresql +[ test-foreign-key-not-null ] test-postgresql +[ test-cascade ] test-postgresql +[ test-restrict ] test-postgresql : test-repeated-insert [ ] [ person ensure-table ] unit-test diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index bc33792e52..242339264d 100755 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -87,16 +87,17 @@ SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL URL ; -: spec>tuple ( class spec -- tuple ) - 3 f pad-right - [ first3 ] keep 3 tail +: ( class slot-name column-name type modifiers -- sql-spec ) sql-spec new swap >>modifiers swap >>type swap >>column-name swap >>slot-name swap >>class - dup normalize-spec ; + dup normalize-spec ; + +: spec>tuple ( class spec -- tuple ) + 3 f pad-right [ first3 ] keep 3 tail ; : number>string* ( n/string -- string ) dup number? [ number>string ] when ; @@ -115,7 +116,6 @@ FACTOR-BLOB NULL URL ; ! PostgreSQL Types: ! http://developer.postgresql.org/pgdocs/postgres/datatype.html - : ?at ( obj assoc -- value/obj ? ) dupd at* [ [ nip ] [ drop ] if ] keep ; @@ -159,8 +159,11 @@ ERROR: no-sql-type type ; HOOK: bind% db ( spec -- ) HOOK: bind# db ( spec obj -- ) +ERROR: no-column column ; + : >reference-string ( string pair -- string ) first2 [ [ unparse join-space ] [ db-columns ] bi ] dip - swap [ slot-name>> = ] with find nip + swap [ column-name>> = ] with find nip + [ no-column ] unless* column-name>> paren append ; From f41733faf1bf0a92b7f7b5e7c13c9e26239932aa Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 30 Sep 2008 11:00:44 -0500 Subject: [PATCH 05/11] add IGNORE types to tuple slots for select --- basis/db/queries/queries.factor | 9 ++++----- basis/db/sqlite/sqlite.factor | 2 +- basis/db/tuples/tuples-tests.factor | 10 ++++++++++ basis/db/types/types.factor | 10 +++++++++- 4 files changed, 24 insertions(+), 7 deletions(-) diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index e3322ada44..17d8870990 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -52,9 +52,7 @@ M: retryable execute-statement* ( statement type -- ) [ 0 sql-counter rot with-variable ] curry { "" { } { } { } } nmake [ maybe-make-retryable ] dip - [ - [ 1array ] dip append - ] unless-empty ; inline + [ [ 1array ] dip append ] unless-empty ; inline : where-primary-key% ( specs -- ) " where " 0% @@ -150,9 +148,10 @@ M: db ( tuple table -- sql ) M: db ( tuple class -- statement ) [ "select " 0% - over [ ", " 0% ] + [ dupd filter-ignores ] dip + over + [ ", " 0% ] [ dup column-name>> 0% 2, ] interleave - " from " 0% 0% where-clause ] query-make ; diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 4fc3dbb227..dfd9fab08c 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -282,7 +282,7 @@ M: sqlite-db persistent-table ( -- assoc ) "sql-spec" get modifiers>> [ +not-null+ = ] contains? not ; : delete-cascade? ( -- ? ) - "sql-spec" get modifiers>> [ +cascade+ = ] contains? ; + "sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ; : sqlite-trigger, ( string -- ) { } { } 3, ; diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 9550ea1cd8..6114c7ebe1 100755 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -350,6 +350,16 @@ TUPLE: exam id name score ; [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test + [ 4 ] + [ T{ exam { name IGNORE } { score IGNORE } } select-tuples length ] unit-test + + [ f ] + [ T{ exam { name IGNORE } { score IGNORE } } select-tuples first score>> ] unit-test + + ! FIXME + ! [ f ] + ! [ T{ exam { name IGNORE } { score IGNORE } { id IGNORE } } select-tuples first score>> ] unit-test + [ { T{ exam f 3 "Kenny" 60 } diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index 242339264d..ac9e3397f8 100755 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -29,9 +29,17 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ +foreign-id+ +has-many+ +on-delete+ +restrict+ +cascade+ +set-null+ +set-default+ ; +SYMBOL: IGNORE + +: filter-ignores ( tuple specs -- specs' ) + [ [ nip IGNORE = ] assoc-filter keys ] dip + [ slot-name>> swap member? not ] with filter ; + +ERROR: no-slot ; + : offset-of-slot ( string tuple -- n ) class superclasses [ "slots" word-prop ] map concat - slot-named offset>> ; + slot-named dup [ no-slot ] unless offset>> ; : get-slot-named ( name tuple -- value ) tuck offset-of-slot slot ; From 3360f5a3acf34ca2585951d4c08564615938654c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Oct 2008 12:50:49 -0500 Subject: [PATCH 06/11] add irc-log webapp to redirect you to today's \#concatenative log --- extra/webapps/irc-log/authors.txt | 1 + extra/webapps/irc-log/irc-log.factor | 22 ++++++++++++++++++++++ 2 files changed, 23 insertions(+) create mode 100644 extra/webapps/irc-log/authors.txt create mode 100644 extra/webapps/irc-log/irc-log.factor diff --git a/extra/webapps/irc-log/authors.txt b/extra/webapps/irc-log/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/webapps/irc-log/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/webapps/irc-log/irc-log.factor b/extra/webapps/irc-log/irc-log.factor new file mode 100644 index 0000000000..c193550719 --- /dev/null +++ b/extra/webapps/irc-log/irc-log.factor @@ -0,0 +1,22 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: calendar kernel http.server.dispatchers prettyprint +sequences printf furnace.actions html.forms accessors +furnace.redirection ; +IN: webapps.irc-log + +TUPLE: irclog-app < dispatcher ; + +: irc-link ( -- string ) + gmt -7 hours convert-timezone >date< + [ unparse 2 tail ] 2dip + "http://bespin.org/~nef/logs/concatenative/%02s.%02d.%02d" + sprintf ; + +: ( -- action ) + + [ irc-link ] >>display ; + +: ( -- dispatcher ) + irclog-app new-dispatcher + "" add-responder ; From 27c38f6d303df2af94f32e3c9758dc1bc3612904 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Oct 2008 14:19:28 -0500 Subject: [PATCH 07/11] checkin for prunedtree, i wrote some docs and spaced things a little better --- extra/suffix-arrays/authors.txt | 1 + extra/suffix-arrays/suffix-arrays-docs.factor | 44 +++++++++++++++++++ .../suffix-arrays/suffix-arrays-tests.factor | 27 ++++++++++++ extra/suffix-arrays/suffix-arrays.factor | 31 +++++++++++++ extra/suffix-arrays/summary.txt | 1 + extra/suffix-arrays/tags.txt | 1 + extra/suffix-arrays/words/words.factor | 19 ++++++++ 7 files changed, 124 insertions(+) create mode 100755 extra/suffix-arrays/authors.txt create mode 100755 extra/suffix-arrays/suffix-arrays-docs.factor create mode 100755 extra/suffix-arrays/suffix-arrays-tests.factor create mode 100755 extra/suffix-arrays/suffix-arrays.factor create mode 100755 extra/suffix-arrays/summary.txt create mode 100755 extra/suffix-arrays/tags.txt create mode 100755 extra/suffix-arrays/words/words.factor diff --git a/extra/suffix-arrays/authors.txt b/extra/suffix-arrays/authors.txt new file mode 100755 index 0000000000..e4a36df7ef --- /dev/null +++ b/extra/suffix-arrays/authors.txt @@ -0,0 +1 @@ +Marc Fauconneau \ No newline at end of file diff --git a/extra/suffix-arrays/suffix-arrays-docs.factor b/extra/suffix-arrays/suffix-arrays-docs.factor new file mode 100755 index 0000000000..3bea1d26fd --- /dev/null +++ b/extra/suffix-arrays/suffix-arrays-docs.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2008 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays help.markup help.syntax io.streams.string +sequences strings math ; +IN: suffix-arrays + +HELP: >suffix-array +{ $values + { "seq" sequence } + { "array" array } } +{ $description "Creates a suffix array from the input sequence." } ; + +HELP: SA{ +{ $description "Creates a new literal suffix array at parse-time." } ; + +HELP: suffixes +{ $values + { "string" string } + { "suffixes-seq" "a sequence of slices" } } +{ $description "Returns a sequence of tail slices of the input string." } ; + +HELP: from-to +{ $values + { "index" integer } { "suffix-array" "a suffix-array" } { "begin" string } + { "from" integer } { "to" integer } } +{ $notes "Slices are [m,n) and we want (m,n) so we increment." } ; + +HELP: query +{ $values + { "begin" string } { "suffix-array" "a suffix-array" } + { "matches" array } } +{ $description "Returns " } ; + +ARTICLE: "suffix-arrays" "Suffix arrays" +"The " { $vocab-link "suffix-arrays" } " vocabulary implements the suffix array data structure for efficient lookup of subsequences." $nl + +"Creating new suffix arrays:" +{ $subsection >suffix-array } +"Literal suffix arrays:" +{ $subsection POSTPONE: SA{ } +"Querying suffix arrays:" +{ $subsection query } ; + +ABOUT: "suffix-arrays" diff --git a/extra/suffix-arrays/suffix-arrays-tests.factor b/extra/suffix-arrays/suffix-arrays-tests.factor new file mode 100755 index 0000000000..f4efd8e002 --- /dev/null +++ b/extra/suffix-arrays/suffix-arrays-tests.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2008 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test suffix-arrays kernel namespaces ; +IN: suffix-arrays.tests + +! built from [ all-words 10 head [ name>> ] map ] +{ + "run-tests" + "must-fail-with" + "test-all" + "short-effect" + "failure" + "test" + "" + "this-test" + "(unit-test)" + "unit-test" +} "strings" set + +[ "strings" get >suffix-array "" swap query ] must-fail + +[ { } >suffix-array "something" swap query ] must-fail + +[ V{ "unit-test" "(unit-test)" } ] +[ "strings" get >suffix-array "unit-test" swap query ] unit-test + +[ V{ } ] [ "strings" get >suffix-array "something else" swap query ] unit-test diff --git a/extra/suffix-arrays/suffix-arrays.factor b/extra/suffix-arrays/suffix-arrays.factor new file mode 100755 index 0000000000..d51548017b --- /dev/null +++ b/extra/suffix-arrays/suffix-arrays.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2008 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: parser kernel arrays math accessors sequences +math.vectors math.order sorting binary-search sets assocs fry ; +IN: suffix-arrays + +! this suffix array is a sorted array of suffixes +! query is efficient through binary searches + +: suffixes ( string -- suffixes-seq ) + dup length [ tail-slice ] with map ; + +: >suffix-array ( seq -- array ) + [ suffixes ] map concat natural-sort ; + +: SA{ \ } [ >suffix-array ] parse-literal ; parsing + +: prefix<=> ( seq begin -- <=> ) + [ swap <=> ] [ head? ] 2bi [ drop +eq+ ] when ; + +: find-index ( suffix-array begin -- index ) + '[ _ prefix<=> ] search drop ; + +: from-to ( index suffix-array begin -- from to ) + '[ _ head? not ] + [ find-last-from drop 1+ ] + [ find-from drop ] 3bi ; + +: query ( begin suffix-array -- matches ) + [ swap [ find-index ] 2keep from-to [ min ] keep ] keep + [ seq>> ] map prune ; diff --git a/extra/suffix-arrays/summary.txt b/extra/suffix-arrays/summary.txt new file mode 100755 index 0000000000..71eda476bc --- /dev/null +++ b/extra/suffix-arrays/summary.txt @@ -0,0 +1 @@ +Suffix arrays diff --git a/extra/suffix-arrays/tags.txt b/extra/suffix-arrays/tags.txt new file mode 100755 index 0000000000..42d711b32b --- /dev/null +++ b/extra/suffix-arrays/tags.txt @@ -0,0 +1 @@ +collections diff --git a/extra/suffix-arrays/words/words.factor b/extra/suffix-arrays/words/words.factor new file mode 100755 index 0000000000..74e2fc2f97 --- /dev/null +++ b/extra/suffix-arrays/words/words.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2008 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel arrays math accessors sequences math.vectors +math.order sorting binary-search sets assocs fry suffix-arrays ; +IN: suffix-arrays.words + +! to search on word names + +: new-word-sa ( words -- sa ) + [ name>> ] map >suffix-array ; + +: name>word-map ( words -- map ) + dup [ name>> V{ } clone ] H{ } map>assoc + [ '[ dup name>> _ at push ] each ] keep ; + +: query-word-sa ( map begin sa -- matches ) query '[ _ at ] map concat ; + +! usage example : +! clear all-words 100 head dup name>word-map "test" rot new-word-sa query . From 4c502165e7feb249f6c7670e077e8f9af84a1c3c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Oct 2008 14:49:21 -0500 Subject: [PATCH 08/11] a little bit of cleanup, trying to get rid of some stack shuffling --- extra/suffix-arrays/suffix-arrays-docs.factor | 4 +- .../suffix-arrays/suffix-arrays-tests.factor | 37 ++++++++++--------- extra/suffix-arrays/suffix-arrays.factor | 29 +++++++-------- 3 files changed, 36 insertions(+), 34 deletions(-) diff --git a/extra/suffix-arrays/suffix-arrays-docs.factor b/extra/suffix-arrays/suffix-arrays-docs.factor index 3bea1d26fd..879839d8cd 100755 --- a/extra/suffix-arrays/suffix-arrays-docs.factor +++ b/extra/suffix-arrays/suffix-arrays-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Marc Fauconneau. ! See http://factorcode.org/license.txt for BSD license. USING: arrays help.markup help.syntax io.streams.string -sequences strings math ; +sequences strings math suffix-arrays.private ; IN: suffix-arrays HELP: >suffix-array @@ -32,7 +32,7 @@ HELP: query { $description "Returns " } ; ARTICLE: "suffix-arrays" "Suffix arrays" -"The " { $vocab-link "suffix-arrays" } " vocabulary implements the suffix array data structure for efficient lookup of subsequences." $nl +"The " { $vocab-link "suffix-arrays" } " vocabulary implements the suffix array data structure for efficient lookup of subsequences. This suffix array implementation is a sorted array of suffixes. Querying it for matches uses binary search for efficiency." $nl "Creating new suffix arrays:" { $subsection >suffix-array } diff --git a/extra/suffix-arrays/suffix-arrays-tests.factor b/extra/suffix-arrays/suffix-arrays-tests.factor index f4efd8e002..8904d35362 100755 --- a/extra/suffix-arrays/suffix-arrays-tests.factor +++ b/extra/suffix-arrays/suffix-arrays-tests.factor @@ -1,27 +1,30 @@ ! Copyright (C) 2008 Marc Fauconneau. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test suffix-arrays kernel namespaces ; +USING: tools.test suffix-arrays kernel namespaces sequences ; IN: suffix-arrays.tests ! built from [ all-words 10 head [ name>> ] map ] -{ - "run-tests" - "must-fail-with" - "test-all" - "short-effect" - "failure" - "test" - "" - "this-test" - "(unit-test)" - "unit-test" -} "strings" set +[ ] [ + SA{ + "run-tests" + "must-fail-with" + "test-all" + "short-effect" + "failure" + "test" + "" + "this-test" + "(unit-test)" + "unit-test" + } "suffix-array" set +] unit-test -[ "strings" get >suffix-array "" swap query ] must-fail +[ "suffix-array" get "" swap query ] must-fail -[ { } >suffix-array "something" swap query ] must-fail +[ SA{ } "something" swap query ] must-fail [ V{ "unit-test" "(unit-test)" } ] -[ "strings" get >suffix-array "unit-test" swap query ] unit-test +[ "suffix-array" get "unit-test" swap query ] unit-test -[ V{ } ] [ "strings" get >suffix-array "something else" swap query ] unit-test +[ t ] +[ "suffix-array" get "something else" swap query empty? ] unit-test diff --git a/extra/suffix-arrays/suffix-arrays.factor b/extra/suffix-arrays/suffix-arrays.factor index d51548017b..2cf2076732 100755 --- a/extra/suffix-arrays/suffix-arrays.factor +++ b/extra/suffix-arrays/suffix-arrays.factor @@ -4,28 +4,27 @@ USING: parser kernel arrays math accessors sequences math.vectors math.order sorting binary-search sets assocs fry ; IN: suffix-arrays -! this suffix array is a sorted array of suffixes -! query is efficient through binary searches - + ( begin seq -- <=> ) + [ <=> ] [ swap head? ] 2bi [ drop +eq+ ] when ; + +: find-index ( begin suffix-array -- index ) + [ prefix<=> ] with search drop ; + +: from-to ( index begin suffix-array -- from to ) + swap '[ _ head? not ] + [ find-last-from drop 1+ ] + [ find-from drop ] 3bi ; +PRIVATE> + : >suffix-array ( seq -- array ) [ suffixes ] map concat natural-sort ; : SA{ \ } [ >suffix-array ] parse-literal ; parsing -: prefix<=> ( seq begin -- <=> ) - [ swap <=> ] [ head? ] 2bi [ drop +eq+ ] when ; - -: find-index ( suffix-array begin -- index ) - '[ _ prefix<=> ] search drop ; - -: from-to ( index suffix-array begin -- from to ) - '[ _ head? not ] - [ find-last-from drop 1+ ] - [ find-from drop ] 3bi ; - : query ( begin suffix-array -- matches ) - [ swap [ find-index ] 2keep from-to [ min ] keep ] keep + [ [ find-index ] 2keep from-to [ min ] keep ] keep [ seq>> ] map prune ; From 64af1a9e67e5f485650dc6f869137b2fbfd002cc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Oct 2008 16:00:23 -0500 Subject: [PATCH 09/11] handle boundary cases better in suffix-arrays. more unit tests --- extra/suffix-arrays/suffix-arrays-docs.factor | 8 ++++---- .../suffix-arrays/suffix-arrays-tests.factor | 18 ++++++++++++----- extra/suffix-arrays/suffix-arrays.factor | 20 ++++++++++++++----- 3 files changed, 32 insertions(+), 14 deletions(-) diff --git a/extra/suffix-arrays/suffix-arrays-docs.factor b/extra/suffix-arrays/suffix-arrays-docs.factor index 879839d8cd..55a78b2cb6 100755 --- a/extra/suffix-arrays/suffix-arrays-docs.factor +++ b/extra/suffix-arrays/suffix-arrays-docs.factor @@ -8,7 +8,7 @@ HELP: >suffix-array { $values { "seq" sequence } { "array" array } } -{ $description "Creates a suffix array from the input sequence." } ; +{ $description "Creates a suffix array from the input sequence. Suffix arrays are arrays of slices." } ; HELP: SA{ { $description "Creates a new literal suffix array at parse-time." } ; @@ -21,15 +21,15 @@ HELP: suffixes HELP: from-to { $values - { "index" integer } { "suffix-array" "a suffix-array" } { "begin" string } + { "index" integer } { "suffix-array" "a suffix-array" } { "begin" sequence } { "from" integer } { "to" integer } } { $notes "Slices are [m,n) and we want (m,n) so we increment." } ; HELP: query { $values - { "begin" string } { "suffix-array" "a suffix-array" } + { "begin" sequence } { "suffix-array" "a suffix-array" } { "matches" array } } -{ $description "Returns " } ; +{ $description "Returns a sequence of sequences from the suffix-array that contain the input sequence. An empty array is returned when there are no matches." } ; ARTICLE: "suffix-arrays" "Suffix arrays" "The " { $vocab-link "suffix-arrays" } " vocabulary implements the suffix array data structure for efficient lookup of subsequences. This suffix array implementation is a sorted array of suffixes. Querying it for matches uses binary search for efficiency." $nl diff --git a/extra/suffix-arrays/suffix-arrays-tests.factor b/extra/suffix-arrays/suffix-arrays-tests.factor index 8904d35362..5149804ce6 100755 --- a/extra/suffix-arrays/suffix-arrays-tests.factor +++ b/extra/suffix-arrays/suffix-arrays-tests.factor @@ -4,8 +4,8 @@ USING: tools.test suffix-arrays kernel namespaces sequences ; IN: suffix-arrays.tests ! built from [ all-words 10 head [ name>> ] map ] -[ ] [ - SA{ +[ ] [ + { "run-tests" "must-fail-with" "test-all" @@ -16,15 +16,23 @@ IN: suffix-arrays.tests "this-test" "(unit-test)" "unit-test" - } "suffix-array" set + } >suffix-array "suffix-array" set ] unit-test -[ "suffix-array" get "" swap query ] must-fail +[ t ] +[ "suffix-array" get "" swap query empty? not ] unit-test -[ SA{ } "something" swap query ] must-fail +[ { } ] +[ SA{ } "something" swap query ] unit-test [ V{ "unit-test" "(unit-test)" } ] [ "suffix-array" get "unit-test" swap query ] unit-test [ t ] [ "suffix-array" get "something else" swap query empty? ] unit-test + +[ V{ "rofl" } ] [ SA{ "rofl" } "r" swap query ] unit-test +[ V{ "rofl" } ] [ SA{ "rofl" } "o" swap query ] unit-test +[ V{ "rofl" } ] [ SA{ "rofl" } "f" swap query ] unit-test +[ V{ "rofl" } ] [ SA{ "rofl" } "l" swap query ] unit-test +[ V{ } ] [ SA{ "rofl" } "t" swap query ] unit-test diff --git a/extra/suffix-arrays/suffix-arrays.factor b/extra/suffix-arrays/suffix-arrays.factor index 2cf2076732..719496243c 100755 --- a/extra/suffix-arrays/suffix-arrays.factor +++ b/extra/suffix-arrays/suffix-arrays.factor @@ -11,13 +11,22 @@ IN: suffix-arrays : prefix<=> ( begin seq -- <=> ) [ <=> ] [ swap head? ] 2bi [ drop +eq+ ] when ; -: find-index ( begin suffix-array -- index ) +: find-index ( begin suffix-array -- index/f ) [ prefix<=> ] with search drop ; -: from-to ( index begin suffix-array -- from to ) +: from-to ( index begin suffix-array -- from/f to/f ) swap '[ _ head? not ] - [ find-last-from drop 1+ ] + [ find-last-from drop dup [ 1+ ] when ] [ find-from drop ] 3bi ; + +: ( from/f to/f seq -- slice ) + [ + tuck + [ drop [ 0 ] unless* ] + [ dupd length ? ] 2bi* + [ min ] keep + ] keep ; + PRIVATE> : >suffix-array ( seq -- array ) @@ -26,5 +35,6 @@ PRIVATE> : SA{ \ } [ >suffix-array ] parse-literal ; parsing : query ( begin suffix-array -- matches ) - [ [ find-index ] 2keep from-to [ min ] keep ] keep - [ seq>> ] map prune ; + 2dup find-index + [ -rot [ from-to ] keep [ seq>> ] map prune ] + [ 2drop { } ] if* ; From 01fcb1b856d05e356bd97c73d79b08b2d85f19a7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Oct 2008 16:04:32 -0500 Subject: [PATCH 10/11] fix help-lint --- extra/suffix-arrays/suffix-arrays-docs.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/suffix-arrays/suffix-arrays-docs.factor b/extra/suffix-arrays/suffix-arrays-docs.factor index 55a78b2cb6..87df27281e 100755 --- a/extra/suffix-arrays/suffix-arrays-docs.factor +++ b/extra/suffix-arrays/suffix-arrays-docs.factor @@ -21,8 +21,9 @@ HELP: suffixes HELP: from-to { $values - { "index" integer } { "suffix-array" "a suffix-array" } { "begin" sequence } - { "from" integer } { "to" integer } } + { "index" integer } { "begin" sequence } { "suffix-array" "a suffix-array" } + { "from/f" "an integer or f" } { "to/f" "an integer or f" } } +{ $description "Finds the bounds of the suffix array that match the input sequence. A return value of " { $link f } " means that the endpoint is included." } { $notes "Slices are [m,n) and we want (m,n) so we increment." } ; HELP: query From 87bb2240fc27f28d2d45ba4b17f76f74662ab342 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 1 Oct 2008 17:11:19 -0500 Subject: [PATCH 11/11] add line-breaks? flag to farkup just for kicks. it might be useful --- basis/farkup/farkup.factor | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index 73b0cba4d0..21e3c05d04 100644 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -9,6 +9,7 @@ IN: farkup SYMBOL: relative-link-prefix SYMBOL: disable-images? SYMBOL: link-no-follow? +SYMBOL: line-breaks? TUPLE: heading1 child ; TUPLE: heading2 child ; @@ -29,6 +30,7 @@ TUPLE: link href text ; TUPLE: image href text ; TUPLE: code mode string ; TUPLE: line ; +TUPLE: line-break ; : absolute-url? ( string -- ? ) { "http://" "https://" "ftp://" } [ head? ] with contains? ; @@ -109,7 +111,9 @@ table = ((table-row nl => [[ first ]] )+ table-row? | table-row) text = (!(nl | code | heading | inline-delimiter | table ).)+ => [[ >string ]] -paragraph-nl-item = nl (list | line)? +paragraph-nl-item = nl list + | nl line + | nl => [[ line-breaks? get [ drop line-break new ] when ]] paragraph-item = (table | code | text | inline-tag | inline-delimiter)+ paragraph = ((paragraph-item paragraph-nl-item)+ nl+ => [[ first ]] | (paragraph-item paragraph-nl-item)+ paragraph-item? @@ -209,6 +213,7 @@ 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: line-break (write-farkup) drop
nl ; M: table-row (write-farkup) ( obj -- ) child>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ; M: table (write-farkup) [ child>> (write-farkup) ] "table" in-tag. ;