l4/pkg/ocaml/ocaml/contrib/camlp4/Camlp4/Struct/Grammar/Print.ml

   1 (****************************************************************************)
   2 (*                                                                          *)
   3 (*                              Objective Caml                              *)
   4 (*                                                                          *)
   5 (*                            INRIA Rocquencourt                            *)
   6 (*                                                                          *)
   7 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
   9 (*  the terms of the GNU Library General Public License, with the special   *)
  10 (*  exception on linking described in LICENSE at the top of the Objective   *)
  11 (*  Caml source tree.                                                       *)
  12 (*                                                                          *)
  13 (****************************************************************************)
  14
  15 (* Authors:
  16  * - Daniel de Rauglaudre: initial version
  17  * - Nicolas Pouillard: refactoring
  18  *)
  19
  20 module Make (Structure : Structure.S) = struct
  21   open Structure;
  22   open Format;
  23   open Sig.Grammar;
  24
  25   value rec flatten_tree =
  26     fun
  27     [ DeadEnd -> []
  28     | LocAct _ _ -> [[]]
  29     | Node {node = n; brother = b; son = s} ->
  30         [ [n :: l] | l <- flatten_tree s ] @ flatten_tree b ];
  31
  32   value rec print_symbol ppf =
  33     fun
  34     [ Smeta n sl _ -> print_meta ppf n sl
  35     | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s
  36     | Slist0sep s t ->
  37         fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t
  38     | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s
  39     | Slist1sep s t ->
  40         fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t
  41     | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s
  42     | Snterml e l -> fprintf ppf "%s@ LEVEL@ %S" e.ename l
  43     | Snterm _ | Snext | Sself | Stree _ | Stoken _ | Skeyword _ as s ->
  44         print_symbol1 ppf s ]
  45   and print_meta ppf n sl =
  46     loop 0 sl where rec loop i =
  47       fun
  48       [ [] -> ()
  49       | [s :: sl] ->
  50           let j =
  51             try String.index_from n i ' ' with [ Not_found -> String.length n ]
  52           in
  53           do {
  54             fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s;
  55             if sl = [] then ()
  56             else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl }
  57           } ]
  58   and print_symbol1 ppf =
  59     fun
  60     [ Snterm e -> pp_print_string ppf e.ename
  61     | Sself -> pp_print_string ppf "SELF"
  62     | Snext -> pp_print_string ppf "NEXT"
  63     | Stoken (_, descr) -> pp_print_string ppf descr
  64     | Skeyword s -> fprintf ppf "%S" s
  65     | Stree t -> print_level ppf pp_print_space (flatten_tree t)
  66     | Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ |
  67       Slist1sep _ _ | Sopt _ as s ->
  68         fprintf ppf "(%a)" print_symbol s ]
  69   and print_rule ppf symbols =
  70     do {
  71       fprintf ppf "@[<hov 0>";
  72       let _ =
  73         List.fold_left
  74           (fun sep symbol ->
  75             do {
  76               fprintf ppf "%t%a" sep print_symbol symbol;
  77               fun ppf -> fprintf ppf ";@ "
  78             })
  79           (fun _ -> ()) symbols
  80       in
  81       fprintf ppf "@]"
  82     }
  83   and print_level ppf pp_print_space rules =
  84     do {
  85       fprintf ppf "@[<hov 0>[ ";
  86       let _ =
  87         List.fold_left
  88           (fun sep rule ->
  89             do {
  90               fprintf ppf "%t%a" sep print_rule rule;
  91               fun ppf -> fprintf ppf "%a| " pp_print_space ()
  92             })
  93           (fun _ -> ()) rules
  94       in
  95       fprintf ppf " ]@]"
  96     }
  97   ;
  98
  99   value levels ppf elev =
 100     let _ =
 101       List.fold_left
 102         (fun sep lev ->
 103           let rules =
 104             [ [Sself :: t] | t <- flatten_tree lev.lsuffix ] @
 105               flatten_tree lev.lprefix
 106           in
 107           do {
 108             fprintf ppf "%t@[<hov 2>" sep;
 109             match lev.lname with
 110             [ Some n -> fprintf ppf "%S@;<1 2>" n
 111             | None -> () ];
 112             match lev.assoc with
 113             [ LeftA -> fprintf ppf "LEFTA"
 114             | RightA -> fprintf ppf "RIGHTA"
 115             | NonA -> fprintf ppf "NONA" ];
 116             fprintf ppf "@]@;<1 2>";
 117             print_level ppf pp_force_newline rules;
 118             fun ppf -> fprintf ppf "@,| "
 119           })
 120         (fun _ -> ()) elev
 121     in
 122     ();
 123
 124   value entry ppf e =
 125     do {
 126       fprintf ppf "@[<v 0>%s: [ " e.ename;
 127       match e.edesc with
 128       [ Dlevels elev -> levels ppf elev
 129       | Dparser _ -> fprintf ppf "<parser>" ];
 130       fprintf ppf " ]@]"
 131     };
 132
 133 end;
 134
 135 module MakeDump (Structure : Structure.S) = struct
 136   open Structure;
 137   open Format;
 138   open Sig.Grammar;
 139
 140   type brothers = [ Bro of symbol and list brothers ];
 141
 142   value rec print_tree ppf tree =
 143     let rec get_brothers acc =
 144       fun
 145       [ DeadEnd -> List.rev acc
 146       | LocAct _ _ -> List.rev acc
 147       | Node {node = n; brother = b; son = s} -> get_brothers [Bro n (get_brothers [] s) :: acc] b ]
 148     and print_brothers ppf brothers =
 149       if brothers = [] then fprintf ppf "@ []"
 150       else
 151         List.iter (fun [ Bro n xs -> do {
 152           fprintf ppf "@ @[<hv2>- %a" print_symbol n;
 153           match xs with
 154           [ [] -> ()
 155           | [_] -> try print_children ppf (get_children [] xs)
 156                    with [ Exit -> fprintf ppf ":%a" print_brothers xs ]
 157           | _ -> fprintf ppf ":%a" print_brothers xs ];
 158           fprintf ppf "@]";
 159         }]) brothers
 160     and print_children ppf = List.iter (fprintf ppf ";@ %a" print_symbol)
 161     and get_children acc =
 162       fun
 163       [ [] -> List.rev acc
 164       | [Bro n x] -> get_children [n::acc] x
 165       | _ -> raise Exit ]
 166     in print_brothers ppf (get_brothers [] tree)
 167   and print_symbol ppf =
 168     fun
 169     [ Smeta n sl _ -> print_meta ppf n sl
 170     | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s
 171     | Slist0sep s t ->
 172         fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t
 173     | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s
 174     | Slist1sep s t ->
 175         fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t
 176     | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s
 177     | Snterml e l -> fprintf ppf "%s@ LEVEL@ %S" e.ename l
 178     | Snterm _ | Snext | Sself | Stree _ | Stoken _ | Skeyword _ as s ->
 179         print_symbol1 ppf s ]
 180   and print_meta ppf n sl =
 181     loop 0 sl where rec loop i =
 182       fun
 183       [ [] -> ()
 184       | [s :: sl] ->
 185           let j =
 186             try String.index_from n i ' ' with [ Not_found -> String.length n ]
 187           in
 188           do {
 189             fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s;
 190             if sl = [] then ()
 191             else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl }
 192           } ]
 193   and print_symbol1 ppf =
 194     fun
 195     [ Snterm e -> pp_print_string ppf e.ename
 196     | Sself -> pp_print_string ppf "SELF"
 197     | Snext -> pp_print_string ppf "NEXT"
 198     | Stoken (_, descr) -> pp_print_string ppf descr
 199     | Skeyword s -> fprintf ppf "%S" s
 200     | Stree t -> print_tree ppf t
 201     | Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ |
 202       Slist1sep _ _ | Sopt _ as s ->
 203         fprintf ppf "(%a)" print_symbol s ]
 204   and print_rule ppf symbols =
 205     do {
 206       fprintf ppf "@[<hov 0>";
 207       let _ =
 208         List.fold_left
 209           (fun sep symbol ->
 210             do {
 211               fprintf ppf "%t%a" sep print_symbol symbol;
 212               fun ppf -> fprintf ppf ";@ "
 213             })
 214           (fun _ -> ()) symbols
 215       in
 216       fprintf ppf "@]"
 217     }
 218   and print_level ppf pp_print_space rules =
 219     do {
 220       fprintf ppf "@[<hov 0>[ ";
 221       let _ =
 222         List.fold_left
 223           (fun sep rule ->
 224             do {
 225               fprintf ppf "%t%a" sep print_rule rule;
 226               fun ppf -> fprintf ppf "%a| " pp_print_space ()
 227             })
 228           (fun _ -> ()) rules
 229       in
 230       fprintf ppf " ]@]"
 231     }
 232   ;
 233
 234   value levels ppf elev =
 235     let _ =
 236       List.fold_left
 237         (fun sep lev ->
 238           do {
 239             fprintf ppf "%t@[<v2>" sep;
 240             match lev.lname with
 241             [ Some n -> fprintf ppf "%S@;<1 2>" n
 242             | None -> () ];
 243             match lev.assoc with
 244             [ LeftA -> fprintf ppf "LEFTA"
 245             | RightA -> fprintf ppf "RIGHTA"
 246             | NonA -> fprintf ppf "NONA" ];
 247             fprintf ppf "@]@;<1 2>";
 248             fprintf ppf "@[<v2>suffix:@ ";
 249             print_tree ppf lev.lsuffix;
 250             fprintf ppf "@]@ @[<v2>prefix:@ ";
 251             print_tree ppf lev.lprefix;
 252             fprintf ppf "@]";
 253             fun ppf -> fprintf ppf "@,| "
 254           })
 255         (fun _ -> ()) elev
 256     in
 257     ();
 258
 259   value entry ppf e =
 260     do {
 261       fprintf ppf "@[<v 0>%s: [ " e.ename;
 262       match e.edesc with
 263       [ Dlevels elev -> levels ppf elev
 264       | Dparser _ -> fprintf ppf "<parser>" ];
 265       fprintf ppf " ]@]"
 266     };
 267
 268 end;