tokyo: Reimplement assoc protocols for remote and abstract db using a functor

extra/tokyo/abstractdb/abstractdb.factor

@@ -1,60 +1,10 @@
 ! Copyright (C) 2009 Bruno Deferrari
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays assocs destructors
+USING: accessors kernel tokyo.alien.tcadb tokyo.assoc-functor ;
-kernel locals sequences serialize vectors
-tokyo.alien.tcadb tokyo.alien.tcutil tokyo.utils ;
 IN: tokyo.abstractdb
 
-TUPLE: tokyo-abstractdb handle disposed ;
+<< "tcadb" "abstractdb" define-tokyo-assoc-api >>
-
-INSTANCE: tokyo-abstractdb assoc
 
 : <tokyo-abstractdb> ( name -- tokyo-abstractdb )
     tcadbnew [ swap tcadbopen drop ] keep
     tokyo-abstractdb new [ (>>handle) ] keep ;
-
-M: tokyo-abstractdb dispose* [ tcadbdel f ] change-handle drop ;
-
-M:: tokyo-abstractdb at* ( key db -- value/f ? )
-    0 <int>          :> sizeout
-    db handle>>      :> handle
-    key object>bytes :> kbytes
-    kbytes length    :> key-size
-    handle kbytes key-size sizeout tcadbget :> output
-    output [
-        [ memory>object ] [ tcfree ] bi t
-    ] [ f f ] if* ;
-
-M: tokyo-abstractdb assoc-size ( db -- size ) handle>> tcadbrnum ;
-
-! FIXME: make this nicer
-M:: tokyo-abstractdb >alist ( db -- alist )
-    db handle>>            :> handle
-    0 <int>                :> size-out
-    db assoc-size <vector> :> keys
-    handle tcadbiterinit drop
-    [ handle size-out tcadbiternext dup ] [
-        [ memory>object ] [ tcfree ] bi
-        keys push
-    ] while drop
-    keys [ dup db at 2array ] { } map-as ;
-
-M:: tokyo-abstractdb set-at ( value key db -- )
-    db handle>>        :> handle
-    key object>bytes   :> kbytes
-    kbytes length      :> key-size
-    value object>bytes :> vbytes
-    vbytes length      :> value-size
-    handle kbytes key-size vbytes value-size tcadbput drop ;
-
-M:: tokyo-abstractdb delete-at ( key db -- )
-    db handle>>      :> handle
-    key object>bytes :> kbytes
-    kbytes length    :> key-size
-    handle kbytes key-size tcadbout drop ;
-
-M: tokyo-abstractdb clear-assoc ( db -- ) handle>> tcadbvanish drop ;
-
-M: tokyo-abstractdb equal? assoc= ;
-
-M: tokyo-abstractdb hashcode* assoc-hashcode ;

extra/tokyo/assoc-functor/assoc-functor.factor

@@ -0,0 +1,59 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types arrays assocs destructors functors
+kernel locals sequences serialize tokyo.alien.tcutil tokyo.utils vectors ;
+IN: tokyo.assoc-functor
+
+FUNCTOR: define-tokyo-assoc-api ( T N -- )
+
+DBGET      IS ${T}get
+DBPUT      IS ${T}put
+DBOUT      IS ${T}out
+DBDEL      IS ${T}del
+DBRNUM     IS ${T}rnum
+DBITERINIT IS ${T}iterinit
+DBITERNEXT IS ${T}iternext
+DBVANISH   IS ${T}vanish
+
+DBKEYS DEFINES tokyo-${N}-keys
+
+TYPE DEFINES-CLASS tokyo-${N}
+
+WHERE
+
+TUPLE: TYPE handle disposed ;
+
+INSTANCE: TYPE assoc
+
+M: TYPE dispose* [ DBDEL f ] change-handle drop ;
+
+M: TYPE at* ( key db -- value/f ? )
+    handle>> [ object>bytes dup length ] dip 0 <int>
+    DBGET [ [ memory>object ] [ tcfree ] bi t ] [ f f ] if* ;
+
+M: TYPE assoc-size ( db -- size ) handle>> DBRNUM ;
+
+: DBKEYS ( db -- keys )
+    [ assoc-size <vector> ] [ handle>> ] bi
+    dup DBITERINIT drop 0 <int>
+    [ 2dup DBITERNEXT dup ] [
+        [ memory>object ] [ tcfree ] bi
+        [ pick ] dip swap push
+    ] while 3drop ;
+
+M: TYPE >alist ( db -- alist )
+    dup DBKEYS [ over at 2array ] with nip ;
+
+M: TYPE set-at ( value key db -- )
+    handle>> spin [ object>bytes dup length ] bi@ DBPUT drop ;
+
+M: TYPE delete-at ( key db -- )
+    handle>> [ object>bytes dup length ] DBOUT drop ;
+
+M: TYPE clear-assoc ( db -- ) handle>> DBVANISH drop ;
+
+M: TYPE equal? assoc= ;
+
+M: TYPE hashcode* assoc-hashcode ;
+
+;FUNCTOR

extra/tokyo/assoc-functor/authors.txt

@@ -0,0 +1 @@
+Bruno Deferrari

extra/tokyo/assoc-functor/summary.txt

@@ -0,0 +1 @@
+Functor used to implement the assoc protocol on the different db apis in Tokyo

extra/tokyo/remotedb/remotedb.factor

@@ -1,60 +1,10 @@
 ! Copyright (C) 2009 Bruno Deferrari
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays assocs destructors
+USING: accessors kernel tokyo.alien.tcrdb tokyo.assoc-functor ;
-kernel locals sequences serialize vectors
-tokyo.alien.tcrdb tokyo.alien.tcutil tokyo.utils ;
 IN: tokyo.remotedb
 
-TUPLE: tokyo-remotedb handle disposed ;
+<< "tcrdb" "remotedb" define-tokyo-assoc-api >>
-
-INSTANCE: tokyo-remotedb assoc
 
 : <tokyo-remotedb> ( host port -- tokyo-remotedb )
     [ tcrdbnew dup ] 2dip tcrdbopen drop
     tokyo-remotedb new [ (>>handle) ] keep ;
-
-M: tokyo-remotedb dispose* [ tcrdbdel f ] change-handle drop ;
-
-M:: tokyo-remotedb at* ( key db -- value/f ? )
-    0 <int>          :> sizeout
-    db handle>>      :> handle
-    key object>bytes :> kbytes
-    kbytes length    :> key-size
-    handle kbytes key-size sizeout tcrdbget :> output
-    output [
-        [ memory>object ] [ tcfree ] bi t
-    ] [ f f ] if* ;
-
-M: tokyo-remotedb assoc-size ( db -- size ) handle>> tcrdbrnum ;
-
-! FIXME: make this nicer
-M:: tokyo-remotedb >alist ( db -- alist )
-    db handle>>            :> handle
-    0 <int>                :> size-out
-    db assoc-size <vector> :> keys
-    handle tcrdbiterinit drop
-    [ handle size-out tcrdbiternext dup ] [
-        [ memory>object ] [ tcfree ] bi
-        keys push
-    ] while drop
-    keys [ dup db at 2array ] { } map-as ;
-
-M:: tokyo-remotedb set-at ( value key db -- )
-    db handle>>        :> handle
-    key object>bytes   :> kbytes
-    kbytes length      :> key-size
-    value object>bytes :> vbytes
-    vbytes length      :> value-size
-    handle kbytes key-size vbytes value-size tcrdbput drop ;
-
-M:: tokyo-remotedb delete-at ( key db -- )
-    db handle>>      :> handle
-    key object>bytes :> kbytes
-    kbytes length    :> key-size
-    handle kbytes key-size tcrdbout drop ;
-
-M: tokyo-remotedb clear-assoc ( db -- ) handle>> tcrdbvanish drop ;
-
-M: tokyo-remotedb equal? assoc= ;
-
-M: tokyo-remotedb hashcode* assoc-hashcode ;