(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the Camlp4 *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Structure : Structure.S) = struct
open Structure;
open Format;
open Sig.Grammar;
value rec flatten_tree =
fun
[ DeadEnd -> []
| LocAct _ _ -> [[]]
| Node {node = n; brother = b; son = s} ->
[ [n :: l] | l <- flatten_tree s ] @ flatten_tree b ];
value rec print_symbol ppf =
fun
[ Smeta n sl _ -> print_meta ppf n sl
| Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s
| Slist0sep s t ->
fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t
| Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s
| Slist1sep s t ->
fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t
| Sopt s -> fprintf ppf "OPT %a" print_symbol1 s
| Stry s -> fprintf ppf "TRY %a" print_symbol1 s
| Snterml e l -> fprintf ppf "%s@ LEVEL@ %S" e.ename l
| Snterm _ | Snext | Sself | Stree _ | Stoken _ | Skeyword _ as s ->
print_symbol1 ppf s ]
and print_meta ppf n sl =
loop 0 sl where rec loop i =
fun
[ [] -> ()
| [s :: sl] ->
let j =
try String.index_from n i ' ' with [ Not_found -> String.length n ]
in
do {
fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s;
if sl = [] then ()
else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl }
} ]
and print_symbol1 ppf =
fun
[ Snterm e -> pp_print_string ppf e.ename
| Sself -> pp_print_string ppf "SELF"
| Snext -> pp_print_string ppf "NEXT"
| Stoken (_, descr) -> pp_print_string ppf descr
| Skeyword s -> fprintf ppf "%S" s
| Stree t -> print_level ppf pp_print_space (flatten_tree t)
| Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ |
Slist1sep _ _ | Sopt _ | Stry _ as s ->
fprintf ppf "(%a)" print_symbol s ]
and print_rule ppf symbols =
do {
fprintf ppf "@[<hov 0>";
let _ =
List.fold_left
(fun sep symbol ->
do {
fprintf ppf "%t%a" sep print_symbol symbol;
fun ppf -> fprintf ppf ";@ "
})
(fun _ -> ()) symbols
in
fprintf ppf "@]"
}
and print_level ppf pp_print_space rules =
do {
fprintf ppf "@[<hov 0>[ ";
let _ =
List.fold_left
(fun sep rule ->
do {
fprintf ppf "%t%a" sep print_rule rule;
fun ppf -> fprintf ppf "%a| " pp_print_space ()
})
(fun _ -> ()) rules
in
fprintf ppf " ]@]"
}
;
value levels ppf elev =
let _ =
List.fold_left
(fun sep lev ->
let rules =
[ [Sself :: t] | t <- flatten_tree lev.lsuffix ] @
flatten_tree lev.lprefix
in
do {
fprintf ppf "%t@[<hov 2>" sep;
match lev.lname with
[ Some n -> fprintf ppf "%S@;<1 2>" n
| None -> () ];
match lev.assoc with
[ LeftA -> fprintf ppf "LEFTA"
| RightA -> fprintf ppf "RIGHTA"
| NonA -> fprintf ppf "NONA" ];
fprintf ppf "@]@;<1 2>";
print_level ppf pp_force_newline rules;
fun ppf -> fprintf ppf "@,| "
})
(fun _ -> ()) elev
in
();
value entry ppf e =
do {
fprintf ppf "@[<v 0>%s: [ " e.ename;
match e.edesc with
[ Dlevels elev -> levels ppf elev
| Dparser _ -> fprintf ppf "<parser>" ];
fprintf ppf " ]@]"
};
end;
module MakeDump (Structure : Structure.S) = struct
open Structure;
open Format;
open Sig.Grammar;
type brothers = [ Bro of symbol and list brothers ];
value rec print_tree ppf tree =
let rec get_brothers acc =
fun
[ DeadEnd -> List.rev acc
| LocAct _ _ -> List.rev acc
| Node {node = n; brother = b; son = s} -> get_brothers [Bro n (get_brothers [] s) :: acc] b ]
and print_brothers ppf brothers =
if brothers = [] then fprintf ppf "@ []"
else
List.iter (fun [ Bro n xs -> do {
fprintf ppf "@ @[<hv2>- %a" print_symbol n;
match xs with
[ [] -> ()
| [_] -> try print_children ppf (get_children [] xs)
with [ Exit -> fprintf ppf ":%a" print_brothers xs ]
| _ -> fprintf ppf ":%a" print_brothers xs ];
fprintf ppf "@]";
}]) brothers
and print_children ppf = List.iter (fprintf ppf ";@ %a" print_symbol)
and get_children acc =
fun
[ [] -> List.rev acc
| [Bro n x] -> get_children [n::acc] x
| _ -> raise Exit ]
in print_brothers ppf (get_brothers [] tree)
and print_symbol ppf =
fun
[ Smeta n sl _ -> print_meta ppf n sl
| Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s
| Slist0sep s t ->
fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t
| Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s
| Slist1sep s t ->
fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t
| Sopt s -> fprintf ppf "OPT %a" print_symbol1 s
| Stry s -> fprintf ppf "TRY %a" print_symbol1 s
| Snterml e l -> fprintf ppf "%s@ LEVEL@ %S" e.ename l
| Snterm _ | Snext | Sself | Stree _ | Stoken _ | Skeyword _ as s ->
print_symbol1 ppf s ]
and print_meta ppf n sl =
loop 0 sl where rec loop i =
fun
[ [] -> ()
| [s :: sl] ->
let j =
try String.index_from n i ' ' with [ Not_found -> String.length n ]
in
do {
fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s;
if sl = [] then ()
else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl }
} ]
and print_symbol1 ppf =
fun
[ Snterm e -> pp_print_string ppf e.ename
| Sself -> pp_print_string ppf "SELF"
| Snext -> pp_print_string ppf "NEXT"
| Stoken (_, descr) -> pp_print_string ppf descr
| Skeyword s -> fprintf ppf "%S" s
| Stree t -> print_tree ppf t
| Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ |
Slist1sep _ _ | Sopt _ | Stry _ as s ->
fprintf ppf "(%a)" print_symbol s ]
and print_rule ppf symbols =
do {
fprintf ppf "@[<hov 0>";
let _ =
List.fold_left
(fun sep symbol ->
do {
fprintf ppf "%t%a" sep print_symbol symbol;
fun ppf -> fprintf ppf ";@ "
})
(fun _ -> ()) symbols
in
fprintf ppf "@]"
}
and print_level ppf pp_print_space rules =
do {
fprintf ppf "@[<hov 0>[ ";
let _ =
List.fold_left
(fun sep rule ->
do {
fprintf ppf "%t%a" sep print_rule rule;
fun ppf -> fprintf ppf "%a| " pp_print_space ()
})
(fun _ -> ()) rules
in
fprintf ppf " ]@]"
}
;
value levels ppf elev =
let _ =
List.fold_left
(fun sep lev ->
do {
fprintf ppf "%t@[<v2>" sep;
match lev.lname with
[ Some n -> fprintf ppf "%S@;<1 2>" n
| None -> () ];
match lev.assoc with
[ LeftA -> fprintf ppf "LEFTA"
| RightA -> fprintf ppf "RIGHTA"
| NonA -> fprintf ppf "NONA" ];
fprintf ppf "@]@;<1 2>";
fprintf ppf "@[<v2>suffix:@ ";
print_tree ppf lev.lsuffix;
fprintf ppf "@]@ @[<v2>prefix:@ ";
print_tree ppf lev.lprefix;
fprintf ppf "@]";
fun ppf -> fprintf ppf "@,| "
})
(fun _ -> ()) elev
in
();
value entry ppf e =
do {
fprintf ppf "@[<v 0>%s: [ " e.ename;
match e.edesc with
[ Dlevels elev -> levels ppf elev
| Dparser _ -> fprintf ppf "<parser>" ];
fprintf ppf " ]@]"
};
end;