bundles/menhirLib/menhir-20120123/src/unparameterizedPrinter.ml

   1 (**************************************************************************)
   2 (*                                                                        *)
   3 (*  Menhir                                                                *)
   4 (*                                                                        *)
   5 (*  François Pottier, INRIA Rocquencourt                                  *)
   6 (*  Yann Régis-Gianas, PPS, Université Paris Diderot                      *)
   7 (*                                                                        *)
   8 (*  Copyright 2005-2008 Institut National de Recherche en Informatique    *)
   9 (*  et en Automatique. All rights reserved. This file is distributed      *)
  10 (*  under the terms of the Q Public License version 1.0, with the change  *)
  11 (*  described in file LICENSE.                                            *)
  12 (*                                                                        *)
  13 (**************************************************************************)
  14
  15 open Positions
  16 open Misc
  17 open Syntax
  18 open Stretch
  19 open UnparameterizedSyntax
  20 open Settings
  21
  22 let print_preludes f g =
  23   List.iter (fun prelude ->
  24     Printf.fprintf f "%%{%s%%}\n" prelude.stretch_raw_content
  25   ) g.preludes
  26
  27 let print_start_symbols b g =
  28   StringSet.iter (fun symbol ->
  29     Printf.fprintf b "%%start %s\n" (Misc.normalize symbol)
  30   ) g.start_symbols
  31
  32 let rec insert_in_partitions item m = function
  33   | [] ->
  34       [ (m, [ item ]) ]
  35
  36   | (m', items) :: partitions when Mark.same m m' ->
  37       (m', item :: items) :: partitions
  38
  39   | t :: partitions ->
  40       t :: (insert_in_partitions item m partitions)
  41
  42 let insert (undefined, partitions) = function
  43   | (item, UndefinedPrecedence) ->
  44       ((item, 0) :: undefined, partitions)
  45
  46   | (item, PrecedenceLevel (m, v, _, _)) ->
  47       (undefined, insert_in_partitions (item, v) m partitions)
  48
  49 let print_ocamltype ocamltype =
  50   Printf.sprintf " <%s>" (
  51     match ocamltype with
  52     | Declared stretch ->
  53         stretch.stretch_raw_content
  54     | Inferred t ->
  55         t
  56     )
  57
  58 let print_assoc = function
  59   | LeftAssoc ->
  60       Printf.sprintf "%%left"
  61   | RightAssoc ->
  62       Printf.sprintf "%%right"
  63   | NonAssoc ->
  64       Printf.sprintf "%%nonassoc"
  65   | UndefinedAssoc ->
  66       ""
  67
  68 let print_tokens mode b g =
  69   (* Sort tokens wrt precedence. *)
  70   let undefined, partition_tokens =
  71     StringMap.fold (fun token prop acu ->
  72       insert acu (token, prop.tk_priority)
  73     ) g.tokens ([], [])
  74   in
  75   let ordered_tokens =
  76     List.fold_left (fun acu (_, ms) ->
  77       acu @ List.sort (fun (_, v) (_, v') -> compare v v') ms
  78     ) undefined partition_tokens
  79   in
  80   List.iter (fun (token, _) ->
  81     let prop = StringMap.find token g.tokens in
  82     if prop.tk_is_declared then
  83       Printf.fprintf b "%%token%s %s\n"
  84         begin match mode with
  85         | PrintNormal
  86         | PrintUnitActions ->
  87             Misc.o2s prop.tk_ocamltype print_ocamltype
  88         | PrintUnitActionsUnitTokens ->
  89             "" (* omitted ocamltype after %token means <unit> *)
  90         end
  91         token
  92   ) ordered_tokens;
  93
  94   ignore (List.fold_left
  95             (fun last_prop (token, v) ->
  96                let prop = StringMap.find token g.tokens in
  97                  match last_prop with
  98
  99                    | None ->
 100                        if prop.tk_associativity = UndefinedAssoc then
 101                          None
 102                        else (
 103                          Printf.fprintf b "%s %s "
 104                            (print_assoc prop.tk_associativity) token;
 105                          Some v)
 106
 107                    | Some v' when v <> v' ->
 108                        if prop.tk_associativity = UndefinedAssoc then
 109                          None
 110                        else (
 111                          Printf.fprintf b "\n%s %s "
 112                            (print_assoc prop.tk_associativity) token;
 113                          Some v)
 114
 115                    | Some v' ->
 116                        Printf.fprintf b "%s " token;
 117                        last_prop
 118
 119             ) None ordered_tokens);
 120   Printf.fprintf b "\n"
 121
 122 let print_types mode b g =
 123   StringMap.iter (fun symbol ty ->
 124     Printf.fprintf b "%%type%s %s\n"
 125       begin match mode with
 126       | PrintNormal ->
 127           print_ocamltype ty
 128       | PrintUnitActions
 129       | PrintUnitActionsUnitTokens ->
 130           " <unit>"
 131       end
 132       (Misc.normalize symbol)
 133   ) g.types
 134
 135 let binding mode id =
 136   match mode with
 137   | PrintNormal ->
 138       id ^ " = "
 139   | PrintUnitActions
 140   | PrintUnitActionsUnitTokens ->
 141       ""
 142
 143 let string_of_producer mode (symbol, ido) =
 144   Misc.o2s ido (binding mode) ^ (Misc.normalize symbol)
 145
 146 let print_branch mode f branch =
 147   Printf.fprintf f "%s%s\n    {"
 148     (String.concat " " (List.map (string_of_producer mode) branch.producers))
 149     (Misc.o2s branch.branch_shift_precedence (fun x -> " %prec "^x.value));
 150   begin match mode with
 151   | PrintNormal ->
 152       Action.print f branch.action
 153   | PrintUnitActions
 154   | PrintUnitActionsUnitTokens ->
 155       Printf.fprintf f "()"
 156   end;
 157   Printf.fprintf f "}\n"
 158
 159 let print_trailers b g =
 160   List.iter (Printf.fprintf b "%s\n") g.postludes
 161
 162 let branches_order r r' =
 163   let branch_order b b' =
 164     match b.branch_reduce_precedence, b'.branch_reduce_precedence with
 165       | UndefinedPrecedence, _ | _, UndefinedPrecedence ->
 166           0
 167       | PrecedenceLevel (m, l, _, _), PrecedenceLevel (m', l', _, _) ->
 168           if Mark.same m m' then
 169             if l < l' then
 170               -1
 171             else if l > l' then
 172               1
 173             else
 174               0
 175           else 0
 176   in
 177   let rec lexical_order bs bs' =
 178     match bs, bs' with
 179       | [], [] ->
 180           0
 181       | [], _ ->
 182           -1
 183       | _, [] ->
 184           1
 185       | b :: bs, b' :: bs' ->
 186           match branch_order b b' with
 187             | 0 ->
 188                 lexical_order bs bs'
 189             | x ->
 190                 x
 191   in
 192     lexical_order r.branches r'.branches
 193
 194 let print_rules mode b g =
 195   let rules_as_list =
 196     StringMap.fold (fun nt r acu -> (nt, r) :: acu) g.rules []
 197   in
 198   let ordered_rules =
 199     List.sort (fun (nt, r) (nt', r') -> branches_order r r') rules_as_list
 200   in
 201   List.iter (fun (nt, r) ->
 202     Printf.fprintf b "\n%s:\n" (Misc.normalize nt);
 203     List.iter (fun br ->
 204       Printf.fprintf b "| ";
 205       print_branch mode b br
 206     ) r.branches
 207   ) ordered_rules
 208
 209 let print mode f g =
 210   begin match mode with
 211   | PrintNormal ->
 212       print_preludes f g
 213   | PrintUnitActions
 214   | PrintUnitActionsUnitTokens ->
 215       ()
 216   end;
 217   print_start_symbols f g;
 218   print_tokens mode f g;
 219   print_types mode f g;
 220   Printf.fprintf f "%%%%\n";
 221   print_rules mode f g;
 222   Printf.fprintf f "\n%%%%\n";
 223   begin match mode with
 224   | PrintNormal ->
 225       print_trailers f g
 226   | PrintUnitActions
 227   | PrintUnitActionsUnitTokens ->
 228       ()
 229   end
 230