Source

ocaml-lib / dcg / pa_dcg.ml


open Camlp4.PreCast
open Syntax

EXTEND Gram
  GLOBAL: expr;

  expr: LEVEL "top"
      [ [ "dcg"; p = rule -> <:expr< fun str -> $p$ str >> ] ];

  rule:
      [ [ "["; OPT "|"; p = alt; "]" -> p ] ];
    
  alt:
      [ [ p1 = seq; p2o = OPT [ "|"; p2 = alt -> p2 ] ->
        match p2o with
	| None -> p1
	| Some p2 -> <:expr< Dcg.alt $p1$ $p2$ >>
	] ];

  seq:
      [ [ "->"; e = expr ->
	    <:expr< Dcg.ret $e$ >>
        | (x1,p1) = atom; ";"; "!"; ";"; p2 = seq2; "|"; p3 = alt ->
	    let f = <:expr< fun $pat:x1$ -> $p2$ >> in
	    <:expr< Dcg.cut $p1$ $f$ $p3$ >>
        | (x1,p1) = atom; f2 = seq1 ->
            f2 (x1,p1)
        ] ];

  seq1:
    [ [ "->"; e = expr ->
        (fun (x,p) ->
	  let f = <:expr< fun $pat:x$ -> $e$ >> in
          <:expr< Dcg.map $p$ $f$ >>)
      | ";"; p2 = seq2 ->
        (fun (x1,p1) ->
	  let f = <:expr< fun $pat:x1$ -> $p2$ >> in
          <:expr< Dcg.seq $p1$ $f$ >>)
      ] ];

  seq2:
    [ [ (x1, p1) = atom; f2 = seq1 -> f2 (x1,p1) 
      | "("; OPT "|"; p = alt; ")" -> p
      ] ];

  atom:
    [ [ "EOF" ->
        <:patt< _ >>, <:expr< Matcher.eof >>
      | "when"; s = str; e = expr LEVEL "top" ->
	  let f = <:expr< fun () -> $e$ >> in
	  <:patt< _ >>, <:expr< Dcg.check $s$ $f$ >>
      | s = str ->
        <:patt< _ >>, <:expr< Matcher.look $s$ >>
      | x = ipatt; "="; p = quantif; eo = OPT [ "when"; s = str; e = expr LEVEL "top" -> (s,e) ] -> 
        ( match eo with
	| None ->
            x, p 
        | Some (s,e) ->
	    let f = <:expr< fun $pat:x$ -> $e$ >> in
            x, <:expr< Dcg.guard $p$ $s$ $f$ >>)
      ] ];

  quantif:
    [ [ "OPT"; p = par; "ELSE"; x = expr LEVEL "top" -> <:expr< Dcg.opt $p$ $x$ >>
      | "MANY"; p = par -> <:expr< Dcg.many $p$ >>
      | "SOME"; p = par -> <:expr< Dcg.some $p$ >>
      | "LIST0"; p = par; "SEP"; s = sep -> <:expr< Dcg.list0 $p$ $s$ >>
      | "LIST1"; p = par; "SEP"; s = sep -> <:expr< Dcg.list1 $p$ $s$ >> ]
    | [ p = par -> p
      ] ];

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

  sep:
    [ [ s = str -> <:expr< Matcher.look $s$ >>
      | p = par -> p
      ] ];

  str:
    [ [ s = a_STRING -> <:expr< $str:s$ >>
      | "'"; e = expr LEVEL "simple" -> <:expr< $e$ >>
(*      | u = UIDENT; "."; i = LIDENT -> <:expr< $uid:u$ . $lid:i$ >> *)
      ] ];

(*
  pat:
    [ [ xl = LIST1 [ "_" -> $_$ | i = a_LIDENT -> $lid:i$ ] SEP "," ->
        match xl with
(*	| [x] -> <:patt< $x$ >> *)
	| _ -> <:patt< ( $list:xl$ ) >>
      ] ];
*)

END;