Source

ocaml-lib / ipp / pa_ipp.ml

Full commit

open Camlp4.PreCast
open Syntax

EXTEND Gram
  GLOBAL: expr;

  expr: LEVEL "top"
      [ [ "ipp"; p = rule ->
	<:expr< fun v cursor ctx -> $p$ v cursor ctx >> ] ];

  rule:
      [ [ "["; OPT "|"; p = alt; "]" -> p ] ];

  alt:
      [ [ p1 = map; p2o = OPT [ "|"; p2 = alt -> p2 ] ->
	match p2o with
	| None -> p1
	| Some p2 -> <:expr< Ipp.alt $p1$ $p2$ >>
	] ];

  map:
      [ [ x = ipatt; "->"; fo = OPT body ->
	match fo with
	| None -> <:expr< Ipp.map (fun [ $pat:x$ -> () | _ -> failwith "" ]) Ipp.empty >>
	| Some f -> f x ] ];

  body:
      [ [ f1 = seq; f2o = OPT [ "else"; f2 = body -> f2 ] ->
	match f2o with
	| None -> f1
	| Some f2 ->
	    (fun x ->
	      let p1 = f1 x in
	      let p2 = f2 x in
	      <:expr< Ipp.alt $p1$ $p2$ >>)
        ] ];

  seq:
      [ [ f1 = atom; "then"; f2 = seq2; f3 = [ "|"; p3 = alt -> (fun _ -> p3) | "else"; f3 = body -> f3 ] ->
	  (fun x ->
	    let p1 = f1 x in
	    let p2 = f2 x in
	    let p3 = f3 x in
            <:expr< Ipp.cut $p1$ $p2$ $p3$ >>)
        | f1 = atom; ";"; f2 = seq2 ->
          (fun x ->
	    let p1 = f1 x in
	    let p2 = f2 x in
	    <:expr< Ipp.seq $p1$ $p2$ >>)
	| f1 = atom -> f1
        ] ];

  seq2:
      [ [ f1 = atom; ";"; f2 = seq2 ->
	  (fun x ->
	    let p1 = f1 x in
	    let p2 = f2 x in
	    <:expr< Ipp.seq $p1$ $p2$ >>)
        | f1 = atom -> f1
        ] ];

  atom:
      [ [ "EOF" -> (fun x -> <:expr< Ipp.map (fun [ $pat:x$ -> () | _ -> failwith "" ]) Printer.eof >>)
        | "when"; e = expr LEVEL "top" ->
	    (fun x ->
	      let f = <:expr< fun [ $pat:x$ -> $e$ | _ -> False ] >> in
              <:expr< Ipp.check $f$ >>)
        | s = a_STRING ->
	    (fun x -> <:expr< Ipp.map (fun [ $pat:x$ -> $str:s$ | _ -> failwith "" ]) Printer.print_string >>)
	| "'"; e = expr LEVEL "top" ->
	    (fun x ->
	      let f = <:expr< fun [ $pat:x$ -> $e$ | _ -> failwith "map" ] >> in
	      <:expr< Ipp.map $f$ Printer.print_string >>)
	| "let"; y = ipatt; "="; e = expr LEVEL "top"; "in"; s = seq2 ->
	    (fun x ->
	      let p = s x in
	      let fl = <:expr< fun [ $pat:x$ -> [ $e$ ] | _ -> [] ] >> in
	      let fp = <:expr< fun [ $pat:y$ -> $p$ | _ -> failwith "" ] >> in
	      <:expr< Ipp.enum $fl$ $fp$ >>)
	| "for"; y = ipatt; e = enum; "do"; s = seq2 ->
	    (fun x ->
	      let p = s x in
	      let fl = <:expr< fun [ $pat:x$ -> $e$ | _ -> [] ] >> in
	      let fp = <:expr< fun [ $pat:y$ -> $p$ | _ -> failwith "" ] >> in
	      <:expr< Ipp.enum $fl$ $fp$ >>)
	| "?"; y = ipatt; ";"; s = seq2 ->
	    (fun x ->
	      let p = s x in
	      let fp = <:expr< fun [ $pat:y$ -> $p$ | _ -> failwith "" ] >> in
	      <:expr< Ipp.get_context $fp$ >>)
	| "!"; e = expr LEVEL "top" ->
	    (fun x -> <:expr< Ipp.set_context $e$ >>)
	| "match"; e = expr LEVEL "top"; "with"; p = rule ->
	    (fun x ->
	      let f = <:expr< fun [ $pat:x$ -> $e$ | _ -> failwith "match" ] >> in
	      <:expr< Ipp.map $f$ $p$ >>)
	| p = quantif; eo = OPT [ "of"; e = expr LEVEL "top" -> e ] ->
	    ( match eo with
	    | Some e ->
		(fun x ->
		  let f = <:expr< fun [ $pat:x$ -> $e$ | _ -> failwith "map" ] >> in
		  <:expr< Ipp.map $f$ $p$ >>)
	    | None -> (fun x -> <:expr< Ipp.map (fun [ $pat:x$ -> () | _ -> failwith "" ]) $p$ >>))
        ] ];

  enum:
      [ [ "in"; e = expr LEVEL "top" -> e
        | "="; e = expr LEVEL "top" -> <:expr< [ $e$ ] >>
        ] ];
 

  quantif:
      [ [ "MANY"; p = print -> <:expr< Ipp.many $p$ >>
        | "SOME"; p = print -> <:expr< Ipp.some $p$ >>
	| "LIST0"; p = print; "SEP"; s = sep; no = OPT [ "ELSE"; n = print -> n ] ->
	    let n = match no with Some n -> n | None -> <:expr< Ipp.empty >> in
	    <:expr< Ipp.list0 $p$ $s$ $n$ >>
	| "LIST1"; p = print; "SEP"; s = sep -> <:expr< Ipp.list1 $p$ $s$ >> ]
      | [ p = print -> p
        ] ];

  print:
      [ [ p = rule -> p
        | p = expr LEVEL "top" -> p
        ] ];

  sep:
    [ [ s = str -> <:expr< Ipp.map (fun () -> $s$) Printer.print_string >>
      | p = print -> p
      ] ];

  str:
    [ [ s = a_STRING -> <:expr< $str:s$ >>
      | "'"; e = expr LEVEL "simple" -> <:expr< $e$ >>
      ] ];

END;