1. Dmitry Grebeniuk
  2. parvel

Commits

Dmitry Grebeniuk  committed c26e5d1

Univ type from Jane Street blog

  • Participants
  • Parent commits 6f85f5f
  • Branches default

Comments (0)

Files changed (2)

File univ.ml

View file
+(* parvel won't use this code, it's an example only *)
+
+(* the original code by Stephen Weeks is:
+module Univ : Univ = struct
+  type t = { 
+    id : unit ref;
+    store : unit -> unit; 
+  }
+ 
+  let embed () = 
+    let id = ref () in
+    let r = ref None in
+    let put a =
+      let o = Some a in
+      { id = id; store = (fun () -> r := o); }
+    in
+    let get t =
+      if id == t.id then (t.store (); let a = !r in r := None; a) else None
+    in
+    (put, get)
+end
+*)
+
+
+module Variant
+ =
+  struct
+
+    type t 'a =
+      { variant_name : string
+      ; temp_contents : mutable option 'a
+      }
+    ;
+
+    value create variant_name =
+      { variant_name = String.copy variant_name
+      ; temp_contents = None
+      }
+    ;
+
+  end
+;
+
+open Variant
+;
+
+type t =
+  { store : unit -> unit
+  ; vname : string
+  }
+;
+
+value variant_name x = x.vname
+;
+
+value create v a =
+  let o = Some a in
+  { store = fun () -> v.temp_contents := o
+  ; vname = v.variant_name
+  }
+;
+
+value match_ v a =
+  if a.vname == v.variant_name
+  then
+    let () = a.store () in
+    let a = v.temp_contents in
+    let () = v.temp_contents := None in
+    a
+  else
+    None
+;
+
+
+(******)
+
+
+value tests () =
+  let vint = Variant.create "int"
+  and vstr = Variant.create "string" in
+  let lst = [ create vint 123; create vstr "asd" ] in
+  let ok1 = (List.map (match_ vint) lst) = [Some 123; None]
+  and ok2 = (List.map (match_ vstr) lst) = [None; Some "asd"] in
+  let ok = ok1 && ok2 in
+  Printf.printf "univ tests ok = %b\n%!" ok
+;
+
+
+value _ () = tests ()
+;

File univ.mli

View file
+(* taken from http://ocaml.janestreet.com/?q=node/95 *)
+
+module Variant
+ :
+  sig
+    type t 'a;
+
+    (** [create variant_name to_sexp] creates a new variant with the
+        given name *)
+    value create : string -> t 'a;
+  end
+;
+
+type t;
+
+value create : Variant.t 'a -> 'a -> t;
+
+value match_ : Variant.t 'a -> t -> option 'a;
+
+value variant_name : t -> string;