Source

ocaml-lib / 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_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$ >>)
*)
      | "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$) >>
      | "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 ] >>) ] ];
 
END;