Commits

Sébastien Ferré committed 15141e2

[sumonad] new version with more syntax extension

  • Participants
  • Parent commits faa8467

Comments (0)

Files changed (4)

File sumonad/essai.ml

     | 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
 
-let state =
-object (self)
-  method print_line s = print_endline s; Sumonad.Stream.Single (Sumonad.Result (), self)
+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 = sumonad
-  if a <= b then (return a | range (a+1) b)
+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 = sumonad
+let rec nqueens n k =
   if k=0
-  then begin
-    # print_line "k=0";
-    return [] end
-  else
-    for ps1 <- nqueens n (k-1) do
-      for p <- range 1 n do
-	if safe p ps1 then
-	  let ps = p::ps1 in
-	  return ps
-      done
-    done
+  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
-  let print ps = List.iter (fun p -> print_int p; print_char ' ') ps; print_newline () in
-  Sumonad.kiter print k (nqueens n n) state
-
-(*
-let rec parse_add = sumonad
-  for v1 <- parse_times do
-    for f <- parse_add_aux do
-      return (f v1)
+  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
-  done
-and parse_add_aux = sumonad
+
+(* ---------------- *)
+
+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 "+";
-      for v2 <- parse_times do
-	for f <- parse_add_aux do
-	  return (fun v1 -> f (v1 + v2))
-	done
-      done
-    | return (fun v1 -> v1)
+      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
+OCAMLFLAGS= $(INCLUDES)   # add other options for ocamlc here
 OCAMLDOCFLAGS= -d doc $(INCLUDES)
 
 # The list of object files
 	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)

File sumonad/pa_sumonad.ml

 open Syntax
 
 EXTEND Gram
-  GLOBAL: expr;
+  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"
-      [ [ "sumonad"; m = atom -> <:expr< fun state -> $m$ state >> ] ];
+      [ [ "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
 
   atom:
     [ [ m = block -> m
-      | "return"; e = expr LEVEL "top" -> <:expr< Sumonad.return $e$ >>
-      | "fail" -> <:expr< Sumonad.fail >>
-      | "error"; e = expr LEVEL "top" -> <:expr< Sumonad.error $e$ >>
+      | "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_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$ >>
+(*
       | "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$ >>)
-      | "let"; x = ipatt; "="; e = expr LEVEL "top"; "in"; m = seq ->
-        <:expr< (fun s -> let $pat:x$ = $e$ in $m$ s) >>
+*)
       | "match"; e = expr LEVEL "top"; "with"; OPT "|"; f = rules -> f e
-      | "for"; x = ipatt; "<-"; m1 = atom; "do"; m2 = alt; "done" ->
+      | "let"; x = ipatt; "="; m1 = alt; "in"; m2 = seq ->
         <:expr< Sumonad.bind $m1$ (fun $pat:x$ -> $m2$) >>
+      | "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$ >>

File sumonad/sumonad.ml

     | 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 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
 
 type ('a,'e) either = Result of 'a | Error of 'e
 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 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 succeeds (m : ('a,'e,'s) t) : (unit,'e,'s) t =
+  fun s ->
+    let str = m s in
+    if Stream.is_empty str
+    then Stream.Nil
+    else Stream.Single (Result (), s)
+
+let fails (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
+
+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
 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 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 =
 	  | 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 =
+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) -> let acc' = f acc x_s in iter_aux f acc' rest
+    | 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