Commits

Sébastien Ferré committed e98cfe8

[sumonad] Last changes before renaming to [monad]

  • Participants
  • Parent commits eacf321

Comments (0)

Files changed (9)

File monad/essai.ml

+
+let rec safe_aux (p1,p2,p3) = (* low diagonal, line, high diagonal *)
+  function
+    | [] -> true
+    | p::ps1 -> p <> p1 && p <> p2 && safe_aux (p1-1,p2,p3+1) ps1
+let safe p ps1 = safe_aux (p-1,p,p+1) ps1
+
+module State =
+struct
+  type t = { cpt : int }
+
+  let init = { cpt = 0 }
+    
+  let get = u_def (let s = u_state in u_return s.cpt)
+  let incr = u_def (let s = u_state in u_state <- { cpt = s.cpt + 1 })
+  let print_line str = u_def (u_return (print_endline str))
+end
+
+let rec range a b =
+  if a <= b
+  then u_def (u_return a | range (a+1) b)
+  else u_def u_fail
+
+let rec nqueens n k =
+  if k=0
+  then u_def (
+    let i = State.get in
+    State.print_line ("k=" ^ string_of_int i);
+    u_return [])
+  else u_def (
+    let ps1 = State.incr; nqueens n (k-1) in
+    let p = range 1 n in
+    u_guard safe p ps1;
+    u_return p::ps1)
+
+let _ =
+  let n = try int_of_string Sys.argv.(1) with _ -> 4 in
+  let k = try int_of_string Sys.argv.(2) with _ -> 10 in
+  if u_run with u_state = State.init
+    u_exists ps = nqueens n n
+  then print_endline "There are solutions!";
+  u_run with u_state = State.init
+    for ps = nqueens n n to k do
+      List.iter
+	(fun p -> print_int p; print_char ' ')
+	ps; 
+      print_newline ()
+    done
+
+(* ----- *)
+
+let generator_of_iterator (iter : (int,_,unit) Sumonad.t) : (int,int,int) Sumonad.t = u_def (
+  u_state <- 0;
+  for x = iter do
+    let sum = u_state in
+    u_yield (sum+x);
+    u_state <- (sum+x)
+  done;
+  u_state)
+
+let iterator_of_generator (gen : (_,'e,'s) Sumonad.t) : ('e,_,'s) Sumonad.t = u_def (
+  try gen; u_fail
+  with x -> u_return x)
+
+let _ = u_run with u_state = 0
+  for i = iterator_of_generator (generator_of_iterator (range 0 9)) do print_int i done
+
+let rec sums = function
+  | [] -> u_def u_return 0
+  | x::l -> u_def (
+    let s = sums l in
+    u_yield (x+s);
+    u_return (x+s))
+
+let _ = u_run for i = u_def (try sums [2;3;5;7;11]; u_fail with i -> u_return (print_int i)) do print_string "\n" done
+
+(* ---------------- *)
+
+let rec parse_add = u_def
+  let v1 = parse_mult in
+  let f = parse_add_aux in
+  u_return (f v1)
+and parse_add_aux = u_def
+  begin
+    | #look "+";
+      let v2 = parse_mult in
+      let f = parse_add_aux in
+      u_return (fun v1 -> f (v1 + v2))
+    | u_return (fun v1 -> v1)
+  end
+and parse_mult = u_def
+  let v1 = parse_atom in
+  let f = parse_mult_aux in
+  u_return (f v1)
+and parse_mult_aux = u_def
+  begin
+    | #look "*";
+      let v2 = parse_atom in
+      let f = parse_mult_aux in
+      u_return (fun v1 -> f (v1 * v2))
+    | u_return (fun v1 -> v1)
+  end
+and parse_atom = u_def
+  begin
+    | let s = #get "[0-9]+" in
+      u_return (int_of_string s)
+    | #look "(";
+      let v = parse_add in
+      #look ")";
+      u_return v
+  end

File monad/makefile

+OCAMLC=ocamlc
+INCLUDES= -I ..               # all relevant -I options here
+OCAMLFLAGS= $(INCLUDES)   # add other options for ocamlc here
+OCAMLDOCFLAGS= -d doc $(INCLUDES)
+
+# The list of object files
+OBJ = sumonad.cmo
+
+all: sumonad.cma pa_sumonad.cmo
+	echo
+
+sumonad.cma: $(OBJ)
+	ocamlc $(OCAMLFLAGS) -a -o sumonad.cma $(OBJ)
+	ocamlopt $(OCAMLFLAGS) -a -o sumonad.cmxa $(OBJ:.cmo=.cmx)
+
+pa_sumonad.cmo: pa_sumonad.ml
+	ocamlc -I +camlp4 camlp4lib.cma -pp camlp4orf -c pa_sumonad.ml
+
+essai.exe: essai.ml
+	ocamlc -o essai.exe -pp "camlp4o -I . pa_sumonad.cmo" str.cma sumonad.cma essai.ml
+
+# Common rules
+.SUFFIXES: .ml .mli .cmo .cmi
+
+%.cmo: %.ml
+	ocamlc $(OCAMLFLAGS) -c $<
+	ocamlopt $(OCAMLFLAGS) -c $<
+
+%.exe: %.ml
+	ocamlc -o $@ -pp "camlp4o -I . pa_sumonad.cmo" str.cma sumonad.cma $<
+
+# Documentationg
+html:
+	ocamldoc $(OCAMLDOCFLAGS) -html $(ALL:.cmo=.ml)
+
+# Clean up
+clean:
+	rm -f *.cm[ioax]
+	rm -f *.cmxa
+	rm -f *.[oa]

File monad/pa_sumonad.ml

+
+open Camlp4.PreCast
+open Syntax
+
+EXTEND Gram
+  GLOBAL: expr ctyp;
+
+  ctyp: LEVEL "simple"
+      [ [ a = SELF; "u_monad"; es_opt = OPT [ "with"; es = ctyp_args -> es ] ->
+         let e, s = match es_opt with Some es -> es | None -> <:ctyp< _ >>, <:ctyp< _ >> in
+         <:ctyp< Sumonad.t $a$ $e$ $s$ >>
+	] ];
+
+  ctyp_args:
+    [ [ "u_state"; "="; s = ctyp; eo = OPT [ "and"; "u_error"; "="; e = ctyp -> e ] ->
+        let e = match eo with Some e -> e | None -> <:ctyp< _ >> in
+	e, s
+      | "u_error"; "="; e = ctyp; so = OPT [ "and"; "u_state"; "="; s = ctyp -> s ] ->
+        let s = match so with Some s -> s | None -> <:ctyp< _ >> in
+	e, s
+      ] ];
+
+  expr: LEVEL "top"
+      [ [ "u_def"; m = atom ->
+          <:expr< fun state -> $m$ state >>
+	| "u_run"; s_opt = OPT [ "with"; "u_state"; "="; s = expr LEVEL "top" -> s ]; f = run ->
+	  let s = match s_opt with None -> <:expr< () >> | Some s -> s in
+	  f s
+	] ];
+    
+  run:
+     [ [ "for"; (x, m) = quantif; l_opt = OPT [ "to"; l = expr LEVEL "top" -> l ]; "do"; e = expr LEVEL ";"; "done" ->
+	  let l = match l_opt with None -> <:expr< -1 >> | Some l -> l in
+	  let f = <:expr< fun $pat:x$ -> $e$ >> in
+	  (fun s -> <:expr< Sumonad.kiter $f$ $l$ $m$ $s$ >>)
+	| "u_exists"; (x, m) = quantif; c_opt = OPT [ ";"; c = expr LEVEL "top" -> c ] ->
+	  let c = match c_opt with None -> <:expr< True >> | Some c -> c in
+	  let f = <:expr< fun $pat:x$ -> $c$ >> in
+	  (fun s -> <:expr< Sumonad.exists $f$ $m$ $s$ >>)
+	| "u_forall"; (x, m) = quantif; ";"; c = expr LEVEL "top" ->
+	  let f = <:expr< fun $pat:x$ -> $c$ >> in
+	  (fun s -> <:expr< Sumonad.forall $f$ $m$ $s$ >>)
+	] ];
+
+  quantif:
+      [ [ x = ipatt; "="; m = atom -> x, m ] ];
+
+  block:
+      [ [ "begin"; OPT "|"; m = alt; "end" -> m
+	| "("; OPT "|"; m = alt; ")" -> m 
+	] ];
+    
+  alt:
+      [ [ m1 = seq; m2o = OPT [ "|"; m2 = alt -> m2 ] ->
+        match m2o with
+	| None -> m1
+	| Some m2 -> <:expr< Sumonad.mplus $m1$ $m2$ >>
+	] ];
+
+  seq:
+    [ [ m1 = atom; m2o = OPT [ ";"; m2 = seq -> m2 ] ->
+      match m2o with
+	| None -> m1
+	| Some m2 -> <:expr< Sumonad.bind $m1$ (fun _ -> $m2$) >>
+        ] ];
+
+  atom:
+    [ [ m = block -> m
+      | "u_return"; eo = OPT [ e = expr LEVEL "top" -> e ] ->
+        let e = match eo with Some e -> e | None -> <:expr< () >> in
+        <:expr< Sumonad.return $e$ >>
+      | "u_fail" -> <:expr< Sumonad.fail >>
+      | "u_error"; e = expr LEVEL "top" -> <:expr< Sumonad.error $e$ >>
+      | "u_yield"; e = expr LEVEL "top" -> <:expr< Sumonad.yield $e$ >>
+      | "u_guard"; b = expr LEVEL "top" -> <:expr< Sumonad.guard $b$ >>
+      | "u_succeeds"; m = atom -> <:expr< Sumonad.succeeds $m$ >>
+      | "u_fails"; m = atom -> <:expr< Sumonad.fails $m$ >>
+      | "if"; x = ipatt; "="; m1 = alt; "then"; m2 = atom; m3o = OPT [ "else"; m3 = atom -> m3 ] ->
+        let k2 = <:expr< fun $pat:x$ -> $m2$ >> in
+        let m3 = match m3o with Some m3 -> m3 | None -> <:expr< Sumonad.fail >> in
+        <:expr< Sumonad.cut $m1$ $k2$ $m3$ >>
+      | "let"; x = ipatt; "="; m1 = alt; "in"; m2 = seq ->
+        <:expr< Sumonad.bind $m1$ (fun $pat:x$ -> $m2$) >>
+      | "match"; e = expr LEVEL "top"; "with"; OPT "|"; k = conts ->
+        <:expr< fun s -> $k$ $e$ s >>
+(*
+      | "match"; m = alt; "with"; OPT "|"; k = conts ->
+        <:expr< Sumonad.bind $m$ $k$ >>
+*)
+      | "try"; m = alt; "with"; OPT "|"; k = conts ->
+        <:expr< Sumonad.catch $m$ $k$ >>
+      | "for"; (x,m) = quantif; so = OPT [ "with"; "u_state"; e = expr LEVEL "top" -> e ]; "do"; m2 = alt; "done" ->
+        let s = match so with Some s -> s | None -> <:expr< () >> in
+        <:expr< Sumonad.iter (fun $pat:x$ -> $m2$) $m$ $s$ >>
+      | "u_state"; "<-"; e = expr LEVEL "top" ->
+        <:expr< Sumonad.set_state $e$ >>
+      | "u_state" ->
+        <:expr< Sumonad.get_state >>
+      | "#"; id = a_LIDENT; le = LIST0 [ e = expr LEVEL "top" -> e ] ->
+        let app = List.fold_left (fun res arg -> <:expr< $res$ $arg$ >>) <:expr< state # $lid:id$ >> le in 
+	<:expr< fun state -> $app$ >>
+      | m = expr LEVEL "top" -> m ] ];
+
+(*
+  rules:
+    [ [ f1 = rule; f2o = OPT [ "|"; f2 = rules -> f2 ] ->
+      match f2o with
+	| None -> f1
+	| Some f2 -> (fun e -> <:expr< Sumonad.mplus $f1 e$ $f2 e$ >>)
+      ] ];
+
+  rule:
+    [ [ x = ipatt; "->"; m = seq -> (fun e -> <:expr< fun s -> match $e$ with [ $pat:x$ -> $m$ s | _ -> Sumonad.Stream.Nil ] >>) ] ];
+*)
+
+  conts:
+    [ [ k1 = cont; k2o = OPT [ "|"; k2 = conts -> k2 ] ->
+      match k2o with
+	| None -> k1
+	| Some k2 -> <:expr< fun x -> Sumonad.mplus ($k1$ x) ($k2$ x) >>
+      ] ];
+
+  cont:
+    [ [ x = ipatt; "->"; m = seq -> <:expr< fun [ $pat:x$ -> $m$ | _ -> Sumonad.fail ] >> ] ];
+ 
+END;

File monad/sumonad.ml

+
+module Stream =
+struct
+  type 'a t =
+    | Nil
+    | Single of 'a
+    | Cons of 'a * 'a t
+    | Lazy of (unit -> 'a t)
+
+  let rec is_empty : 'a t -> bool = function
+    | Nil -> true
+    | Single _ -> false
+    | Cons _ -> false
+    | Lazy f -> is_empty (f ())
+
+  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 ())
+
+  let rec fold (f : 'a -> 'b -> 'a) (init : 'a) (str : 'b t) : 'a =
+    match read str with
+      | None -> init
+      | Some (x,rest) -> fold f (f init x) rest
+
+  let of_list l =
+    List.fold_left
+      (fun str x -> Cons (x,str))
+      Nil l
+
+  let of_hashtbl ht =
+    Hashtbl.fold
+      (fun k v str -> Cons ((k,v), str))
+      ht Nil
+end
+
+(* monad definition *)
+
+type ('a,'e) either = Result of 'a | Error of 'e
+
+type ('a,'e,'s) t = 's -> (('a,'e) either * 's) Stream.t
+
+(* Monad interface *)
+
+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')
+
+(* MonadPlus interface *)
+
+let mzero : ('a,'e,'s) t =
+  fun s -> Stream.Nil
+
+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 error msg : ('a,'e,'s) t =
+  fun s -> Stream.Single (Error msg, s)
+
+let rec catch (m : ('a,'e,'s) t) (k : 'e -> ('a,'e,'s) t) : ('a,'e,'s) t =
+  fun s -> catch_aux (m s) k
+and catch_aux str k =
+  match str with
+    | Stream.Nil -> Stream.Nil
+    | Stream.Single (x,s') -> catch_either x s' k
+    | Stream.Cons ((x,s'),str1) -> Stream.concat (catch_either x s' k, Stream.Lazy (fun () -> catch_aux str1 k))
+    | Stream.Lazy fstr -> Stream.Lazy (fun () -> catch_aux (fstr ()) k)
+and catch_either x s' k =
+  match x with
+    | Result v -> Stream.Single (x,s')
+    | Error e -> k e s'
+
+let yield (e : 'e) : (unit,'e,'s) t =
+  mplus (error e) (return ())
+
+let cut (m1 : ('a,'e,'s) t) (k2 : 'a -> ('b,'e,'s) t) (m3 : ('b,'e,'s) t) : ('b,'e,'s) t =
+  fun s ->
+    let str1 = m1 s in
+    if Stream.is_empty str1
+    then m3 s
+    else bind_aux str1 k2
+
+let guard (cond : bool) : (unit,'e,'s) t =
+  fun s ->
+    if cond
+    then Stream.Single (Result (), s)
+    else Stream.Nil
+
+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 rec once (m : ('a,'e,'s) t) : ('a,'e,'s) t =
+  fun s -> once_aux (m s) s
+and once_aux str =
+  fun s ->
+    match Stream.read str with
+      | None -> mzero s
+      | Some ((x,s'),rest) ->
+	match x with
+	  | Result v -> return v s'
+	  | _ -> once_aux rest s
+
+let rec succeeds (m : ('a,'e,'s) t) : (unit,'e,'s) t =
+  fun s ->
+    if succeeds_aux (m s)
+    then return () s
+    else mzero s
+and fails (m : ('a,'e,'s) t) : (unit,'e,'s) t =
+  fun s ->
+    if succeeds_aux (m s)
+    then mzero s
+    else return () s
+and succeeds_aux str =
+  match Stream.read str with
+    | None -> false
+    | Some ((x,_),rest) ->
+      match x with
+	| Result _ -> true
+	| Error _ -> succeeds_aux rest
+
+let rec iter (f : 'a -> ('a2,'e2,'s2) t) (m : ('a,'e,'s) t) (s : 's) : ('a2,'e2,'s2) t =
+  iter_aux f (m s)
+and iter_aux f str =
+  match Stream.read str with
+    | None -> return ()
+    | Some ((x,_),rest) ->
+      match x with
+	| Result v -> bind (f v) (fun _ -> iter_aux f rest)
+	| Error e -> iter_aux f rest
+
+let aggreg (f : 'c -> 'b -> 'c) (init : 'c) (m : ('a * 'b,'e,'s) t) : ('a * 'c,'e,'s) t =
+  fun s ->
+    let ht = Hashtbl.create 13 in
+    let str = m s in
+    let _ =
+      Stream.fold
+	(fun _ -> function
+	  | (Result (k,v),_) ->
+	    let res0 = try Hashtbl.find ht k with Not_found -> init in
+	    Hashtbl.replace ht k (f res0 v)
+	  | _ -> ())
+	() str in
+    Hashtbl.fold
+      (fun k v str -> Stream.Cons ((Result (k,v),s),str))
+      ht Stream.Nil
+
+let get_state : ('s,'e,'s) t =
+  fun s -> Stream.Single (Result s, s)
+
+let set_state (s2 : 's) : (unit,'e,'s) t =
+  fun s -> Stream.Single (Result (), s2)
+
+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)
+
+let effect (action : 's -> unit) : (unit,'e,'s) t =
+  fun s -> action s; Stream.Single (Result (), s)
+
+
+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 -> '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) ->
+      match x with
+	| Result v -> let acc' = f acc v in iter_aux f acc' rest
+	| Error e -> acc
+
+let rec exists (f : 'a -> bool) (m : ('a,'e,'s) t) (s : 's) : bool =
+  exists_aux f (m s)
+and exists_aux f str =
+  match Stream.read str with
+    | None -> false
+    | Some ((x,s), rest) ->
+      match x with
+	| Result v -> f v || exists_aux f rest
+	| Error e -> exists_aux f rest
+
+let rec forall (f : 'a -> bool) (m : ('a,'e,'s) t) (s : 's) : bool =
+  forall_aux f (m s)
+and forall_aux f str =
+  match Stream.read str with
+    | None -> true
+    | Some ((x,s), rest) -> 
+      match x with
+	| Result v -> f v && forall_aux f rest
+	| Error e -> forall_aux f rest
+
+
+module Int =
+struct
+  let rec range a b =
+    if a <= b
+    then mplus (return a) (range (a+1) b)
+    else mzero
+end
+
+module List =
+struct
+  let rec choose : 'a list -> ('a,'e,'s) t = function
+    | [] -> mzero
+    | 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  

File monad/sumonad_parser.ml

+
+(* Dcg cursors can be used as states *)
+class type state =
+object ('self)
+  method look : string -> bool
+  method get : Str.regexp -> string option
+  method eof : bool
+  method shift : string -> 'self
+  method coord : int * int (* line, column *)
+end
+
+let look (w : string) : string sumonad = sudef (
+  let state = sustate in
+  if state#look w
+  then begin sustate <- state#shift w; return w end
+  else error (`KwdExpected (w, state#coord)))
+
+let get ?(name = "") (re : Str.regexp) : string sumonad = sudef (
+  let state = sustate in
+  match state#get re with
+    | Some w -> sustate <- state#shift w; return w
+    | None ->
+      if name=""
+      then fail
+      else error (`WordExpected (name, state#coord)))
+
+let eof : unit sumonad = sudef (
+  let state = sustate in
+  if state#eof
+  then return ()
+  else error (`EofExpected state#coord))
+
+let get_coord : (int*int) sumonad = sudef (
+  let state = sustate in
+  return (state#coord))

File sumonad/essai.ml

-
-let rec safe_aux (p1,p2,p3) = (* low diagonal, line, high diagonal *)
-  function
-    | [] -> true
-    | p::ps1 -> p <> p1 && p <> p2 && safe_aux (p1-1,p2,p3+1) ps1
-let safe p ps1 = safe_aux (p-1,p,p+1) ps1
-
-module State =
-struct
-  type t = { cpt : int }
-
-  let init = { cpt = 0 }
-    
-  let get = u_def (let s = u_state in u_return s.cpt)
-  let incr = u_def (let s = u_state in u_state <- { cpt = s.cpt + 1 })
-  let print_line str = u_def (u_return (print_endline str))
-end
-
-let rec range a b =
-  if a <= b
-  then u_def (u_return a | range (a+1) b)
-  else u_def u_fail
-(*
-let rec range a b = u_def
-  if _ = u_guard (a <= b) then (u_return a | range (a+1) b)
-*)
-
-let rec nqueens n k =
-  if k=0
-  then u_def (
-    let i = State.get in
-    State.print_line ("k=" ^ string_of_int i);
-    u_return [])
-  else u_def (
-    let ps1 = State.incr; nqueens n (k-1) in
-    let p = range 1 n in
-    u_guard safe p ps1;
-    u_return p::ps1)
-
-let _ =
-  let n = try int_of_string Sys.argv.(1) with _ -> 4 in
-  let k = try int_of_string Sys.argv.(2) with _ -> 10 in
-  if u_run with u_state = State.init
-    u_exists ps = nqueens n n
-  then print_endline "There are solutions!";
-  u_run with u_state = State.init
-    for ps = nqueens n n to k do
-      List.iter
-	(fun p -> print_int p; print_char ' ')
-	ps; 
-      print_newline ()
-    done
-
-(* ----- *)
-
-let generator_of_iterator (iter : (int,_,unit) Sumonad.t) : (int,int,int) Sumonad.t = u_def (
-  u_state <- 0;
-  for x = iter do
-    let sum = u_state in
-    u_yield (sum+x);
-    u_state <- (sum+x)
-  done;
-  u_state)
-
-let iterator_of_generator (gen : (_,'e,'s) Sumonad.t) : ('e,_,'s) Sumonad.t = u_def (
-  try gen; u_fail
-  with x -> u_return x)
-
-let _ = u_run with u_state = 0
-  for i = iterator_of_generator (generator_of_iterator (range 0 9)) do print_int i done
-
-let rec sums = function
-  | [] -> u_def u_return 0
-  | x::l -> u_def (
-    let s = sums l in
-    u_yield (x+s);
-    u_return (x+s))
-
-let _ = u_run for i = u_def (try sums [2;3;5;7;11]; u_fail with i -> u_return (print_int i)) do print_string "\n" done
-
-(* ---------------- *)
-
-let rec parse_add = u_def
-  let v1 = parse_mult in
-  let f = parse_add_aux in
-  u_return (f v1)
-and parse_add_aux = u_def
-  begin
-    | #look "+";
-      let v2 = parse_mult in
-      let f = parse_add_aux in
-      u_return (fun v1 -> f (v1 + v2))
-    | u_return (fun v1 -> v1)
-  end
-and parse_mult = u_def
-  let v1 = parse_atom in
-  let f = parse_mult_aux in
-  u_return (f v1)
-and parse_mult_aux = u_def
-  begin
-    | #look "*";
-      let v2 = parse_atom in
-      let f = parse_mult_aux in
-      u_return (fun v1 -> f (v1 * v2))
-    | u_return (fun v1 -> v1)
-  end
-and parse_atom = u_def
-  begin
-    | let s = #get "[0-9]+" in
-      u_return (int_of_string s)
-    | #look "(";
-      let v = parse_add in
-      #look ")";
-      u_return v
-  end

File sumonad/makefile

-OCAMLC=ocamlc
-INCLUDES= -I ..               # all relevant -I options here
-OCAMLFLAGS= $(INCLUDES)   # add other options for ocamlc here
-OCAMLDOCFLAGS= -d doc $(INCLUDES)
-
-# The list of object files
-OBJ = sumonad.cmo
-
-all: sumonad.cma pa_sumonad.cmo
-	echo
-
-sumonad.cma: $(OBJ)
-	ocamlc $(OCAMLFLAGS) -a -o sumonad.cma $(OBJ)
-	ocamlopt $(OCAMLFLAGS) -a -o sumonad.cmxa $(OBJ:.cmo=.cmx)
-
-pa_sumonad.cmo: pa_sumonad.ml
-	ocamlc -I +camlp4 camlp4lib.cma -pp camlp4orf -c pa_sumonad.ml
-
-essai.exe: essai.ml
-	ocamlc -o essai.exe -pp "camlp4o -I . pa_sumonad.cmo" str.cma sumonad.cma essai.ml
-
-# Common rules
-.SUFFIXES: .ml .mli .cmo .cmi
-
-%.cmo: %.ml
-	ocamlc $(OCAMLFLAGS) -c $<
-	ocamlopt $(OCAMLFLAGS) -c $<
-
-%.exe: %.ml
-	ocamlc -o $@ -pp "camlp4o -I . pa_sumonad.cmo" str.cma sumonad.cma $<
-
-# Documentationg
-html:
-	ocamldoc $(OCAMLDOCFLAGS) -html $(ALL:.cmo=.ml)
-
-# Clean up
-clean:
-	rm -f *.cm[ioax]
-	rm -f *.cmxa
-	rm -f *.[oa]

File sumonad/pa_sumonad.ml

-
-open Camlp4.PreCast
-open Syntax
-
-EXTEND Gram
-  GLOBAL: expr ctyp;
-
-  ctyp: LEVEL "simple"
-      [ [ a = SELF; "u_monad"; es_opt = OPT [ "with"; es = ctyp_args -> es ] ->
-         let e, s = match es_opt with Some es -> es | None -> <:ctyp< _ >>, <:ctyp< _ >> in
-         <:ctyp< Sumonad.t $a$ $e$ $s$ >>
-	] ];
-
-  ctyp_args:
-    [ [ "u_state"; "="; s = ctyp; eo = OPT [ "and"; "u_error"; "="; e = ctyp -> e ] ->
-        let e = match eo with Some e -> e | None -> <:ctyp< _ >> in
-	e, s
-      | "u_error"; "="; e = ctyp; so = OPT [ "and"; "u_state"; "="; s = ctyp -> s ] ->
-        let s = match so with Some s -> s | None -> <:ctyp< _ >> in
-	e, s
-      ] ];
-
-  expr: LEVEL "top"
-      [ [ "u_def"; m = atom ->
-          <:expr< fun state -> $m$ state >>
-	| "u_run"; s_opt = OPT [ "with"; "u_state"; "="; s = expr LEVEL "top" -> s ]; f = run ->
-	  let s = match s_opt with None -> <:expr< () >> | Some s -> s in
-	  f s
-	] ];
-    
-  run:
-     [ [ "for"; (x, m) = quantif; l_opt = OPT [ "to"; l = expr LEVEL "top" -> l ]; "do"; e = expr LEVEL ";"; "done" ->
-	  let l = match l_opt with None -> <:expr< -1 >> | Some l -> l in
-	  let f = <:expr< fun $pat:x$ -> $e$ >> in
-	  (fun s -> <:expr< Sumonad.kiter $f$ $l$ $m$ $s$ >>)
-	| "u_exists"; (x, m) = quantif; c_opt = OPT [ ";"; c = expr LEVEL "top" -> c ] ->
-	  let c = match c_opt with None -> <:expr< True >> | Some c -> c in
-	  let f = <:expr< fun $pat:x$ -> $c$ >> in
-	  (fun s -> <:expr< Sumonad.exists $f$ $m$ $s$ >>)
-	| "u_forall"; (x, m) = quantif; ";"; c = expr LEVEL "top" ->
-	  let f = <:expr< fun $pat:x$ -> $c$ >> in
-	  (fun s -> <:expr< Sumonad.forall $f$ $m$ $s$ >>)
-	] ];
-
-  quantif:
-      [ [ x = ipatt; "="; m = atom -> x, m ] ];
-
-  block:
-      [ [ "begin"; OPT "|"; m = alt; "end" -> m
-	| "("; OPT "|"; m = alt; ")" -> m 
-	] ];
-    
-  alt:
-      [ [ m1 = seq; m2o = OPT [ "|"; m2 = alt -> m2 ] ->
-        match m2o with
-	| None -> m1
-	| Some m2 -> <:expr< Sumonad.mplus $m1$ $m2$ >>
-	] ];
-
-  seq:
-    [ [ m1 = atom; m2o = OPT [ ";"; m2 = seq -> m2 ] ->
-      match m2o with
-	| None -> m1
-	| Some m2 -> <:expr< Sumonad.bind $m1$ (fun _ -> $m2$) >>
-        ] ];
-
-  atom:
-    [ [ m = block -> m
-      | "u_return"; eo = OPT [ e = expr LEVEL "top" -> e ] ->
-        let e = match eo with Some e -> e | None -> <:expr< () >> in
-        <:expr< Sumonad.return $e$ >>
-      | "u_fail" -> <:expr< Sumonad.fail >>
-      | "u_error"; e = expr LEVEL "top" -> <:expr< Sumonad.error $e$ >>
-      | "u_yield"; e = expr LEVEL "top" -> <:expr< Sumonad.yield $e$ >>
-      | "u_guard"; b = expr LEVEL "top" -> <:expr< Sumonad.guard $b$ >>
-      | "u_succeeds"; m = atom -> <:expr< Sumonad.succeeds $m$ >>
-      | "u_fails"; m = atom -> <:expr< Sumonad.fails $m$ >>
-      | "if"; x = ipatt; "="; m1 = alt; "then"; m2 = atom; m3o = OPT [ "else"; m3 = atom -> m3 ] ->
-        let k2 = <:expr< fun $pat:x$ -> $m2$ >> in
-        let m3 = match m3o with Some m3 -> m3 | None -> <:expr< Sumonad.fail >> in
-        <:expr< Sumonad.cut $m1$ $k2$ $m3$ >>
-      | "let"; x = ipatt; "="; m1 = alt; "in"; m2 = seq ->
-        <:expr< Sumonad.bind $m1$ (fun $pat:x$ -> $m2$) >>
-      | "match"; e = expr LEVEL "top"; "with"; OPT "|"; k = conts ->
-        <:expr< fun s -> $k$ $e$ s >>
-(*
-      | "match"; m = alt; "with"; OPT "|"; k = conts ->
-        <:expr< Sumonad.bind $m$ $k$ >>
-*)
-      | "try"; m = alt; "with"; OPT "|"; k = conts ->
-        <:expr< Sumonad.catch $m$ $k$ >>
-      | "for"; (x,m) = quantif; so = OPT [ "with"; "u_state"; e = expr LEVEL "top" -> e ]; "do"; m2 = alt; "done" ->
-        let s = match so with Some s -> s | None -> <:expr< () >> in
-        <:expr< Sumonad.iter (fun $pat:x$ -> $m2$) $m$ $s$ >>
-      | "u_state"; "<-"; e = expr LEVEL "top" ->
-        <:expr< Sumonad.set_state $e$ >>
-      | "u_state" ->
-        <:expr< Sumonad.get_state >>
-      | "#"; id = a_LIDENT; le = LIST0 [ e = expr LEVEL "top" -> e ] ->
-        let app = List.fold_left (fun res arg -> <:expr< $res$ $arg$ >>) <:expr< state # $lid:id$ >> le in 
-	<:expr< fun state -> $app$ >>
-      | m = expr LEVEL "top" -> m ] ];
-
-(*
-  rules:
-    [ [ f1 = rule; f2o = OPT [ "|"; f2 = rules -> f2 ] ->
-      match f2o with
-	| None -> f1
-	| Some f2 -> (fun e -> <:expr< Sumonad.mplus $f1 e$ $f2 e$ >>)
-      ] ];
-
-  rule:
-    [ [ x = ipatt; "->"; m = seq -> (fun e -> <:expr< fun s -> match $e$ with [ $pat:x$ -> $m$ s | _ -> Sumonad.Stream.Nil ] >>) ] ];
-*)
-
-  conts:
-    [ [ k1 = cont; k2o = OPT [ "|"; k2 = conts -> k2 ] ->
-      match k2o with
-	| None -> k1
-	| Some k2 -> <:expr< fun x -> Sumonad.mplus ($k1$ x) ($k2$ x) >>
-      ] ];
-
-  cont:
-    [ [ x = ipatt; "->"; m = seq -> <:expr< fun [ $pat:x$ -> $m$ | _ -> Sumonad.fail ] >> ] ];
- 
-END;

File 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 is_empty : 'a t -> bool = function
-    | Nil -> true
-    | Single _ -> false
-    | Cons _ -> false
-    | Lazy f -> is_empty (f ())
-
-  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 ())
-
-  let rec fold (f : 'a -> 'b -> 'a) (init : 'a) (str : 'b t) : 'a =
-    match read str with
-      | None -> init
-      | Some (x,rest) -> fold f (f init x) rest
-
-  let of_list l =
-    List.fold_left
-      (fun str x -> Cons (x,str))
-      Nil l
-
-  let of_hashtbl ht =
-    Hashtbl.fold
-      (fun k v str -> Cons ((k,v), str))
-      ht Nil
-end
-
-(* monad definition *)
-
-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 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 error msg : ('a,'e,'s) t =
-  fun s -> Stream.Single (Error msg, s)
-
-let rec catch (m : ('a,'e,'s) t) (k : 'e -> ('a,'e,'s) t) : ('a,'e,'s) t =
-  fun s -> catch_aux (m s) k
-and catch_aux str k =
-  match str with
-    | Stream.Nil -> Stream.Nil
-    | Stream.Single (x,s') -> catch_either x s' k
-    | Stream.Cons ((x,s'),str1) -> Stream.concat (catch_either x s' k, Stream.Lazy (fun () -> catch_aux str1 k))
-    | Stream.Lazy fstr -> Stream.Lazy (fun () -> catch_aux (fstr ()) k)
-and catch_either x s' k =
-  match x with
-    | Result v -> Stream.Single (x,s')
-    | Error e -> k e s'
-
-let yield (e : 'e) : (unit,'e,'s) t =
-  mplus (error e) (return ())
-
-let cut (m1 : ('a,'e,'s) t) (k2 : 'a -> ('b,'e,'s) t) (m3 : ('b,'e,'s) t) : ('b,'e,'s) t =
-  fun s ->
-    let str1 = m1 s in
-    if Stream.is_empty str1
-    then m3 s
-    else bind_aux str1 k2
-
-let guard (cond : bool) : (unit,'e,'s) t =
-  fun s ->
-    if cond
-    then Stream.Single (Result (), s)
-    else Stream.Nil
-
-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 rec once (m : ('a,'e,'s) t) : ('a,'e,'s) t =
-  fun s -> once_aux (m s) s
-and once_aux str =
-  fun s ->
-    match Stream.read str with
-      | None -> fail s
-      | Some ((x,s'),rest) ->
-	match x with
-	  | Result v -> return v s'
-	  | _ -> once_aux rest s
-
-let rec succeeds (m : ('a,'e,'s) t) : (unit,'e,'s) t =
-  fun s ->
-    if succeeds_aux (m s)
-    then return () s
-    else fail s
-and fails (m : ('a,'e,'s) t) : (unit,'e,'s) t =
-  fun s ->
-    if succeeds_aux (m s)
-    then fail s
-    else return () s
-and succeeds_aux str =
-  match Stream.read str with
-    | None -> false
-    | Some ((x,_),rest) ->
-      match x with
-	| Result _ -> true
-	| Error _ -> succeeds_aux rest
-
-let rec iter (f : 'a -> ('a2,'e2,'s2) t) (m : ('a,'e,'s) t) (s : 's) : ('a2,'e2,'s2) t =
-  iter_aux f (m s)
-and iter_aux f str =
-  match Stream.read str with
-    | None -> return ()
-    | Some ((x,_),rest) ->
-      match x with
-	| Result v -> bind (f v) (fun _ -> iter_aux f rest)
-	| Error e -> iter_aux f rest
-
-let aggreg (f : 'c -> 'b -> 'c) (init : 'c) (m : ('a * 'b,'e,'s) t) : ('a * 'c,'e,'s) t =
-  fun s ->
-    let ht = Hashtbl.create 13 in
-    let str = m s in
-    let _ =
-      Stream.fold
-	(fun _ -> function
-	  | (Result (k,v),_) ->
-	    let res0 = try Hashtbl.find ht k with Not_found -> init in
-	    Hashtbl.replace ht k (f res0 v)
-	  | _ -> ())
-	() str in
-    Hashtbl.fold
-      (fun k v str -> Stream.Cons ((Result (k,v),s),str))
-      ht Stream.Nil
-
-let get_state : ('s,'e,'s) t =
-  fun s -> Stream.Single (Result s, s)
-
-let set_state (s2 : 's) : (unit,'e,'s) t =
-  fun s -> Stream.Single (Result (), s2)
-
-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)
-
-let effect (action : 's -> unit) : (unit,'e,'s) t =
-  fun s -> action s; Stream.Single (Result (), s)
-
-
-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 -> '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) ->
-      match x with
-	| Result v -> let acc' = f acc v in iter_aux f acc' rest
-	| Error e -> acc
-
-let rec exists (f : 'a -> bool) (m : ('a,'e,'s) t) (s : 's) : bool =
-  exists_aux f (m s)
-and exists_aux f str =
-  match Stream.read str with
-    | None -> false
-    | Some ((x,s), rest) ->
-      match x with
-	| Result v -> f v || exists_aux f rest
-	| Error e -> exists_aux f rest
-
-let rec forall (f : 'a -> bool) (m : ('a,'e,'s) t) (s : 's) : bool =
-  forall_aux f (m s)
-and forall_aux f str =
-  match Stream.read str with
-    | None -> true
-    | Some ((x,s), rest) -> 
-      match x with
-	| Result v -> f v && forall_aux f rest
-	| Error e -> forall_aux f rest
-
-
-module Int =
-struct
-  let rec range a b =
-    if a <= b
-    then mplus (return a) (range (a+1) b)
-    else fail
-end
-
-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