Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
module type CELL = sig
type 'a cell
type 'a exp
val return : 'a -> 'a exp
val (>>=) : 'a exp -> ('a -> 'b exp) -> 'b exp
val cell : 'a exp -> 'a cell exp
val get : 'a cell -> 'a exp
val set : 'a cell -> 'a exp -> unit
val run : 'a exp -> 'a
end
module Cell : CELL = struct
type 'a cell = {
mutable code : 'a exp;
mutable value : 'a option;
mutable reads : ecell list;
mutable observers : ecell list;
id : int
}
and 'a exp = unit -> ('a * ecell list)
and ecell = Pack : 'a cell -> ecell
let id (Pack c) = c.id
let rec union xs ys =
match xs with
| [] -> []
| x :: xs' ->
if List.exists (fun y -> id x = id y) ys then
union xs' ys
else
x :: (union xs' ys)
let return v () = (v, [])
let (>>=) cmd f () =
let (a, cs) = cmd () in
let (b, ds) = f a () in
(b, union cs ds)
let r = ref 0
let new_id () = incr r; !r
let cell exp () =
let n = new_id() in
let cell = {
code = exp;
value = None;
reads = [];
observers = [];
id = n;
} in
(cell, [])
let get c () =
match c.value with
| Some v -> (v, [Pack c])
| None ->
let (v, ds) = c.code () in
c.value <- Some v;
c.reads <- ds;
List.iter (fun (Pack d) -> d.observers <- (Pack c) :: d.observers) ds;
(v, [Pack c])
let remove_observer o (Pack c) =
c.observers <- List.filter (fun o' -> id o != id o') c.observers
let rec invalidate (Pack c) =
let os = c.observers in
let rs = c.reads in
c.observers <- [];
c.value <- None;
c.reads <- [];
List.iter (remove_observer (Pack c)) rs;
List.iter invalidate os
let set c exp =
c.code <- exp;
invalidate (Pack c)
let run cmd = fst (cmd ())
end
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment