1. Sébastien Ferré
  2. ocaml-lib

Source

ocaml-lib / sumonad / sumonad.ml


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