Skip to content

Commit

Permalink
Bump the version of the selected AST to 4.08 (#80)
Browse files Browse the repository at this point in the history
  • Loading branch information
@xclerc @trefis
xclerc authored and trefis committed Aug 1, 2019
1 parent 4f1e941 commit 67febc1
Show file tree
Hide file tree
Showing 28 changed files with 5,452 additions and 4,899 deletions.
9,807 changes: 5,098 additions & 4,709 deletions ast/ast.ml
View file

Large diffs are not rendered by default.

2 changes: 1 addition & 1 deletion ast/import.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@
It must be opened in all modules, especially the ones coming from the compiler.
*)

module Js = Migrate_parsetree.OCaml_407
module Js = Migrate_parsetree.OCaml_408
module Ocaml = Migrate_parsetree.Versions.OCaml_current

module Select_ast(Ocaml : Migrate_parsetree.Versions.OCaml_version) = struct
Expand Down
173 changes: 121 additions & 52 deletions ast/pprintast.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -37,37 +37,64 @@ let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/';
let special_infix_strings =
["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ]

let letop s =
String.length s > 3
&& s.[0] = 'l'
&& s.[1] = 'e'
&& s.[2] = 't'
&& List.mem s.[3] infix_symbols

let andop s =
String.length s > 3
&& s.[0] = 'a'
&& s.[1] = 'n'
&& s.[2] = 'd'
&& List.mem s.[3] infix_symbols

(* determines if the string is an infix string.
checks backwards, first allowing a renaming postfix ("_102") which
may have resulted from Pexp -> Texp -> Pexp translation, then checking
if all the characters in the beginning of the string are valid infix
characters. *)
let fixity_of_string = function
| "" -> `Normal
| s when List.mem s special_infix_strings -> `Infix s
| s when List.mem s.[0] infix_symbols -> `Infix s
| s when List.mem s.[0] prefix_symbols -> `Prefix s
| s when s.[0] = '.' -> `Mixfix s
| s when letop s -> `Letop s
| s when andop s -> `Andop s
| _ -> `Normal

let view_fixity_of_exp = function
| {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} ->
fixity_of_string l
| _ -> `Normal

let is_infix = function | `Infix _ -> true | _ -> false
let is_infix = function `Infix _ -> true | _ -> false
let is_mixfix = function `Mixfix _ -> true | _ -> false
let is_kwdop = function `Letop _ | `Andop _ -> true | _ -> false

let first_is c str =
str <> "" && str.[0] = c
let last_is c str =
str <> "" && str.[String.length str - 1] = c

let first_is_in cs str =
str <> "" && List.mem str.[0] cs

(* which identifiers are in fact operators needing parentheses *)
let needs_parens txt =
let fix = fixity_of_string txt in
is_infix fix
|| is_mixfix fix
|| List.mem txt.[0] prefix_symbols
|| is_kwdop fix
|| first_is_in prefix_symbols txt

(* some infixes need spaces around parens to avoid clashes with comment
syntax *)
let needs_spaces txt =
txt.[0]='*' || txt.[String.length txt - 1] = '*'
first_is '*' txt || last_is '*' txt

(* add parentheses to binders when they are in fact infix or prefix operators *)
let protect_ident ppf txt =
Expand Down Expand Up @@ -193,15 +220,20 @@ let rec longident f = function
let longident_loc f x = pp f "%a" longident x.txt

let constant f = function
| Pconst_char i -> pp f "%C" i
| Pconst_string (i, None) -> pp f "%S" i
| Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim
| Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i
| Pconst_char i ->
pp f "%C" i
| Pconst_string (i, None) ->
pp f "%S" i
| Pconst_string (i, Some delim) ->
pp f "{%s|%s|%s}" delim i delim
| Pconst_integer (i, None) ->
paren (first_is '-' i) (fun f -> pp f "%s") f i
| Pconst_integer (i, Some m) ->
paren (i.[0]='-') (fun f (i, m) -> pp f "%s%c" i m) f (i,m)
| Pconst_float (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i
| Pconst_float (i, Some m) -> paren (i.[0]='-') (fun f (i,m) ->
pp f "%s%c" i m) f (i,m)
paren (first_is '-' i) (fun f (i, m) -> pp f "%s%c" i m) f (i,m)
| Pconst_float (i, None) ->
paren (first_is '-' i) (fun f -> pp f "%s") f i
| Pconst_float (i, Some m) ->
paren (first_is '-' i) (fun f (i,m) -> pp f "%s%c" i m) f (i,m)

(* trailing space*)
let mutable_flag f = function
Expand All @@ -227,9 +259,19 @@ let private_flag f = function
| Public -> ()
| Private -> pp f "private@ "

let iter_loc f ctxt {txt; loc = _} = f ctxt txt

let constant_string f s = pp f "%S" s
let tyvar f str = pp f "'%s" str
let tyvar_loc f str = pp f "'%s" str.txt

let tyvar ppf s =
if String.length s >= 2 && s.[1] = '\'' then
(* without the space, this would be parsed as
a character literal *)
Format.fprintf ppf "' %s" s
else
Format.fprintf ppf "'%s" s

let tyvar_loc f str = tyvar f str.txt
let string_quot f x = pp f "`%s" x

(* c ['a,'b] *)
Expand All @@ -255,7 +297,7 @@ and core_type ctxt f x =
pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
(type_with_label ctxt) (l,ct1) (core_type ctxt) ct2
| Ptyp_alias (ct, s) ->
pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s
pp f "@[<2>%a@;as@;%a@]" (core_type1 ctxt) ct tyvar s
| Ptyp_poly ([], ct) ->
core_type ctxt f ct
| Ptyp_poly (sl, ct) ->
Expand Down Expand Up @@ -286,14 +328,14 @@ and core_type1 ctxt f x =
l longident_loc li
| Ptyp_variant (l, closed, low) ->
let type_variant_helper f x =
match x with
| Rtag (l, attrs, _, ctl) ->
pp f "@[<2>%a%a@;%a@]" string_quot l.txt
match x.prf_desc with
| Rtag (l, _, ctl) ->
pp f "@[<2>%a%a@;%a@]" (iter_loc string_quot) l
(fun f l -> match l with
|[] -> ()
| _ -> pp f "@;of@;%a"
(list (core_type ctxt) ~sep:"&") ctl) ctl
(attributes ctxt) attrs
(attributes ctxt) x.prf_attributes
| Rinherit ct -> core_type ctxt f ct in
pp f "@[<2>[%a%a]@]"
(fun f l ->
Expand All @@ -313,10 +355,11 @@ and core_type1 ctxt f x =
pp f ">@ %a"
(list string_quot) xs) low
| Ptyp_object (l, o) ->
let core_field_type f = function
| Otag (l, attrs, ct) ->
let core_field_type f x = match x.pof_desc with
| Otag (l, ct) ->
(* Cf #7200 *)
pp f "@[<hov2>%s: %a@ %a@ @]" l.txt
(core_type ctxt) ct (attributes ctxt) attrs (* Cf #7200 *)
(core_type ctxt) ct (attributes ctxt) x.pof_attributes
| Oinherit ct ->
pp f "@[<hov2>%a@ @]" (core_type ctxt) ct
in
Expand All @@ -327,7 +370,8 @@ and core_type1 ctxt f x =
| [] -> pp f ".."
| _ -> pp f " ;.."
in
pp f "@[<hov2><@ %a%a@ > @]" (list core_field_type ~sep:";") l
pp f "@[<hov2><@ %a%a@ > @]"
(list core_field_type ~sep:";") l
field_var o (* Cf #7200 *)
| Ptyp_class (li, l) -> (*FIXME*)
pp f "@[<hov2>%a#%a@]"
Expand Down Expand Up @@ -512,15 +556,15 @@ and sugar_expr ctxt f e =
| _ -> false
end
| (Lident s | Ldot(_,s)) , a :: i :: rest
when s.[0] = '.' ->
let n = String.length s in
when first_is '.' s ->
(* extract operator:
assignment operators end with [right_bracket ^ "<-"],
access operators end with [right_bracket] directly
*)
let assign = s.[n - 1] = '-' in
let assign = last_is '-' s in
let kind =
(* extract the right end bracket *)
let n = String.length s in
if assign then s.[n - 3] else s.[n - 1] in
let left, right = match kind with
| ')' -> '(', ")"
Expand All @@ -547,7 +591,8 @@ and expression ctxt f x =
paren true (expression reset_ctxt) f x
| Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse ->
paren true (expression reset_ctxt) f x
| Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _
| Pexp_let _ | Pexp_letmodule _ | Pexp_open _
| Pexp_letexception _ | Pexp_letop _
when ctxt.semi ->
paren true (expression reset_ctxt) f x
| Pexp_fun (l, e0, p, e) ->
Expand Down Expand Up @@ -667,11 +712,17 @@ and expression ctxt f x =
| Pexp_poly (e, Some ct) ->
pp f "@[<hov2>(!poly!@ %a@ : %a)@]"
(simple_expr ctxt) e (core_type ctxt) ct
| Pexp_open (ovf, lid, e) ->
pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid
| Pexp_open (o, e) ->
pp f "@[<2>let open%s %a in@;%a@]"
(override o.popen_override) (module_expr ctxt) o.popen_expr
(expression ctxt) e
| Pexp_variant (l,Some eo) ->
pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo
| Pexp_letop {let_; ands; body} ->
pp f "@[<2>@[<v>%a@,%a@] in@;<1 -2>%a@]"
(binding_op ctxt) let_
(list ~sep:"@," (binding_op ctxt)) ands
(expression ctxt) body
| Pexp_extension e -> extension ctxt f e
| Pexp_unreachable -> pp f "."
| _ -> expression1 ctxt f x
Expand Down Expand Up @@ -755,14 +806,14 @@ and attributes ctxt f l =
and item_attributes ctxt f l =
List.iter (item_attribute ctxt f) l

and attribute ctxt f (s, e) =
pp f "@[<2>[@@%s@ %a]@]" s.txt (payload ctxt) e
and attribute ctxt f a =
pp f "@[<2>[@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload

and item_attribute ctxt f (s, e) =
pp f "@[<2>[@@@@%s@ %a]@]" s.txt (payload ctxt) e
and item_attribute ctxt f a =
pp f "@[<2>[@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload

and floating_attribute ctxt f (s, e) =
pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt (payload ctxt) e
and floating_attribute ctxt f a =
pp f "@[<2>[@@@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload

and value_description ctxt f x =
(* note: value_description has an attribute field,
Expand All @@ -779,8 +830,10 @@ and extension ctxt f (s, e) =
and item_extension ctxt f (s, e) =
pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e

and exception_declaration ctxt f ext =
pp f "@[<hov2>exception@ %a@]" (extension_constructor ctxt) ext
and exception_declaration ctxt f x =
pp f "@[<hov2>exception@ %a@]%a"
(extension_constructor ctxt) x.ptyexn_constructor
(item_attributes ctxt) x.ptyexn_attributes

and class_type_field ctxt f x =
match x.pctf_desc with
Expand Down Expand Up @@ -831,8 +884,9 @@ and class_type ctxt f x =
| Pcty_extension e ->
extension ctxt f e;
attributes ctxt f x.pcty_attributes
| Pcty_open (ovf, lid, e) ->
pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid
| Pcty_open (o, e) ->
pp f "@[<2>let open%s %a in@;%a@]"
(override o.popen_override) longident_loc o.popen_expr
(class_type ctxt) e

(* [class type a = object end] *)
Expand Down Expand Up @@ -881,7 +935,10 @@ and class_field ctxt f x =
let bind e =
binding ctxt f
{pvb_pat=
{ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]};
{ppat_desc=Ppat_var s;
ppat_loc=Location.none;
ppat_loc_stack=[];
ppat_attributes=[]};
pvb_expr=e;
pvb_attributes=[];
pvb_loc=Location.none;
Expand Down Expand Up @@ -950,8 +1007,9 @@ and class_expr ctxt f x =
(class_expr ctxt) ce
(class_type ctxt) ct
| Pcl_extension e -> extension ctxt f e
| Pcl_open (ovf, lid, e) ->
pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid
| Pcl_open (o, e) ->
pp f "@[<2>let open%s %a in@;%a@]"
(override o.popen_override) longident_loc o.popen_expr
(class_expr ctxt) e

and module_type ctxt f x =
Expand Down Expand Up @@ -1011,7 +1069,9 @@ and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x
and signature_item ctxt f x : unit =
match x.psig_desc with
| Psig_type (rf, l) ->
type_def_list ctxt f (rf, l)
type_def_list ctxt f (rf, true, l)
| Psig_typesubst l ->
type_def_list ctxt f (Nonrecursive, false, l)
| Psig_value vd ->
let intro = if vd.pval_prim = [] then "val" else "external" in
pp f "@[<2>%s@ %a@ :@ %a@]%a" intro
Expand Down Expand Up @@ -1048,10 +1108,14 @@ and signature_item ctxt f x : unit =
pmd.pmd_name.txt
(module_type ctxt) pmd.pmd_type
(item_attributes ctxt) pmd.pmd_attributes
| Psig_modsubst pms ->
pp f "@[<hov>module@ %s@ :=@ %a@]%a" pms.pms_name.txt
longident_loc pms.pms_manifest
(item_attributes ctxt) pms.pms_attributes
| Psig_open od ->
pp f "@[<hov2>open%s@ %a@]%a"
(override od.popen_override)
longident_loc od.popen_lid
longident_loc od.popen_expr
(item_attributes ctxt) od.popen_attributes
| Psig_include incl ->
pp f "@[<hov2>include@ %a@]%a"
Expand Down Expand Up @@ -1213,14 +1277,18 @@ and bindings ctxt f (rf,l) =
(binding "let" rf) x
(list ~sep:"@," (binding "and" Nonrecursive)) xs

and binding_op ctxt f x =
pp f "@[<2>%s %a@;=@;%a@]"
x.pbop_op.txt (pattern ctxt) x.pbop_pat (expression ctxt) x.pbop_exp

and structure_item ctxt f x =
match x.pstr_desc with
| Pstr_eval (e, attrs) ->
pp f "@[<hov2>;;%a@]%a"
(expression ctxt) e
(item_attributes ctxt) attrs
| Pstr_type (_, []) -> assert false
| Pstr_type (rf, l) -> type_def_list ctxt f (rf, l)
| Pstr_type (rf, l) -> type_def_list ctxt f (rf, true, l)
| Pstr_value (rf, l) ->
(* pp f "@[<hov2>let %a%a@]" rec_flag rf bindings l *)
pp f "@[<2>%a@]" (bindings ctxt) (rf,l)
Expand Down Expand Up @@ -1253,7 +1321,7 @@ and structure_item ctxt f x =
| Pstr_open od ->
pp f "@[<2>open%s@;%a@]%a"
(override od.popen_override)
longident_loc od.popen_lid
(module_expr ctxt) od.popen_expr
(item_attributes ctxt) od.popen_attributes
| Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
pp f "@[<hov2>module@ type@ %s%a@]%a"
Expand Down Expand Up @@ -1342,12 +1410,13 @@ and type_params ctxt f = function
| [] -> ()
| l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l

and type_def_list ctxt f (rf, l) =
and type_def_list ctxt f (rf, exported, l) =
let type_decl kwd rf f x =
let eq =
if (x.ptype_kind = Ptype_abstract)
&& (x.ptype_manifest = None) then ""
else " ="
else if exported then " ="
else " :="
in
pp f "@[<2>%s %a%a%s%s%a@]%a" kwd
nonrec_flag rf
Expand Down Expand Up @@ -1502,8 +1571,7 @@ and label_x_expression_param ctxt f (l,e) =
pp f "~%s:%a" lbl (simple_expr ctxt) e

and directive_argument f x =
match x with
| Pdir_none -> ()
match x.pdira_desc with
| Pdir_string (s) -> pp f "@ %S" s
| Pdir_int (n, None) -> pp f "@ %s" n
| Pdir_int (n, Some m) -> pp f "@ %s%c" n m
Expand All @@ -1516,9 +1584,10 @@ let toplevel_phrase f x =
(* pp_open_hvbox f 0; *)
(* pp_print_list structure_item f s ; *)
(* pp_close_box f (); *)
| Ptop_dir (s, da) ->
pp f "@[<hov2>#%s@ %a@]" s directive_argument da
(* pp f "@[<hov2>#%s@ %a@]" s directive_argument da *)
| Ptop_dir {pdir_name; pdir_arg = None; _} ->
pp f "@[<hov2>#%s@]" pdir_name.txt
| Ptop_dir {pdir_name; pdir_arg = Some pdir_arg; _} ->
pp f "@[<hov2>#%s@ %a@]" pdir_name.txt directive_argument pdir_arg

let expression f x =
pp f "@[%a@]" (expression reset_ctxt) x
Expand Down
Loading

0 comments on commit 67febc1

Please sign in to comment.