Pprintast support for new local syntax

Author: stedolan

parsing/pprintast.ml

@@ -121,6 +121,14 @@ let filter_curry_attrs attrs =
 let has_non_curry_attr attrs =
   List.exists (fun attr -> not (is_curry_attr attr)) attrs
 
+let check_local_attr attrs =
+  match
+    List.partition (fun attr ->
+        attr.attr_name.txt = "ocaml.local") attrs
+  with
+  | [], _ -> attrs, false
+  | _::_, rest -> rest, true
+
 type space_formatter = (unit, Format.formatter, unit) format
 
 let override = function
@@ -288,6 +296,14 @@ let tyvar ppf s =
 let tyvar_loc f str = tyvar f str.txt
 let string_quot f x = pp f "`%s" x
 
+let maybe_local_type pty ctxt f c =
+  let cattrs, is_local = check_local_attr c.ptyp_attributes in
+  let c = { c with ptyp_attributes = cattrs } in
+  if is_local then
+    pp f "local_ %a" (pty ctxt) c
+  else
+    pty ctxt f c
+
 (* c ['a,'b] *)
 let rec class_params_def ctxt f =  function
   | [] -> ()
@@ -297,9 +313,9 @@ let rec class_params_def ctxt f =  function
 
 and type_with_label ctxt f (label, c) =
   match label with
-  | Nolabel    -> core_type1 ctxt f c (* otherwise parenthesize *)
-  | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c
-  | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c
+  | Nolabel    -> maybe_local_type core_type1 ctxt f c (* otherwise parenthesize *)
+  | Labelled s -> pp f "%s:%a" s (maybe_local_type core_type1 ctxt) c
+  | Optional s -> pp f "?%s:%a" s (maybe_local_type core_type1 ctxt) c
 
 and core_type ctxt f x =
   let filtered_attrs = filter_curry_attrs x.ptyp_attributes in
@@ -407,8 +423,8 @@ and core_type1 ctxt f x =
     | _ -> paren true (core_type ctxt) f x
 
 and return_type ctxt f x =
-  if x.ptyp_attributes <> [] then core_type1 ctxt f x
-  else core_type ctxt f x
+  if x.ptyp_attributes <> [] then maybe_local_type core_type1 ctxt f x
+  else maybe_local_type core_type ctxt f x
 
 (********************pattern********************)
 (* be cautious when use [pattern], [pattern1] is preferred *)
@@ -514,30 +530,43 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit =
           (paren with_paren @@ pattern1 ctxt) p
     | _ -> paren true (pattern ctxt) f x
 
+and maybe_local_pat ctxt is_local f p =
+  if is_local then
+    pp f "(local_ %a)" (simple_pattern ctxt) p
+  else
+    pp f "%a" (simple_pattern ctxt) p
+
 and label_exp ctxt f (l,opt,p) =
+  let pattrs, is_local = check_local_attr p.ppat_attributes in
+  let p = { p with ppat_attributes = pattrs } in
   match l with
   | Nolabel ->
       (* single case pattern parens needed here *)
-      pp f "%a" (simple_pattern ctxt) p
+      pp f "%a" (maybe_local_pat ctxt is_local) p
   | Optional rest ->
       begin match p with
       | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []}
-        when txt = rest ->
+        when txt = rest && not is_local ->
           (match opt with
            | Some o -> pp f "?(%s=@;%a)" rest  (expression ctxt) o
            | None -> pp f "?%s" rest)
       | _ ->
           (match opt with
            | Some o ->
-               pp f "?%s:(%a=@;%a)"
-                 rest (pattern1 ctxt) p (expression ctxt) o
-           | None -> pp f "?%s:%a" rest (simple_pattern ctxt) p)
+               pp f "?%s:(%s%a=@;%a)"
+                 rest
+                 (if is_local then "local_ " else "")
+                 (pattern1 ctxt) p (expression ctxt) o
+           | None -> pp f "?%s:%a" rest (maybe_local_pat ctxt is_local) p)
       end
   | Labelled l -> match p with
     | {ppat_desc  = Ppat_var {txt;_}; ppat_attributes = []}
       when txt = l ->
-        pp f "~%s" l
-    | _ ->  pp f "~%s:%a" l (simple_pattern ctxt) p
+        if is_local then
+          pp f "~(local_ %s)" l
+        else
+          pp f "~%s" l
+    | _ ->  pp f "~%s:%a" l (maybe_local_pat ctxt is_local) p
 
 and sugar_expr ctxt f e =
   if e.pexp_attributes <> [] then false
@@ -654,6 +683,10 @@ and expression ctxt f x =
         pp f "@[<2>%a in@;<1 -2>%a@]"
           (bindings reset_ctxt) (rf,l)
           (expression ctxt) e
+    | Pexp_apply
+      ({ pexp_desc = Pexp_extension({txt = "extension.local"}, PStr []) },
+       [Nolabel, sbody]) ->
+        pp f "@[<2>local_ %a@]" (expression ctxt) sbody
     | Pexp_apply (e, l) ->
         begin if not (sugar_expr ctxt f x) then
             match view_fixity_of_exp e with
@@ -1238,14 +1271,18 @@ and payload ctxt f = function
       pp f " when "; expression ctxt f e
 
 and pp_print_pexp_function ctxt sep f x =
+  (* do not print [@ocaml.local] on expressions *)
+  let attrs, _ = check_local_attr x.pexp_attributes in
+  let x = { x with pexp_attributes = attrs } in
   if x.pexp_attributes <> [] then pp f "%s@;%a" sep (expression ctxt) x
   else match x.pexp_desc with
     | Pexp_fun (label, eo, p, e) ->
       pp f "%a@ %a"
         (label_exp ctxt) (label,eo,p) (pp_print_pexp_function ctxt sep) e
     | Pexp_newtype (str,e) ->
       pp f "(type@ %s)@ %a" str.txt (pp_print_pexp_function ctxt sep) e
-    | _ -> pp f "%s@;%a" sep (expression ctxt) x
+    | _ ->
+       pp f "%s@;%a" sep (expression ctxt) x
 
 (* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
 and binding ctxt f {pvb_pat=p; pvb_expr=x; _} =
@@ -1316,7 +1353,19 @@ and binding ctxt f {pvb_pat=p; pvb_expr=x; _} =
 (* [in] is not printed *)
 and bindings ctxt f (rf,l) =
   let binding kwd rf f x =
-    pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf
+    let x, is_local =
+      match x.pvb_expr.pexp_desc with
+      | Pexp_apply
+        ({ pexp_desc = Pexp_extension({txt = "extension.local"}, PStr []) },
+         [Nolabel, sbody]) ->
+         let sattrs, _ = check_local_attr sbody.pexp_attributes in
+         let sbody = {sbody with pexp_attributes = sattrs} in
+         let pattrs, _ = check_local_attr x.pvb_pat.ppat_attributes in
+         let pat = {x.pvb_pat with ppat_attributes = pattrs} in
+         {x with pvb_pat = pat; pvb_expr = sbody}, "local_ "
+      | _ -> x, ""
+    in
+    pp f "@[<2>%s %a%s%a@]%a" kwd rec_flag rf is_local
       (binding ctxt) x (item_attributes ctxt) x.pvb_attributes
   in
   match l with
@@ -1498,12 +1547,26 @@ and type_def_list ctxt f (rf, exported, l) =
                  (list ~sep:"@," (type_decl "and" Recursive)) xs
 
 and record_declaration ctxt f lbls =
+  let has_attr pld name =
+    List.exists (fun attr -> attr.attr_name.txt = name) pld.pld_attributes
+  in
+  let field_flag f pld =
+    pp f "%a" mutable_flag pld.pld_mutable;
+    if has_attr pld "ocaml.nonlocal" then pp f "nonlocal_ ";
+    if has_attr pld "ocaml.global" then pp f "global_ "
+  in
   let type_record_field f pld =
+    let pld_attributes =
+      List.filter (fun attr ->
+        match attr.attr_name.txt with
+        | "ocaml.nonlocal" | "ocaml.global" -> false
+        | _ -> true) pld.pld_attributes
+    in
     pp f "@[<2>%a%s:@;%a@;%a@]"
-      mutable_flag pld.pld_mutable
+      field_flag pld
       pld.pld_name.txt
       (core_type ctxt) pld.pld_type
-      (attributes ctxt) pld.pld_attributes
+      (attributes ctxt) pld_attributes
   in
   pp f "{@\n%a}"
     (list type_record_field ~sep:";@\n" )  lbls

testsuite/tests/typing-local/example_syntax.ml

@@ -0,0 +1,13 @@
+let f a b c = 1
+let f (local_ a) ~foo:(local_ b) ?foo:(local_ c= 1) ~(local_ d) = ()
+let f () =
+  let a = [local_ 1] in
+  let local_ r = 1 in
+  let local_ f : 'a . 'a -> 'a = fun x -> x in
+  local_ "asdfasdfasdfasdfasdfasdfasdf"
+type 'a r = {
+  mutable a: 'a ;
+  nonlocal_ b: 'a ;
+  global_ c: 'a }
+type ('a, 'b) cfn =
+  a:local_ 'a -> ?b:local_ b -> local_ 'a -> (int -> local_ 'b)

testsuite/tests/typing-local/print_syntax.ml

@@ -0,0 +1,14 @@
+(* TEST
+   include ocamlcommon
+   files = "example_syntax.ml"
+   reference = "${test_source_directory}/example_syntax.ml"
+*)
+
+let () =
+  let fname = "example_syntax.ml" in
+  let ic = open_in fname in
+  let lexbuf = Lexing.from_channel ic in
+  Location.init lexbuf fname;
+  let ast = Parse.implementation lexbuf in
+  close_in ic;
+  Format.printf "%a@." Pprintast.structure ast