hphp/hack/src/h2tp/unparser/unparser.ml

   1 (**
   2  * Copyright (c) 2015, Facebook, Inc.
   3  * All rights reserved.
   4  *
   5  * This source code is licensed under the BSD-style license found in the
   6  * LICENSE file in the "hack" directory of this source tree. An additional grant
   7  * of patent rights can be found in the PATENTS file in the same directory.
   8  *
   9  *)
  10
  11 (* generated by ocamltarzan *)
  12
  13 module R = Str
  14 open Ast
  15 open Unparsed
  16 open Utils
  17 open Common_exns
  18
  19
  20 (*
  21   =============================================================================
  22   Unparsing is fairly complicated, especially with a language like php which has
  23   many nuances. Instead of implementing the entire unparser at one go, I prefer to
  24   implement it piecemeal as I come across constructs I care about for task at hand.
  25
  26   At the same time I do not want to depend on wildcards to identify what's not been
  27   unparsed and I want the error message when I cannot unparse something to be clear.
  28
  29   To that extend I'm using ocamltarzan to generate the scaffold for the unparser,
  30   it recursively unparses each element of every construct, but also raises TODO
  31   by default until the particular construct is implemented.
  32
  33   Here are some helper functions for the same.
  34   =================================================================================
  35 *)
  36 (*
  37 These are todo constructs for which we will choose not to fail but to
  38     instead return the default which is known to be incorrect or incomplete
  39 *)
  40 let ok_todos = set_of_list [
  41   "mode";
  42 ]
  43
  44 (*
  45   The first argument is the error message to raise and the second argument is
  46   the autogenerated code that is not useful. The reason we retain the autogenerated
  47   code is to not have to regenerate it later, and at the same time to not have it
  48   return unused warnings.
  49 *)
  50 let u_todo msg pregen_fn =
  51   if SSet.mem msg ok_todos
  52   then pregen_fn ()
  53   else raise(Todo ("unsupported construct in Unparser:  " ^ msg))
  54
  55 (*
  56   This is a more nuanced variation of u_todo. It accepts a list of
  57   (cond, msg, pregen_fn), in each case, if the condition is true, we call
  58   u_todo with the msg and pregen_fn, but when its false we fall through.
  59   This makes it easier to implement just parts of the unparser for complex constructs
  60   (like class definitions)
  61 *)
  62 let u_todo_conds todos else_fn =
  63   match (List.find ~f:(fun (cond, _, _) -> cond) todos) with
  64     | Some (_, msg, fn) -> u_todo msg fn
  65     | None -> else_fn ()
  66
  67 (*
  68   env is something that is used while unparsing so that we can handle special issues
  69   where the code that is unparsed depends implicitly on the structure of some
  70   condition of the ancestors in the AST rather than just the current node.
  71
  72   Examples are modes and namespaces. Currently I've introduced mode as an example.
  73 *)
  74 type unparse_env = {
  75   mutable mode: FileInfo.mode
  76 }
  77
  78 (*
  79   functions and methods have a lot in common, but their own peculiarities also.
  80   This captures all the common stuff to prevent having to repeat it while
  81   unparsing.
  82 *)
  83 type fun_common = {
  84   fc_tparams         : tparam list;
  85   fc_ret             : hint option;
  86   fc_ret_by_ref          : bool;
  87   fc_name            : id;
  88   fc_params          : fun_param list;
  89   fc_body            : block;
  90   fc_user_attributes : user_attribute list;
  91   fc_fun_kind        : fun_kind;
  92 }
  93
  94 (* for expressions that contain sub-expressions, this identifies
  95   if the sub-expression needs to be parenthesised when it is inside another expression
  96 *)
  97 type shouldParens = YES | NO | TODO of string
  98
  99 let is_associative = function
 100   | Plus | Star | AMpamp | BArbar | Dot
 101   | Amp | Bar | Xor -> true
 102   | Minus | Slash | Lt | Lte | Gt | Gte | Starstar
 103   | Eqeq | EQeqeq | Diff | Diff2 | Ltlt
 104   | Gtgt | Percent | Eq _ -> false
 105
 106 module Unparse = struct
 107 (*
 108   unparsers for simple and predefined types.
 109 *)
 110 let u_of_list_spc u_of_elem elems =
 111   List.map ~f:u_of_elem elems |>
 112   fun x -> StrWords x
 113
 114 let u_of_list_comma u_of_elem elems =
 115   List.map ~f:u_of_elem elems |>
 116   fun x -> StrCommaList x
 117
 118 let u_of_list_parens_comma u_of_elem elems =
 119   List.map ~f:u_of_elem elems |>
 120   fun x -> StrParens (StrCommaList x)
 121
 122 let u_of_list_braces_spc u_of_elem elems =
 123   List.map ~f:u_of_elem elems |>
 124   fun x -> StrBraces (StrWords x)
 125
 126 let u_of_bool b = Str (if b then "true" else "false")
 127
 128 let u_of_float f = Str (string_of_float f)
 129
 130 let u_of_option f = function
 131   | Some x -> f x
 132   | None -> StrEmpty
 133
 134 let u_of_string str = Str str
 135
 136 (*
 137   unparser for the AST. Autogenerated with ocamltarzan
 138 *)
 139
 140 let dummy_unparse_fn = fun () -> StrEmpty
 141
 142 let u_file_type =
 143   function
 144   | FileInfo.PhpFile -> Str "<?php"
 145   | FileInfo.HhFile -> Str "<?hh"
 146
 147 let u_pos_t _ = StrEmpty
 148
 149 let u_id (_pos, s) =
 150   Str s
 151
 152 let u_pstring (_pos, s) =
 153   Str s
 154
 155 let u_var_name (_pos, s) =
 156   Str ("$" ^ s)
 157
 158 let u_of_smap _ _ = u_todo "smap"  (fun () -> StrEmpty)
 159
 160 let is_empty_ns ns =
 161   (* FIXME: Don't use the default popt *)
 162   if (ns = Namespace_env.empty ParserOptions.default) then true else false
 163
 164 let rec u_program v = u_of_list_spc u_def v
 165   and u_in_mode _ f = u_todo "mode" f
 166   and u_def =
 167     function
 168     | Fun fun_ -> u_fun_ fun_
 169     | Class v2 -> u_class_ v2
 170     | Stmt stmt -> u_stmt stmt
 171     | Typedef v2 ->
 172         u_todo "Typedef"
 173           (fun () ->
 174              let v1 = Str "Typedef" and v2 = u_typedef v2 in StrWords [ v1; v2 ])
 175     | Constant v2 -> u_gconst v2
 176     | Namespace (id, program) ->
 177         let strProgram = u_program program
 178         in StrWords [Str "namespace"; u_id id; StrBraces strProgram]
 179     | NamespaceUse uses ->
 180         let u_use (kind, (p1, ns), (p2, name)) =
 181           let ns_end = List.last_exn (R.split (R.regexp "\\\\") ns) in
 182           let qualifier = if ns_end <> name
 183                           then [Str "as"; u_id (p2, name)]
 184                           else [] in
 185           let id_and_qualifier = u_id (p1, ns) :: qualifier in
 186           let kind_id_and_qualifier = match kind with
 187             | NSClass -> id_and_qualifier
 188             | NSFun -> Str "function" :: id_and_qualifier
 189             | NSConst -> Str "const" :: id_and_qualifier in
 190           StrStatement (Str "use" :: kind_id_and_qualifier) in
 191         u_of_list_spc u_use uses
 192   and
 193     u_typedef {
 194                 t_id = (pos, _) as v_t_id;
 195                 t_tparams = v_t_tparams;
 196                 t_constraint = v_t_constraint;
 197                 t_kind = v_t_kind;
 198                 t_user_attributes = v_t_user_attributes;
 199                 t_namespace = v_t_namespace;
 200                 t_mode = v_t_mode
 201               } =
 202     invariant (is_empty_ns v_t_namespace)
 203       (pos, "Namespaces are expected to not be elaborated");
 204     u_todo "typedef"
 205       (fun () ->
 206         u_in_mode v_t_mode (fun () ->
 207           u_todo_conds [
 208             (v_t_user_attributes <> [], "t_user_attributes",
 209               (fun () -> u_of_smap u_user_attribute v_t_user_attributes)) ;
 210           ] (fun () ->
 211             let v_t_id = u_id v_t_id in
 212             let v_t_tparams = u_of_list_spc u_tparam v_t_tparams in
 213             let v_t_constraint = u_tconstraint v_t_constraint in
 214             let v_t_kind = u_typedef_kind v_t_kind in
 215               StrWords [v_t_id; v_t_tparams; v_t_constraint; v_t_kind])))
 216   and
 217     u_gconst {
 218                cst_mode = v_cst_mode;
 219                cst_kind = v_cst_kind;
 220                cst_name = (pos, _) as v_cst_name;
 221                cst_type = v_cst_type;
 222                cst_value = v_cst_value;
 223                cst_namespace = v_cst_namespace
 224              } =
 225     u_in_mode v_cst_mode (fun () ->
 226       invariant (is_empty_ns v_cst_namespace)
 227         (pos, "Namespaces are expected to not be elaborated");
 228       let v_cst_value = u_expr v_cst_value in
 229       match v_cst_kind with
 230       | Cst_const ->
 231           let v_cst_name = u_id v_cst_name in
 232           let v_cst_type = u_of_option u_hint v_cst_type in
 233           StrStatement [
 234             Str "const";
 235             v_cst_type;
 236             v_cst_name;
 237             Str "=";
 238             v_cst_value
 239           ]
 240       | Cst_define ->
 241           invariant (v_cst_type = None) (pos, "Constants using the define " ^
 242             "syntax cannot use type hints");
 243           StrStatement [
 244             Str "define";
 245             StrParens (StrCommaList [
 246               u_expr_ (String v_cst_name);
 247               v_cst_value;
 248             ])
 249           ])
 250   and u_variance =
 251     function
 252     | Covariant -> u_todo "Covariant" (fun () -> StrEmpty )
 253     | Contravariant -> u_todo "Contravariant" (fun () -> StrEmpty )
 254     | Invariant -> u_todo "Invariant" (fun () -> StrEmpty )
 255   and u_constraint_kind =
 256     function
 257     | Constraint_as -> u_todo "as" (fun () -> StrEmpty)
 258     | Constraint_eq -> u_todo "=" (fun () -> StrEmpty)
 259     | Constraint_super -> u_todo "super" (fun () -> StrEmpty)
 260   and u_tparam (v2, v3, v4) =
 261     u_todo "tparam"
 262       (fun () ->
 263          let v1 = Str "tparam"
 264          and v2 = u_variance v2
 265          and v3 = u_id v3
 266          and v4 = u_of_list_spc (fun (ck, h) ->
 267            StrWords [u_constraint_kind ck; u_hint h]) v4
 268          in StrWords [ v1; v2; v3; v4 ])
 269   and u_tconstraint v = u_of_option u_hint v
 270   and u_typedef_kind =
 271     function
 272     | Alias v2 ->
 273         u_todo "Alias"
 274           (fun () ->
 275              let v1 = Str "Alias" and v2 = u_hint v2 in StrWords [ v1; v2 ])
 276     | NewType v2 ->
 277         u_todo "NewType"
 278           (fun () ->
 279              let v1 = Str "NewType" and v2 = u_hint v2 in StrWords [ v1; v2 ])
 280   and
 281     u_class_ {
 282                c_mode = v_c_mode;
 283                c_user_attributes = v_c_user_attributes;
 284                c_final = v_c_final;
 285                c_kind = v_c_kind;
 286                c_is_xhp = v_c_is_xhp;
 287                c_name = (pos, _) as v_c_name;
 288                c_tparams = v_c_tparams;
 289                c_extends = v_c_extends;
 290                c_implements = v_c_implements;
 291                c_body = v_c_body;
 292                c_namespace = v_c_namespace;
 293                c_enum = v_c_enum;
 294                c_span = _;
 295              } =
 296       u_in_mode v_c_mode (fun () ->
 297           invariant (List.length v_c_extends <= 1 || v_c_kind = Cinterface)
 298             (pos, "Multiple inheritance is not supported.");
 299           invariant (is_empty_ns v_c_namespace)
 300             (pos, "Namespaces are expected to not be elaborated");
 301         u_todo_conds [
 302           (v_c_is_xhp, "c_is_xhp", (fun () -> u_of_bool v_c_is_xhp)) ;
 303           (not (List.is_empty v_c_tparams), "c_tparams", (fun () -> u_of_list_spc u_tparam v_c_tparams)) ;
 304           (v_c_user_attributes <> [], "c_user_attributes",
 305             (fun () -> u_of_smap u_user_attribute v_c_user_attributes)) ;
 306           (Option.is_some v_c_enum, "c_enum", (fun () -> u_of_option u_enum_ v_c_enum))
 307         ] (fun () ->
 308           let u_elt = u_class_elt v_c_kind in
 309           let str_c_final = if v_c_final then Str "final" else StrEmpty in
 310           let str_c_kind = u_class_kind v_c_kind in
 311           let str_c_name = u_id v_c_name in
 312           let str_c_body = u_of_list_braces_spc u_elt v_c_body in
 313           let str_c_extends = u_extends v_c_extends in
 314           let str_c_implements = u_implements v_c_implements in
 315             StrWords [
 316               str_c_final;
 317               str_c_kind;
 318               str_c_name;
 319               str_c_extends;
 320               str_c_implements;
 321               str_c_body;
 322             ]))
 323   and u_extends = function
 324     | [] -> StrBlank
 325     | hints -> StrWords [Str "extends"; u_of_list_comma u_hint hints]
 326   and u_implements = function
 327   | [] -> StrEmpty
 328   | implements -> StrWords [Str "implements"; u_of_list_comma u_hint implements]
 329   and u_enum_ { e_base = v_e_base; e_constraint = v_e_constraint } =
 330     u_todo "enum_"
 331       (fun () ->
 332          let v_e_base = u_hint v_e_base in
 333          let v_e_constraint = u_of_option u_hint v_e_constraint
 334          in StrWords [ v_e_base; v_e_constraint ])
 335   and u_user_attribute v = u_of_list_spc u_expr v
 336   and u_class_kind =
 337     function
 338     | Cabstract -> StrWords [Str "abstract"; Str "class"]
 339     | Cnormal -> Str "class"
 340     | Cinterface -> Str "interface"
 341     | Ctrait -> Str "trait"
 342     | Cenum -> u_todo "Cenum" (fun () -> StrEmpty)
 343   and u_trait_req_kind =
 344     function
 345     | MustExtend -> Str "extends"
 346     | MustImplement -> Str "implements"
 347   and u_class_elt kind =
 348     function
 349     | Const (hOption, decls) ->
 350       let hOptionStr = u_of_option u_hint hOption
 351       and declsStr = u_of_list_comma (fun (id, expr) ->
 352         StrWords [ u_id id; Str "="; u_expr expr]) decls
 353       in StrStatement [ Str "const" ; hOptionStr; declsStr ]
 354     | AbsConst (hOption, name) ->
 355       let hOptionStr = u_of_option u_hint hOption
 356       and nameStr = u_id name
 357       in StrStatement [ Str "abstract const" ; hOptionStr; nameStr ]
 358     | Attributes v2 ->
 359         u_todo "Attributes"
 360           (fun () ->
 361              let v1 = Str "Attributes"
 362              and v2 = u_of_list_spc u_class_attr v2
 363              in StrWords [ v1; v2 ])
 364     | ClassUse hint ->
 365         StrStatement [Str "use"; u_hint hint]
 366     | XhpAttrUse hint ->
 367         StrStatement [Str "attribute"; u_hint hint]
 368     | ClassTraitRequire (trait_req_kind, hint) ->
 369         StrStatement [
 370           Str "require";
 371           u_trait_req_kind trait_req_kind;
 372           u_hint hint;
 373         ]
 374     | ClassVars (kinds, hintOption, classVars) ->
 375         let kindStr = u_of_list_spc u_kind kinds
 376         and hintStr = u_of_option u_hint hintOption
 377         and varStr = u_of_list_comma u_class_var classVars in
 378         StrStatement [kindStr; hintStr; varStr]
 379     | XhpAttr _ ->
 380         u_todo "XhpAttr" (fun () -> StrEmpty)
 381     | XhpCategory _ ->
 382         u_todo "XhpCategory" (fun () -> StrEmpty)
 383     | Method m -> u_method_ kind m
 384     | TypeConst _ -> u_todo "TypeConst" (fun () -> StrEmpty)
 385
 386   and u_class_attr =
 387     function
 388     | CA_name v2 ->
 389         u_todo "CA_name"
 390           (fun () ->
 391              let v1 = Str "CA_name" and v2 = u_id v2 in StrWords [ v1; v2 ])
 392     | CA_field v2 ->
 393         u_todo "CA_field"
 394           (fun () ->
 395              let v1 = Str "CA_field"
 396              and v2 = u_ca_field v2
 397              in StrWords [ v1; v2 ])
 398   and
 399     u_ca_field {
 400                  ca_type = v_ca_type;
 401                  ca_id = v_ca_id;
 402                  ca_value = v_ca_value;
 403                  ca_required = v_ca_required
 404                } =
 405     u_todo "ca_field"
 406       (fun () ->
 407          let v_ca_type = u_ca_type v_ca_type in
 408          let v_ca_id = u_id v_ca_id in
 409          let v_ca_value = u_of_option u_expr v_ca_value in
 410          let v_ca_required = u_of_bool v_ca_required
 411          in StrWords [ v_ca_type; v_ca_id; v_ca_value; v_ca_required ])
 412   and u_ca_type =
 413     function
 414     | CA_hint v2 ->
 415         u_todo "CA_hint"
 416           (fun () ->
 417              let v1 = Str "CA_hint" and v2 = u_hint v2 in StrWords [ v1; v2 ])
 418     | CA_enum v2 ->
 419         u_todo "CA_enum"
 420           (fun () ->
 421              let v1 = Str "CA_enum"
 422              and v2 = u_of_list_spc u_of_string v2
 423              in StrWords [ v1; v2 ])
 424   and u_kind kind =
 425     let s = match kind with
 426       | Final -> "final"
 427       | Static -> "static"
 428       | Abstract -> "abstract"
 429       | Private -> "private"
 430       | Public -> "public"
 431       | Protected -> "protected" in
 432     Str s
 433   and u_class_var (_, id, exprOpt) =
 434     let exprStr = match exprOpt with
 435       | None -> StrEmpty
 436       | Some expr -> StrWords [Str "=" ; u_expr expr] in
 437     StrWords [u_var_name id; exprStr]
 438   and
 439     u_method_ class_kind {
 440       m_kind;
 441       m_tparams;
 442       m_name;
 443       m_params;
 444       m_constrs = _;
 445       m_body;
 446       m_user_attributes;
 447       m_ret;
 448       m_ret_by_ref;
 449       m_fun_kind;
 450       m_span = _;
 451     } =
 452       let str_m_kind = u_of_list_spc u_kind m_kind
 453       and v_f_common = {
 454         fc_tparams = m_tparams;
 455         fc_ret = m_ret;
 456         fc_ret_by_ref = m_ret_by_ref;
 457         fc_name = m_name;
 458         fc_params = m_params;
 459         fc_body = m_body;
 460         fc_user_attributes = m_user_attributes;
 461         fc_fun_kind = m_fun_kind;
 462       }
 463       and is_abstract = class_kind = Cinterface || List.mem m_kind Abstract in
 464       StrWords [str_m_kind; u_fun_common v_f_common StrEmpty u_id is_abstract]
 465   and
 466     u_fun_param {
 467                   param_hint = v_param_hint;
 468                   param_is_reference = v_param_is_reference;
 469                   param_is_variadic = v_param_is_variadic;
 470                   param_id = v_param_id;
 471                   param_expr = v_param_expr;
 472                   param_modifier = v_param_modifier;
 473                   param_user_attributes = v_param_user_attributes
 474                 } =
 475      u_todo_conds [
 476        (v_param_user_attributes <> [], "param_user_attributes",
 477          fun () -> u_of_smap u_user_attribute v_param_user_attributes);
 478      ] begin fun () ->
 479          let str_param_mod = u_of_option u_kind v_param_modifier
 480          and str_param_hint = u_of_option u_hint v_param_hint
 481          and str_param_id = u_id v_param_id in
 482          let str_param_id = if v_param_is_reference
 483                             then StrList [Str "&"; str_param_id]
 484                             else str_param_id in
 485          let str_param_id =
 486           match (v_param_is_variadic, str_param_id) with
 487           | (true, Str "...") (* hack variadic *) | (false, _) -> str_param_id
 488           | (true, _) -> StrList [Str "..."; str_param_id] in
 489          let str_param_expr = match v_param_expr with
 490          | None -> StrEmpty
 491          | Some e -> StrWords [Str "="; u_expr e] in
 492          StrWords [ str_param_mod; str_param_hint; str_param_id; str_param_expr]
 493       end
 494       (* We have to treat the use clause specially because its in the middle of
 495         a function, but only used by lambdas.
 496       *)
 497   and u_fun_name name_parser id =
 498     match u_id id with
 499       | Str ";anonymous" -> StrEmpty
 500       | _ -> name_parser id
 501   and u_fun_common {
 502     fc_tparams;
 503     fc_ret;
 504     fc_ret_by_ref;
 505     fc_name;
 506     fc_params;
 507     fc_body;
 508     fc_user_attributes;
 509     fc_fun_kind;
 510   } useStr u_of_name abstract =
 511     u_todo_conds [(
 512       fc_user_attributes <> [],
 513       "m_user_attributes",
 514       (fun () -> u_of_smap u_user_attribute fc_user_attributes)
 515     )] begin fun () ->
 516         let str_tparams = match fc_tparams with
 517           | [] -> StrEmpty
 518           | _ -> u_todo "fc_tparams" (fun () -> StrList [Str "<"; u_of_list_comma u_tparam fc_tparams; Str ">"])
 519         and str_params = u_of_list_parens_comma u_fun_param fc_params
 520         and str_body = if abstract then StrSemi else u_block fc_body
 521         and str_ret = match fc_ret with
 522           | None -> StrEmpty
 523           | Some r -> StrWords [Str ":"; u_hint r]
 524         and str_fun_kind = u_fun_kind fc_fun_kind
 525         and str_name = u_fun_name u_of_name fc_name in
 526         let str_name = if fc_ret_by_ref
 527                        then StrList [Str "&"; str_name]
 528                        else str_name in
 529           StrWords [
 530             str_fun_kind;
 531             Str "function";
 532             str_name;
 533             str_tparams;
 534             str_params;
 535             useStr;
 536             str_ret ;
 537             str_body;
 538           ]
 539     end
 540
 541   and u_fun_with_use {
 542     f_mode;
 543     f_tparams;
 544     f_ret;
 545     f_ret_by_ref;
 546     f_name = (pos, _) as f_name;
 547     f_params;
 548     f_body;
 549     f_user_attributes;
 550     f_fun_kind;
 551     f_namespace;
 552     f_span = _;
 553   } useStr =
 554     u_in_mode f_mode begin fun () ->
 555       invariant (is_empty_ns f_namespace)
 556         (pos, "Namespaces are expected to not be elaborated");
 557       u_fun_common {
 558         fc_tparams = f_tparams;
 559         fc_ret = f_ret;
 560         fc_ret_by_ref = f_ret_by_ref;
 561         fc_name = f_name;
 562         fc_params = f_params;
 563         fc_body = f_body;
 564         fc_user_attributes = f_user_attributes;
 565         fc_fun_kind = f_fun_kind;
 566       } useStr (u_id) false
 567     end
 568   and
 569     u_fun_ fun_ = u_fun_with_use fun_ StrEmpty
 570   and u_fun_kind =
 571     function
 572     | FAsync | FAsyncGenerator -> Str "async"
 573     | FSync | FGenerator -> StrEmpty
 574   and u_hint (v2, v3) = StrList [u_pos_t v2; u_hint_ v3]
 575   and u_hint_ =
 576     function
 577     | Hoption hint -> StrList [Str "?"; u_hint hint]
 578     | Hfun ((v2, v3, v4)) ->
 579         u_todo "Hfun"
 580           (fun () ->
 581              let v1 = Str "Hfun"
 582              and v2 = u_of_list_spc u_hint v2
 583              and v3 = u_of_bool v3
 584              and v4 = u_hint v4
 585              in StrWords [ v1; v2; v3; v4 ])
 586     | Htuple v2 ->
 587         u_todo "Htuple"
 588           (fun () ->
 589              let v1 = Str "Htuple"
 590              and v2 = u_of_list_spc u_hint v2
 591              in StrWords [ v1; v2 ])
 592     | Happly (v2, v3) ->
 593         u_todo_conds [
 594           (List.length v3 <> 0, "Happly", (fun () -> u_of_list_spc u_hint v3))
 595         ] (fun () -> u_id v2)
 596     | Hshape v2 ->
 597         u_todo "Hshape"
 598           (fun () ->
 599              let v1 = Str "Hshape"
 600              and v2 = u_of_list_spc u_shape_field v2
 601              in StrWords [ v1; v2 ])
 602     | Haccess _ -> u_todo "Haccess" (fun () -> StrEmpty)
 603   and u_shape_field_optional =
 604     function
 605     | true -> [Str "optional"]
 606     | false -> []
 607   and u_shape_field_name =
 608     function
 609     | SFlit v2 ->
 610         u_todo "SFlit"
 611           (fun () ->
 612              let v1 = Str "SFlit" and v2 = u_pstring v2 in StrWords [ v1; v2 ])
 613     | SFclass_const ((v2, v3)) ->
 614         u_todo "SFclass_const"
 615           (fun () ->
 616              let v1 = Str "SFclass_const"
 617              and v2 = u_id v2
 618              and v3 = u_pstring v3
 619              in StrWords [ v1; v2; v3 ])
 620   and u_shape_field { sf_optional; sf_name; sf_hint } =
 621     u_todo "shape_field"
 622       (fun () ->
 623         let word_list =
 624           Str "shape_field"
 625             :: u_shape_field_optional sf_optional
 626             @ [u_shape_field_name sf_name; u_hint sf_hint] in
 627         StrWords word_list)
 628   and u_stmt stmt =
 629     let stmtStr = match stmt with
 630       | Unsafe -> StrComment "UNSAFE"
 631       | Fallthrough -> StrComment "FALLTHROUGH"
 632       | Expr expr -> u_expr expr
 633       | Block stmts -> u_block stmts
 634       | Break _pos -> Str "break"
 635       | Continue _pos -> Str "continue"
 636       | Throw expr -> StrWords [Str "throw"; u_expr expr]
 637       | Return (_pos, exprOpt) ->
 638           let exprStr = u_of_option u_expr exprOpt in
 639           StrWords [ Str "return"; exprStr]
 640       | Static_var exprList ->
 641           StrWords [Str "static"; u_of_list_comma u_expr exprList;]
 642       | If (cond, thenExpr, elseExpr) ->
 643           let condStr = StrParens (u_expr cond)
 644           and thenStr = u_block thenExpr
 645           and elseStr = match elseExpr with
 646           | [Noop] -> StrEmpty
 647           | _ -> StrWords [Str "else"; u_block elseExpr]
 648           in StrWords [ Str "if"; condStr; thenStr; elseStr ]
 649       | Do (block, expr) ->
 650           StrWords [
 651             Str "do";
 652             u_block block;
 653             Str "while";
 654             StrParens (u_expr expr)
 655           ]
 656       | While (expr, block) ->
 657           StrWords [
 658             Str "while";
 659             StrParens (u_expr expr);
 660             u_block block;
 661           ]
 662       | For (initExpr, testExpr, loopExpr, block) ->
 663           StrWords [
 664             Str "for";
 665             StrParens (StrSemiList [
 666               u_expr initExpr;
 667               u_expr testExpr;
 668               u_expr loopExpr;
 669             ]);
 670             u_block block;
 671           ]
 672       | Switch (expr, cases) ->
 673           StrWords [
 674             Str "switch";
 675             StrParens (u_expr expr);
 676             u_of_list_braces_spc u_case cases;
 677           ]
 678       | Foreach (expr, _posOption, as_expr, block) ->
 679           StrWords [
 680             Str "foreach";
 681             StrParens (StrWords [
 682               u_expr expr ;
 683               u_as_expr as_expr ;
 684             ]);
 685             u_block block;
 686           ]
 687       | Try (try_block, catches, finally_block) ->
 688           dn (string_of_int (List.length finally_block));
 689           let strFinally = match finally_block with
 690           | [] | [Noop] -> StrEmpty
 691           | _ -> StrWords [Str "finally"; u_block finally_block] in
 692           StrWords [Str "try"; u_block try_block; u_of_list_spc u_catch catches; strFinally]
 693       | Noop -> StrEmpty in
 694     match stmt with
 695       | Noop
 696       | Block _
 697       | If _
 698       | For _
 699       | Switch _
 700       | Foreach _
 701       | While _
 702       | Try _
 703       | Unsafe
 704       | Fallthrough -> stmtStr
 705       | Do _
 706       | Expr _
 707       | Break _
 708       | Continue _
 709       | Throw _
 710       | Return _
 711       | Static_var _ -> StrStatement [stmtStr]
 712
 713   and u_catch (hint, var, block) =
 714     StrWords [
 715       Str "catch";
 716       StrParens (u_of_list_spc u_id [hint; var;]);
 717       u_block block;
 718     ]
 719
 720   and u_as_expr =
 721     function
 722     | As_v expr -> StrWords [Str "as"; u_expr expr]
 723     | As_kv (kExpr, vExpr) -> StrWords [Str "as"; u_expr kExpr; Str "=>"; u_expr vExpr]
 724   and u_block v = match v with
 725     | [Block v] -> u_block v
 726     | _ -> u_of_list_braces_spc u_stmt v
 727   and u_naked_block v = u_of_list_spc u_stmt v
 728   (*
 729     unparses an expression nested inside another expression.
 730     introduces an additional set of parens if necessary.
 731   *)
 732   and u_expr_nested (_pos, expr_) =
 733     let res = u_expr_ expr_ in
 734     let todo_with s = u_todo ("Parens " ^ s) (fun () -> res) in
 735     match expr_ with
 736       | Array _
 737       | Null
 738       | True
 739       | False
 740       | Id _
 741       | Id_type_arguments _
 742       | Lvar _
 743       | Lvarvar _
 744       | Array_get _
 745       | Class_get _
 746       | Class_const _
 747       | Call _
 748       | Int _
 749       | Float _
 750       | String _
 751       | String2 _
 752       | List _
 753       | Obj_get _
 754       | Unsafeexpr _ -> res
 755       | Collection _
 756       | Cast _
 757       | Unop _
 758       | Binop _
 759       | Pipe _
 760       | Eif _
 761       | NullCoalesce _
 762       | InstanceOf _
 763       | New _
 764       | Efun _
 765       | Lfun _
 766       | Yield _
 767       | Yield_break
 768       | Expr_list _
 769       | Clone _
 770       | Import _
 771       | Await _ -> StrParens res
 772       | Shape _ -> todo_with "shape"
 773       | Xml _ -> todo_with "xml"
 774       | Dollardollar -> todo_with "Dollardollar"
 775   and u_expr (_pos, expr_) = u_expr_ expr_
 776   and u_expr_ =
 777     function
 778     | Array v2 -> StrList [Str "array"; u_of_list_parens_comma u_afield v2]
 779     | Shape v2 ->
 780         u_todo "Shape"
 781           (fun () ->
 782              let v1 = Str "Shape"
 783              and v2 =
 784                u_of_list_spc
 785                  (fun (v2, v3) ->
 786                     u_todo "expr_"
 787                       (fun () ->
 788                          let v1 = Str "expr_"
 789                          and v2 = u_shape_field_name v2
 790                          and v3 = u_expr v3
 791                          in StrWords [ v1; v2; v3 ]))
 792                  v2
 793              in StrWords [ v1; v2 ])
 794     | Dollardollar ->
 795         u_todo "Dollardollar"
 796           (fun () ->
 797             Str "$$")
 798     | Collection (id, afields) ->
 799       let idStr = u_id id
 800       and fieldStr = StrBraces (u_of_list_comma u_afield afields) in
 801       StrWords [idStr; fieldStr;]
 802     | Null -> Str "null"
 803     | True -> Str "true"
 804     | False -> Str "false"
 805     | Id id -> u_id id
 806     | Id_type_arguments (id, hintExprs) ->
 807       let hintStr = StrAngles (StrCommaList (List.map ~f:u_hint hintExprs)) in
 808       StrList [u_id id; hintStr]
 809     | Lvar lvar -> u_id lvar
 810     | Lvarvar (n, lvar) -> begin
 811       let p, var_id = lvar in
 812       u_id (p, (String.make n '$') ^ var_id)
 813     end
 814     | Clone expr -> StrWords [Str "clone"; u_expr_nested expr]
 815     | Obj_get (objExpr, itemExpr, null_flavor) ->
 816         let objStr = u_expr_nested objExpr
 817         and itemStr = u_expr itemExpr
 818         and operString = match null_flavor with
 819         | OG_nullthrows -> "->"
 820         | OG_nullsafe -> "?->"
 821         in StrList [ objStr; Str operString; itemStr ]
 822     | Array_get (exprArr, exprKey) ->
 823       let exprArrStr = u_expr_nested exprArr
 824       and exprKeyStr = u_of_option u_expr exprKey in
 825       StrList [exprArrStr; Str "["; exprKeyStr; Str "]"]
 826     | Class_get (hintExpr, getExpr) ->
 827         let hintStr = u_id hintExpr
 828         and getStr = u_pstring getExpr in
 829         StrList [hintStr; Str "::"; getStr]
 830     | Class_const (hintExpr, constExpr) ->
 831         let hintStr = u_id hintExpr
 832         and constStr = u_pstring constExpr in
 833         StrList [hintStr; Str "::"; constStr]
 834     | Call (funExpr, paramExprs, unpackParamExprs) ->
 835       let funStr = u_expr_nested funExpr in
 836       let paramStr = match funStr with
 837       | Str "echo" when List.length paramExprs > 1 ->
 838         if unpackParamExprs <> [] then
 839           u_todo "echo with ... ?" (fun () -> StrEmpty)
 840         else StrList [StrBlank; u_of_list_comma u_expr paramExprs]
 841       | _ ->
 842         let listExprs =
 843           (List.map ~f:u_expr paramExprs) @
 844             (List.map ~f:(fun e -> StrList [Str "..." ; u_expr e]) unpackParamExprs) in
 845         StrParens (StrCommaList listExprs)
 846       in StrList [ funStr; paramStr ]
 847     | Int i -> u_pstring i
 848     | Float f -> u_pstring f
 849     | String (p, s) ->
 850       StrList [Str "\""; u_pstring (p, Php_escaping.escape s); Str "\""]
 851     | String2 elems ->
 852       (* build the string back by concatenating the parts *)
 853       List.map ~f:u_expr elems |>
 854       fun els -> StrList (List.intersperse ~sep:(Str ".") els)
 855     | Yield afield ->
 856         StrWords [Str "yield"; u_afield afield]
 857     | Yield_break -> u_todo "Yield_break" (fun () -> StrEmpty)
 858     | Await v2 ->
 859         StrWords [Str "await"; u_expr v2]
 860     | List exprs ->
 861         StrList [Str "list"; u_of_list_parens_comma u_expr exprs]
 862     | Expr_list exprs ->
 863         u_of_list_comma u_expr exprs
 864     | Cast (hint, expr) ->
 865         StrList [StrParens (u_hint hint); u_expr_nested expr];
 866     | Unop (uop, expr) -> u_uop expr uop
 867     | Binop (bop, e1, e2) -> u_bop e1 e2 bop
 868     (** The pipe ID is only used for typechecking phase. *)
 869     | Pipe (e1, e2) -> u_pipe e1 e2
 870     | Eif (condExpr, trueExprOption, falseExpr) ->
 871         StrWords [
 872           u_expr_nested condExpr;
 873           Str "?";
 874           u_of_option u_expr_nested trueExprOption;
 875           Str ":";
 876           u_expr_nested falseExpr;
 877         ]
 878     | NullCoalesce (trueExpr, falseExpr) ->
 879         StrWords [
 880           u_expr_nested trueExpr;
 881           Str "??";
 882           u_expr_nested falseExpr;
 883         ]
 884     | InstanceOf (instExpr, hintExpr) ->
 885         StrWords [
 886           u_expr_nested instExpr;
 887           Str "instanceof";
 888           u_expr_nested hintExpr;
 889         ];
 890     | New (klass, paramExprs, unpackParamExprs) ->
 891       let klassStr = u_expr klass in
 892       let listExprs =
 893         (List.map ~f:u_expr paramExprs) @
 894           (List.map ~f:(fun e -> StrList [Str "..." ; u_expr e]) unpackParamExprs) in
 895       let paramStr = StrParens (StrCommaList listExprs) in
 896       StrList [ Str "new"; StrBlank ; klassStr; paramStr]
 897     | Efun (fun_, uselist) ->
 898       let useStr = match uselist with
 899         | [] -> StrEmpty
 900         | _ -> StrList [Str "use"; u_of_list_parens_comma u_use uselist] in
 901       u_fun_with_use fun_ useStr
 902     | Lfun v2 ->
 903         u_todo "Lfun"
 904           (fun () ->
 905              let v1 = Str "Lfun" and v2 = u_fun_ v2 in StrWords [ v1; v2 ])
 906     | Xml ((v2, v3, v4)) ->
 907         u_todo "Xml"
 908           (fun () ->
 909              let v1 = Str "Xml"
 910              and v2 = u_id v2
 911              and v3 =
 912                u_of_list_spc
 913                  (fun (v2, v3) ->
 914                     u_todo "expr_"
 915                       (fun () ->
 916                          let v1 = Str "expr_"
 917                          and v2 = u_id v2
 918                          and v3 = u_expr v3
 919                          in StrWords [ v1; v2; v3 ]))
 920                  v3
 921              and v4 = u_of_list_spc u_expr v4
 922              in StrWords [ v1; v2; v3; v4 ])
 923     | Unsafeexpr expr ->
 924         StrWords [Str "/* UNSAFE_EXPR */"; u_expr expr]
 925     | Import (flavor, expr) ->
 926         StrWords [u_import_flavor flavor; StrParens (u_expr expr)]
 927   and u_import_flavor =
 928     function
 929     | Require -> Str "require"
 930     | Include -> Str "include"
 931     | RequireOnce -> Str "require_once"
 932     | IncludeOnce -> Str "include_once"
 933   and u_use (id, is_ref) =
 934     let str_id = u_id id
 935     and str_ref = if is_ref then Str "&" else StrBlank
 936     in StrList [str_ref; str_id]
 937   and u_afield =
 938     function
 939     | AFvalue v2 -> u_expr v2
 940     | AFkvalue (kExpr, vExpr) -> StrWords [u_expr kExpr; Str "=>"; u_expr vExpr]
 941   and u_bop e1 e2 bop =
 942       let bop_str = function
 943         | Plus -> Str "+"
 944         | Minus -> Str "-"
 945         | Star -> Str "*"
 946         | Starstar -> Str "**"
 947         | Slash -> Str "/"
 948         | Eqeq -> Str "=="
 949         | EQeqeq -> Str "==="
 950         | AMpamp -> Str "&&"
 951         | BArbar -> Str "||"
 952         | Lt -> Str "<"
 953         | Lte -> Str "<="
 954         | Gt -> Str ">"
 955         | Gte -> Str ">="
 956         | Dot -> Str "."
 957         | Amp -> Str "&"
 958         | Bar -> Str "|"
 959         | Ltlt -> Str "<<"
 960         | Gtgt -> Str ">>"
 961         | Percent -> Str "%"
 962         | Xor -> Str "^"
 963         | Diff -> Str "!="
 964         | Diff2 -> Str "!=="
 965         | _ -> raise Impossible in
 966       match bop with
 967       | Eq b -> StrWords [
 968                   u_expr e1;
 969                   StrList [u_of_option bop_str b; Str "="];
 970                   u_expr e2
 971                 ]
 972       | _ ->
 973           let e1 = u_expr_in_bop bop e1 in
 974           let e2 = u_expr_in_bop bop e2 in
 975           let s = bop_str bop in
 976           StrWords [e1; s; e2]
 977   and u_expr_in_bop bop expr =
 978     match expr with
 979     | (_, Binop (b,_,_)) when bop = b && is_associative bop -> u_expr expr
 980     | _ -> u_expr_nested expr
 981   and u_pipe e1 e2 =
 982     StrWords [u_expr e1; Str "|>"; u_expr e2]
 983   and u_uop expr uop =
 984         let prefix_with s = StrList [Str s; u_expr_nested expr] in
 985         match uop with
 986         | Upincr -> StrList [u_expr_nested expr; Str "++"]
 987         | Updecr -> StrList [u_expr_nested expr; Str "--"]
 988         | Utild -> prefix_with "~"
 989         | Unot -> prefix_with "!"
 990         | Uplus -> prefix_with "+"
 991         | Uminus -> prefix_with "-"
 992         | Uincr -> prefix_with "++"
 993         | Udecr -> prefix_with "--"
 994         | Uref -> prefix_with "&"
 995   and u_case v =
 996     let case_expr name block =
 997       StrWords [name; Str ":"; u_naked_block block;] in
 998     match v with
 999     | Default block ->
1000         case_expr (Str "default") block
1001     | Case (expr, block) ->
1002         case_expr (StrWords [Str "case"; u_expr expr;]) block
1003       let unparser _env = u_program
1004 end
1005
1006 open Unparse
1007
1008 let unparse_internal program =
1009   (*
1010     we feed the output of the unparser to the hack formatter which only
1011     accepts files with hh prefix, so we have to fake it.
1012   *)
1013   StrWords [
1014     u_file_type FileInfo.HhFile;
1015     unparser {mode = FileInfo.Mdecl} program
1016   ]
1017
1018 let unparse :
1019     FileInfo.file_type -> Path.t -> program -> string =
1020     fun filetype file program ->
1021   unparse_internal program |>
1022   to_string |>
1023   fun s ->
1024     dn s;
1025     let modes = [Some FileInfo.Mstrict; Some FileInfo.Mpartial] in
1026     let formatted = Format_hack.program modes file ~no_trailing_commas:true s in
1027     let s' = match formatted with
1028     | Format_hack.Disabled_mode -> raise Impossible
1029     | Format_hack.Internal_error -> raise (FormatterError "")
1030     | Format_hack.Success s' -> s'
1031     | Format_hack.Parsing_error error -> raise (FormatterError
1032       ("parsing error \n" ^ (Errors.to_string (Errors.to_absolute
1033       (List.hd_exn error))))) in
1034     match filetype with
1035      | FileInfo.HhFile -> s'
1036      | FileInfo.PhpFile ->  let r = R.regexp "<\\?hh" in
1037                    R.replace_first r "<?php" s'