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

semantic-db: using new-slots

db4
Alex Chapman 2008-02-18 12:35:11 +11:00
parent 5215e3af5f
commit a47aa3d288
1 changed files with 45 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
extra/semantic-db/db/db.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007, 2008 Alex Chapman ! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math namespaces sequences sqlite ; USING: arrays assocs kernel math namespaces new-slots sequences sqlite ;
IN: semantic-db.db IN: semantic-db.db
! sqlite utils ! sqlite utils
@ -56,37 +56,37 @@ TUPLE: query fields tables conditions args statement results ;
query construct-boa ; query construct-boa ;
: invalidate-query ( query -- query ) : invalidate-query ( query -- query )
f over set-query-results ; f >>results ;
: add-field ( field query -- ) invalidate-query query-fields push ; : add-field ( field query -- query )
: ,field ( name table retriever -- ) <field> query get add-field ; dup invalidate-query fields>> push ;
: add-table ( table query -- ) invalidate-query query-tables push ; : add-table ( table query -- query )
: ,table ( table -- ) query get add-table ; dup invalidate-query tables>> push ;
: add-condition ( condition query -- ) invalidate-query query-conditions push ; : add-condition ( condition query -- query )
: ,condition ( condition -- ) query get add-condition ; tuck invalidate-query conditions>> push ;
: add-arg ( arg key query -- ) invalidate-query query-args set-at ; : add-arg ( arg key query -- query )
: ,arg ( arg key -- ) query get add-arg ; [ invalidate-query args>> set-at ] keep ;
<PRIVATE <PRIVATE
: field-sql ( field -- sql ) : field-sql ( field -- sql )
[ dup field-table % CHAR: . , field-name % ] "" make ; [ dup table>> % CHAR: . , name>> % ] "" make ;
: fields-sql ( query -- sql ) : fields-sql ( query -- sql )
query-fields dup length [ fields>> dup length [
[ field-sql ] map ", " join [ field-sql ] map ", " join
] [ ] [
drop "*" drop "*"
] if ; ] if ;
: tables-sql ( query -- sql ) : tables-sql ( query -- sql )
query-tables ", " join ; tables>> ", " join ;
: conditions-sql ( query -- sql ) : conditions-sql ( query -- sql )
query-conditions dup length [ conditions>> dup length [
" and " join "where " swap append " and " join "where " swap append
] [ ] [
drop "" drop ""
@ -97,22 +97,22 @@ TUPLE: query fields tables conditions args statement results ;
"select" , dup fields-sql , dup "from" , tables-sql , conditions-sql , "select" , dup fields-sql , dup "from" , tables-sql , conditions-sql ,
] { } make " " join ; ] { } make " " join ;
: prepare-query ( query -- ) : prepare-query ( query -- query )
[ query-sql prepare ] keep set-query-statement ; dup query-sql prepare >>statement ;
: bind-query ( query -- ) : bind-query ( query -- query )
dup query-args over query-statement bindings swap set-query-statement ; dup args>> over statement>> bindings >>statement ;
: (retrieve) ( statement query -- result ) : (retrieve) ( statement query -- result )
query-fields swap [ field-retriever call ] curry each ; fields>> swap [ retriever>> call ] curry each ;
: retrieve ( query -- ) : retrieve ( query -- query )
dup query-statement over [ (retrieve) ] curry sqlite-map dup statement>> over [ (retrieve) ] curry sqlite-map
swap set-query-results ; swap >>results ;
! dup query-statement over query-retriever sqlite-map swap set-query-results ; ! dup query-statement over query-retriever sqlite-map swap >>results ;
: finalize-query ( query -- ) : finalize-query ( query -- query )
query-statement dup sqlite-finalize f swap set-query-statement ; statement>> dup sqlite-finalize f swap >>statement ;
PRIVATE> PRIVATE>
@ -120,14 +120,7 @@ PRIVATE>
dup prepare-query dup bind-query dup retrieve finalize-query ; dup prepare-query dup bind-query dup retrieve finalize-query ;
: get-results ( query -- results ) : get-results ( query -- results )
dup query-results [ nip ] [ dup run-query query-results ] if* ; dup results>> [ nip ] [ dup run-query results>> ] if* ;
: with-query ( quot -- results )
[
<query> query set
call
query get get-results
] with-scope ;
! nodes and arcs ! nodes and arcs
@ -252,24 +245,25 @@ PRIVATE>
2dup type-and-name-node [ 2nip ] [ create-node-of-type ] if* ; 2dup type-and-name-node [ 2nip ] [ create-node-of-type ] if* ;
: type-and-name-in-context-node ( context type name -- node ) : type-and-name-in-context-node ( context type name -- node )
[ <query>
"id" "n" [ 0 column-int ] ,field "id" "n" [ 0 column-int ] add-field
"nodes n" ,table "nodes n" add-table
"n.name = :name" ,condition "n.name = :name" add-condition
":name" ,arg ":name" add-arg
"arcs a" ,table "arcs a" add-table
"a.relation = :has_type" ,condition "a.relation = :has_type" add-condition
has-type-relation ":has_type" ,arg has-type-relation ":has_type" add-arg
"a.subject = n.id" ,condition "a.subject = n.id" add-condition
"a.object = :type" ,condition "a.object = :type" add-condition
":type" ,arg ":type" add-arg
"arcs b" ,table "arcs b" add-table
"b.subject = a.relation" ,condition "b.subject = a.relation" add-condition
"b.relation = :has_context" ,condition "b.relation = :has_context" add-condition
has-context-relation ":has_context" ,arg has-context-relation ":has_context" add-arg
"b.object = :context" ,condition "b.object = :context" add-condition
":context" ,arg ":context" add-arg
] with-query 1result ; get-results 1result ;
! ideas for an api: ! ideas for an api:
! this would work something like jquery, where arcs can be selected according ! this would work something like jquery, where arcs can be selected according