# Source

 ``` 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 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125``` ``` module Stream = struct type 'a t = | Nil | Single of 'a | Cons of 'a * 'a t | Lazy of (unit -> 'a t) let rec concat : 'a t * 'a t -> 'a t = function | Nil, str2 -> str2 | str1, Nil -> str1 | Single x1, str2 -> Cons (x1,str2) | Cons (x1,rest1), str2 -> Cons (x1, concat (rest1, str2)) | Lazy f1, str2 -> Lazy (fun () -> concat (f1 (), str2)) let rec read : 'a t -> ('a * 'a t) option = function | Nil -> None | Single x -> Some (x, Nil) | Cons (x,str) -> Some (x, str) | Lazy f -> read (f ()) end type ('a,'e) either = Result of 'a | Error of 'e type ('a,'e,'s) t = 's -> (('a,'e) either * 's) Stream.t let return (x : 'a) : ('a,'e,'s) t = fun s -> Stream.Single (Result x, s) let rec bind (m : ('a,'e,'s) t) (k : 'a -> ('b,'e,'s) t) : ('b,'e,'s) t = fun s -> bind_aux (m s) k and bind_aux ms k = match ms with | Stream.Nil -> Stream.Nil | Stream.Single (x,s') -> bind_either x s' k | Stream.Cons ((x,s'),str) -> Stream.concat (bind_either x s' k, Stream.Lazy (fun () -> bind_aux str k)) | Stream.Lazy fstr -> bind_aux (fstr ()) k and bind_either x s' k = match x with | Result v -> k v s' | Error e -> Stream.Single (Error e, s') let fail : ('a,'e,'s) t = fun s -> Stream.Nil let error msg : ('a,'e,'s) t = fun s -> Stream.Single (Error msg, s) let mplus (m1 : ('a,'e,'s) t) (m2 : ('a,'e,'s) t) : ('a,'e,'s) t = fun s -> Stream.concat (m1 s, Stream.Lazy (fun () -> m2 s)) let ifthenelse (cond : bool) (m1 : ('a,'e,'s) t) (m2 : ('a,'e,'s) t) : ('a,'e,'s) t = fun s -> if cond then m1 s else m2 s let update (modif : 's -> ('s,'e) either) : (unit,'e,'s) t = fun s -> match modif s with | Result s' -> Stream.Single (Result (), s') | Error e -> Stream.Single (Error e, s) let view (access : 's -> ('a,'e) either) : ('a,'e,'s) t = fun s -> Stream.Single (access s, s) (* syntactic sugar return v fail error e for x in m1; m2 ---> bind m1 (fun x -> m2) m1 | m2 ---> mplus m1 m2 when cond ---> guard cond update modif view access *) let rec kiter (f : 'a -> unit) (k : int) (m : ('a,'e,'s) t) (s : 's) : unit = kiter_aux f k (m s) and kiter_aux f k str = if k = 0 then () else match Stream.read str with | None -> () | Some ((x,s), rest) -> match x with | Result v -> f v; kiter_aux f (k-1) rest | Error e -> kiter_aux f k rest let rec klist (k : int) (m : ('a,'e,'s) t) (s : 's) : 'a list = klist_aux k (m s) and klist_aux k str = if k = 0 then [] else match Stream.read str with | None -> [] | Some ((x,s), rest) -> match x with | Result v -> v :: klist_aux (k-1) rest | Error e -> klist_aux k rest let rec fold (f : 'acc -> ('a,'e) either * 's -> 'acc) (acc : 'acc) (m : ('a,'e,'s) t) (s : 's) : unit = iter_aux f acc (m s) and iter_aux f acc str = match Stream.read str with | None -> acc | Some (x_s, rest) -> let acc' = f acc x_s in iter_aux f acc' rest module List = struct let rec choose : 'a list -> ('a,'e,'s) t = function | [] -> fail | x::l -> mplus (return x) (choose l) let rec map (f : 'a -> ('b,'e,'s) t) : 'a list -> ('b list,'e,'s) t = function | [] -> return [] | x::lx -> bind (f x) (fun y -> bind (map f lx) (fun ly -> return (y::ly))) end ```