Commits

Sébastien Ferré committed eacf321

New monadic constructs: try with, yield

  • Participants
  • Parent commits 15141e2

Comments (0)

Files changed (3)

       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

sumonad/pa_sumonad.ml

         <: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$ >>
         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$ >>
-(*
-      | "if"; b = expr LEVEL "top";
-	"then"; m1 = atom;
-	m2o = OPT [ "else"; m2 = atom -> m2 ] ->
-	(match m2o with
-	  | None -> <:expr< Sumonad.ifthenelse $b$ $m1$ Sumonad.fail >>
-	  | Some m2 -> <:expr< Sumonad.ifthenelse $b$ $m1$ $m2$ >>)
-*)
-      | "match"; e = expr LEVEL "top"; "with"; OPT "|"; f = rules -> f e
       | "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< fun state -> $app$ >>
       | m = expr LEVEL "top" -> m ] ];
 
+(*
   rules:
     [ [ f1 = rule; f2o = OPT [ "|"; f2 = rules -> f2 ] ->
       match f2o with
 
   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;

sumonad/sumonad.ml

       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 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 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 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 ->
     then m1 s
     else m2 s
 
-let succeeds (m : ('a,'e,'s) t) : (unit,'e,'s) t =
+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 ->
-    let str = m s in
-    if Stream.is_empty str
-    then Stream.Nil
-    else Stream.Single (Result (), 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 fails (m : ('a,'e,'s) t) : (unit,'e,'s) t =
+let rec succeeds (m : ('a,'e,'s) t) : (unit,'e,'s) t =
   fun s ->
-    let str = m s in
-    if Stream.is_empty str
-    then Stream.Single (Result (), s)
-    else Stream.Nil
+    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 ->