[MLton-commit] r6389
Vesa Karvonen
vesak at mlton.org
Thu Feb 7 19:04:15 PST 2008
Added support for pickle versioning.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig
U mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2008-02-07 07:22:42 UTC (rev 6388)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2008-02-08 03:04:14 UTC (rev 6389)
@@ -501,6 +501,40 @@
else unpickler)
end}) t
end
+
+ datatype 'a v = IN of Int.t -> 'a U.monad
+
+ exception Version of Int.t
+
+ fun check i = if i < 0 then raise Size else ()
+
+ fun version iOfT t fromT =
+ (check iOfT
+ ; case U.map fromT (#unpickler (getPU t))
+ of u => Fold.mapSt (fn IN other =>
+ IN (fn i => if i = iOfT
+ then u
+ else other i)))
+
+ fun versioned ? =
+ Fold.wrap
+ (IN (Exn.throw o Version),
+ fn IN other => fn iOfT => fn t =>
+ (check iOfT
+ ; case getPU t
+ of {pickler, unpickler} =>
+ setPU {pickler = let
+ open P
+ in
+ fn v => wr size iOfT >>= (fn () => pickler v)
+ end,
+ unpickler = let
+ open U
+ in
+ rd size >>= (fn i =>
+ if i = iOfT then unpickler else other i)
+ end}
+ t)) ?
end
fun pickler aT =
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig 2008-02-07 07:22:42 UTC (rev 6388)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig 2008-02-08 03:04:14 UTC (rev 6389)
@@ -118,6 +118,37 @@
* match during unpickling, the {TypeMismatch} exception is raised.
*)
+ (** == Pickler Versioning ==
+ *
+ * For example:
+ *
+ *> val t = versioned (version 4 t4 fromV4)
+ *> (version 7 t7 fromV7)
+ *> $ 8 t8
+ *
+ * Above, type reps {t4} and {t7} are old versions that can still be
+ * unpickled. Type rep {t8} is the current version, whose values
+ * can be pickled and unpickled.
+ *
+ * Version numbers must be non-negative integers.
+ *)
+
+ exception Version of Int.t
+ (** Raised in case unpickling encounters an unsupported version. *)
+
+ type 'a v
+ (** Version fold state type. *)
+
+ val versioned :
+ (('a v, 'a v, Int.t -> ('a, 'x) PickleRep.t UnOp.t) Fold.t, 'k) CPS.t
+ (** Starts a fold to update a type rep to contain a versioned pickler. *)
+
+ val version : Int.t ->
+ ('a, 'x) PickleRep.t ->
+ ('a -> 'b) ->
+ (('b v, 'c, 'd) Fold.t, ('b v, 'c, 'd) Fold.t, 'k) Fold.s
+ (** Adds a version. *)
+
(** == Monadic Combinator Interface == *)
structure P : MONAD and U : MONAD
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml 2008-02-07 07:22:42 UTC (rev 6388)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml 2008-02-08 03:04:14 UTC (rev 6389)
@@ -61,35 +61,18 @@
(* This test shows how pickles can be versioned and multiple
* versions supported at the same time. *)
- open Cvt Pickle
+ open Pickle
- val puInt = getPU int
-
(* First a plain old type rep for our data: *)
val t1 = iso (record (R' "id" int
*` R' "name" string))
(fn {id = a, name = b} => a & b,
fn a & b => {id = a, name = b})
- (* Then we customize it to store and check a version number: *)
- val pu1 = getPU t1
- val t =
- setPU {pickler = let
- open P
- in
- fn v =>
- #pickler puInt 1 >>= (fn () => #pickler pu1 v)
- end,
- unpickler = let
- open U
- in
- #unpickler puInt
- >>= (fn 1 => #unpickler pu1
- | n => fails ["Bad ", D n])
- end}
- t1
+ (* Then we assign version {1} to the type: *)
+ val t = versioned $ 1 t1
- val pickled = pickle t {id = 1, name = "whatever"}
+ val v1pickle = pickle t {id = 1, name = "whatever"}
(* Then a plain old type rep for our new data: *)
val t2 = iso (record (R' "id" int
@@ -98,35 +81,21 @@
(fn {id = a, extra = b, name = c} => a & b & c,
fn a & b & c => {id = a, extra = b, name = c})
- (* Then we customize it to store a version number and dispatch
- * based on it: *)
- val pu2 = getPU t2
- val t =
- setPU {pickler = let
- open P
- in
- fn v =>
- #pickler puInt 2 >>= (fn () => #pickler pu2 v)
- end,
- unpickler = let
- open U
- fun fromR1 {id, name} =
- {id = id, extra = false, name = name}
- in
- #unpickler puInt
- >>= (fn 1 => map fromR1 (#unpickler pu1)
- | 2 => #unpickler pu2
- | n => fails ["Bad ", D n])
- end}
- t2
- (* Note that the original customized {t} is no longer
- * needed. In an actual program, you would have just edited
- * the original definition instead of introducing a new one.
+ (* Then we assigning version {2} to the new type, keeping
+ * the version {1} for the old type: *)
+ val t = versioned (version 1 t1
+ (fn {id, name} =>
+ {id = id, extra = false, name = name}))
+ $ 2 t2
+
+ (* Note that the original versioned {t} is no longer needed.
+ * In an actual program, you would have just edited the
+ * original definition instead of introducing a new one.
* However, the old type rep is required if you wish to be
* able to unpickle old versions. *)
in
thatEq t {expect = {id = 1, extra = false, name = "whatever"},
- actual = unpickle t pickled}
+ actual = unpickle t v1pickle}
; thatEq t {expect = {id = 3, extra = true, name = "whenever"},
actual = unpickle t (pickle t {id = 3, extra = true,
name = "whenever"})}
More information about the MLton-commit
mailing list