l4/pkg/ocaml/contrib/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml

   1 open Camlp4;                                        (* -*- camlp4r -*- *)
   2 (****************************************************************************)
   3 (*                                                                          *)
   4 (*                              Objective Caml                              *)
   5 (*                                                                          *)
   6 (*                            INRIA Rocquencourt                            *)
   7 (*                                                                          *)
   8 (*  Copyright 1998-2006 Institut National de Recherche en Informatique et   *)
   9 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
  10 (*  the terms of the GNU Library General Public License, with the special   *)
  11 (*  exception on linking described in LICENSE at the top of the Objective   *)
  12 (*  Caml source tree.                                                       *)
  13 (*                                                                          *)
  14 (****************************************************************************)
  15
  16 (* Authors:
  17  * - Daniel de Rauglaudre: initial version
  18  * - Nicolas Pouillard: refactoring
  19  *)
  20
  21
  22 module Id : Sig.Id = struct
  23   value name = "Camlp4OCamlRevisedParserParser";
  24   value version = Sys.ocaml_version;
  25 end;
  26
  27 module Make (Syntax : Sig.Camlp4Syntax) = struct
  28   open Sig;
  29   include Syntax;
  30
  31   type spat_comp =
  32     [ SpTrm of Loc.t and Ast.patt and option Ast.expr
  33     | SpNtr of Loc.t and Ast.patt and Ast.expr
  34     | SpStr of Loc.t and Ast.patt ]
  35   ;
  36   type sexp_comp =
  37     [ SeTrm of Loc.t and Ast.expr | SeNtr of Loc.t and Ast.expr ]
  38   ;
  39
  40   value stream_expr = Gram.Entry.mk "stream_expr";
  41   value stream_begin = Gram.Entry.mk "stream_begin";
  42   value stream_end = Gram.Entry.mk "stream_end";
  43   value stream_quot = Gram.Entry.mk "stream_quot";
  44   value parser_case = Gram.Entry.mk "parser_case";
  45   value parser_case_list = Gram.Entry.mk "parser_case_list";
  46
  47   value strm_n = "__strm";
  48   value peek_fun _loc = <:expr< Stream.peek >>;
  49   value junk_fun _loc = <:expr< Stream.junk >>;
  50
  51   (* Parsers. *)
  52   (* In syntax generated, many cases are optimisations. *)
  53
  54   value rec pattern_eq_expression p e =
  55     match (p, e) with
  56     [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b
  57     | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b
  58     | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) ->
  59         pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2
  60     | _ -> False ]
  61   ;
  62
  63   value is_raise e =
  64     match e with
  65     [ <:expr< raise $_$ >> -> True
  66     | _ -> False ]
  67   ;
  68
  69   value is_raise_failure e =
  70     match e with
  71     [ <:expr< raise Stream.Failure >> -> True
  72     | _ -> False ]
  73   ;
  74
  75   value rec handle_failure e =
  76     match e with
  77     [ <:expr< try $_$ with [ Stream.Failure -> $e$] >> ->
  78         handle_failure e
  79     | <:expr< match $me$ with [ $a$ ] >> ->
  80         let rec match_case_handle_failure =
  81           fun
  82           [ <:match_case< $a1$ | $a2$ >> ->
  83               match_case_handle_failure a1 && match_case_handle_failure a2
  84           | <:match_case< $pat:_$ -> $e$ >> -> handle_failure e
  85           | _ -> False ]
  86         in handle_failure me && match_case_handle_failure a
  87     | <:expr< let $bi$ in $e$ >> ->
  88         let rec binding_handle_failure =
  89           fun
  90           [ <:binding< $b1$ and $b2$ >> ->
  91               binding_handle_failure b1 && binding_handle_failure b2
  92           | <:binding< $_$ = $e$ >> -> handle_failure e
  93           | _ -> False ]
  94         in binding_handle_failure bi && handle_failure e
  95     | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> |
  96       <:expr< $chr:_$ >> | <:expr< fun [ $_$ ] >> | <:expr< $uid:_$ >> ->
  97         True
  98     | <:expr< raise $e$ >> ->
  99         match e with
 100         [ <:expr< Stream.Failure >> -> False
 101         | _ -> True ]
 102     | <:expr< $f$ $x$ >> ->
 103         is_constr_apply f && handle_failure f && handle_failure x
 104     | _ -> False ]
 105   and is_constr_apply =
 106     fun
 107     [ <:expr< $uid:_$ >> -> True
 108     | <:expr< $lid:_$ >> -> False
 109     | <:expr< $x$ $_$ >> -> is_constr_apply x
 110     | _ -> False ]
 111   ;
 112
 113   value rec subst v e =
 114     let _loc = Ast.loc_of_expr e in
 115     match e with
 116     [ <:expr< $lid:x$ >> ->
 117         let x = if x = v then strm_n else x in
 118         <:expr< $lid:x$ >>
 119     | <:expr< $uid:_$ >> -> e
 120     | <:expr< $int:_$ >> -> e
 121     | <:expr< $chr:_$ >> -> e
 122     | <:expr< $str:_$ >> -> e
 123     | <:expr< $_$ . $_$ >> -> e
 124     | <:expr< let $rec:rf$ $bi$ in $e$ >> ->
 125         <:expr< let $rec:rf$ $subst_binding v bi$ in $subst v e$ >>
 126     | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >>
 127     | <:expr< ( $tup:e$ ) >> -> <:expr< ( $tup:subst v e$ ) >>
 128     | <:expr< $e1$, $e2$ >> -> <:expr< $subst v e1$, $subst v e2$ >>
 129     | _ -> raise Not_found ]
 130   and subst_binding v =
 131     fun
 132     [ <:binding@_loc< $b1$ and $b2$ >> ->
 133         <:binding< $subst_binding v b1$ and $subst_binding v b2$ >>
 134     | <:binding@_loc< $lid:v'$ = $e$ >> ->
 135         <:binding< $lid:v'$ = $if v = v' then e else subst v e$ >>
 136     | _ -> raise Not_found ];
 137
 138   value stream_pattern_component skont ckont =
 139     fun
 140     [ SpTrm _loc p None ->
 141         <:expr< match $peek_fun _loc$ $lid:strm_n$ with
 142                 [ Some $p$ ->
 143                     do { $junk_fun _loc$ $lid:strm_n$; $skont$ }
 144                 | _ -> $ckont$ ] >>
 145     | SpTrm _loc p (Some w) ->
 146         <:expr< match $peek_fun _loc$ $lid:strm_n$ with
 147                 [ Some $p$ when $w$ ->
 148                     do { $junk_fun _loc$ $lid:strm_n$; $skont$ }
 149                 | _ -> $ckont$ ] >>
 150     | SpNtr _loc p e ->
 151         let e =
 152           match e with
 153           [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n -> e
 154           | _ -> <:expr< $e$ $lid:strm_n$ >> ]
 155         in
 156         if pattern_eq_expression p skont then
 157           if is_raise_failure ckont then e
 158           else if handle_failure e then e
 159           else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >>
 160         else if is_raise_failure ckont then
 161           <:expr< let $p$ = $e$ in $skont$ >>
 162         else if pattern_eq_expression <:patt< Some $p$ >> skont then
 163           <:expr< try Some $e$ with [ Stream.Failure -> $ckont$ ] >>
 164         else if is_raise ckont then
 165           let tst =
 166             if handle_failure e then e
 167             else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >>
 168           in
 169           <:expr< let $p$ = $tst$ in $skont$ >>
 170         else
 171           <:expr< match try Some $e$ with [ Stream.Failure -> None ] with
 172                   [ Some $p$ -> $skont$
 173                   | _ -> $ckont$ ] >>
 174     | SpStr _loc p ->
 175         try
 176           match p with
 177           [ <:patt< $lid:v$ >> -> subst v skont
 178           | _ -> raise Not_found ]
 179         with
 180         [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ]
 181   ;
 182
 183   value rec stream_pattern _loc epo e ekont =
 184     fun
 185     [ [] ->
 186         match epo with
 187         [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >>
 188         | _ -> e ]
 189     | [(spc, err) :: spcl] ->
 190         let skont =
 191           let ekont err =
 192             let str =
 193               match err with
 194               [ Some estr -> estr
 195               | _ -> <:expr< "" >> ]
 196             in
 197             <:expr< raise (Stream.Error $str$) >>
 198           in
 199           stream_pattern _loc epo e ekont spcl
 200         in
 201         let ckont = ekont err in stream_pattern_component skont ckont spc ]
 202   ;
 203
 204   value stream_patterns_term _loc ekont tspel =
 205     let pel =
 206       List.fold_right
 207         (fun (p, w, _loc, spcl, epo, e) acc ->
 208           let p = <:patt< Some $p$ >> in
 209           let e =
 210             let ekont err =
 211               let str =
 212                 match err with
 213                 [ Some estr -> estr
 214                 | _ -> <:expr< "" >> ]
 215               in
 216               <:expr< raise (Stream.Error $str$) >>
 217             in
 218             let skont = stream_pattern _loc epo e ekont spcl in
 219             <:expr< do { $junk_fun _loc$ $lid:strm_n$; $skont$ } >>
 220           in
 221           match w with
 222           [ Some w -> <:match_case< $pat:p$ when $w$ -> $e$ | $acc$ >>
 223           | None -> <:match_case< $pat:p$ -> $e$ | $acc$ >> ])
 224         tspel <:match_case<>>
 225     in
 226     <:expr< match $peek_fun _loc$ $lid:strm_n$ with [ $pel$ | _ -> $ekont ()$ ] >>
 227   ;
 228
 229   value rec group_terms =
 230     fun
 231     [ [([(SpTrm _loc p w, None) :: spcl], epo, e) :: spel] ->
 232         let (tspel, spel) = group_terms spel in
 233         ([(p, w, _loc, spcl, epo, e) :: tspel], spel)
 234     | spel -> ([], spel) ]
 235   ;
 236
 237   value rec parser_cases _loc =
 238     fun
 239     [ [] -> <:expr< raise Stream.Failure >>
 240     | spel ->
 241         match group_terms spel with
 242         [ ([], [(spcl, epo, e) :: spel]) ->
 243             stream_pattern _loc epo e (fun _ -> parser_cases _loc spel) spcl
 244         | (tspel, spel) ->
 245             stream_patterns_term _loc (fun _ -> parser_cases _loc spel) tspel ] ]
 246   ;
 247
 248   value cparser _loc bpo pc =
 249     let e = parser_cases _loc pc in
 250     let e =
 251       match bpo with
 252       [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >>
 253       | None -> e ]
 254     in
 255     let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in
 256     <:expr< fun $p$ -> $e$ >>
 257   ;
 258
 259   value cparser_match _loc me bpo pc =
 260     let pc = parser_cases _loc pc in
 261     let e =
 262       match bpo with
 263       [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>
 264       | None -> pc ]
 265     in
 266     let me =
 267       match me with
 268       [ <:expr@_loc< $_$; $_$ >> as e -> <:expr< do { $e$ } >>
 269       | e -> e ]
 270     in
 271     match me with
 272     [ <:expr< $lid:x$ >> when x = strm_n -> e
 273     | _ -> <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> ]
 274   ;
 275
 276   (* streams *)
 277
 278   value rec not_computing =
 279     fun
 280     [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> |
 281       <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> -> True
 282     | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y
 283     | _ -> False ]
 284   and is_cons_apply_not_computing =
 285     fun
 286     [ <:expr< $uid:_$ >> -> True
 287     | <:expr< $lid:_$ >> -> False
 288     | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y
 289     | _ -> False ]
 290   ;
 291
 292   value slazy _loc e =
 293     match e with
 294     [ <:expr< $f$ () >> ->
 295         match f with
 296         [ <:expr< $lid:_$ >> -> f
 297         | _ -> <:expr< fun _ -> $e$ >> ]
 298     | _ -> <:expr< fun _ -> $e$ >> ]
 299   ;
 300
 301   value rec cstream gloc =
 302     fun
 303     [ [] -> let _loc = gloc in <:expr< Stream.sempty >>
 304     | [SeTrm _loc e] ->
 305         if not_computing e then <:expr< Stream.ising $e$ >>
 306         else <:expr< Stream.lsing $slazy _loc e$ >>
 307     | [SeTrm _loc e :: secl] ->
 308         if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >>
 309         else <:expr< Stream.lcons $slazy _loc e$ $cstream gloc secl$ >>
 310     | [SeNtr _loc e] ->
 311         if not_computing e then e else <:expr< Stream.slazy $slazy _loc e$ >>
 312     | [SeNtr _loc e :: secl] ->
 313         if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >>
 314         else <:expr< Stream.lapp $slazy _loc e$ $cstream gloc secl$ >> ]
 315   ;
 316   (* Syntax extensions in Revised Syntax grammar *)
 317
 318   EXTEND Gram
 319     GLOBAL: expr stream_expr stream_begin stream_end stream_quot
 320       parser_case parser_case_list;
 321     expr: LEVEL "top"
 322       [ [ "parser"; po = OPT parser_ipatt; pcl = parser_case_list ->
 323             <:expr< $cparser _loc po pcl$ >>
 324         | "match"; e = sequence; "with"; "parser"; po = OPT parser_ipatt;
 325           pcl = parser_case_list ->
 326             <:expr< $cparser_match _loc e po pcl$ >>
 327       ] ]
 328     ;
 329     parser_case_list:
 330       [ [ "["; pcl = LIST0 parser_case SEP "|"; "]" -> pcl
 331         | pc = parser_case -> [pc]
 332       ] ]
 333     ;
 334     parser_case:
 335       [ [ stream_begin; sp = stream_patt; stream_end; po = OPT parser_ipatt; "->"; e = expr ->
 336             (sp, po, e) ] ]
 337     ;
 338     stream_begin:
 339       [ [ "[:" -> () ] ]
 340     ;
 341     stream_end:
 342       [ [ ":]" -> () ] ]
 343     ;
 344     stream_quot:
 345       [ [ "`" -> () ] ]
 346     ;
 347     stream_expr:
 348       [ [ e = expr -> e ] ]
 349     ;
 350     stream_patt:
 351       [ [ spc = stream_patt_comp -> [(spc, None)]
 352         | spc = stream_patt_comp; ";"; sp = stream_patt_comp_err_list ->
 353             [(spc, None) :: sp]
 354         | -> [] ] ]
 355     ;
 356     stream_patt_comp_err:
 357       [ [ spc = stream_patt_comp; eo = OPT [ "??"; e = stream_expr -> e ] ->
 358             (spc, eo) ] ]
 359     ;
 360     stream_patt_comp_err_list:
 361       [ [ spc = stream_patt_comp_err -> [spc]
 362         | spc = stream_patt_comp_err; ";" -> [spc]
 363         | spc = stream_patt_comp_err; ";"; sp = stream_patt_comp_err_list ->
 364             [spc :: sp] ] ]
 365     ;
 366     stream_patt_comp:
 367       [ [ stream_quot; p = patt; eo = OPT [ "when"; e = stream_expr -> e ] -> SpTrm _loc p eo
 368         | p = patt; "="; e = stream_expr -> SpNtr _loc p e
 369         | p = patt -> SpStr _loc p ] ]
 370     ;
 371     parser_ipatt:
 372       [ [ i = a_LIDENT -> <:patt< $lid:i$ >>
 373         | "_" -> <:patt< _ >>
 374       ] ]
 375     ;
 376     expr: LEVEL "simple"
 377       [ [ stream_begin; stream_end -> <:expr< $cstream _loc []$ >>
 378         | stream_begin; sel = stream_expr_comp_list; stream_end ->
 379             <:expr< $cstream _loc sel$ >> ] ]
 380     ;
 381     stream_expr_comp_list:
 382       [ [ se = stream_expr_comp; ";"; sel = stream_expr_comp_list -> [se :: sel]
 383         | se = stream_expr_comp; ";" -> [se]
 384         | se = stream_expr_comp -> [se] ] ]
 385     ;
 386     stream_expr_comp:
 387       [ [ stream_quot; e = stream_expr -> SeTrm _loc e
 388         | e = stream_expr -> SeNtr _loc e ] ]
 389     ;
 390   END;
 391
 392 end;
 393
 394 module M = Register.OCamlSyntaxExtension Id Make;