Source

ocaml-lib / sumonad / pa_sumonad.ml

Full commit

open Camlp4.PreCast
open Syntax

EXTEND Gram
  GLOBAL: expr;

  expr: LEVEL "top"
      [ [ "sumonad"; m = atom -> <:expr< fun state -> $m$ state >> ] ];

  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
      | "return"; e = expr LEVEL "top" -> <:expr< Sumonad.return $e$ >>
      | "fail" -> <:expr< Sumonad.fail >>
      | "error"; e = expr LEVEL "top" -> <:expr< Sumonad.error $e$ >>
      | "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" ->
        <:expr< Sumonad.bind $m1$ (fun $pat:x$ -> $m2$) >>
      | "#"; 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;