factor/contrib/serialize/serialize.factor

! Copyright (C) 2006 Adam Langley and Chris Double.
! Adam Langley was the original author of this work.
!
! Chris Double modified it to fix bugs and get it working
! correctly under the latest versions of Factor.
!
! See http://factorcode.org/license.txt for BSD license.
!
IN: serialize
USING: kernel kernel-internals math hashtables namespaces io strings sequences generic words errors arrays vectors ;

! Variable holding a sequence of objects already serialized
SYMBOL: serialized

: add-object ( obj -- id )
  #! Add an object to the sequence of already serialized objects.
  #! Return the id of that object.
  serialized get [ push ] keep length 1 - ;

: object-id ( obj -- id )
  #! Return the id of an already serialized object 
  serialized get [ eq? ] find-with [ drop f ] unless ;

USE: prettyprint 

! Serialize object
GENERIC: serialize  ( obj -- )

: serialize-shared ( obj quot -- )
  >r dup object-id [ "o" write serialize drop ] r> if* ; inline

M: f serialize ( obj -- )
  drop "n" write ;

M: fixnum serialize ( obj -- )
  ! Factor may use 64 bit fixnums on such systems
  "f" write
  4 >be write ;

: bytes-needed ( bignum -- int )
  log2 8 + 8 / floor ;

M: bignum serialize ( obj -- )
  "b" write
  dup bytes-needed serialize
  dup bytes-needed >be write ;

M: float serialize ( obj -- )
  "F" write
  float>bits serialize ;

M: complex serialize ( obj -- )
  [
    "c" write
    dup add-object serialize
    dup real serialize
    imaginary serialize 
  ] serialize-shared ;

M: ratio serialize ( obj -- )
  "r" write
  dup numerator serialize
  denominator serialize ;

M: string serialize ( obj -- )
  [
    "s" write
    dup add-object serialize
    dup length serialize
    write 
  ] serialize-shared ;

M: object serialize ( obj -- )
  class word-name "Don't know to serialize a " swap append throw ;

M: sbuf serialize ( obj -- )
  "S" write 
  dup length serialize
  [ serialize ] each ;

: serialize-seq ( seq code -- )
  swap [ 
    over write
    dup add-object serialize
    dup length serialize
    [ serialize ] each
  ] serialize-shared drop ;

M: tuple serialize ( obj -- )
  [
    "t" write 
    dup add-object serialize
    tuple>array serialize 
  ] serialize-shared ;

M: array serialize ( obj -- )
  "a" serialize-seq ;

M: vector serialize ( obj -- )
  "v" serialize-seq ;

M: quotation serialize ( obj -- )
  "q" serialize-seq ;

M: hashtable serialize ( obj -- )
  [
    "h" write
    dup add-object serialize
    hash>alist serialize
  ] serialize-shared ;

M: word serialize ( obj -- )
  "w" write
  dup word-name serialize
  word-vocabulary serialize ;

M: wrapper serialize ( obj -- )
  "W" write
  wrapped serialize ;

DEFER: deserialize ( -- obj )

: intern-object ( id obj -- )
  swap serialized get set-nth ;

: deserialize-false ( -- f )
  f ;

: deserialize-fixnum ( -- fixnum )
  4 read be> ;

: deserialize-string ( -- string )
  deserialize deserialize read [ intern-object ] keep ;

: deserialize-ratio ( -- ratio )
  deserialize deserialize / ;

: deserialize-complex ( -- complex )
  deserialize deserialize deserialize rect> [ intern-object ] keep ;

: deserialize-bignum ( -- bignum )
  deserialize read be> ;

: deserialize-float ( -- float )
  deserialize bits>float ;

: deserialize-word ( -- word )
  deserialize dup deserialize lookup dup [ nip ] [ "Unknown word" throw ] if ;

: deserialize-wrapper ( -- wrapper )
  deserialize <wrapper> ;

: deserialize-array ( -- array )
  deserialize     
  [ 
    deserialize 
    [ deserialize , ] repeat 
  ] { } make 
  [ intern-object ] keep ;

: deserialize-vector ( -- array )
  deserialize     
  [ 
    deserialize 
    [ deserialize , ] repeat 
  ] V{ } make 
  [ intern-object ] keep ;

: deserialize-quotation ( -- array )
  deserialize     
  [ 
    deserialize 
    [ deserialize , ] repeat 
  ] [ ] make 
  [ intern-object ] keep ;

: deserialize-hashtable ( -- array )
  deserialize 
  deserialize alist>hash    
  [ intern-object ] keep ;

: deserialize-tuple ( -- array )
  deserialize 
  deserialize array>tuple
  [ intern-object ] keep ;

: deserialize-unknown ( -- object )
  deserialize serialized get nth ;

: deserialize ( -- object )
  read1 ch>string dup
  H{ { "f" deserialize-fixnum }
     { "s" deserialize-string }
     { "r" deserialize-ratio }
     { "c" deserialize-complex }
     { "b" deserialize-bignum }
     { "F" deserialize-float }
     { "w" deserialize-word }
     { "W" deserialize-wrapper }
     { "n" deserialize-false }
     { "a" deserialize-array }
     { "v" deserialize-vector }
     { "q" deserialize-quotation }
     { "h" deserialize-hashtable }
     { "t" deserialize-tuple }
     { "o" deserialize-unknown }
  }
  hash dup [ "Unknown typecode" throw ] unless nip execute ;

: with-serialized ( quot -- )
  [ V{ } serialized set call ] with-scope ; inline