Source file genM.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
(** {1 Monadic Interface} *)
module type MONAD = GenM_intf.MONAD
module Make(M : MONAD) = struct
module M = M
let (>>=) = M.(>>=)
let (>|=) = M.(>|=)
type +'a t = unit -> 'a option M.t
let return x =
let first = ref true in
fun () ->
if !first then (
first := false;
M.return (Some x)
) else M.return None
let sequence_m g () = match g() with
| None -> M.return None
| Some act ->
act >|= fun x -> Some x
let map f g () =
g() >|= function
| None -> None
| Some x -> Some (f x)
let flat_map f g =
let rec next f g () =
g() >>= function
| None -> M.return None
| Some x ->
let cur = f x in
map_from f g cur ()
and map_from f g cur () =
let res = cur() in
res >>= function
| None -> next f g ()
| Some _ -> res
in
next f g
let rec fold f acc g =
g() >>= function
| None -> M.return acc
| Some x ->
let acc = f acc x in
fold f acc g
let rec fold_m f acc g =
g() >>= function
| None -> M.return acc
| Some x ->
f acc x >>= fun acc -> fold_m f acc g
let rec iter f g =
g() >>= function
| None -> M.return ()
| Some x -> f x; iter f g
let rec iter_s f g =
g() >>= function
| None -> M.return ()
| Some x -> f x >>= fun () -> iter_s f g
let rec iter_p f g =
g() >>= function
| None -> M.return ()
| Some x ->
let _ = f x in
iter_p f g
module Infix = struct
let (>|=) x f = map f x
let (>>=) x f = flat_map f x
end
include Infix
end