From 0da202f1785774212fb57570b33013080ad95a87 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Fri, 29 Feb 2008 13:51:59 +1100 Subject: [PATCH] latest db and semantic-db (not really working) --- extra/db/sqlite/sqlite.factor | 9 ++-- extra/db/tuples/tuples.factor | 7 +--- extra/semantic-db/db/db.factor | 2 +- extra/semantic-db/semantic-db-tests.factor | 10 ++++- extra/semantic-db/semantic-db.factor | 48 ++++++++++++++-------- extra/semantic-db/type/type.factor | 35 +++++++++++++--- 6 files changed, 75 insertions(+), 36 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 460b178c0e..5cb8f0c3bd 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -22,7 +22,7 @@ M: sqlite-db db-close ( handle -- ) M: sqlite-db dispose ( db -- ) dispose-db ; : with-sqlite ( path quot -- ) - >r r> with-db ; inline + sqlite-db swap with-db ; inline : with-tmp-sqlite ( quot -- ) ".db" [ @@ -33,10 +33,10 @@ TUPLE: sqlite-statement ; TUPLE: sqlite-result-set has-more? ; -M: sqlite-db ( str -- obj ) +M: sqlite-db ( str in out -- obj ) ; -M: sqlite-db ( str -- obj ) +M: sqlite-db ( str in out -- obj ) db get db-handle { set-statement-sql @@ -44,7 +44,7 @@ M: sqlite-db ( str -- obj ) set-statement-out-params set-statement-handle } statement construct - dup statement-handle over statement-sql sqlite-prepare + dup statement-handle over statement-sql sqlite-prepare over set-statement-handle sqlite-statement construct-delegate ; M: sqlite-statement dispose ( statement -- ) @@ -86,7 +86,6 @@ M: sqlite-result-set more-rows? ( result-set -- ? ) sqlite-result-set-has-more? ; M: sqlite-statement query-results ( query -- result-set ) -break dup statement-handle sqlite-result-set dup advance-row ; diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index c775bac3ab..6c0a580980 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -22,12 +22,6 @@ IN: db.tuples class db-columns find-primary-key sql-spec-slot-name ] keep set-slot-named ; -! : primary-key-spec ( class -- spec ) -! db-columns [ primary-key? ] find nip ; -! -! : primary-key ( tuple -- obj ) -! dup class primary-key-spec first swap get-slot-named ; - ! returns a sequence of prepared-statements HOOK: create-sql-statement db ( class -- obj ) HOOK: drop-sql-statement db ( class -- obj ) @@ -81,6 +75,7 @@ HOOK: insert-tuple* db ( tuple statement -- ) [ bind-tuple ] keep execute-statement ; : insert-tuple ( tuple -- ) + break dup class db-columns find-primary-key assigned-id? [ insert-assigned ] [ diff --git a/extra/semantic-db/db/db.factor b/extra/semantic-db/db/db.factor index df8c5b4a8a..52271bfda8 100644 --- a/extra/semantic-db/db/db.factor +++ b/extra/semantic-db/db/db.factor @@ -35,7 +35,7 @@ M: sequence bindings : 1result ( array -- result ) #! return the first (and hopefully only) element of the array, or f - dup length 0 > [ first ] [ drop f ] if ; + dup length zero? [ drop f ] [ first ] if ; : (collect-int-columns) ( statement n -- ) [ dupd column-int , ] each drop ; diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor index 0096b89d34..1ac4a76d3a 100644 --- a/extra/semantic-db/semantic-db-tests.factor +++ b/extra/semantic-db/semantic-db-tests.factor @@ -1,7 +1,9 @@ -USING: accessors db db.sqlite db.tuples kernel semantic-db tools.test ; +USING: accessors db db.sqlite db.tuples kernel math semantic-db semantic-db.type tools.test ; IN: temporary [ +USE: tools.walker +break create-node-table create-arc-table [ 1 ] [ "first node" create-node ] unit-test [ 2 ] [ "second node" create-node ] unit-test @@ -9,3 +11,9 @@ IN: temporary [ 4 ] [ f create-node ] unit-test [ 5 ] [ 1 2 3 create-arc ] unit-test ] with-tmp-sqlite + +[ + init-semantic-db + [ t ] [ "content" ensure-type "this is some content" ensure-node-of-type integer? ] unit-test + [ t ] [ "content" select-node-of-type integer? ] +] with-tmp-sqlite diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index bd29dba5f8..f6a6983ae4 100644 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays db db.tuples db.types db.sqlite kernel new-slots sequences ; +USING: accessors arrays db db.tuples db.types db.sqlite kernel math new-slots sequences ; IN: semantic-db ! new semantic-db using Doug Coleman's new db abstraction library @@ -11,7 +11,7 @@ TUPLE: node id content ; node "node" { - { "id" "id" SERIAL +native-id+ +autoincrement+ } + { "id" "id" +native-id+ +autoincrement+ } { "content" "content" TEXT } } define-persistent @@ -19,7 +19,7 @@ node "node" node create-table ; : create-node ( content -- id ) - dup persist id>> ; + dup insert-tuple id>> ; TUPLE: arc relation subject object ; @@ -30,10 +30,10 @@ TUPLE: arc relation subject object ; arc "arc" { - { "id" "id" SERIAL +native-id+ } ! foreign key to node table? - { "relation" "relation" SERIAL +not-null+ } - { "subject" "subject" SERIAL +not-null+ } - { "object" "object" SERIAL +not-null+ } + { "id" "id" INTEGER } ! foreign key to node table? + { "relation" "relation" INTEGER +not-null+ } + { "subject" "subject" INTEGER +not-null+ } + { "object" "object" INTEGER +not-null+ } } define-persistent : create-arc-table ( -- ) @@ -41,34 +41,48 @@ arc "arc" : insert-arc ( arc -- ) dup delegate insert-tuple - [ ] [ insert-sql ] make-tuple-statement insert-statement drop ; + insert-tuple ; + ! [ ] [ insert-sql ] make-tuple-statement insert-statement drop ; -: persist-arc ( arc -- ) - dup primary-key [ update-tuple ] [ insert-arc ] if ; +! : insert-arc ( arc -- ) +! dup primary-key [ update-tuple ] [ insert-arc ] if ; : delete-arc ( arc -- ) dup delete-tuple delegate delete-tuple ; : create-arc ( relation subject object -- id ) - dup persist-arc id>> ; + dup insert-arc id>> ; : create-bootstrap-nodes ( -- ) - { "context" "relation" "is of type" "semantic-db" "is in context" } + { "context" "type" "relation" "is of type" "semantic-db" "is in context" } [ create-node drop ] each ; +! TODO: maybe put these in a 'special nodes' table : context-type 1 ; inline -: relation-type 2 ; inline -: has-type-relation 3 ; inline -: semantic-db-context 4 ; inline -: has-context-relation 5 ; inline +: type-type 2 ; inline +: relation-type 3 ; inline +: has-type-relation 4 ; inline +: semantic-db-context 5 ; inline +: has-context-relation 6 ; inline : create-bootstrap-arcs ( -- ) + ! give everything a type + has-type-relation context-type type-type create-arc drop + has-type-relation type-type type-type create-arc drop + has-type-relation relation-type type-type create-arc drop has-type-relation has-type-relation relation-type create-arc drop has-type-relation semantic-db-context context-type create-arc drop - has-context-relation has-type-relation semantic-db-context create-arc drop has-type-relation has-context-relation relation-type create-arc drop + ! give relations a context (semantic-db context) + has-context-relation has-type-relation semantic-db-context create-arc drop has-context-relation has-context-relation semantic-db-context create-arc drop ; : init-semantic-db ( -- ) create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ; +: 1result ( array -- result ) + #! return the first (and hopefully only) element of the array, or f + dup length zero? [ drop f ] [ first ] if ; + +: param ( value key type -- param ) + rot 3array ; diff --git a/extra/semantic-db/type/type.factor b/extra/semantic-db/type/type.factor index be4da4da83..32c93fdb80 100644 --- a/extra/semantic-db/type/type.factor +++ b/extra/semantic-db/type/type.factor @@ -1,19 +1,42 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel semantic-db ; +USING: arrays db db.types kernel semantic-db ; IN: semantic-db.type : assign-type ( type nid -- arc-id ) has-type-relation spin create-arc ; -: create-node-of-type ( type name -- node-id ) +: create-node-of-type ( type content -- node-id ) create-node [ assign-type drop ] keep ; -: select-node-of-type ( type name -- node-id? ) - ! find a node with the given name, that is the subject of an arc with: +: select-nodes-of-type ( type -- node-ids ) + "type" INTEGER param + has-type-relation "has_type" INTEGER param 2array + "select a.subject from arc a where a.relation = :has_type and a.object = :type" + do-bound-query ; + +: select-node-of-type ( type -- node-id ) + select-nodes-of-type 1array ; + +: select-nodes-of-type-with-content ( type content -- node-ids ) + ! find nodes with the given content that are the subjects of arcs with: ! relation = has-type-relation ! object = type - ; + "name" TEXT param + swap "type" INTEGER param + has-type-relation "has_type" INTEGER param 3array + "select n.id from node n, arc a where n.content = :name and n.id = a.subject and a.object = :type and a.relation = :has_type" + do-bound-query ; -: ensure-node-of-type ( type name -- node-id ) +: select-node-of-type-with-content ( type content -- node-id/f ) + select-nodes-of-type-with-content 1result ; + +: ensure-node-of-type ( type content -- node-id ) 2dup select-node-of-type [ 2nip ] [ create-node-of-type ] if* ; + +: ensure-type ( type -- node-id ) + dup "type" = [ + drop type-type + ] [ + type-type swap ensure-node-of-type + ] if ;