unparameterizedPrinter.ml 5.17 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99
open Positions
open Syntax
open Stretch
open UnparameterizedSyntax
open Settings

let print_preludes f g =
  List.iter (fun prelude ->
    Printf.fprintf f "%%{%s%%}\n" prelude.stretch_raw_content
  ) g.preludes

let print_start_symbols b g = 
  StringSet.iter (fun symbol ->
    Printf.fprintf b "%%start %s\n" (Misc.normalize symbol)
  ) g.start_symbols
    
let rec insert_in_partitions item m = function
  | [] -> 
      [ (m, [ item ]) ]
	
  | (m', items) :: partitions when Mark.same m m' -> 
      (m', item :: items) :: partitions
	
  | t :: partitions ->
      t :: (insert_in_partitions item m partitions)
     
let insert (undefined, partitions) = function
  | (item, UndefinedPrecedence) ->
      ((item, 0) :: undefined, partitions)
	
  | (item, PrecedenceLevel (m, v, _, _)) ->
      (undefined, insert_in_partitions (item, v) m partitions)

let print_ocamltype ocamltype =
  Printf.sprintf " <%s>" (
    match ocamltype with
    | Declared stretch ->
	stretch.stretch_raw_content
    | Inferred t ->
	t
    )

let print_assoc = function
  | LeftAssoc ->
      Printf.sprintf "%%left"
  | RightAssoc ->
      Printf.sprintf "%%right"
  | NonAssoc ->
      Printf.sprintf "%%nonassoc"
  | UndefinedAssoc ->
      ""

let print_tokens mode b g = 
  (* Sort tokens wrt precedence. *)
  let undefined, partition_tokens = 
    StringMap.fold (fun token prop acu ->
      insert acu (token, prop.tk_priority)
    ) g.tokens ([], [])
  in
  let ordered_tokens =
    List.fold_left (fun acu (_, ms) -> 
      acu @ List.sort (fun (_, v) (_, v') -> compare v v') ms
    ) undefined partition_tokens
  in
  List.iter (fun (token, _) ->
    let prop = StringMap.find token g.tokens in
    if prop.tk_is_declared then
      Printf.fprintf b "%%token%s %s\n"
	begin match mode with
	| PrintNormal
	| PrintUnitActions ->
	    Misc.o2s prop.tk_ocamltype print_ocamltype
	| PrintUnitActionsUnitTokens ->
	    "" (* omitted ocamltype after %token means <unit> *)
	end
	token
  ) ordered_tokens;

  ignore (List.fold_left 
	    (fun last_prop (token, v) -> 
	       let prop = StringMap.find token g.tokens in 
		 match last_prop with

		   | None ->
		       if prop.tk_associativity = UndefinedAssoc then
			 None
		       else (
			 Printf.fprintf b "%s %s "
			   (print_assoc prop.tk_associativity) token;
			 Some v)
			 
		   | Some v' when v <> v' -> 
		       if prop.tk_associativity = UndefinedAssoc then
			 None
		       else (
			 Printf.fprintf b "\n%s %s "
			   (print_assoc prop.tk_associativity) token;
			 Some v)
			 
100
		   | Some _ -> 
101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128
		       Printf.fprintf b "%s " token;
		       last_prop
			 
	    ) None ordered_tokens);
  Printf.fprintf b "\n"

let print_types mode b g = 
  StringMap.iter (fun symbol ty ->
    Printf.fprintf b "%%type%s %s\n" 
      begin match mode with
      | PrintNormal ->
	  print_ocamltype ty
      | PrintUnitActions
      | PrintUnitActionsUnitTokens ->
	  " <unit>"
      end
      (Misc.normalize symbol)
  ) g.types

let binding mode id =
  match mode with
  | PrintNormal ->
      id ^ " = "
  | PrintUnitActions
  | PrintUnitActionsUnitTokens ->
      ""

let string_of_producer mode (symbol, ido) =
129
  binding mode ido ^ (Misc.normalize symbol)
130 131 132 133 134 135 136 137 138 139 140 141 142 143 144

let print_branch mode f branch = 
  Printf.fprintf f "%s%s\n    {"
    (String.concat " " (List.map (string_of_producer mode) branch.producers))
    (Misc.o2s branch.branch_shift_precedence (fun x -> " %prec "^x.value));
  begin match mode with
  | PrintNormal ->
      Action.print f branch.action  
  | PrintUnitActions
  | PrintUnitActionsUnitTokens ->
      Printf.fprintf f "()"
  end;
  Printf.fprintf f "}\n"

let print_trailers b g =
145
  List.iter (fun stretch -> Printf.fprintf b "%s\n" stretch.stretch_raw_content) g.postludes
146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183

let branches_order r r' = 
  let branch_order b b' = 
    match b.branch_reduce_precedence, b'.branch_reduce_precedence with
      | UndefinedPrecedence, _ | _, UndefinedPrecedence ->
	  0
      | PrecedenceLevel (m, l, _, _), PrecedenceLevel (m', l', _, _) ->
	  if Mark.same m m' then
	    if l < l' then
	      -1
	    else if l > l' then
	      1
	    else 
	      0
	  else 0
  in
  let rec lexical_order bs bs' = 
    match bs, bs' with
      | [], [] ->
	  0
      | [], _ ->
	  -1
      | _, [] ->
	  1
      | b :: bs, b' :: bs' ->
	  match branch_order b b' with
	    | 0 -> 
		lexical_order bs bs'
	    | x -> 
		x
  in
    lexical_order r.branches r'.branches

let print_rules mode b g = 
  let rules_as_list =
    StringMap.fold (fun nt r acu -> (nt, r) :: acu) g.rules []
  in
  let ordered_rules =
184
    List.sort (fun (_nt, r) (_nt', r') -> branches_order r r') rules_as_list
185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215
  in
  List.iter (fun (nt, r) ->
    Printf.fprintf b "\n%s:\n" (Misc.normalize nt);
    List.iter (fun br -> 
      Printf.fprintf b "| ";
      print_branch mode b br
    ) r.branches
  ) ordered_rules

let print mode f g =
  begin match mode with
  | PrintNormal ->
      print_preludes f g
  | PrintUnitActions
  | PrintUnitActionsUnitTokens ->
      ()
  end;
  print_start_symbols f g;
  print_tokens mode f g;
  print_types mode f g;
  Printf.fprintf f "%%%%\n";
  print_rules mode f g;
  Printf.fprintf f "\n%%%%\n";
  begin match mode with
  | PrintNormal ->
      print_trailers f g
  | PrintUnitActions
  | PrintUnitActionsUnitTokens ->
      ()
  end