519 lines
14 KiB
OCaml
519 lines
14 KiB
OCaml
(* camlp4r q_MLast.cmo ./pa_extfun.cmo *)
|
|
(***********************************************************************)
|
|
(* *)
|
|
(* Camlp4 *)
|
|
(* *)
|
|
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 2002 Institut National de Recherche en Informatique et *)
|
|
(* Automatique. Distributed only by permission. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(* $Id$ *)
|
|
|
|
open Pcaml;
|
|
open Spretty;
|
|
|
|
value no_slist = ref False;
|
|
|
|
value expr e dg k = pr_expr.pr_fun "top" e dg k;
|
|
value patt e dg k = pr_patt.pr_fun "top" e dg k;
|
|
|
|
(* Utilities *)
|
|
|
|
value rec list elem el k =
|
|
match el with
|
|
[ [] -> k
|
|
| [x] -> [: `elem x k :]
|
|
| [x :: l] -> [: `elem x [: :]; list elem l k :] ]
|
|
;
|
|
|
|
value rec listws elem sep el k =
|
|
match el with
|
|
[ [] -> k
|
|
| [x] -> [: `elem x k :]
|
|
| [x :: l] -> [: `elem x [: `sep :]; listws elem sep l k :] ]
|
|
;
|
|
|
|
value rec listwbws elem b sep el dg k =
|
|
match el with
|
|
[ [] -> [: b; k :]
|
|
| [x] -> [: `elem b x dg k :]
|
|
| [x :: l] ->
|
|
let sdg =
|
|
match sep with
|
|
[ S _ x -> x
|
|
| _ -> "" ]
|
|
in
|
|
[: `elem b x sdg [: :]; listwbws elem [: `sep :] sep l dg k :] ]
|
|
;
|
|
|
|
(* Extracting *)
|
|
|
|
value rec get_globals =
|
|
fun
|
|
[ [(<:patt< _ >>, <:expr< ($e$ : $uid:gmod1$.Entry.e '$_$) >>) :: pel] ->
|
|
let (gmod, gl) = get_globals pel in
|
|
if gmod = "" || gmod = gmod1 then (gmod1, [e :: gl])
|
|
else raise Not_found
|
|
| [] -> ("", [])
|
|
| _ -> raise Not_found ]
|
|
;
|
|
|
|
value rec get_locals =
|
|
fun
|
|
[ [(<:patt< $_$ >>,
|
|
<:expr< (grammar_entry_create $_$ : $_$) >>) :: pel] ->
|
|
get_locals pel
|
|
| [] -> ()
|
|
| _ -> raise Not_found ]
|
|
;
|
|
|
|
value unposition =
|
|
fun
|
|
[ <:expr< None >> -> None
|
|
| <:expr< Some Gramext.First >> -> Some Gramext.First
|
|
| <:expr< Some Gramext.Last >> -> Some Gramext.Last
|
|
| <:expr< Some (Gramext.Before $str:s$) >> -> Some (Gramext.Before s)
|
|
| <:expr< Some (Gramext.After $str:s$) >> -> Some (Gramext.After s)
|
|
| <:expr< Some (Gramext.Level $str:s$) >> -> Some (Gramext.Level s)
|
|
| _ -> raise Not_found ]
|
|
;
|
|
|
|
value unlabel =
|
|
fun
|
|
[ <:expr< None >> -> None
|
|
| <:expr< Some $str:s$ >> -> Some s
|
|
| _ -> raise Not_found ]
|
|
;
|
|
|
|
value unassoc =
|
|
fun
|
|
[ <:expr< None >> -> None
|
|
| <:expr< Some Gramext.NonA >> -> Some Gramext.NonA
|
|
| <:expr< Some Gramext.LeftA >> -> Some Gramext.LeftA
|
|
| <:expr< Some Gramext.RightA >> -> Some Gramext.RightA
|
|
| _ -> raise Not_found ]
|
|
;
|
|
|
|
value rec unaction =
|
|
fun
|
|
[ <:expr< fun ($lid:locp$ : Loc.t) -> ($a$ : $_$) >>
|
|
when locp = Stdpp.loc_name.val ->
|
|
let ao =
|
|
match a with
|
|
[ <:expr< () >> -> None
|
|
| _ -> Some a ]
|
|
in
|
|
([], ao)
|
|
| <:expr< fun ($p$ : $_$) -> $e$ >> ->
|
|
let (pl, a) = unaction e in ([p :: pl], a)
|
|
| <:expr@_loc< fun _ -> $e$ >> ->
|
|
let (pl, a) = unaction e in ([ <:patt< _ >> :: pl ], a)
|
|
| _ -> raise Not_found ]
|
|
;
|
|
|
|
value untoken =
|
|
fun
|
|
[ <:expr< ($str:x$, $str:y$) >> -> (x, y)
|
|
| _ -> raise Not_found ]
|
|
;
|
|
|
|
type symbol =
|
|
[ Snterm of MLast.expr
|
|
| Snterml of MLast.expr and string
|
|
| Slist0 of symbol
|
|
| Slist0sep of symbol and symbol
|
|
| Slist1 of symbol
|
|
| Slist1sep of symbol and symbol
|
|
| Sopt of symbol
|
|
| Sself
|
|
| Snext
|
|
| Stoken of Token.pattern
|
|
| Srules of list (list (option MLast.patt * symbol) * option MLast.expr) ]
|
|
;
|
|
|
|
value rec unsymbol =
|
|
fun
|
|
[ <:expr< Gramext.Snterm ($uid:_$.Entry.obj ($e$ : $_$)) >> -> Snterm e
|
|
| <:expr< Gramext.Snterml ($uid:_$.Entry.obj ($e$ : $_$)) $str:s$ >> ->
|
|
Snterml e s
|
|
| <:expr< Gramext.Snterml ($uid:_$.Entry.obj ($e$ : $_$), $str:s$) >> ->
|
|
Snterml e s
|
|
| <:expr< Gramext.Slist0 $e$ >> -> Slist0 (unsymbol e)
|
|
| <:expr< Gramext.Slist0sep $e1$ $e2$ >> ->
|
|
Slist0sep (unsymbol e1) (unsymbol e2)
|
|
| <:expr< Gramext.Slist0sep ($e1$, $e2$) >> ->
|
|
Slist0sep (unsymbol e1) (unsymbol e2)
|
|
| <:expr< Gramext.Slist1 $e$ >> -> Slist1 (unsymbol e)
|
|
| <:expr< Gramext.Slist1sep $e1$ $e2$ >> ->
|
|
Slist1sep (unsymbol e1) (unsymbol e2)
|
|
| <:expr< Gramext.Slist1sep ($e1$, $e2$) >> ->
|
|
Slist1sep (unsymbol e1) (unsymbol e2)
|
|
| <:expr< Gramext.Sopt $e$ >> -> Sopt (unsymbol e)
|
|
| <:expr< Gramext.Sself >> -> Sself
|
|
| <:expr< Gramext.Snext >> -> Snext
|
|
| <:expr< Gramext.Stoken $e$ >> -> Stoken (untoken e)
|
|
| <:expr< Gramext.srules $e$ >> -> Srules (unrule_list [] e)
|
|
| _ -> raise Not_found ]
|
|
and unpsymbol_list pl e =
|
|
match (pl, e) with
|
|
[ ([], <:expr< [] >>) -> []
|
|
| ([p :: pl], <:expr< [$e$ :: $el$] >>) ->
|
|
let op =
|
|
match p with
|
|
[ <:patt< _ >> -> None
|
|
| _ -> Some p ]
|
|
in
|
|
[(op, unsymbol e) :: unpsymbol_list pl el]
|
|
| _ -> raise Not_found ]
|
|
and unrule =
|
|
fun
|
|
[ <:expr@_loc< ($e1$, Gramext.action $e2$) >> ->
|
|
let (pl, a) =
|
|
match unaction e2 with
|
|
[ ([], None) -> ([], Some <:expr< () >>)
|
|
| x -> x ]
|
|
in
|
|
let sl = unpsymbol_list (List.rev pl) e1 in
|
|
(sl, a)
|
|
| _ -> raise Not_found ]
|
|
and unrule_list rl =
|
|
fun
|
|
[ <:expr< [$e$ :: $el$] >> -> unrule_list [unrule e :: rl] el
|
|
| <:expr< [] >> -> rl
|
|
| _ -> raise Not_found ]
|
|
;
|
|
|
|
value unlevel =
|
|
fun
|
|
[ <:expr< ($e1$, $e2$, $e3$) >> ->
|
|
(unlabel e1, unassoc e2, unrule_list [] e3)
|
|
| _ -> raise Not_found ]
|
|
;
|
|
|
|
value rec unlevel_list =
|
|
fun
|
|
[ <:expr< [$e$ :: $el$] >> -> [unlevel e :: unlevel_list el]
|
|
| <:expr< [] >> -> []
|
|
| _ -> raise Not_found ]
|
|
;
|
|
|
|
value unentry =
|
|
fun
|
|
[ <:expr< (Grammar.Entry.obj ($e$ : Grammar.Entry.e '$_$), $pos$, $ll$) >> ->
|
|
(e, unposition pos, unlevel_list ll)
|
|
| _ -> raise Not_found ]
|
|
;
|
|
|
|
value rec unentry_list =
|
|
fun
|
|
[ <:expr< [$e$ :: $el$] >> -> [unentry e :: unentry_list el]
|
|
| <:expr< [] >> -> []
|
|
| _ -> raise Not_found ]
|
|
;
|
|
|
|
value unextend_body e =
|
|
let ((_, globals), e) =
|
|
match e with
|
|
[ <:expr< let $list:pel$ in $e1$ >> ->
|
|
try (get_globals pel, e1) with
|
|
[ Not_found -> (("", []), e) ]
|
|
| _ -> (("", []), e) ]
|
|
in
|
|
let e =
|
|
match e with
|
|
[ <:expr<
|
|
let grammar_entry_create s =
|
|
Grammar.Entry.create (Grammar.of_entry $_$) s
|
|
in
|
|
$e$ >> ->
|
|
let e =
|
|
match e with
|
|
[ <:expr< let $list:pel$ in $e1$ >> ->
|
|
try let _ = get_locals pel in e1 with
|
|
[ Not_found -> e ]
|
|
| _ -> e ]
|
|
in
|
|
e
|
|
| _ -> e ]
|
|
in
|
|
let el = unentry_list e in
|
|
(globals, el)
|
|
;
|
|
|
|
value ungextend_body e =
|
|
let e =
|
|
match e with
|
|
[ <:expr<
|
|
let grammar_entry_create = Gram.Entry.create in
|
|
let $list:ll$ in $e$
|
|
>> ->
|
|
let _ = get_locals ll in e
|
|
| _ -> e ]
|
|
in
|
|
match e with
|
|
[ <:expr< do { $list:el$ } >> ->
|
|
List.map
|
|
(fun
|
|
[ <:expr< $uid:_$.extend ($e$ : $uid:_$.Entry.e '$_$) $pos$ $ll$ >> ->
|
|
(e, unposition pos, unlevel_list ll)
|
|
| _ -> raise Not_found ])
|
|
el
|
|
| _ -> raise Not_found ]
|
|
;
|
|
|
|
(* Printing *)
|
|
|
|
value ident s k = HVbox [: `S LR s; k :];
|
|
value string s k = HVbox [: `S LR ("\"" ^ s ^ "\""); k :];
|
|
|
|
value position =
|
|
fun
|
|
[ None -> [: :]
|
|
| Some Gramext.First -> [: `S LR "FIRST" :]
|
|
| Some Gramext.Last -> [: `S LR "LAST" :]
|
|
| Some (Gramext.Before s) -> [: `S LR "BEFORE"; `string s [: :] :]
|
|
| Some (Gramext.After s) -> [: `S LR "AFTER"; `string s [: :] :]
|
|
| Some (Gramext.Level s) -> [: `S LR "LEVEL"; `string s [: :] :] ]
|
|
;
|
|
|
|
value action expr a dg k =
|
|
expr a dg k
|
|
;
|
|
|
|
value token (con, prm) k =
|
|
if con = "" then string prm k
|
|
else if prm = "" then HVbox [: `S LR con; k :]
|
|
else HVbox [: `S LR con; `string prm k :]
|
|
;
|
|
|
|
value simplify_rules rl =
|
|
try
|
|
List.map
|
|
(fun
|
|
[ ([(Some <:patt< $lid:x$ >>, s)], Some <:expr< $lid:y$ >>) ->
|
|
if x = y then ([(None, s)], None) else raise Exit
|
|
| ([], _) as r -> r
|
|
| _ -> raise Exit ])
|
|
rl
|
|
with
|
|
[ Exit -> rl ]
|
|
;
|
|
|
|
value rec symbol s k =
|
|
match s with
|
|
[ Snterm e -> expr e "" k
|
|
| Snterml e s -> HVbox [: `expr e "" [: :]; `S LR "LEVEL"; `string s k :]
|
|
| Slist0 s -> HVbox [: `S LR "LIST0"; `symbol s k :]
|
|
| Slist0sep s sep ->
|
|
HVbox
|
|
[: `S LR "LIST0"; `symbol s [: :]; `S LR "SEP";
|
|
`symbol sep k :]
|
|
| Slist1 s -> HVbox [: `S LR "LIST1"; `symbol s k :]
|
|
| Slist1sep s sep ->
|
|
HVbox
|
|
[: `S LR "LIST1"; `symbol s [: :]; `S LR "SEP";
|
|
`symbol sep k :]
|
|
| Sopt s -> HVbox [: `S LR "OPT"; `symbol s k :]
|
|
| Sself -> HVbox [: `S LR "SELF"; k :]
|
|
| Snext -> HVbox [: `S LR "NEXT"; k :]
|
|
| Stoken tok -> token tok k
|
|
| Srules
|
|
[([(Some <:patt< a >>, Snterm <:expr< a_list >>)], Some <:expr< a >>);
|
|
([(Some <:patt< a >>,
|
|
((Slist0 _ | Slist1 _ | Slist0sep _ _ | Slist1sep _ _) as s))],
|
|
Some <:expr< Qast.List a >>)]
|
|
when not no_slist.val
|
|
->
|
|
match s with
|
|
[ Slist0 s -> HVbox [: `S LR "SLIST0"; `simple_symbol s k :]
|
|
| Slist1 s -> HVbox [: `S LR "SLIST1"; `simple_symbol s k :]
|
|
| Slist0sep s sep ->
|
|
HVbox
|
|
[: `S LR "SLIST0"; `simple_symbol s [: :]; `S LR "SEP";
|
|
`symbol sep k :]
|
|
| Slist1sep s sep ->
|
|
HVbox
|
|
[: `S LR "SLIST1"; `simple_symbol s [: :]; `S LR "SEP";
|
|
`simple_symbol sep k :]
|
|
| _ -> assert False ]
|
|
| Srules
|
|
[([(Some <:patt< a >>, Snterm <:expr< a_opt >>)], Some <:expr< a >>);
|
|
([(Some <:patt< a >>, Sopt s)], Some <:expr< Qast.Option a >>)]
|
|
when not no_slist.val
|
|
->
|
|
let s =
|
|
match s with
|
|
[ Srules
|
|
[([(Some <:patt< x >>, Stoken ("", str))],
|
|
Some <:expr< Qast.Str x >>)] ->
|
|
Stoken ("", str)
|
|
| s -> s ]
|
|
in
|
|
HVbox [: `S LR "SOPT"; `simple_symbol s k :]
|
|
| Srules rl ->
|
|
let rl = simplify_rules rl in
|
|
HVbox [: `HVbox [: :]; rule_list rl k :] ]
|
|
and simple_symbol s k =
|
|
match s with
|
|
[ Snterml _ _ -> HVbox [: `S LO "("; `symbol s [: `S RO ")"; k :] :]
|
|
| s -> symbol s k ]
|
|
and psymbol (p, s) k =
|
|
match p with
|
|
[ None -> symbol s k
|
|
| Some p -> HVbox [: `patt p "" [: `S LR "=" :]; `symbol s k :] ]
|
|
and psymbol_list sl k =
|
|
listws psymbol (S RO ";") sl k
|
|
and rule b (sl, a) dg k =
|
|
match a with
|
|
[ None -> HVbox [: b; `HOVbox [: psymbol_list sl k :] :]
|
|
| Some a ->
|
|
HVbox
|
|
[: b;
|
|
`HOVbox
|
|
[: `HOVbox
|
|
[: `HVbox [: :];
|
|
psymbol_list sl [: `S LR "->" :] :];
|
|
`action expr a dg k :] :] ]
|
|
and rule_list ll k =
|
|
listwbws rule [: `S LR "[" :] (S LR "|") ll ""
|
|
[: `S LR "]"; k :]
|
|
;
|
|
|
|
value label =
|
|
fun
|
|
[ Some s -> [: `S LR ("\"" ^ s ^ "\"") :]
|
|
| None -> [: :] ]
|
|
;
|
|
|
|
value intloc loc = ((Loc.start_off loc), (Loc.stop_off loc));
|
|
|
|
value intloc2 (bp, ep) = (bp.Lexing.pos_cnum, ep.Lexing.pos_cnum);
|
|
|
|
|
|
value assoc =
|
|
fun
|
|
[ Some Gramext.NonA -> [: `S LR "NONA" :]
|
|
| Some Gramext.LeftA -> [: `S LR "LEFTA" :]
|
|
| Some Gramext.RightA -> [: `S LR "RIGHTA" :]
|
|
| None -> [: :] ]
|
|
;
|
|
|
|
value level b (lab, ass, rl) _ k =
|
|
let s =
|
|
if rl = [] then [: `S LR "[ ]"; k :]
|
|
else [: `Vbox [: `HVbox [: :]; rule_list rl k :] :]
|
|
in
|
|
match (lab, ass) with
|
|
[ (None, None) -> HVbox [: b; s :]
|
|
| _ ->
|
|
Vbox
|
|
[: `HVbox [: b; label lab; assoc ass :];
|
|
`HVbox [: `HVbox [: :]; s :] :] ]
|
|
;
|
|
|
|
value level_list ll k =
|
|
Vbox
|
|
[: `HVbox [: :];
|
|
listwbws level [: `S LR "[" :] (S LR "|") ll ""
|
|
[: `S LR "]"; k :] :]
|
|
;
|
|
|
|
value entry (e, pos, ll) k =
|
|
BEbox
|
|
[: `LocInfo (intloc(MLast.loc_of_expr e))
|
|
(HVbox [: `expr e "" [: `S RO ":" :]; position pos :]);
|
|
`level_list ll [: :];
|
|
`HVbox [: `S RO ";"; k :] :]
|
|
;
|
|
|
|
value entry_list el k =
|
|
Vbox [: `HVbox [: :]; list entry el k :]
|
|
;
|
|
|
|
value extend_body (globals, e) k =
|
|
let s = entry_list e k in
|
|
match globals with
|
|
[ [] -> s
|
|
| sl ->
|
|
HVbox
|
|
[: `HVbox [: :];
|
|
`HOVbox
|
|
[: `S LR "GLOBAL"; `S RO ":";
|
|
list (fun e k -> HVbox [: `expr e "" k :]) sl
|
|
[: `S RO ";" :] :];
|
|
`s :] ]
|
|
;
|
|
|
|
value extend e _ k =
|
|
match e with
|
|
[ <:expr< Grammar.extend $e$ >> ->
|
|
try
|
|
let ex = unextend_body e in
|
|
BEbox
|
|
[: `S LR "EXTEND"; `extend_body ex [: :];
|
|
`HVbox [: `S LR "END"; k :] :]
|
|
with
|
|
[ Not_found ->
|
|
HVbox
|
|
[: `S LR "Grammar.extend";
|
|
`HOVbox
|
|
[: `S LO "(";
|
|
`expr e "" [: `HVbox [: `S RO ")"; k :] :] :] :] ]
|
|
| _ -> expr e "" k ]
|
|
;
|
|
|
|
value get_gextend =
|
|
fun
|
|
[ <:expr< let $list:gl$ in $e$ >> ->
|
|
try
|
|
let (gmod, gl) = get_globals gl in
|
|
let el = ungextend_body e in
|
|
Some (gmod, gl, el)
|
|
with
|
|
[ Not_found -> None ]
|
|
| _ -> None ]
|
|
;
|
|
|
|
value gextend e _ k =
|
|
match get_gextend e with
|
|
[ Some (gmod, gl, el) ->
|
|
BEbox
|
|
[: `HVbox [: `S LR "GEXTEND"; `S LR gmod :];
|
|
`extend_body (gl, el) [: :];
|
|
`HVbox [: `S LR "END"; k :] :]
|
|
| None -> expr e "" k ]
|
|
;
|
|
|
|
value is_gextend e = get_gextend e <> None;
|
|
|
|
(* Printer extensions *)
|
|
|
|
let lev =
|
|
try find_pr_level "expr1" pr_expr.pr_levels with
|
|
[ Failure _ -> find_pr_level "top" pr_expr.pr_levels ]
|
|
in
|
|
lev.pr_rules :=
|
|
extfun lev.pr_rules with
|
|
[ <:expr< let $list:_$ in $_$ >> as e when is_gextend e ->
|
|
fun _ next _ k -> [: `next e "" k :] ];
|
|
|
|
let lev = find_pr_level "apply" pr_expr.pr_levels in
|
|
lev.pr_rules :=
|
|
extfun lev.pr_rules with
|
|
[ <:expr< Grammar.extend $_$ >> as e ->
|
|
fun _ next _ k -> [: `next e "" k :] ];
|
|
|
|
let lev = find_pr_level "simple" pr_expr.pr_levels in
|
|
lev.pr_rules :=
|
|
extfun lev.pr_rules with
|
|
[ <:expr< Grammar.extend $_$ >> as e ->
|
|
fun _ _ _ k -> [: `extend e "" k :]
|
|
| <:expr< let $list:_$ in $_$ >> as e when is_gextend e ->
|
|
fun _ _ _ k -> [: `gextend e "" k :] ];
|
|
|
|
Pcaml.add_option "-no_slist" (Arg.Set no_slist)
|
|
"Don't reconstruct SLIST and SOPT";
|