made bson a toplevel vocab

bson/bson.factor

@@ -0,0 +1,9 @@
+
+IN: bson
+
+USE: vocabs.loader
+
+SINGLETON: bson-null
+
+"bson.reader" require
+"bson.writer" require

bson/constants/constants.factor

@@ -1,6 +1,8 @@
 USING: alien.c-types ;
 
-IN: mongodb.bson.constants
+IN: bson.constants
+
+TUPLE: oid { a initial: 0 } { b initial: 0 } ;
 
 
 : T_EOO ( -- type ) 0 ; inline
@@ -26,32 +28,4 @@ IN: mongodb.bson.constants
 : T_Binary_Bytes ( -- subtype ) 2 ; inline
 : T_Binary_Function ( -- subtype ) 1 ; inline 
 
-: S_Name ( -- name ) "__t_name" ; inline
-: S_Vocab ( -- name ) "__t_vocab" ; inline
-
-! todo Move to mongo vocab 
-
-: OP_Reply ( -- const )
-    1 <int> ; inline
-
-: OP_Message ( -- const )
-    1000 <int> ; inline
-
-: OP_Update ( -- const )
-    2001 <int> ; inline
-
-: OP_Insert ( -- const )
-    2002 <int> ; inline
-
-: OP_Query ( -- const )
-    2004 <int> ; inline
-
-: OP_GetMore ( -- const )
-    2005 <int> ; inline
-
-: OP_Delete ( -- const )
-    2006 <int> ; inline
-
-: OP_KillCursors ( -- const )
-    2007 <int> ; inline
 

bson/reader/reader.factor

@@ -1,21 +1,22 @@
 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
+       bson.constants assocs alien.c-types alien.strings fry words
-       tools.walker serialize mongodb.persistent ;
+       tools.walker serialize locals byte-arrays ;
 
-IN: mongodb.bson.reader
+IN: bson.reader
 
 ERROR: size-mismatch actual declared ;
 
 <PRIVATE
 
 TUPLE: element { type integer } name ;
-TUPLE: state { size initial: -1 } { read initial: 0 } result scope element ;
+TUPLE: state { size initial: -1 } { read initial: 0 } exemplar result scope element ;
 
-: <state> ( -- state )
+:: <state> ( exemplar -- state )
-    state new H{ } clone
+    state new  
-    [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi
+    exemplar clone >>exemplar
-    V{ } clone [ T_Object "" element boa swap push ] keep >>element ;
+    exemplar clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi
+    V{ } clone [ T_Object "" element boa swap push ] keep >>element ; inline
 
 PREDICATE: bson-eoo     < integer T_EOO = ;
 PREDICATE: bson-not-eoo < integer T_EOO > ;
@@ -63,45 +64,38 @@ GENERIC: element-binary-read ( length type -- object )
     read-byte-raw dup
     B{ 0 } =
     [ append ]
-    [ append (read-cstring) ] if ; 
+    [ append (read-cstring) ] if ; inline recursive
 
 : read-cstring ( -- string )
     B{ } clone
-    (read-cstring) utf8 alien>string ;
+    (read-cstring) utf8 alien>string ; inline
 
 : read-sized-string ( length -- string )
     [ read ] [ count-bytes ] bi
-    utf8 alien>string ;
+    utf8 alien>string ; inline
 
 : read-element-type ( -- type )
-    read-byte ;
+    read-byte ; inline
 
 : push-element ( type name -- element )
     element boa
-    [ get-state element>> push ] keep ; 
+    [ get-state element>> push ] keep ; inline
 
 : pop-element ( -- element )
-    get-state element>> pop ;
+    get-state element>> pop ; inline
 
 : peek-scope ( -- ht )
-    get-state scope>> peek ; 
+    get-state scope>> peek ; inline
 
 : read-elements ( -- )
     read-element-type
     element-read 
-    [ read-elements ] when ;
+    [ read-elements ] when ; inline recursive
-
-: make-tuple ( assoc -- tuple )
-    [ P_INFO swap at persistent-tuple-class new ] keep     ! instance assoc
-    [ dup <mirror> [ keys ] keep ] dip                 ! instance array mirror assoc
-    '[ dup _ [ _ at ] dip [ swap ] dip set-at ] each ;   
 
 GENERIC: fix-result ( assoc type -- result )
 
 M: bson-object fix-result ( assoc type -- result )
-    drop
+    drop ;
-    [ ] [ P_INFO swap key? ] bi
-    [ make-tuple ] [ ] if ;
 
 M: bson-array fix-result ( assoc type -- result )
     drop
@@ -110,9 +104,9 @@ M: bson-array fix-result ( assoc type -- result )
 M: bson-eoo element-read ( type -- cont? )
     drop
     get-state scope>> [ pop ] keep swap ! vec assoc
-    pop-element [ type>> ] keep                        ! vec assoc type element
+    pop-element [ type>> ] keep       ! vec assoc element
-    [ fix-result ] dip                                 ! vec result element 
+    [ fix-result ] dip
-    rot length 0 >                                     ! result element 
+    rot length 0 >                      ! assoc element 
     [ name>> peek-scope set-at t ]
     [ drop [ get-state ] dip >>result drop f ] if ;
 
@@ -133,19 +127,21 @@ M: bson-oid element-data-read ( type -- object )
     oid boa
     pop-element drop ;
 
-M: bson-object element-data-read ( type -- object )
+: [scope-changer] ( state -- state quot )
+    dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline
+
+: (object-data-read) ( type -- object )
     drop
     read-int32 drop
     get-state
-    [ [ [ H{ } clone ] dip push ] keep ] change-scope
+    [scope-changer] change-scope
-    scope>> peek ;
+    scope>> peek ; inline
+    
+M: bson-object element-data-read ( type -- object )
+    (object-data-read) ;
 
 M: bson-array element-data-read ( type -- object )
-    drop
+    (object-data-read) ;
-    read-int32 drop
-    get-state
-    [ [ [ H{ } clone ] dip push ] keep ] change-scope
-    scope>> peek ;
     
 M: bson-string element-data-read ( type -- object )
     drop
@@ -180,9 +176,17 @@ M: bson-binary-function element-binary-read ( size type -- quot )
 
 PRIVATE>
 
-: bson> ( arr -- ht )
+GENERIC: stream>assoc ( exemplar -- assoc )
-    binary
+
-    [ <state> dup state
+M: assoc stream>assoc ( exemplar -- assoc )
+    <state> dup state
         [ read-int32 >>size read-elements ] with-variable 
-        result>>
+        result>> ;
-    ] with-byte-reader ;
+
+USING: multi-methods ;
+    
+GENERIC: array>assoc ( array exemplar -- assoc )
+    
+METHOD: array>assoc { byte-array assoc } ( array exemplar -- assoc )
+    [ binary ] dip '[ _ stream>assoc ] with-byte-reader ;
+

bson/writer/writer.factor

@@ -0,0 +1,102 @@
+! Copyright (C) 2008 Sascha Matzke.
+! See http://factorcode.org/license.txt for BSD license.
+USING: bson bson.constants accessors kernel io.streams.string
+       io.encodings.binary classes byte-arrays quotations serialize
+       io.encodings.utf8 strings splitting math.parser locals
+       sequences math assocs classes words make fry 
+       prettyprint hashtables mirrors alien.strings alien.c-types
+       io.streams.byte-array io ;
+
+IN: bson.writer
+
+#! Writes the object out to a stream in BSON format
+
+<PRIVATE
+
+GENERIC: bson-type? ( obj -- type )
+GENERIC: bson-write ( obj -- )
+
+M: t bson-type? ( boolean -- type ) drop T_Boolean ; 
+M: f bson-type? ( boolean -- type ) drop T_Boolean ; 
+
+M: oid bson-type? ( word -- type ) drop T_OID ; 
+M: real bson-type? ( real -- type ) drop T_Double ; 
+M: word bson-type? ( word -- type ) drop T_String ; 
+M: tuple bson-type? ( tuple -- type ) drop T_Object ;  
+M: assoc bson-type? ( hashtable -- type ) drop T_Object ; 
+M: string bson-type? ( string -- type ) drop T_String ; 
+M: integer bson-type? ( integer -- type ) drop T_Integer ; 
+M: sequence bson-type? ( seq -- type ) drop T_Array ; 
+M: quotation bson-type? ( quotation -- type ) drop T_Binary ; 
+M: bson-null bson-type? ( null -- type ) drop T_NULL ; 
+M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; 
+
+: write-byte ( byte -- ) <char> write ; inline
+: write-int32 ( int -- ) <int> write ; inline
+: write-double ( real -- ) <double> write ; inline
+: write-cstring ( string -- ) utf8 string>alien write ; inline
+: write-longlong ( object -- ) <longlong> write ; inline
+
+: write-eoo ( -- ) T_EOO write-byte ; inline
+: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline
+: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline
+
+
+M: f bson-write ( f -- )
+    drop 0 write-byte ; 
+
+M: t bson-write ( t -- )
+    drop 1 write-byte ;
+
+M: bson-null bson-write ( null -- )
+    drop ;
+
+M: string bson-write ( obj -- )
+    utf8 string>alien 
+    [ length write-int32 ] keep
+    write ;
+
+M: integer bson-write ( num -- )
+    write-int32 ;
+
+M: real bson-write ( num -- )
+    >float write-double ;
+
+M: byte-array bson-write ( binary -- )
+    [ length write-int32 ] keep
+    T_Binary_Bytes write-byte
+    write ; 
+
+M: quotation bson-write ( quotation -- )
+    object>bytes [ length write-int32 ] keep
+    T_Binary_Function write-byte
+    write ; 
+
+M: oid bson-write ( oid -- )
+    [ a>> write-longlong ] [ b>> write-int32 ] bi ;
+    
+M: sequence bson-write ( array -- )
+    '[ _ [ [ write-type ] dip number>string write-cstring bson-write ]
+        each-index ]
+        binary swap with-byte-writer
+        [ length 5 + bson-write ] keep
+        write
+        write-eoo ; 
+    
+M: assoc bson-write ( hashtable -- )
+    '[ _ [ write-pair ] assoc-each ]
+    binary swap with-byte-writer
+    [ length 5 + bson-write ] keep
+    write
+    write-eoo ; 
+
+M: word bson-write name>> bson-write ;
+
+PRIVATE>
+    
+: assoc>array ( assoc -- byte-array )
+    '[ _ bson-write ] binary swap with-byte-writer ; inline
+
+: assoc>stream ( assoc -- )
+    bson-write ; inline
+

mongodb/bson/bson.factor

@@ -1,9 +0,0 @@
-
-IN: mongodb.bson
-
-USE: vocabs.loader
-
-SINGLETON: bson-null
-
-"mongodb.bson.reader" require
-"mongodb.bson.writer" require

mongodb/bson/writer/writer.factor

@@ -1,122 +0,0 @@
-! Copyright (C) 2008 Sascha Matzke.
-! 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 locals
-       sequences math assocs classes words make fry mongodb.persistent
-       prettyprint hashtables mirrors alien.strings alien.c-types
-       io.streams.byte-array io ;
-
-IN: mongodb.bson.writer
-
-#! Writes the object out to a stream in BSON format
-
-<PRIVATE
-
-GENERIC: bson-type? ( obj -- type )
-GENERIC: bson-write ( obj -- )
-
-M: t bson-type? ( boolean -- type ) drop T_Boolean ;
-M: f bson-type? ( boolean -- type ) drop T_Boolean ;
-
-M: oid bson-type? ( word -- type ) drop T_OID ;
-M: real bson-type? ( real -- type ) drop T_Double ;
-M: word bson-type? ( word -- type ) drop T_String ;
-M: tuple bson-type? ( tuple -- type ) drop T_Object ;
-M: assoc bson-type? ( hashtable -- type ) drop T_Object ;
-M: string bson-type? ( string -- type ) drop T_String ;
-M: integer bson-type? ( integer -- type ) drop T_Integer ;
-M: sequence bson-type? ( seq -- type ) drop T_Array ;
-M: quotation bson-type? ( quotation -- type ) drop T_Binary ;
-M: bson-null bson-type? ( null -- type ) drop T_NULL ;
-M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
-
-: write-byte ( byte -- ) <char> write ;
-: write-int32 ( int -- ) <int> write ;
-: write-double ( real -- ) <double> write ;
-: write-cstring ( string -- ) utf8 string>alien write ;
-: write-longlong ( object -- ) <longlong> write ;
-
-: write-eoo ( -- ) T_EOO write-byte ;
-: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ;
-: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ;
-
-:: write-tuple-info ( object -- )
-    P_SLOTS [ [ ] [ object at ] bi write-pair ] each ;    
-
-M: f bson-write ( f -- )
-    drop 0 write-byte ;
-
-M: t bson-write ( t -- )
-    drop 1 write-byte ;
-
-M: bson-null bson-write ( null -- )
-    drop ;
-
-M: string bson-write ( obj -- )
-    utf8 string>alien 
-    [ length write-int32 ] keep
-    write ;
-
-M: integer bson-write ( num -- )
-    write-int32 ;
-
-M: real bson-write ( num -- )
-    >float write-double ;
-
-M: byte-array bson-write ( binary -- )
-    [ length write-int32 ] keep
-    T_Binary_Bytes write-byte
-    write ;
-
-M: quotation bson-write ( quotation -- )
-    object>bytes [ length write-int32 ] keep
-    T_Binary_Function write-byte
-    write ;
-
-M: oid bson-write ( oid -- )
-    [ a>> write-longlong ] [ b>> write-int32 ] bi ;
-    
-M: sequence bson-write ( array -- )
-    '[ _ [ [ write-type ] dip number>string write-cstring bson-write ]
-        each-index ]
-        binary swap with-byte-writer
-        [ length 5 + bson-write ] keep
-        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 -- )
-    <mirror>
-    '[ _ [ write-tuple-info ]
-         [ [ check-p-field [ 2drop ] [ write-pair ] if ] assoc-each ] bi ]
-    binary swap with-byte-writer
-    [ length 5 + bson-write ] keep
-    write
-    write-eoo ;
-
-M: tuple bson-write ( tuple -- )
-    make-persistent bson-write ;
-    
-M: assoc bson-write ( hashtable -- )
-    '[ _ [ write-pair ] assoc-each ]
-    binary swap with-byte-writer
-    [ length 5 + bson-write ] keep
-    write
-    write-eoo ;
-
-M: word bson-write name>> bson-write ;
-
-PRIVATE>
-
-GENERIC: >bson ( obj -- byte-aray )    
-
-M: tuple >bson ( tuble -- byte-array )
-    '[ _ bson-write ] binary swap with-byte-writer ;
-    
-M: hashtable >bson ( hashmap -- byte-array )
-    '[ _ bson-write ] binary swap with-byte-writer ;
-
-