lib/dump.ml

   1 (** Dump **)
   2
   3 (* Copyright Jeremy Yallop 2007.
   4    This file is free software, distributed under the MIT license.
   5    See the file COPYING for details.
   6 *)
   7
   8 (* TODO: we could have an additional debugging deserialisation method. *)
   9 module type Dump = sig
  10   type a
  11     val to_buffer : Buffer.t -> a -> unit
  12     val to_string : a -> string
  13     val to_channel : out_channel -> a -> unit
  14     val from_stream : char Stream.t -> a
  15     val from_string : string -> a
  16     val from_channel : in_channel -> a
  17 end
  18
  19 module type SimpleDump = sig
  20   type a
  21   val to_buffer : Buffer.t -> a -> unit
  22   val from_stream : char Stream.t -> a
  23 end
  24
  25 exception Dump_error of string
  26
  27 let bad_tag tag stream typename =
  28   raise (Dump_error
  29            (Printf.sprintf
  30               "Dump: failure during %s deserialisation at character %d; unexpected tag %d"
  31               typename (Stream.count stream) tag))
  32
  33 module Defaults (P : sig
  34                           type a
  35                           val to_buffer : Buffer.t -> a -> unit
  36                           val from_stream : char Stream.t -> a
  37                         end) : Dump with type a = P.a =
  38 struct
  39   include P
  40
  41  (* is there a reasonable value to use here? *)
  42   let buffer_size = 128
  43
  44   let to_string obj =
  45     let buffer = Buffer.create buffer_size in
  46       P.to_buffer buffer obj;
  47       Buffer.contents buffer
  48       (* should we explicitly deallocate the buffer? *)
  49   and from_string string = P.from_stream (Stream.of_string string)
  50   and from_channel in_channel =
  51     from_stream (Stream.of_channel in_channel)
  52   and to_channel out_channel obj =
  53     let buffer = Buffer.create buffer_size in
  54       P.to_buffer buffer obj;
  55       Buffer.output_buffer out_channel buffer
  56 end
  57
  58
  59 (* Generic int dumper.  This should work for any (fixed-size) integer
  60    type with suitable operations. *)
  61 module Dump_intN (P : sig
  62                       type t
  63                       val zero : t
  64                       val logand : t -> t -> t
  65                       val logor : t -> t -> t
  66                       val lognot : t -> t
  67                       val shift_right_logical : t -> int -> t
  68                       val shift_left : t -> int -> t
  69                       val of_int : int -> t
  70                       val to_int : t -> int
  71                     end) = Defaults (
  72   struct
  73     type a = P.t
  74         (* Format an integer using the following scheme:
  75
  76            The lower 7 bits of each byte are used to store successive 7-bit
  77            chunks of the integer.
  78
  79            The highest bit of each byte is used as a flag to indicate
  80            whether the next byte is present.
  81         *)
  82     open Buffer
  83     open Char
  84     open P
  85
  86     let to_buffer buffer =
  87       let rec aux int =
  88         (* are there more than 7 bits? *)
  89         if logand int (lognot (of_int 0x7f)) <> zero
  90         (* if there are, write the lowest 7 bite plus a high bit (to
  91            indicate that there's more).  Then recurse, shifting the value
  92            7 bits right *)
  93         then begin
  94           add_char buffer (chr (to_int (logor (of_int 0x80) (logand int (of_int 0x7f)))));
  95           aux (shift_right_logical int 7)
  96         end
  97           (* otherwise, write the bottom 7 bits only *)
  98         else add_char buffer (chr (to_int int))
  99       in aux
 100
 101     and from_stream stream =
 102       let rec aux (int : t) shift =
 103         let c = of_int (code (Stream.next stream)) in
 104         let int = logor int (shift_left (logand c (of_int 0x7f)) shift) in
 105           if logand c (of_int 0x80) <> zero then aux int (shift + 7)
 106           else int
 107       in aux zero 0
 108   end
 109 )
 110
 111 module Dump_int32 = Dump_intN (Int32)
 112 module Dump_int64 = Dump_intN (Int64)
 113 module Dump_nativeint = Dump_intN (Nativeint)
 114 module Dump_int = Defaults (
 115   struct
 116     type a = int
 117     let to_buffer buffer int = Dump_nativeint.to_buffer buffer (Nativeint.of_int int)
 118     and from_stream stream = Nativeint.to_int (Dump_nativeint.from_stream stream)
 119   end
 120 )
 121
 122 module Dump_char = Defaults (
 123   struct
 124     type a = char
 125     let to_buffer = Buffer.add_char
 126     and from_stream = Stream.next
 127   end
 128 )
 129
 130 (* This is questionable; it doesn't preserve sharing *)
 131 module Dump_string = Defaults (
 132   struct
 133     type a = string
 134     let to_buffer buffer string =
 135       begin
 136         Dump_int.to_buffer buffer (String.length string);
 137         Buffer.add_string buffer string
 138       end
 139     and from_stream stream =
 140       let len = Dump_int.from_stream stream in
 141       let s = String.create len in
 142         for i = 0 to len - 1 do
 143           String.set s i (Stream.next stream) (* could use String.unsafe_set here *)
 144         done;
 145         s
 146   end
 147 )
 148
 149 module Dump_float = Defaults (
 150   struct
 151     type a = float
 152     let to_buffer buffer f = Dump_int64.to_buffer buffer (Int64.bits_of_float f)
 153     and from_stream stream = Int64.float_of_bits (Dump_int64.from_stream stream)
 154   end
 155 )
 156
 157 (* This should end up a bit more compact than the derived version *)
 158 module Dump_list (P : SimpleDump) = Defaults (
 159   (* This could perhaps be more efficient by serialising the list in
 160      reverse: this would result in only one traversal being needed
 161      during serialisation, and no "reverse" being needed during
 162      deserialisation.  (However, dumping would no longer be
 163      tail-recursive) *)
 164   struct
 165     type a = P.a list
 166     let to_buffer buffer items =
 167       begin
 168         Dump_int.to_buffer buffer (List.length items);
 169         List.iter (P.to_buffer buffer) items
 170       end
 171     and from_stream stream =
 172       let rec aux items = function
 173         | 0 -> items
 174         | n -> aux (P.from_stream stream :: items) (n-1)
 175       in List.rev (aux [] (Dump_int.from_stream stream))
 176   end
 177 )
 178
 179 (* Dump_ref and Dump_array cannot preserve sharing, so we don't
 180    provide implementations *)
 181
 182 module Dump_option (P : SimpleDump) = Defaults (
 183   struct
 184     type a = P.a option
 185     let to_buffer buffer = function
 186       | None   -> Dump_int.to_buffer buffer 0
 187       | Some s ->
 188           begin
 189             Dump_int.to_buffer buffer 1;
 190             P.to_buffer buffer s
 191           end
 192     and from_stream stream =
 193       match Dump_int.from_stream stream with
 194         | 0 -> None
 195         | 1 -> Some (P.from_stream stream)
 196         | i      -> bad_tag i stream "option"
 197   end
 198 )
 199
 200
 201 module Dump_bool = Defaults (
 202   struct
 203     type a = bool
 204     let to_buffer buffer = function
 205       | false -> Buffer.add_char buffer '\000'
 206       | true  -> Buffer.add_char buffer '\001'
 207     and from_stream stream =
 208       match Stream.next stream with
 209         | '\000' -> false
 210         | '\001' -> true
 211         | c      -> bad_tag (Char.code c) stream "bool"
 212   end
 213 )
 214
 215 module Dump_unit = Defaults (
 216   struct
 217     type a = unit
 218     let to_buffer _ () = ()
 219     and from_stream _ = ()
 220   end
 221 )
 222
 223 module Dump_num = Defaults (
 224   struct
 225     (* TODO: a less wasteful dumper for nums.  A good start would be
 226        using half a byte per decimal-coded digit, instead of a whole
 227        byte. *)
 228     type a = Num.num
 229     let to_buffer buffer n = Dump_string.to_buffer buffer (Num.string_of_num n)
 230     and from_stream stream = Num.num_of_string (Dump_string.from_stream stream)
 231   end
 232 )
 233
 234 module Dump_undumpable (P : sig type a val tname : string end) = Defaults (
 235   struct
 236     type a = P.a
 237     let to_buffer _ _ = failwith ("Dump: attempt to serialise a value of unserialisable type : " ^ P.tname)
 238     let from_stream _ = failwith ("Dump: attempt to deserialise a value of unserialisable type : " ^ P.tname)
 239   end
 240 )
 241
 242 (* Uses Marshal to serialise the values that the parse-the-declarations
 243    technique can't reach. *)
 244 module Dump_via_marshal (P : sig type a end) = Defaults (
 245 (* Rather inefficient. *)
 246   struct
 247     include P
 248     let to_buffer buffer obj = Buffer.add_string buffer (Marshal.to_string obj [Marshal.Closures])
 249     let from_stream stream =
 250       let readn n =
 251         let s = String.create n in
 252           for i = 0 to n - 1 do
 253             String.set s i (Stream.next stream)
 254           done;
 255           s
 256       in
 257       let header = readn Marshal.header_size in
 258       let datasize = Marshal.data_size header 0 in
 259       let datapart = readn datasize in
 260         Marshal.from_string (header ^ datapart) 0
 261   end)