(* 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. *)
(* *)
(***********************************************************************)
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";