semantic-db: now loads and passes tests

diff --git a/extra/semantic-db/hierarchy/hierarchy.factor b/extra/semantic-db/hierarchy/hierarchy.factor
index fa10fff01cf622b59652a4edf66579f6a8793279..7d5f97690994faaf77315eb28247807e5869ce84 100644 (file)
--- a/extra/semantic-db/hierarchy/hierarchy.factor
+++ b/extra/semantic-db/hierarchy/hierarchy.factor
@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors db.tuples kernel new-slots semantic-db semantic-db.relations sequences sequences.deep ;
+USING: accessors db.tuples kernel new-slots semantic-db
+semantic-db.relations sorting sequences sequences.deep ;
 IN: semantic-db.hierarchy
 
 TUPLE: tree id children ;
@@ -33,6 +34,9 @@ C: <tree> tree
 : get-node-hierarchy ( node-id -- tree )
     dup children [ get-node-hierarchy ] map <tree> ;
 
+: uniq ( sorted-seq -- seq )
+    f swap [ tuck = not ] subset nip ;
+
 : (get-root-nodes) ( node-id -- root-nodes/node-id )
     dup parents dup empty? [
         drop
@@ -41,4 +45,4 @@ C: <tree> tree
     ] if ;
 
 : get-root-nodes ( node-id -- root-nodes )
-    (get-root-nodes) flatten ;
+    (get-root-nodes) flatten natural-sort uniq ;

diff --git a/extra/semantic-db/semantic-db-tests.factor b/extra/semantic-db/semantic-db-tests.factor
index 01476a145a54253d9347a80a53e181909bee2056..6c2c4d3e9e9c8eed310abb24d74bf7b544dbec4f 100644 (file)
--- a/extra/semantic-db/semantic-db-tests.factor
+++ b/extra/semantic-db/semantic-db-tests.factor
@@ -1,18 +1,27 @@
-USING: accessors arrays db db.sqlite db.tuples kernel math namespaces
-semantic-db semantic-db.context semantic-db.hierarchy semantic-db.relations
-sequences tools.test tools.walker ;
+USING: accessors arrays continuations db db.sqlite db.tuples io.files
+kernel math namespaces semantic-db semantic-db.context
+semantic-db.hierarchy semantic-db.relations sequences tools.test
+tools.walker ;
 IN: semantic-db.tests
 
-[
+: db-path "semantic-db-test.db" temp-file ;
+: test-db db-path sqlite-db ;
+: delete-db [ db-path delete-file ] ignore-errors ;
+
+delete-db
+
+test-db [
     create-node-table create-arc-table
     [ 1 ] [ "first node" create-node* ] unit-test
     [ 2 ] [ "second node" create-node* ] unit-test
     [ 3 ] [ "third node" create-node* ] unit-test
     [ 4 ] [ f create-node* ] unit-test
     [ 5 ] [ 1 2 3 create-arc* ] unit-test
-] with-tmp-sqlite
+] with-db
+
+delete-db
 
-[
+test-db [
     init-semantic-db
     "test content" create-context* [
         [ 4 ] [ context ] unit-test
@@ -35,10 +44,12 @@ IN: semantic-db.tests
     ! [ t ] [ "content" ensure-type "first content" ensure-node-of-type integer? ] unit-test
     ! [ t ] [ "content" ensure-type "second content" ensure-node-of-type integer? ] unit-test
     ! [ 2 ] [ "content" ensure-type select-nodes-of-type length ] unit-test
-] with-tmp-sqlite
+] with-db
+
+delete-db
 
 ! test hierarchy
-[
+test-db [
     init-semantic-db
     "family tree" create-context* [
         "adam" create-node* "adam" set
@@ -52,7 +63,9 @@ IN: semantic-db.tests
         [ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test
         [ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test
         [ "fran" { "charlie" } ] [ "fran" get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test
-        [ { "adam" "eve" } ] [ "charlie" get break get-root-nodes [ node-content ] map ] unit-test
+        [ { "adam" "eve" } ] [ "charlie" get get-root-nodes [ node-content ] map ] unit-test
         [ { } ] [ "fran" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test
     ] with-context
-] with-tmp-sqlite
+] with-db
+
+delete-db

diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor
index a48048f1529cbea47d85147d81d58d04fcb9b8cc..e8075c016da83fc1a9bf9b15b48d71078b74b0c2 100644 (file)
--- a/extra/semantic-db/semantic-db.factor
+++ b/extra/semantic-db/semantic-db.factor
@@ -86,3 +86,4 @@ arc "arc"
     #! quot1 ( x y -- z/f ) finds an existing z
     #! quot2 ( x y -- z ) creates a new z if quot1 returns f
     >r >r 2dup r> call [ 2nip ] r> if* ;
+