some further persistent tuple work; not sure if the whole tuple

persistence behavior should bleed into the bson reader/writer,
of if to keep them "pure"

mongodb/bson/reader/reader.factor

@@ -1,7 +1,7 @@
 USING: mirrors io io.encodings.utf8 io.encodings.binary math match kernel sequences
        splitting accessors io.streams.byte-array namespaces prettyprint
        mongodb.bson.constants assocs alien.c-types alien.strings fry words
-       tools.walker serialize ;
+       tools.walker serialize mongodb.persistent ;
 
 IN: mongodb.bson.reader
 
@@ -47,6 +47,9 @@ GENERIC: element-binary-read ( length type -- object )
 : read-int32 ( -- int32 )
     4 [ read *int ] [ count-bytes ] bi  ; inline
 
+: read-longlong ( -- longlong )
+    8 [ read *longlong ] [ count-bytes ] bi ; inline
+
 : read-double ( -- double )
     8 [ read *double ] [ count-bytes ] bi ; inline
 
@@ -89,8 +92,7 @@ GENERIC: element-binary-read ( length type -- object )
     [ read-elements ] when ;
 
 : make-tuple ( assoc -- tuple )
-    [ [ S_Name swap at ] [ S_Vocab swap at ] bi ] keep ! name vocab assoc
+    [ P_INFO swap at persistent-tuple-class new ] keep     ! instance assoc
-    [ lookup new ] dip                                 ! instance assoc
     [ dup <mirror> [ keys ] keep ] dip                 ! instance array mirror assoc
     '[ dup _ [ _ at ] dip [ swap ] dip set-at ] each ;   
 
@@ -98,7 +100,7 @@ GENERIC: fix-result ( assoc type -- result )
 
 M: bson-object fix-result ( assoc type -- result )
     drop
-    [ ] [ S_Name swap key? ] bi
+    [ ] [ P_INFO swap key? ] bi
     [ make-tuple ] [ ] if ;
 
 M: bson-array fix-result ( assoc type -- result )
@@ -124,6 +126,13 @@ M: bson-not-eoo element-read ( type -- cont? )
     set-at
     t ;
 
+M: bson-oid element-data-read ( type -- object )
+    drop
+    read-longlong
+    read-int32
+    oid boa
+    pop-element drop ;
+
 M: bson-object element-data-read ( type -- object )
     drop
     read-int32 drop

mongodb/bson/writer/writer.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: mongodb.bson mongodb.bson.constants accessors kernel io.streams.string
        io.encodings.binary classes byte-arrays quotations serialize
-       io.encodings.utf8 strings splitting math.parser
+       io.encodings.utf8 strings splitting math.parser locals
        sequences math assocs classes words make fry mongodb.persistent
        prettyprint hashtables mirrors alien.strings alien.c-types
        io.streams.byte-array io ;
@@ -41,10 +41,8 @@ M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
 : write-type ( obj -- obj ) [ bson-type? write-byte ] keep ;
 : write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ;
 
-: write-tuple-info ( object -- )
+:: write-tuple-info ( object -- )
-    class  
+    P_SLOTS [ [ ] [ object at ] bi write-pair ] each ;    
-    [ [ S_Name ] dip name>> write-pair ]
-    [ [ S_Vocab ] dip vocabulary>> write-pair ] bi ;    
 
 M: f bson-write ( f -- )
     drop 0 write-byte ;
@@ -87,27 +85,20 @@ M: sequence bson-write ( array -- )
         write
         write-eoo ;
 
+: check-p-field ( key value -- key value boolean )
+    [ [ "_p_" swap start 0 = ] keep ] dip rot ;
+    
 M: persistent-tuple bson-write ( persistent-tuple -- )
-    dup
+    <mirror>
-    <mirror> '[
+    '[ _ [ write-tuple-info ]
-        _ write-tuple-info
+         [ [ check-p-field [ 2drop ] [ write-pair ] if ] assoc-each ] bi ]
-        _ [ write-pair ] assoc-each
-    ]
     binary swap with-byte-writer
     [ length 5 + bson-write ] keep
     write
     write-eoo ;
 
 M: tuple bson-write ( tuple -- )
-    dup 
+    make-persistent bson-write ;
-    <mirror> '[
-        _ write-tuple-info
-        _ [ write-pair ] assoc-each
-    ]
-    binary swap with-byte-writer
-    [ length 5 + bson-write ] keep
-    write
-    write-eoo ;
     
 M: assoc bson-write ( hashtable -- )
     '[ _ [ write-pair ] assoc-each ]

mongodb/persistent/persistent.factor

@@ -1,5 +1,5 @@
-USING: formatting words classes.mixin kernel fry compiler.units
+USING: accessors classes classes.mixin classes.tuple compiler.units
-       accessors classes classes.tuple ;
+fry kernel words locals mirrors formatting assocs hashtables ;
 
 IN: mongodb.persistent
 
@@ -12,24 +12,35 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ;
 
 : MDB_CLASS ( -- string ) "p_class" ; inline
 : MDB_VOCAB ( -- string ) "p_vocab" ; inline
-: MDB_MODIF ( -- string ) "p_mt" ; inline
+: MDB_MT ( -- string ) "p_mt" ; inline
-: MDB_CREAT ( -- string ) "p_ct" ; inline
+: MDB_CT ( -- string ) "p_ct" ; inline
+: MDB_COL ( -- string ) "p_col" ; inline 
+
+PREDICATE: pinfo-hashtable < hashtable  [ MDB_CLASS swap key? ] [ MDB_VOCAB swap key? ] bi and ;
+
+: P_OID ( -- name ) "_p_oid" ; inline
+: P_INFO ( -- name ) "_p_info" ; inline
+
+: P_SLOTS ( -- array )
+    { "_p_oid" "_p_info" } ;
 
 <PRIVATE
 
 : P_VOCAB ( -- string )
     "mongodb.persistent" ; inline
 
-: P_SLOTS ( -- array )
+:: define-persistent-tuple ( superclass name -- class )
-    { "_p_oid" "_p_info" } ;
+    [let | pclass [ name P_VOCAB create ] |
-
+        [ pclass pclass [  ] curry define ] with-compilation-unit
-: define-persistent-tuple ( class name -- class )
+        [ pclass superclass P_SLOTS define-tuple-class
-    P_VOCAB create ! class word
+          pclass persistent-tuple add-mixin-instance ] with-compilation-unit
-    dup dup '[ _  _ [  ] curry define ] with-compilation-unit
+        pclass ] ; 
-    dup [ swap ] dip
+    
-    '[ _ _ P_SLOTS define-tuple-class
+:: copy-slots ( tuple 'tuple -- 'tuple )
-        _ persistent-tuple define-mixin-class ] with-compilation-unit ; 
+    [let | tm1 [ tuple <mirror> ]
-
+           tm2 [ 'tuple <mirror> ] |
+        tm1 [ swap tm2 set-at ] assoc-each
+        tm2 object>> ] ;
     
 PRIVATE>
 
@@ -38,6 +49,10 @@ GENERIC: persistent-tuple-class ( tuple -- class )
 M: tuple persistent-tuple-class ( tuple -- class )
     class persistent-tuple-class ;
 
+M: pinfo-hashtable persistent-tuple-class ( tuple -- class )
+    [ MDB_CLASS swap at ] [ MDB_VOCAB swap at ] bi lookup
+    persistent-tuple-class ;
+
 M: tuple-class persistent-tuple-class ( class -- class' )
     [ [ vocabulary>> ] [ name>> ] bi ] keep ! name vocab class
     [ "%s_%s" sprintf ] dip swap dup   ! class new_name new_name
@@ -47,9 +62,20 @@ M: tuple-class persistent-tuple-class ( class -- class' )
 
 GENERIC: make-persistent ( tuple -- 'tuple )
 
-! M: tuple make-persistent ( tuple -- 'tuple )
+M: tuple make-persistent ( tuple -- 'tuple )
-!    [let* | tuple [ ] 
+    [let* | tuple [  ]
-!            class [ tuple class ]
+            tclass [ tuple class ]
-!            'tuple [ class persistent-tuple-class new ] |
+            'tuple [ tclass persistent-tuple-class new ]
-!            
+            pinfo  [ H{  } clone ] |
-!            ] ; 
+        tuple 'tuple copy-slots
+        oid new >>_p_oid
+        tclass name>> MDB_CLASS pinfo set-at
+        tclass vocabulary>> MDB_VOCAB pinfo set-at
+        0 MDB_MT pinfo set-at
+        0 MDB_CT pinfo set-at
+        "" MDB_COL pinfo set-at
+         pinfo >>_p_info
+    ] ; 
+
+M: persistent-tuple make-persistent ( tuple -- tuple )
+    ;