Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 126 lines (94 sloc) 4.107 kB
991ccf1 @VictorNicollet Initial import of Ohm
authored
1 (* Ohm is © 2012 Victor Nicollet *)
2
3 (* Types, both public and private ---------------------------------------------------------- *)
4
5 type thread = Do of thread list Lazy.t
6 type ('ctx,'value) t = 'ctx -> ('value -> thread) -> thread
7
8 type ('ctx,'value) value = ('ctx,'value) t
9 type 'ctx effect = ('ctx,unit) t
10
11 (* Monad usage ----------------------------------------------------------------------------- *)
12
13 let return x = fun _ emit -> Do (lazy [emit x])
14 let bind f m = fun c emit -> m c (fun x -> f x c emit)
15 let map f m = fun c emit -> m c (fun x -> emit (f x))
16 let unwrap m = fun c emit -> m c (fun x -> x c emit)
17
18 (* Context manipulation -------------------------------------------------------------------- *)
19
20 let context = fun c emit -> Do (lazy [emit c])
21
22 let with_context c m = fun _ emit -> m c emit
23
24 let edit_context f m = fun c emit -> m (f c) emit
25
26 (* Concurrency manipulation ---------------------------------------------------------------- *)
27
28 let nop = Do (lazy [])
29
30 let yield m = fun c emit -> Do (lazy [nop ; m c emit])
31
32 let join a b f = fun c emit -> let ra = ref None and rb = ref None in
33 let emit_a xa = match !rb with
34 | None -> ra := Some xa ; nop
35 | Some xb -> f xa xb c emit
36 and emit_b xb = match !ra with
37 | None -> rb := Some xb ; nop
38 | Some xa -> f xa xb c emit
39 in
40 Do (lazy [a c emit_a ; b c emit_b])
41
42 let fork a b = fun c emit -> Do (lazy [b c emit ; a c (fun _ -> nop)])
43
44 (* Utilities ------------------------------------------------------------------------------ *)
45
46 let memo m =
47 let r = ref None in
48 fun c emit -> Do (lazy [(
49 match !r with
50 | Some (c',v) when c' == c -> emit v
51 | _ -> m c (fun x -> r := Some (c,x) ; emit x)
52 )])
53
54 let of_lazy l = fun c emit -> Do (lazy [emit (Lazy.force l)])
55 let of_func f = fun c emit -> Do (lazy [emit (f ())])
56
57 let of_call f a = fun c emit -> f a c emit
58
59 let list_map f l = fun c emit ->
60 if l = [] then emit [] else
61 let num_unevaled = ref (List.length l) in
62 let result = List.map (fun x -> x, ref None) l in
63 let emit r y =
64 if !r = None then decr num_unevaled ;
65 r := Some y ;
66 if !num_unevaled > 0 then nop
67 else emit (List.map
68 (fun (x,r) -> match !r with Some y -> y | None -> assert false)
69 result)
70 in
71 Do (lazy (List.map (fun (x,r) -> f x c (emit r)) result))
72
73 let list_filter f l = map (BatList.filter_map BatPervasives.identity) (list_map f l)
74 let list_collect f l = map List.concat (list_map f l)
75
76 let rec list_find f = function
77 | [] -> return None
78 | h :: t -> bind (function
79 | None -> list_find f t
80 | some -> return some) (f h)
81
82 let rec list_fold f a = function
83 | [] -> return a
84 | h :: t -> bind (fun a -> list_fold f a t) (f h a)
85
86 let list_mfold f a l = bind (fun l -> list_fold (fun f a -> f a) a l) (list_map f l)
87
88 let list_iter f l = fun c emit ->
89 if l = [] then emit () else
90 let r = ref (List.length l) in
91 let emit () =
92 decr r ;
93 if !r = 0 then emit () else nop
94 in
95 Do (lazy (List.map (fun x -> f x c emit) l))
96
97 let list_exists pred l =
98 map (function None -> false | Some () -> true)
99 (list_find (fun x -> map (fun px -> if px then Some () else None) (pred x)) l)
100
101 let opt_map f = function
102 | None -> (fun c emit -> emit None)
103 | Some x -> (fun c emit -> f x c (fun y -> emit (Some y)))
104
105 let opt_bind f = function
106 | None -> (fun c emit -> emit None)
107 | Some x -> (fun c emit -> f x c emit)
108
109 (* Evaluation ------------------------------------------------------------------------------ *)
110
111 let eval ctx m =
112 let queue = Queue.create () in
113 let r = ref None in
114 let emit x = r := Some x ; nop in
115
116 let rec loop = function Do step ->
117 match Lazy.force step with
118 | h :: t -> List.iter (fun x -> Queue.push x queue) t ; loop h
119 | [] -> match try Some (Queue.pop queue) with Queue.Empty -> None with
120 | Some thread -> loop thread
121 | None -> ()
122 in
123
124 loop (m ctx emit) ;
125 match !r with None -> assert false | Some result -> result
Something went wrong with that request. Please try again.