blob: 9bff69b49457566ad20815cace4eca4209b43296 (
plain) (
blame)
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
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
module Ordering = struct
type t = Equal | Smaller | Greater
let of_int x = if x < 0 then Smaller else if x > 0 then Greater else Equal
end
module Result = struct
let ( let* ) = Result.bind
let fmap f m = Result.bind m f
end
module type SEQUENCE = sig
type 'a t
val empty : 'a t
val cons : 'a -> 'a t -> 'a t
val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
end
module Generic (S : SEQUENCE) = struct
let sequence ms =
let open Result in
S.fold
(fun m acc ->
let* acc = acc in
let* m = m in
Ok (S.cons m acc))
ms
(Ok S.empty)
end
module List = struct
module ListSequence : SEQUENCE with type 'a t = 'a list = struct
type 'a t = 'a list
let empty = []
let cons x xs = x::xs
let fold = List.fold_right
end
include Generic (ListSequence)
let hd_opt = function
| x::_ -> Some x
| [] -> None
end
module FingerTree = struct
module FingerTreeSequence : SEQUENCE with type 'a t = 'a BatFingerTree.t = struct
type 'a t = 'a BatFingerTree.t
let empty = BatFingerTree.empty
let cons x xs = BatFingerTree.cons xs x
let fold f xs acc = BatFingerTree.fold_right
(Fun.flip f)
acc
xs
end
include Generic (FingerTreeSequence)
let map2 f xs ys =
let rec frob xs ys acc =
match BatFingerTree.front xs with
| None -> acc
| Some (xs', x) ->
match BatFingerTree.front ys with
| None -> acc
| Some (ys', y) ->
f x y
|> BatFingerTree.snoc acc
|> frob xs' ys'
in
frob xs ys BatFingerTree.empty
let zip xs ys = map2 (fun x y -> x, y) xs ys
let join ss sep =
BatFingerTree.print ~first:"" ~last:"" ~sep:sep BatIO.nwrite
|> Fun.flip BatIO.to_string ss
end
module Option = struct
let ( let* ) = Option.bind
let fmap f m = Option.bind m f
end
module Atomic = struct
let rec swap atom f =
let v = Atomic.get atom in
let v' = f v in
if Atomic.compare_and_set atom v v'
then atom
else swap atom f
let rec mswap atom f =
let open Result in
let v = Atomic.get atom in
let* v' = f v in
if Atomic.compare_and_set atom v v'
then Ok atom
else mswap atom f
end
|
