diff --git a/lib/Normalize_std_ast.ml b/lib/Normalize_std_ast.ml index 0b11501ff5..b88fe3be19 100644 --- a/lib/Normalize_std_ast.ml +++ b/lib/Normalize_std_ast.ml @@ -16,10 +16,6 @@ let is_doc = function | {attr_name= {Location.txt= "ocaml.doc" | "ocaml.text"; _}; _} -> true | _ -> false -let is_builtin_jane_syntax attr = - let name = attr.attr_name.txt in - String.is_prefix ~prefix:"jane.erasable._builtin" name - let is_erasable_jane_syntax attr = let name = attr.attr_name.txt in String.is_prefix ~prefix:"jane.erasable." name @@ -50,7 +46,7 @@ let normalize_immediate_annot_and_attrs attrs = , PStr [ { pstr_desc= Pstr_attribute - { attr_name= {txt= "jane.erasable.layouts.prim"; _} + { attr_name= {txt= "jane.erasable.layouts.abbrev"; _} ; attr_payload= PStr [ { pstr_desc= @@ -70,7 +66,7 @@ let normalize_immediate_annot_and_attrs attrs = , PStr [ { pstr_desc= Pstr_attribute - { attr_name= {txt= "jane.erasable.layouts.prim"; _} + { attr_name= {txt= "jane.erasable.layouts.abbrev"; _} ; attr_payload= PStr [ { pstr_desc= @@ -216,61 +212,116 @@ let make_mapper conf ~ignore_doc_comments ~erase_jane_syntax = } in let {pexp_desc; pexp_loc= loc1; pexp_attributes= attrs1; _} = exp in - match pexp_desc with - | Pexp_apply - ( {pexp_desc= Pexp_extension ({txt= "extension.exclave"; _}, _); _} - , [(Nolabel, expr)] ) - when erase_jane_syntax -> - m.expr m expr - | Pexp_poly ({pexp_desc= Pexp_constraint (e, Some t, []); _}, None) -> - m.expr m {exp with pexp_desc= Pexp_poly (e, Some t)} - | Pexp_constraint (exp1, None, _ :: _) when erase_jane_syntax -> - (* When erasing jane syntax, if [Pexp_constraint] was only - constraining based on modes, remove the node entirely instead of - just making the modes list empty *) - m.expr m exp1 - | Pexp_constraint (e, Some {ptyp_desc= Ptyp_poly ([], _t); _}, []) -> - m.expr m e - | Pexp_sequence - ( exp1 - , { pexp_desc= Pexp_sequence (exp2, exp3) - ; pexp_loc= loc2 - ; pexp_attributes= attrs2 - ; _ } ) -> + match Jane_syntax.Expression.of_ast exp with + | Some + ( Jexp_layout + (Lexp_newtype + (l, jkind, {pexp_desc= Pexp_constraint (exp1, Some ty, []); _}) + ) + , attrs ) -> + (* CR jane-syntax: Special case where we transform a jane syntax + expression into a non-jane syntax expression, since jkind + annotations are in the parsetree for [Pparam_newtype] but not + [Pexp_newtype] *) + (* See comment on [Pexp_newtype] below *) m.expr m - (Exp.sequence ~loc:loc1 ~attrs:attrs1 - (Exp.sequence ~loc:loc2 ~attrs:attrs2 exp1 exp2) - exp3 ) - | Pexp_fun - ( Labelled l - , None - , { ppat_desc= - Ppat_constraint - ( pat - , Some - {ptyp_desc= Ptyp_extension ({txt= "call_pos"; loc}, _); _} - , _ ) - ; _ } - , expression ) - when erase_jane_syntax -> - let default_pos = dummy_position ~loc in - let expression = - let pexp_desc = - Pexp_fun (Optional l, Some default_pos, pat, expression) + { exp with + pexp_attributes= attrs + ; pexp_desc= + Pexp_function + ( [ { pparam_loc= l.loc + ; pparam_desc= Pparam_newtype (l, Some jkind) } ] + , Some {mode_annotations= []; type_constraint= Pconstraint ty} + , Pfunction_body exp1 ) } + | _ -> ( + match pexp_desc with + | Pexp_apply + ( {pexp_desc= Pexp_extension ({txt= "extension.exclave"; _}, _); _} + , [(Nolabel, expr)] ) + when erase_jane_syntax -> + m.expr m expr + | Pexp_poly ({pexp_desc= Pexp_constraint (e, Some t, []); _}, None) -> + m.expr m {exp with pexp_desc= Pexp_poly (e, Some t)} + | Pexp_constraint (exp1, None, _ :: _) when erase_jane_syntax -> + (* When erasing jane syntax, if [Pexp_constraint] was only + constraining based on modes, remove the node entirely instead of + just making the modes list empty *) + m.expr m exp1 + | Pexp_constraint (e, Some {ptyp_desc= Ptyp_poly ([], _t); _}, []) -> + m.expr m e + | Pexp_sequence + ( exp1 + , { pexp_desc= Pexp_sequence (exp2, exp3) + ; pexp_loc= loc2 + ; pexp_attributes= attrs2 + ; _ } ) -> + m.expr m + (Exp.sequence ~loc:loc1 ~attrs:attrs1 + (Exp.sequence ~loc:loc2 ~attrs:attrs2 exp1 exp2) + exp3 ) + | Pexp_function + ( ps + , c + , Pfunction_body {pexp_desc= Pexp_function (ps', None, b'); _} ) -> + m.expr m {exp with pexp_desc= Pexp_function (ps @ ps', c, b')} + | Pexp_newtype (l, {pexp_desc= Pexp_constraint (exp1, Some ty, []); _}) + -> + (* This is a hack. Our version of ocamlformat rewrites [fun (type + a) -> (function x -> x)] into [fun (type a) -> function x -> x], + but these two things parse differently by design. We shouldn't + do this, but have decided to avoid making ocamlformat work + sanely for syntactic function arity until upstream does. We + should delete this, and other similar bits of normalization, + when we merge with 5.2 ocamlforamt. *) + m.expr m + { exp with + pexp_desc= + Pexp_function + ( [ { pparam_loc= l.loc + ; pparam_desc= Pparam_newtype (l, None) } ] + , Some + {mode_annotations= []; type_constraint= Pconstraint ty} + , Pfunction_body exp1 ) } + | Pexp_function + ( ps + , c + , Pfunction_body {pexp_desc= Pexp_constraint (exp1, Some ty, []); _} + ) + when Option.is_none c -> + let c = + Some {mode_annotations= []; type_constraint= Pconstraint ty} in - {exp with pexp_desc} - in - m.expr m expression - | Pexp_extension ({txt= "src_pos"; loc}, _) when erase_jane_syntax -> - m.expr m (dummy_position ~loc) - | Pexp_fun _ | Pexp_function _ | Pexp_newtype _ -> - (* CR jane-syntax: This just ignores N_ary functions, and can be - removed when ocamlformat stops messing with them *) - let attrs1 = - List.filter ~f:(fun a -> not (is_builtin_jane_syntax a)) attrs1 - in - Ast_mapper.default_mapper.expr m {exp with pexp_attributes= attrs1} - | _ -> Ast_mapper.default_mapper.expr m exp + m.expr m + {exp with pexp_desc= Pexp_function (ps, c, Pfunction_body exp1)} + | Pexp_function (ps, c, b) when erase_jane_syntax -> + let ps = + List.map ps ~f:(fun param -> + match param.pparam_desc with + | Pparam_newtype (x, Some _) -> + {param with pparam_desc= Pparam_newtype (x, None)} + | Pparam_val + ( Labelled l + , None + , { ppat_desc= + Ppat_constraint + ( pat + , Some + { ptyp_desc= + Ptyp_extension ({txt= "call_pos"; loc}, _) + ; _ } + , _ ) + ; _ } ) -> + let default_pos = dummy_position ~loc in + { param with + pparam_desc= + Pparam_val (Optional l, Some default_pos, pat) } + | _ -> param ) + in + Ast_mapper.default_mapper.expr m + {exp with pexp_desc= Pexp_function (ps, c, b)} + | Pexp_extension ({txt= "src_pos"; loc}, _) when erase_jane_syntax -> + m.expr m (dummy_position ~loc) + | _ -> Ast_mapper.default_mapper.expr m exp ) in let pat (m : Ast_mapper.mapper) pat = let pat = {pat with ppat_loc_stack= []} in diff --git a/test/passing/dune.inc b/test/passing/dune.inc index 713e050462..671d7dba77 100644 --- a/test/passing/dune.inc +++ b/test/passing/dune.inc @@ -4301,6 +4301,42 @@ (package ocamlformat) (action (diff tests/fun_function.ml.js-err fun_function.ml.js-stderr))) +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-stdout-to function_constraint.ml.stdout + (with-stderr-to function_constraint.ml.stderr + (run %{bin:ocamlformat} --margin-check --max-iters=5 %{dep:tests/function_constraint.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/function_constraint.ml.ref function_constraint.ml.stdout))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/function_constraint.ml.err function_constraint.ml.stderr))) + +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-stdout-to function_constraint.ml.js-stdout + (with-stderr-to function_constraint.ml.js-stderr + (run %{bin:ocamlformat} --profile=janestreet --enable-outside-detected-project --disable-conf-files %{dep:tests/function_constraint.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/function_constraint.ml.js-ref function_constraint.ml.js-stdout))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/function_constraint.ml.js-err function_constraint.ml.js-stderr))) + (rule (deps tests/.ocamlformat ) (package ocamlformat) diff --git a/test/passing/tests/function_constraint.ml b/test/passing/tests/function_constraint.ml new file mode 100644 index 0000000000..86b6e34f99 --- /dev/null +++ b/test/passing/tests/function_constraint.ml @@ -0,0 +1,133 @@ +(* RHS annotated with a type *) +let f (type a) = (() : unit) +let (* 1 *) f (* 2 *) (type a) (* 3 *) = (* 4 *) + (* 5 *) ((* 6 *) () (* 7 *) : (* 8 *) unit (* 9 *)) (* 10 *) +let[@a1] f (type a) = (()[@a2] : unit[@a3]) + +let f (type a : immediate) = (() : unit) +let (* 1 *) f (type a (* 2 *) : (* 3 *) immediate (* 4 *)) (* 5 *) = (* 6 *) + (* 7 *) ( (* 8 *) () (* 9 *) : (* 10 *) unit (* 11 *) ) (* 12 *) +let[@a1] f (type a : immediate) = (()[@a2] : unit[@a3]) + +let f x y = (() : unit) +let (* 1 *) f (* 2 *) x (* 3 *) y (* 4 *) = + (* 5 *) ((* 6 *)() (* 7 *) : (* 8 *) unit (* 9 *)) (* 10 *) +let[@a1] f (x[@a2]) (y[@a3]) = (()[@a4] : unit[@a5]) + +(* RHS annotated with a type and mode *) +let f (type a) = (() : unit @@ local) +let (* 1 *) f (* 2 *) ((* 3 *) type (* 4 *) a (* 5 *)) (* 6 *) = (* 7 *) + (* 8 *) ( (* 9 *) () : (* 10 *) unit (* 11 *) @@ (* 12 *) local (* 13 *) ) +let[@a1] f (type a) = (()[@a2] : unit [@a3] @@ local) + +let f (type a : value) = (() : unit @@ local) +let (* 1 *) f (* 2 *) ((* 3 *) type (* 4 *) a (* 5 *) : (* 6 *) value (* 7 *)) (* 8 *) = + (* 9 *) ((* 10 *) () (* 11 *) : (* 12 *) unit (* 13 *) @@ (* 14 *) local (* 15 *)) + (* 16 *) +let[@a1] f (type a : value) = (()[@a2] : unit[@a3] @@ local) + +let f x y = (() : unit @@ local) +let (* 1 *) f (* 2 *) x (* 3 *) y (* 4 *) = (* 5 *) + ((* 6 *) () (* 7 *) : (* 8 *) unit (* 9 *) @@ (* 10 *) local (* 11 *)) (* 12 *) +let[@a1] f (x[@a2]) (y[@a3]) = (()[@a4] : unit[@a5] @@ local) + +(* LHS and RHS annotated with the same type *) +let f (type a) : unit = (() : unit) +let (* 1 *) f (* 2 *) ((* 3 *) type (* 4 *) a (* 5 *)) (* 6 *) : (* 7 *) unit (* 8 *) = + (* 9 *) ((* 10 *) () (* 11 *) : (* 12 *) unit (* 13 *)) (* 14 *) +let[@a1] f (type a) : unit[@a2] = (()[@a3] : unit[@a4]) + +let f (type a : value) : unit = (() : unit) +let (* 1 *) f (* 2 *) ((* 3 *) type (* 4 *) a (* 5 *) : (* 6 *) value (* 7 *)) (* 8 *) + : (* 9 *) unit (* 10 *) = + (* 11 *) ((* 12 *) () (* 13 *) : (* 14 *) unit (* 15 *)) (* 16 *) +let[@a1] f (type a : value) : unit[@a2] = (()[@a3] : unit[@a4]) + +let f x y : unit = (() : unit) +let (* 1 *) f (* 2 *) x (* 3 *) y (* 4 *) : (* 5 *) unit (* 6 *) = + (* 7 *) ((* 8 *) () (* 9 *) : (* 10 *) unit (* 11 *)) (* 12 *) +let[@a1] f (x[@a2]) (y[@a3]) : unit[@a4] = (()[@a5] : unit[@a6]) + +(* LHS and RHS annotated with different types *) +let f (type a) : unit = (() : int) +let (* 1 *) f (* 2 *) ((* 3 *) type (* 4 *) a (* 5 *)) (* 6 *) : (* 7 *) unit (* 8 *) = + (* 9 *) ((* 10 *) () (* 11 *) : (* 12 *) int (* 13 *)) (* 14 *) +let[@a1] f (type a) : unit[@a2] = (()[@a3] : int[@a4]) + +let f (type a : value) : unit = (() : int) +let (* 1 *) f (* 2 *) ((* 3 *) type (* 4 *) a (* 5 *) : (* 6 *) value (* 7 *)) (* 8 *) + : (* 9 *) unit (* 10 *) = + (* 11 *) ((* 12 *) () (* 13 *) : (* 14 *) int (* 15 *)) (* 16 *) +let[@a1] f (type a : value) : unit[@a2] = (()[@a3] : int[@a4]) + +let f x y : unit = (() : int) +let (* 1 *) f (* 2 *) x (* 3 *) y (* 4 *) : (* 5 *) unit (* 6 *) = + (* 7 *) ( (* 8 *) () (* 9 *) : (* 10 *) int (* 11 *) ) (* 12 *) +let[@a1] f (x[@a2]) (y[@a3]) : unit[@a4] = (()[@a5] : int[@a6]) + +(* LHS annotated with a mode, RHS annotated with a type *) +let (f @ local) (type a) = (() : unit) +let (* 1 *) ((* 2 *) f (* 3 *) @ (* 4 *) local (* 5 *)) + (* 6 *) ((* 7 *) type (* 8 *) a (* 9 *) ) (* 10 *) = + (* 11 *) ((* 12 *) () (* 13 *) : (* 14 *) unit (* 15 *)) (* 16 *) +let[@a1] (f @ local) (type a) = (()[@a2] : unit[@a3]) + +let (f @ local) (type a : value) = (() : unit) +let (* 1 *) ((* 2 *) f (* 3 *) @ (* 4 *) local (* 5 *)) (* 6 *) + ((* 7 *) type (* 8 *) a (* 9 *) : (* 10 *) value (* 11 *)) (* 12 *) = + (* 13 *) ((* 14 *) () (* 15 *) : (* 16 *) unit (* 17 *)) (* 18 *) +let[@a1] (f @ local) (type a : value) = (()[@a2] : unit[@a3]) + +let (f @ local) x y = (() : unit) +let (* 1 *) ((* 2 *) f (* 3 *) @ (* 4 *) local (* 5 *)) (* 6 *) x (* 7 *) y (* 8 *) = + (* 9 *) ((* 10 *) () (* 11 *) : (* 12 *) unit (* 13 *) ) (* 14 *) +let[@a1] (f @ local) (x[@a2]) (y[@a3]) = (()[@a4] : unit[@a5]) + +(* Nested funs *) +let _ = f (fun x -> fun y -> z) +let (* 1 *) _ (* 2 *) = + (* 3 *) f (* 4 *) ((* 5 *) fun (* 6 *) x (* 7 *) -> + (* 8 *) fun (* 9 *) y (* 10 *) -> (* 11 *) z (* 12 *) ) (* 13 *) +let[@a1] _ = (f[@a2]) (fun (x[@a3]) -> fun (y[@a4]) -> z[@a5]) + +let _ = f (fun x : unit -> fun y -> z) +let (* 1 *) _ (* 2 *) = + (* 3 *) f (* 4 *) ((* 5 *) fun (* 6 *) x (* 7 *) : (* 8 *) unit (* 9 *) -> + (* 10 *) fun (* 11 *) y (* 12 *) -> (* 13 *) z (* 14 *)) (* 15 *) +let[@a1] _ = (f[@a2]) (fun (x[@a3]) : (unit[@a4]) -> fun (y[@a5]) -> z[@a6]) + +let _ = f (fun x -> fun y : unit -> z) +let (* 1 *) _ (* 2 *) = + (* 3 *) f (* 4 *) ((* 5*) fun (* 6 *) x (* 7 *) -> + (* 8 *) fun (* 9 *) y (* 10 *) : (* 11 *) unit (* 12 *) -> (* 13 *) z (* 14 *)) (* 15 *) +let[@a1] _ = (f[@a2]) (fun (x[@a3]) -> fun (y[@a4]) : (unit[@a5]) -> z[@a6]) + +let _ = f (fun x : unit -> fun y : unit -> z) +let (* 1 *) _ (* 2 *) = + (* 3 *) f (* 4 *) ((* 5*) fun (* 6 *) x (* 7 *) : (* 8 *) unit (* 9 *) -> + (* 10 *) fun (* 11 *) y (* 12 *) : (* 13 *) unit (* 14 *) -> (* 15 *) z) + (* 17 *) +let[@a1] _ = (f[@a2]) (fun (x[@a3]) : (unit[@a4]) -> fun (y[@a5]) : (unit[@a6]) -> z[@a7]) + +(* CR: Some of the comment movement above are kind of sad. For + example this: + let f (* 2 *) (type (* 3 *) a) = (() : unit @@ local) + becomes: + let f (type (* 3 *) a) = (* 2 *) (() : unit @@ local) + + Why does (* 2 *) get moved out to the rhs? *) + +(* CR: there is a live bug that drops [@a4] in examples like + + let f (type a) = (() : unit) [@a4] + + Add that attribute back to the relevant examples in this file once the bug is fixed. +*) +(* CR the last comments test in this file seems to hit some scale limitation. If you add + back the "missing" (* 16 *) after [z], ocamlformat hits its iteration limit: + +let (* 1 *) _ (* 2 *) = + (* 3 *) f (* 4 *) ((* 5*) fun (* 6 *) x (* 7 *) : (* 8 *) unit (* 9 *) -> + (* 10 *) fun (* 11 *) y (* 12 *) : (* 13 *) unit (* 14 *) -> (* 15 *) z (* 16 *)) + (* 17 *) +*) diff --git a/test/passing/tests/function_constraint.ml.err b/test/passing/tests/function_constraint.ml.err new file mode 100644 index 0000000000..2f088ac897 --- /dev/null +++ b/test/passing/tests/function_constraint.ml.err @@ -0,0 +1,4 @@ +Warning: tests/function_constraint.ml:307 exceeds the margin +Warning: tests/function_constraint.ml:309 exceeds the margin +Warning: tests/function_constraint.ml:310 exceeds the margin +Warning: tests/function_constraint.ml:314 exceeds the margin diff --git a/test/passing/tests/function_constraint.ml.js-ref b/test/passing/tests/function_constraint.ml.js-ref new file mode 100644 index 0000000000..39f733495a --- /dev/null +++ b/test/passing/tests/function_constraint.ml.js-ref @@ -0,0 +1,358 @@ +(* RHS annotated with a type *) +let f (type a) : unit = () + +let (* 1 *) f (type a) : (* 8 *) unit (* 9 *) = + (* 2 *) + (* 3 *) + (* 4 *) + (* 5 *) + (* 6 *) + () +;; + +(* 7 *) + +(* 10 *) + +let[@a1] f (type a) : (unit[@a3]) = () [@a2] +let f (type a : immediate) : unit = () + +let (* 1 *) f (type a (* 2 *) : (* 3 *) immediate (* 4 *)) : (* 10 *) unit (* 11 *) = + (* 5 *) + (* 6 *) + (* 7 *) + (* 8 *) + () +;; + +(* 9 *) + +(* 12 *) + +let[@a1] f (type a : immediate) : (unit[@a3]) = () [@a2] +let f x y : unit = () + +let (* 1 *) f (* 2 *) x (* 3 *) y : (* 8 *) unit (* 9 *) = + (* 4 *) + (* 5 *) + (* 6 *) + () +;; + +(* 7 *) + +(* 10 *) + +let[@a1] f (x [@a2]) (y [@a3]) : (unit[@a5]) = () [@a4] + +(* RHS annotated with a type and mode *) +let f (type a) = (() : unit @@ local) + +let (* 1 *) f + (type (* 3 *) + (* 4 *) + a (* 5 *)) + = + (* 2 *) + (* 6 *) + (* 7 *) + (* 8 *) + ((* 9 *) () : (* 10 *) unit (* 11 *) @@ (* 12 *) local (* 13 *)) +;; + +let[@a1] f (type a) = (() [@a2] : (unit[@a3]) @@ local) +let f (type a : value) = (() : unit @@ local) + +let (* 1 *) f + (type (* 3 *) + (* 4 *) + a (* 5 *) : (* 6 *) value (* 7 *)) + = + (* 2 *) + (* 8 *) + (* 9 *) + ((* 10 *) () (* 11 *) : (* 12 *) unit (* 13 *) @@ (* 14 *) local (* 15 *)) +;; + +(* 16 *) + +let[@a1] f (type a : value) = (() [@a2] : (unit[@a3]) @@ local) +let f x y = (() : unit @@ local) + +let (* 1 *) f (* 2 *) x (* 3 *) y (* 4 *) = + (* 5 *) + ((* 6 *) () (* 7 *) : (* 8 *) unit (* 9 *) @@ (* 10 *) local (* 11 *)) +;; + +(* 12 *) + +let[@a1] f (x [@a2]) (y [@a3]) = (() [@a4] : (unit[@a5]) @@ local) + +(* LHS and RHS annotated with the same type *) +let f (type a) : unit = (() : unit) + +let (* 1 *) f + (type (* 3 *) + (* 4 *) + a (* 5 *)) + : (* 7 *) unit (* 8 *) + = + (* 2 *) + (* 6 *) + (* 9 *) + ((* 10 *) () (* 11 *) : (* 12 *) unit (* 13 *)) +;; + +(* 14 *) + +let[@a1] f (type a) : (unit[@a2]) = (() [@a3] : (unit[@a4])) +let f (type a : value) : unit = (() : unit) + +let (* 1 *) f + (type (* 3 *) + (* 4 *) + a (* 5 *) : (* 6 *) value (* 7 *)) + : (* 9 *) unit (* 10 *) + = + (* 2 *) + (* 8 *) + + (* 11 *) + ((* 12 *) () (* 13 *) : (* 14 *) unit (* 15 *)) +;; + +(* 16 *) + +let[@a1] f (type a : value) : (unit[@a2]) = (() [@a3] : (unit[@a4])) +let f x y : unit = (() : unit) + +let (* 1 *) f (* 2 *) x (* 3 *) y : (* 5 *) unit (* 6 *) = + (* 4 *) + (* 7 *) + ((* 8 *) () (* 9 *) : (* 10 *) unit (* 11 *)) +;; + +(* 12 *) + +let[@a1] f (x [@a2]) (y [@a3]) : (unit[@a4]) = (() [@a5] : (unit[@a6])) + +(* LHS and RHS annotated with different types *) +let f (type a) : unit = (() : int) + +let (* 1 *) f + (type (* 3 *) + (* 4 *) + a (* 5 *)) + : (* 7 *) unit (* 8 *) + = + (* 2 *) + (* 6 *) + (* 9 *) + ((* 10 *) () (* 11 *) : (* 12 *) int (* 13 *)) +;; + +(* 14 *) + +let[@a1] f (type a) : (unit[@a2]) = (() [@a3] : (int[@a4])) +let f (type a : value) : unit = (() : int) + +let (* 1 *) f + (type (* 3 *) + (* 4 *) + a (* 5 *) : (* 6 *) value (* 7 *)) + : (* 9 *) unit (* 10 *) + = + (* 2 *) + (* 8 *) + + (* 11 *) + ((* 12 *) () (* 13 *) : (* 14 *) int (* 15 *)) +;; + +(* 16 *) + +let[@a1] f (type a : value) : (unit[@a2]) = (() [@a3] : (int[@a4])) +let f x y : unit = (() : int) + +let (* 1 *) f (* 2 *) x (* 3 *) y : (* 5 *) unit (* 6 *) = + (* 4 *) + (* 7 *) + ((* 8 *) () (* 9 *) : (* 10 *) int (* 11 *)) +;; + +(* 12 *) + +let[@a1] f (x [@a2]) (y [@a3]) : (unit[@a4]) = (() [@a5] : (int[@a6])) + +(* LHS annotated with a mode, RHS annotated with a type *) +let (f @ local) (type a) : unit = () + +let + ((* 1 *) + (* 2 *) f (* 3 *) @ (* 4 *) local (* 5 *)) + (type (* 7 *) + (* 8 *) + a (* 9 *)) + : (* 14 *) unit (* 15 *) + = + (* 6 *) + (* 10 *) + (* 11 *) + (* 12 *) + () +;; + +(* 13 *) + +(* 16 *) + +let[@a1] (f @ local) (type a) : (unit[@a3]) = () [@a2] +let (f @ local) (type a : value) : unit = () + +let + ((* 1 *) + (* 2 *) f (* 3 *) @ (* 4 *) local (* 5 *)) + (type (* 7 *) + (* 8 *) + a (* 9 *) : (* 10 *) value (* 11 *)) + : (* 16 *) unit (* 17 *) + = + (* 6 *) + (* 12 *) + (* 13 *) + (* 14 *) + () +;; + +(* 15 *) + +(* 18 *) + +let[@a1] (f @ local) (type a : value) : (unit[@a3]) = () [@a2] +let (f @ local) x y : unit = () + +let + ((* 1 *) + (* 2 *) f (* 3 *) @ (* 4 *) local (* 5 *)) + (* 6 *) x + (* 7 *) y (* 8 *) + : (* 12 *) unit (* 13 *) + = + (* 9 *) + (* 10 *) + () +;; + +(* 11 *) + +(* 14 *) + +let[@a1] (f @ local) (x [@a2]) (y [@a3]) : (unit[@a5]) = () [@a4] + +(* Nested funs *) +let _ = f (fun x y -> z) + +let (* 1 *) _ (* 2 *) = + (* 3 *) + f + (* 4 *) + (fun + (* 5 *) + (* 6 *) x + (* 7 *) + (* 8 *) + (* 9 *) y (* 10 *) + -> (* 11 *) z (* 12 *)) +;; + +(* 13 *) + +let[@a1] _ = (f [@a2]) (fun (x [@a3]) (y [@a4]) -> z [@a5]) +let _ = f (fun x : unit -> fun y -> z) + +let (* 1 *) _ (* 2 *) = + (* 3 *) + f + (* 4 *) + (fun + (* 5 *) + (* 6 *) x + : (* 8 *) unit (* 9 *) + -> + (* 7 *) + (* 10 *) fun (* 11 *) y (* 12 *) -> (* 13 *) z (* 14 *)) +;; + +(* 15 *) + +let[@a1] _ = (f [@a2]) (fun (x [@a3]) : (unit[@a4]) -> fun (y [@a5]) -> z [@a6]) +let _ = f (fun x y : unit -> z) + +let (* 1 *) _ (* 2 *) = + (* 3 *) + f + (* 4 *) + (fun + (* 5*) + (* 6 *) x + (* 7 *) + (* 8 *) + (* 9 *) y + : (* 11 *) unit (* 12 *) + -> + (* 10 *) + (* 13 *) + z + (* 14 *)) +;; + +(* 15 *) + +let[@a1] _ = (f [@a2]) (fun (x [@a3]) (y [@a4]) : (unit[@a5]) -> z [@a6]) +let _ = f (fun x : unit -> fun y : unit -> z) + +let (* 1 *) _ (* 2 *) = + (* 3 *) + f + (* 4 *) + (fun + (* 5*) + (* 6 *) x + : (* 8 *) unit (* 9 *) + -> + (* 7 *) + (* 10 *) + fun (* 11 *) y : (* 13 *) unit (* 14 *) -> + (* 12 *) + (* 15 *) + z) +;; + +(* 17 *) + +let[@a1] _ = + (f [@a2]) (fun (x [@a3]) : (unit[@a4]) -> fun (y [@a5]) : (unit[@a6]) -> z [@a7]) +;; + +(* CR: Some of the comment movement above are kind of sad. For + example this: + let f (* 2 *) (type (* 3 *) a) = (() : unit @@ local) + becomes: + let f (type (* 3 *) a) = (* 2 *) (() : unit @@ local) + + Why does (* 2 *) get moved out to the rhs? *) + +(* CR: there is a live bug that drops [@a4] in examples like + + let f (type a) = (() : unit) [@a4] + + Add that attribute back to the relevant examples in this file once the bug is fixed. +*) +(* CR the last comments test in this file seems to hit some scale limitation. If you add + back the "missing" (* 16 *) after [z], ocamlformat hits its iteration limit: + +let (* 1 *) _ (* 2 *) = + (* 3 *) f (* 4 *) ((* 5*) fun (* 6 *) x (* 7 *) : (* 8 *) unit (* 9 *) -> + (* 10 *) fun (* 11 *) y (* 12 *) : (* 13 *) unit (* 14 *) -> (* 15 *) z (* 16 *)) + (* 17 *) +*) diff --git a/test/passing/tests/function_constraint.ml.opts b/test/passing/tests/function_constraint.ml.opts new file mode 100644 index 0000000000..559617f4de --- /dev/null +++ b/test/passing/tests/function_constraint.ml.opts @@ -0,0 +1 @@ +--max-iters=5 diff --git a/test/passing/tests/function_constraint.ml.ref b/test/passing/tests/function_constraint.ml.ref new file mode 100644 index 0000000000..fb96634b6d --- /dev/null +++ b/test/passing/tests/function_constraint.ml.ref @@ -0,0 +1,317 @@ +(* RHS annotated with a type *) +let f (type a) : unit = () + +let (* 1 *) f (type a) : (* 8 *) unit (* 9 *) = + (* 2 *) + (* 3 *) + (* 4 *) + (* 5 *) + (* 6 *) + () +(* 7 *) +(* 10 *) + +let[@a1] f (type a) : (unit[@a3]) = () [@a2] + +let f (type a : immediate) : unit = () + +let (* 1 *) f (type a (* 2 *) : (* 3 *) immediate (* 4 *)) : + (* 10 *) unit (* 11 *) = + (* 5 *) + (* 6 *) + (* 7 *) + (* 8 *) + () +(* 9 *) +(* 12 *) + +let[@a1] f (type a : immediate) : (unit[@a3]) = () [@a2] + +let f x y : unit = () + +let (* 1 *) f (* 2 *) x (* 3 *) y : (* 8 *) unit (* 9 *) = + (* 4 *) + (* 5 *) + (* 6 *) + () +(* 7 *) +(* 10 *) + +let[@a1] f (x [@a2]) (y [@a3]) : (unit[@a5]) = () [@a4] + +(* RHS annotated with a type and mode *) +let f (type a) = (() : unit @@ local) + +let (* 1 *) f + (type (* 3 *) + (* 4 *) + a (* 5 *) ) = + (* 2 *) + (* 6 *) + (* 7 *) + (* 8 *) + ((* 9 *) () : (* 10 *) unit (* 11 *) @@ (* 12 *) local (* 13 *)) + +let[@a1] f (type a) = (() [@a2] : (unit[@a3]) @@ local) + +let f (type a : value) = (() : unit @@ local) + +let (* 1 *) f + (type (* 3 *) + (* 4 *) + a (* 5 *) : (* 6 *) value (* 7 *) ) = + (* 2 *) + (* 8 *) + (* 9 *) + ((* 10 *) () (* 11 *) : (* 12 *) unit (* 13 *) @@ (* 14 *) local (* 15 *)) +(* 16 *) + +let[@a1] f (type a : value) = (() [@a2] : (unit[@a3]) @@ local) + +let f x y = (() : unit @@ local) + +let (* 1 *) f (* 2 *) x (* 3 *) y (* 4 *) = + (* 5 *) + ((* 6 *) () (* 7 *) : (* 8 *) unit (* 9 *) @@ (* 10 *) local (* 11 *)) +(* 12 *) + +let[@a1] f (x [@a2]) (y [@a3]) = (() [@a4] : (unit[@a5]) @@ local) + +(* LHS and RHS annotated with the same type *) +let f (type a) : unit = (() : unit) + +let (* 1 *) f + (type (* 3 *) + (* 4 *) + a (* 5 *) ) : (* 7 *) unit (* 8 *) = + (* 2 *) + (* 6 *) + (* 9 *) + ((* 10 *) () (* 11 *) : (* 12 *) unit (* 13 *)) +(* 14 *) + +let[@a1] f (type a) : (unit[@a2]) = (() [@a3] : (unit[@a4])) + +let f (type a : value) : unit = (() : unit) + +let (* 1 *) f + (type (* 3 *) + (* 4 *) + a (* 5 *) : (* 6 *) value (* 7 *) ) : (* 9 *) unit (* 10 *) = + (* 2 *) + (* 8 *) + + (* 11 *) + ((* 12 *) () (* 13 *) : (* 14 *) unit (* 15 *)) +(* 16 *) + +let[@a1] f (type a : value) : (unit[@a2]) = (() [@a3] : (unit[@a4])) + +let f x y : unit = (() : unit) + +let (* 1 *) f (* 2 *) x (* 3 *) y : (* 5 *) unit (* 6 *) = + (* 4 *) + (* 7 *) + ((* 8 *) () (* 9 *) : (* 10 *) unit (* 11 *)) +(* 12 *) + +let[@a1] f (x [@a2]) (y [@a3]) : (unit[@a4]) = (() [@a5] : (unit[@a6])) + +(* LHS and RHS annotated with different types *) +let f (type a) : unit = (() : int) + +let (* 1 *) f + (type (* 3 *) + (* 4 *) + a (* 5 *) ) : (* 7 *) unit (* 8 *) = + (* 2 *) + (* 6 *) + (* 9 *) + ((* 10 *) () (* 11 *) : (* 12 *) int (* 13 *)) +(* 14 *) + +let[@a1] f (type a) : (unit[@a2]) = (() [@a3] : (int[@a4])) + +let f (type a : value) : unit = (() : int) + +let (* 1 *) f + (type (* 3 *) + (* 4 *) + a (* 5 *) : (* 6 *) value (* 7 *) ) : (* 9 *) unit (* 10 *) = + (* 2 *) + (* 8 *) + + (* 11 *) + ((* 12 *) () (* 13 *) : (* 14 *) int (* 15 *)) +(* 16 *) + +let[@a1] f (type a : value) : (unit[@a2]) = (() [@a3] : (int[@a4])) + +let f x y : unit = (() : int) + +let (* 1 *) f (* 2 *) x (* 3 *) y : (* 5 *) unit (* 6 *) = + (* 4 *) + (* 7 *) + ((* 8 *) () (* 9 *) : (* 10 *) int (* 11 *)) +(* 12 *) + +let[@a1] f (x [@a2]) (y [@a3]) : (unit[@a4]) = (() [@a5] : (int[@a6])) + +(* LHS annotated with a mode, RHS annotated with a type *) +let (f @ local) (type a) : unit = () + +let + ((* 1 *) + (* 2 *) f (* 3 *) @ (* 4 *) local (* 5 *)) + (type (* 7 *) + (* 8 *) + a (* 9 *) ) : (* 14 *) unit (* 15 *) = + (* 6 *) + (* 10 *) + (* 11 *) + (* 12 *) + () +(* 13 *) +(* 16 *) + +let[@a1] (f @ local) (type a) : (unit[@a3]) = () [@a2] + +let (f @ local) (type a : value) : unit = () + +let + ((* 1 *) + (* 2 *) f (* 3 *) @ (* 4 *) local (* 5 *)) + (type (* 7 *) + (* 8 *) + a (* 9 *) : (* 10 *) value (* 11 *) ) : (* 16 *) unit (* 17 *) = + (* 6 *) + (* 12 *) + (* 13 *) + (* 14 *) + () +(* 15 *) +(* 18 *) + +let[@a1] (f @ local) (type a : value) : (unit[@a3]) = () [@a2] + +let (f @ local) x y : unit = () + +let + ((* 1 *) + (* 2 *) f (* 3 *) @ (* 4 *) local (* 5 *)) (* 6 *) x (* 7 *) y : + (* 12 *) unit (* 13 *) = + (* 8 *) + + (* 9 *) + (* 10 *) + () +(* 11 *) +(* 14 *) + +let[@a1] (f @ local) (x [@a2]) (y [@a3]) : (unit[@a5]) = () [@a4] + +(* Nested funs *) +let _ = f (fun x y -> z) + +let (* 1 *) _ (* 2 *) = + (* 3 *) + f + (* 4 *) + (fun + (* 5 *) + (* 6 *) x + (* 7 *) + (* 8 *) + (* 9 *) y (* 10 *) + -> (* 11 *) z (* 12 *) ) +(* 13 *) + +let[@a1] _ = (f [@a2]) (fun (x [@a3]) (y [@a4]) -> z [@a5]) + +let _ = f (fun x : unit -> fun y -> z) + +let (* 1 *) _ (* 2 *) = + (* 3 *) + f + (* 4 *) + (fun + (* 5 *) + (* 6 *) x + : + (* 8 *) unit (* 9 *) + -> + (* 7 *) + (* 10 *) + fun (* 11 *) y (* 12 *) -> (* 13 *) z (* 14 *) ) +(* 15 *) + +let[@a1] _ = + (f [@a2]) (fun (x [@a3]) : (unit[@a4]) -> fun (y [@a5]) -> z [@a6]) + +let _ = f (fun x y : unit -> z) + +let (* 1 *) _ (* 2 *) = + (* 3 *) + f + (* 4 *) + (fun + (* 5*) + (* 6 *) x + (* 7 *) + (* 8 *) + (* 9 *) y + : + (* 11 *) unit (* 12 *) + -> + (* 10 *) + (* 13 *) + z + (* 14 *) ) +(* 15 *) + +let[@a1] _ = (f [@a2]) (fun (x [@a3]) (y [@a4]) : (unit[@a5]) -> z [@a6]) + +let _ = f (fun x : unit -> fun y : unit -> z) + +let (* 1 *) _ (* 2 *) = + (* 3 *) + f + (* 4 *) + (fun + (* 5*) + (* 6 *) x + : + (* 8 *) unit (* 9 *) + -> + (* 7 *) + (* 10 *) + fun (* 11 *) y : (* 13 *) unit (* 14 *) -> + (* 12 *) + (* 15 *) + z ) +(* 17 *) + +let[@a1] _ = + (f [@a2]) (fun (x [@a3]) : (unit[@a4]) -> fun (y [@a5]) : (unit[@a6]) -> + z [@a7] ) + +(* CR: Some of the comment movement above are kind of sad. For example this: + let f (* 2 *) (type (* 3 *) a) = (() : unit @@ local) becomes: let f (type + (* 3 *) a) = (* 2 *) (() : unit @@ local) + + Why does (* 2 *) get moved out to the rhs? *) + +(* CR: there is a live bug that drops [@a4] in examples like + + let f (type a) = (() : unit) [@a4] + + Add that attribute back to the relevant examples in this file once the bug is fixed. +*) +(* CR the last comments test in this file seems to hit some scale limitation. If you add + back the "missing" (* 16 *) after [z], ocamlformat hits its iteration limit: + +let (* 1 *) _ (* 2 *) = + (* 3 *) f (* 4 *) ((* 5*) fun (* 6 *) x (* 7 *) : (* 8 *) unit (* 9 *) -> + (* 10 *) fun (* 11 *) y (* 12 *) : (* 13 *) unit (* 14 *) -> (* 15 *) z (* 16 *)) + (* 17 *) +*) diff --git a/vendor/ocaml-common/location.ml b/vendor/ocaml-common/location.ml index 71caf20121..e6ad7b9034 100644 --- a/vendor/ocaml-common/location.ml +++ b/vendor/ocaml-common/location.ml @@ -110,6 +110,27 @@ let rhs_interval m n = { let get_pos_info pos = (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol) +let merge ?(ghost = true) locs = + let hd, tl = + match locs with + | hd :: tl -> hd, tl + | [] -> failwith "Compiler bug: Called [Location.merge] with an empty list" + in + List.fold_left + (fun acc x -> + let loc_start = + if compare_position x.loc_start acc.loc_start < 0 + then x.loc_start else acc.loc_start + in + let loc_end = + if compare_position x.loc_end acc.loc_end > 0 + then x.loc_end else acc.loc_end + in + let loc_ghost = x.loc_ghost || acc.loc_ghost in + { loc_start; loc_end; loc_ghost }) + { hd with loc_ghost = hd.loc_ghost || ghost } + tl + type 'a loc = { txt : 'a; loc : t; diff --git a/vendor/ocaml-common/location.mli b/vendor/ocaml-common/location.mli index f61e2945db..3fb620d6eb 100644 --- a/vendor/ocaml-common/location.mli +++ b/vendor/ocaml-common/location.mli @@ -91,6 +91,13 @@ val rhs_interval: int -> int -> t val get_pos_info: Lexing.position -> string * int * int (** file, line, char *) +(** [merge locs] returns the location covering all locations from [locs]. It raises if + [locs] is empty, and the result only makes sense if all the locations are from the + same file. If [~ghost:false] is passed, the result location will only be ghost if one + of the input locations was ghost. The default is [~ghost:true], which causes the + result location to be ghost no matter what *) +val merge: ?ghost:bool -> t list -> t + type 'a loc = { txt : 'a; loc : t; diff --git a/vendor/ocaml-common/warnings.ml b/vendor/ocaml-common/warnings.ml index 5b2661e92b..ba5f9a1e43 100644 --- a/vendor/ocaml-common/warnings.ml +++ b/vendor/ocaml-common/warnings.ml @@ -123,7 +123,6 @@ type t = | Probe_name_too_long of string (* 190 *) | Unchecked_zero_alloc_attribute (* 199 *) | Unboxing_impossible (* 210 *) - | Redundant_modality of string (* 250 *) (* If you remove a warning, leave a hole in the numbering. NEVER change the numbers of existing warnings. @@ -211,7 +210,6 @@ let number = function | Probe_name_too_long _ -> 190 | Unchecked_zero_alloc_attribute -> 199 | Unboxing_impossible -> 210 - | Redundant_modality _ -> 250 ;; (* DO NOT REMOVE the ;; above: it is used by the testsuite/ests/warnings/mnemonics.mll test to determine where @@ -583,10 +581,6 @@ let descriptions = [ names = ["unboxing-impossible"]; description = "The parameter or return value corresponding @unboxed attribute cannot be unboxed."; since = since 4 14 }; - { number = 250; - names = ["redundant-modality"]; - description = "The modality is redundant."; - since = since 5 1 }; ] let name_to_number = @@ -1223,8 +1217,6 @@ let message = function Printf.sprintf "This [@unboxed] attribute cannot be used.\n\ The type of this value does not allow unboxing." - | Redundant_modality s -> - Printf.sprintf "This %s modality is redundant." s ;; let nerrors = ref 0 diff --git a/vendor/ocaml-common/warnings.mli b/vendor/ocaml-common/warnings.mli index f25b495aae..47aad271a2 100644 --- a/vendor/ocaml-common/warnings.mli +++ b/vendor/ocaml-common/warnings.mli @@ -124,7 +124,6 @@ type t = | Probe_name_too_long of string (* 190 *) | Unchecked_zero_alloc_attribute (* 199 *) | Unboxing_impossible (* 210 *) - | Redundant_modality of string (* 250 *) type alert = {kind:string; message:string; def:loc; use:loc} diff --git a/vendor/parser-jane/README.md b/vendor/parser-jane/README.md index f03ffa0a6f..968f3a595f 100644 --- a/vendor/parser-jane/README.md +++ b/vendor/parser-jane/README.md @@ -4,25 +4,26 @@ parser. The code is not used in `ocamlformat` at all; it only exists as a base to perform a merge off of. ## How to merge changes from the compiler's parser -*WARNING*: Currently, the version of the parser in `parser-jane/` is ahead of -the compiler's parser. Be careful about "downgrading" it, as it might break a -lot of the logic in `Normalize_std_ast.ml`. - ### "Manually" -First, in the `vendor/` directory, generate a patchfile +First, in the `vendor/` directory, generate patchfiles ``` -diff -ruN parser-jane/ parser-standard/ > changes.patch +diff -ruN parser-jane/for-parser-standard/ parser-standard/ > changes-parser.patch +diff -ruN parser-jane/for-ocaml-common/ ocaml-common/ > changes-common.patch ``` Then, update the files in `parser-jane/` by running the update script ``` ./parser-jane/update.sh {path-to-flambda-backend} ``` -Finally, create the new `parser-standard/` by copying `parser-jane/` and applying the patchfile +Finally, create the new `parser-standard/` and `ocaml-common/` by copying from +`parser-jane/` and applying the patchfiles ``` -rm -rf parser-standard/ -cp -r parser-jane/ parser-standard/ -patch -p1 -d parser-standard/ < changes.patch -rm changes.patch +rm -rf parser-standard/ ocaml-common/ +cp -r parser-jane/for-parser-standard parser-standard/ +cp -r parser-jane/for-ocaml-common ocaml-common/ +patch -p1 -d parser-standard/ < changes-parser.patch +patch -p1 -d ocaml-common/ < changes-common.patch +rm changes-parser.patch +rm changes-common.patch ``` ### With [repatch.sh] diff --git a/vendor/parser-jane/for-ocaml-common/location.ml b/vendor/parser-jane/for-ocaml-common/location.ml index 12e185deb8..8f6c008563 100644 --- a/vendor/parser-jane/for-ocaml-common/location.ml +++ b/vendor/parser-jane/for-ocaml-common/location.ml @@ -110,6 +110,27 @@ let rhs_interval m n = { let get_pos_info pos = (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol) +let merge ?(ghost = true) locs = + let hd, tl = + match locs with + | hd :: tl -> hd, tl + | [] -> failwith "Compiler bug: Called [Location.merge] with an empty list" + in + List.fold_left + (fun acc x -> + let loc_start = + if compare_position x.loc_start acc.loc_start < 0 + then x.loc_start else acc.loc_start + in + let loc_end = + if compare_position x.loc_end acc.loc_end > 0 + then x.loc_end else acc.loc_end + in + let loc_ghost = x.loc_ghost || acc.loc_ghost in + { loc_start; loc_end; loc_ghost }) + { hd with loc_ghost = hd.loc_ghost || ghost } + tl + type 'a loc = { txt : 'a; loc : t; diff --git a/vendor/parser-jane/for-ocaml-common/location.mli b/vendor/parser-jane/for-ocaml-common/location.mli index fa42348468..0069aefad5 100644 --- a/vendor/parser-jane/for-ocaml-common/location.mli +++ b/vendor/parser-jane/for-ocaml-common/location.mli @@ -91,6 +91,13 @@ val rhs_interval: int -> int -> t val get_pos_info: Lexing.position -> string * int * int (** file, line, char *) +(** [merge locs] returns the location covering all locations from [locs]. It raises if + [locs] is empty, and the result only makes sense if all the locations are from the + same file. If [~ghost:false] is passed, the result location will only be ghost if one + of the input locations was ghost. The default is [~ghost:true], which causes the + result location to be ghost no matter what *) +val merge: ?ghost:bool -> t list -> t + type 'a loc = { txt : 'a; loc : t; diff --git a/vendor/parser-jane/for-ocaml-common/warnings.ml b/vendor/parser-jane/for-ocaml-common/warnings.ml index 5b2661e92b..ba5f9a1e43 100644 --- a/vendor/parser-jane/for-ocaml-common/warnings.ml +++ b/vendor/parser-jane/for-ocaml-common/warnings.ml @@ -123,7 +123,6 @@ type t = | Probe_name_too_long of string (* 190 *) | Unchecked_zero_alloc_attribute (* 199 *) | Unboxing_impossible (* 210 *) - | Redundant_modality of string (* 250 *) (* If you remove a warning, leave a hole in the numbering. NEVER change the numbers of existing warnings. @@ -211,7 +210,6 @@ let number = function | Probe_name_too_long _ -> 190 | Unchecked_zero_alloc_attribute -> 199 | Unboxing_impossible -> 210 - | Redundant_modality _ -> 250 ;; (* DO NOT REMOVE the ;; above: it is used by the testsuite/ests/warnings/mnemonics.mll test to determine where @@ -583,10 +581,6 @@ let descriptions = [ names = ["unboxing-impossible"]; description = "The parameter or return value corresponding @unboxed attribute cannot be unboxed."; since = since 4 14 }; - { number = 250; - names = ["redundant-modality"]; - description = "The modality is redundant."; - since = since 5 1 }; ] let name_to_number = @@ -1223,8 +1217,6 @@ let message = function Printf.sprintf "This [@unboxed] attribute cannot be used.\n\ The type of this value does not allow unboxing." - | Redundant_modality s -> - Printf.sprintf "This %s modality is redundant." s ;; let nerrors = ref 0 diff --git a/vendor/parser-jane/for-ocaml-common/warnings.mli b/vendor/parser-jane/for-ocaml-common/warnings.mli index f25b495aae..47aad271a2 100644 --- a/vendor/parser-jane/for-ocaml-common/warnings.mli +++ b/vendor/parser-jane/for-ocaml-common/warnings.mli @@ -124,7 +124,6 @@ type t = | Probe_name_too_long of string (* 190 *) | Unchecked_zero_alloc_attribute (* 199 *) | Unboxing_impossible (* 210 *) - | Redundant_modality of string (* 250 *) type alert = {kind:string; message:string; def:loc; use:loc} diff --git a/vendor/parser-jane/for-parser-standard/ast_helper.ml b/vendor/parser-jane/for-parser-standard/ast_helper.ml index f097ea4beb..2d5a831f48 100644 --- a/vendor/parser-jane/for-parser-standard/ast_helper.ml +++ b/vendor/parser-jane/for-parser-standard/ast_helper.ml @@ -188,8 +188,7 @@ module Exp = struct let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) + let function_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_function (a, b, c)) let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) @@ -412,12 +411,12 @@ end module Val = struct let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) ?(modalities = []) name typ = + ?(prim = []) ?(modalities=[]) name typ = { pval_name = name; pval_type = typ; - pval_modalities = modalities; pval_attributes = add_docs_attrs docs attrs; + pval_modalities = modalities; pval_loc = loc; pval_prim = prim; } diff --git a/vendor/parser-jane/for-parser-standard/ast_mapper.ml b/vendor/parser-jane/for-parser-standard/ast_mapper.ml index 2c269089fb..36cdc16fc7 100644 --- a/vendor/parser-jane/for-parser-standard/ast_mapper.ml +++ b/vendor/parser-jane/for-parser-standard/ast_mapper.ml @@ -29,8 +29,8 @@ module String = Misc.Stdlib.String type mapper = { attribute: mapper -> attribute -> attribute; attributes: mapper -> attribute list -> attribute list; - modes : mapper -> mode loc list -> mode loc list; - modalities : mapper -> modality loc list -> modality loc list; + modes : mapper -> modes -> modes; + modalities : mapper -> modalities -> modalities; binding_op: mapper -> binding_op -> binding_op; case: mapper -> case -> case; cases: mapper -> case list -> case list; @@ -569,9 +569,40 @@ module E = struct module C = Jane_syntax.Comprehensions module IA = Jane_syntax.Immutable_arrays module L = Jane_syntax.Layouts - module N_ary = Jane_syntax.N_ary_functions module LT = Jane_syntax.Labeled_tuples + let map_function_param sub { pparam_loc = loc; pparam_desc = desc } = + let loc = sub.location sub loc in + let desc = + match desc with + | Pparam_val (label, def, pat) -> + Pparam_val (label, Option.map (sub.expr sub) def, sub.pat sub pat) + | Pparam_newtype (newtype, jkind) -> + Pparam_newtype + ( map_loc sub newtype + , map_opt (map_loc_txt sub sub.jkind_annotation) jkind + ) + in + { pparam_loc = loc; pparam_desc = desc } + + let map_function_body sub body = + match body with + | Pfunction_body exp -> Pfunction_body (sub.expr sub exp) + | Pfunction_cases (cases, loc, attrs) -> + Pfunction_cases + (sub.cases sub cases, sub.location sub loc, sub.attributes sub attrs) + + let map_type_constraint sub constraint_ = + match constraint_ with + | Pconstraint ty -> Pconstraint (sub.typ sub ty) + | Pcoerce (ty1, ty2) -> + Pcoerce (Option.map (sub.typ sub) ty1, sub.typ sub ty2) + + let map_function_constraint sub { mode_annotations; type_constraint } = + { mode_annotations = sub.modes sub mode_annotations; + type_constraint = map_type_constraint sub type_constraint; + } + let map_iterator sub : C.iterator -> C.iterator = function | Range { start; stop; direction } -> Range { start = sub.expr sub start; @@ -617,49 +648,6 @@ module E = struct let inner_expr = sub.expr sub inner_expr in Lexp_newtype (str, jkind, inner_expr) - let map_function_param sub : N_ary.function_param -> N_ary.function_param = - fun { pparam_loc = loc; pparam_desc = desc } -> - let loc = sub.location sub loc in - let desc : N_ary.function_param_desc = - match desc with - | Pparam_val (label, def, pat) -> - Pparam_val (label, Option.map (sub.expr sub) def, sub.pat sub pat) - | Pparam_newtype (newtype, jkind) -> - Pparam_newtype - ( map_loc sub newtype - , map_opt (map_loc_txt sub sub.jkind_annotation) jkind - ) - in - { pparam_loc = loc; pparam_desc = desc } - - let map_type_constraint sub : N_ary.type_constraint -> N_ary.type_constraint = - function - | Pconstraint ty -> Pconstraint (sub.typ sub ty) - | Pcoerce (ty1, ty2) -> - Pcoerce (Option.map (sub.typ sub) ty1, sub.typ sub ty2) - - let map_function_constraint sub - : N_ary.function_constraint -> N_ary.function_constraint = - function - | { mode_annotations; type_constraint } -> - { mode_annotations = sub.modes sub mode_annotations; - type_constraint = map_type_constraint sub type_constraint; - } - - let map_function_body sub : N_ary.function_body -> N_ary.function_body = - function - | Pfunction_body exp -> Pfunction_body (sub.expr sub exp) - | Pfunction_cases (cases, loc, attrs) -> - Pfunction_cases - (sub.cases sub cases, sub.location sub loc, sub.attributes sub attrs) - - let map_n_ary_exp sub : N_ary.expression -> N_ary.expression = function - | (params, constraint_, body) -> - let params = List.map (map_function_param sub) params in - let constraint_ = Option.map (map_function_constraint sub) constraint_ in - let body = map_function_body sub body in - params, constraint_, body - let map_ltexp sub : LT.expression -> LT.expression = function (* CR labeled tuples: Eventually mappers may want to see the labels. *) | el -> List.map (map_snd (sub.expr sub)) el @@ -669,7 +657,6 @@ module E = struct | Jexp_comprehension x -> Jexp_comprehension (map_cexp sub x) | Jexp_immutable_array x -> Jexp_immutable_array (map_iaexp sub x) | Jexp_layout x -> Jexp_layout (map_layout_exp sub x) - | Jexp_n_ary_function x -> Jexp_n_ary_function (map_n_ary_exp sub x) | Jexp_tuple ltexp -> Jexp_tuple (map_ltexp sub ltexp) let map sub @@ -690,12 +677,11 @@ module E = struct | Pexp_let (r, vbs, e) -> let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - (fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) [@alert "-prefer_jane_syntax"]) - | Pexp_function pel -> - (function_ ~loc ~attrs (sub.cases sub pel) - [@alert "-prefer_jane_syntax"]) + | Pexp_function (ps, c, b) -> + function_ ~loc ~attrs + (List.map (map_function_param sub) ps) + (map_opt (map_function_constraint sub) c) + (map_function_body sub b) | Pexp_apply (e, l) -> apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) | Pexp_match (e, pel) -> @@ -939,7 +925,7 @@ let default_mapper = type_exception = T.map_type_exception; extension_constructor = T.map_extension_constructor; value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; pval_modalities; + (fun this {pval_name; pval_type; pval_modalities; pval_prim; pval_loc; pval_attributes} -> Val.mk (map_loc this pval_name) @@ -1111,11 +1097,11 @@ let default_mapper = let open Jane_syntax in function | Default -> Default - | Primitive_layout_or_abbreviation s -> + | Abbreviation s -> let {txt; loc} = - map_loc this (s : Jkind.Const.t :> _ loc) + map_loc this s in - Primitive_layout_or_abbreviation (Jkind.Const.mk txt loc) + Abbreviation (Jkind.Const.mk txt loc) | Mod (t, mode_list) -> Mod (this.jkind_annotation this t, this.modes this mode_list) | With (t, ty) -> diff --git a/vendor/parser-jane/for-parser-standard/jane_syntax.ml b/vendor/parser-jane/for-parser-standard/jane_syntax.ml index 8998adbe94..e22c385b72 100644 --- a/vendor/parser-jane/for-parser-standard/jane_syntax.ml +++ b/vendor/parser-jane/for-parser-standard/jane_syntax.ml @@ -39,22 +39,10 @@ end = struct end module Of_ast (Ext : Extension) : sig - module Desugaring_error : sig - type error = - | Not_this_embedding of Embedded_name.t - | Non_embedding - end - type unwrapped := string list * payload * attributes - (* Find and remove a jane-syntax attribute marker, returning an error + (* Find and remove a jane-syntax attribute marker, throwing an exception if the attribute name does not have the right format or extension. *) - val unwrap_jane_syntax_attributes : - attributes -> (unwrapped, Desugaring_error.error) result - - (* The same as [unwrap_jane_syntax_attributes], except throwing - an exception instead of returning an error. - *) val unwrap_jane_syntax_attributes_exn : loc:Location.t -> attributes -> unwrapped end = struct @@ -338,19 +326,28 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) : Make_payload_protocol_of_structure_item_encodable (Make_structure_item_encodable_of_stringable (Stringable)) +module Arrow_curry = struct + let curry_attr_name = "extension.curry" + + let curry_attr loc = + Ast_helper.Attr.mk ~loc:Location.none + (Location.mkloc curry_attr_name loc) + (PStr []) +end + (* only used for [Jkind] below *) module Mode = struct module Protocol = Make_payload_protocol_of_stringable (struct - type t = mode + type t = mode - let indefinite_article_and_name = "a", "mode" + let indefinite_article_and_name = "a", "mode" - let to_string (Mode s) = s + let to_string (Mode s) = s - let of_string' s = Mode s + let of_string' s = Mode s - let of_string s = Some (of_string' s) - end) + let of_string s = Some (of_string' s) + end) let list_as_payload = Protocol.Encode.list_as_payload @@ -359,9 +356,7 @@ end module Jkind = struct module Const : sig - type raw = string - - type t = private raw loc + type t = Parsetree.jkind_const_annotation val mk : string -> Location.t -> t @@ -390,10 +385,10 @@ module Jkind = struct let to_structure_item = Protocol.to_structure_item end - type t = + type t = Parsetree.jkind_annotation = | Default - | Primitive_layout_or_abbreviation of Const.t - | Mod of t * mode loc list + | Abbreviation of Const.t + | Mod of t * modes | With of t * core_type | Kind_of of core_type @@ -449,8 +444,8 @@ module Jkind = struct let to_structure_item t = to_structure_item (Location.mknoloc t) in match t_loc.txt with | Default -> struct_item_of_list "default" [] t_loc.loc - | Primitive_layout_or_abbreviation c -> - struct_item_of_list "prim" [Const.to_structure_item c] t_loc.loc + | Abbreviation c -> + struct_item_of_list "abbrev" [Const.to_structure_item c] t_loc.loc | Mod (t, modes) -> let mode_list_item = struct_item_of_attr @@ -475,9 +470,7 @@ module Jkind = struct | Some ("mod", [item_of_t; item_of_mode_expr], loc) -> bind (of_structure_item item_of_t) (fun { txt = t } -> bind (struct_item_to_attr item_of_mode_expr) (fun attr -> - let modes = - Mode.list_from_payload ~loc attr.attr_payload - in + let modes = Mode.list_from_payload ~loc attr.attr_payload in ret loc (Mod (t, modes)))) | Some ("with", [item_of_t; item_of_ty], loc) -> bind (of_structure_item item_of_t) (fun { txt = t } -> @@ -485,9 +478,8 @@ module Jkind = struct ret loc (With (t, ty)))) | Some ("kind_of", [item_of_ty], loc) -> bind (struct_item_to_type item_of_ty) (fun ty -> ret loc (Kind_of ty)) - | Some ("prim", [item], loc) -> - bind (Const.of_structure_item item) (fun c -> - ret loc (Primitive_layout_or_abbreviation c)) + | Some ("abbrev", [item], loc) -> + bind (Const.of_structure_item item) (fun c -> ret loc (Abbreviation c)) | Some _ | None -> None end @@ -789,459 +781,6 @@ module Immutable_arrays = struct | _ -> failwith "Malformed immutable array pattern" end -module N_ary_functions = struct - module Ext = struct - let feature : Feature.t = Builtin - end - - module Ast_of = Ast_of (Expression) (Ext) - module Of_ast = Of_ast (Ext) - open Ext - - type function_body = - | Pfunction_body of expression - | Pfunction_cases of case list * Location.t * attributes - - type function_param_desc = - | Pparam_val of arg_label * expression option * pattern - | Pparam_newtype of string loc * Jkind.annotation option - - type function_param = - { pparam_desc : function_param_desc; - pparam_loc : Location.t - } - - type type_constraint = - | Pconstraint of core_type - | Pcoerce of core_type option * core_type - - type function_constraint = - { mode_annotations : mode loc list; - type_constraint : type_constraint - } - - type expression = - function_param list * function_constraint option * function_body - - (** An attribute of the form [@jane.erasable._builtin.*] that's relevant - to n-ary functions. The "*" in the example is what we call the "suffix". - See the below BNF for the meaning of the attributes. - *) - module Attribute_node = struct - type after_fun = - | Cases - | Constraint_then_cases - - type t = - | Top_level - | Fun_then of after_fun - | Jkind_annotation of Jkind.annotation - - (* We return an [of_suffix_result] from [of_suffix] rather than having - [of_suffix] interpret the payload for two reasons: - 1. It's nice to keep the string production / matching extremely - visually simple so it's easy to check that [to_suffix_and_payload] - and [of_suffix] correspond. - 2. We want to raise a [Desugaring_error.Has_payload] in the case that - a [No_payload t] has an improper payload, but this creates a - dependency cycle between [Attribute_node] and [Desugaring_error]. - Moving the interpretation of the payload to the caller of - [of_suffix] breaks this cycle. - *) - - type of_suffix_result = - | No_payload of t - | Payload of (payload -> loc:Location.t -> t) - | Unknown_suffix - - let to_suffix_and_payload = function - | Top_level -> [], None - | Fun_then Cases -> ["cases"], None - | Fun_then Constraint_then_cases -> ["constraint"; "cases"], None - | Jkind_annotation jkind_annotation -> - let payload = Jkind_annotation.Encode.as_payload jkind_annotation in - ["jkind_annotation"], Some payload - - let of_suffix suffix = - match suffix with - | [] -> No_payload Top_level - | ["cases"] -> No_payload (Fun_then Cases) - | ["constraint"; "cases"] -> No_payload (Fun_then Constraint_then_cases) - | ["jkind_annotation"] -> - Payload - (fun payload ~loc -> - assert_extension_enabled ~loc Layouts - (Stable : Language_extension.maturity); - let jkind_annotation = - Jkind_annotation.Decode.from_payload payload ~loc - in - Jkind_annotation jkind_annotation) - | _ -> Unknown_suffix - - let format ppf t = - let suffix, _ = to_suffix_and_payload t in - Embedded_name.pp_quoted_name ppf (Embedded_name.of_feature feature suffix) - end - - module Desugaring_error = struct - type error = - | Has_payload of payload - | Expected_constraint_or_coerce - | Expected_function_cases of Attribute_node.t - | Expected_fun_or_newtype of Attribute_node.t - | Expected_newtype_with_jkind_annotation of Jkind.annotation - | Parameterless_function - - let report_error ~loc = function - | Has_payload payload -> - Location.errorf ~loc - "Syntactic arity attribute has an unexpected payload:@;%a" - (Printast.payload 0) payload - | Expected_constraint_or_coerce -> - Location.errorf ~loc - "Expected a Pexp_constraint or Pexp_coerce node at this position." - | Expected_function_cases attribute -> - Location.errorf ~loc - "Expected a Pexp_function node in this position, as the enclosing \ - Pexp_fun is annotated with %a." - Attribute_node.format attribute - | Expected_fun_or_newtype attribute -> - Location.errorf ~loc - "Only Pexp_fun or Pexp_newtype may carry the attribute %a." - Attribute_node.format attribute - | Expected_newtype_with_jkind_annotation annotation -> - Location.errorf ~loc "Only Pexp_newtype may carry the attribute %a." - Attribute_node.format (Attribute_node.Jkind_annotation annotation) - | Parameterless_function -> - Location.errorf ~loc - "The expression is a Jane Syntax encoding of a function with no \ - parameters, which is an invalid expression." - - exception Error of Location.t * error - - let () = - Location.register_error_of_exn (function - | Error (loc, err) -> Some (report_error ~loc err) - | _ -> None) - - let raise_with_loc loc err = raise (Error (loc, err)) - - let raise expr err = raise (Error (expr.pexp_loc, err)) - end - - (* The desugared-to-OCaml version of an n-ary function is described by the - following BNF, where [{% '...' | expr %}] refers to the result of - [Expression.make_jane_syntax] (via n_ary_function_expr) as described at the - top of [jane_syntax_parsing.mli]. Within the '...' string, I use <...> - brackets to denote string interpolation. - - {v - (* The entry point. - - The encoding only puts attributes on: - - [fun] nodes - - constraint/coercion nodes, on the rare occasions - that a constraint should be interpreted at the [local] mode - - This ensures that we rarely put attributes on the *body* of the - function, which means that ppxes that move or transform the body - of a function won't make Jane Syntax complain. - *) - n_ary_function ::= - | nested_n_ary_function - (* A function need not have [fun] params; it can be a function - or a constrained function. These need not have extra attributes, - except in the rare case that the function is constrained at the - local mode. - *) - | pexp_function - | constraint_with_mode_then(pexp_function) - - nested_n_ary_function ::= - | fun_then(nested_n_ary_function) - | fun_then(constraint_with_mode_then(expression)) - | {% '_builtin.cases' | fun_then(pexp_function) } - | {% '_builtin.constraint.cases' | - fun_then(constraint_with_mode_then(pexp_function)) } - | fun_then(expression) - - - fun_then(body) ::= - | 'fun' pattern '->' body (* Pexp_fun *) - | 'fun' '(' 'type' ident ')' '->' body (* Pexp_newtype *) - |{% '_builtin.jkind_annotation' | - 'fun' '(' 'type' ident ')' '->' body %} (* Pexp_newtype *) - - pexp_function ::= - | 'function' cases - - constraint_then(ast) ::= - | ast (':' type)? ':>' type (* Pexp_coerce *) - | ast ':' type (* Pexp_constraint *) - - constraint_with_mode_then(ast) ::= - | constraint_then(ast) - | {% '_builtin.local_constraint' | constraint_then(ast) %} - v} - *) - - let expand_n_ary_expr expr = - match Of_ast.unwrap_jane_syntax_attributes expr.pexp_attributes with - | Error (Not_this_embedding _ | Non_embedding) -> None - | Ok (suffix, payload, attributes) -> - let attribute_node = - match Attribute_node.of_suffix suffix, payload with - | No_payload t, PStr [] -> Some t - | Payload f, payload -> Some (f payload ~loc:expr.pexp_loc) - | No_payload _, payload -> - Desugaring_error.raise expr (Has_payload payload) - | Unknown_suffix, _ -> None - in - Option.map (fun x -> x, attributes) attribute_node - - let require_function_cases expr ~arity_attribute = - match expr.pexp_desc with - | Pexp_function cases -> cases - | _ -> Desugaring_error.raise expr (Expected_function_cases arity_attribute) - - let check_constraint expr = - match expr.pexp_desc with - | Pexp_constraint (e, Some ty, m) -> - Some ({ mode_annotations = m; type_constraint = Pconstraint ty }, e) - | Pexp_coerce (e, ty1, ty2) -> - Some ({ mode_annotations = []; type_constraint = Pcoerce (ty1, ty2) }, e) - | _ -> None - - let require_constraint expr = - match check_constraint expr with - | Some constraint_ -> constraint_ - | None -> Desugaring_error.raise expr Expected_constraint_or_coerce - - let check_param pexp_desc (pexp_loc : Location.t) ~jkind = - match pexp_desc, jkind with - | Pexp_fun (lbl, def, pat, body), None -> - let pparam_loc : Location.t = - { loc_ghost = true; - loc_start = pexp_loc.loc_start; - loc_end = pat.ppat_loc.loc_end - } - in - let pparam_desc = Pparam_val (lbl, def, pat) in - Some ({ pparam_desc; pparam_loc }, body) - | Pexp_newtype (newtype, body), jkind -> - (* This imperfectly estimates where a newtype parameter ends: it uses - the end of the type name rather than the closing paren. The closing - paren location is not tracked anywhere in the parsetree. We don't - think merlin is affected. - *) - let pparam_loc : Location.t = - { loc_ghost = true; - loc_start = pexp_loc.loc_start; - loc_end = newtype.loc.loc_end - } - in - let pparam_desc = Pparam_newtype (newtype, jkind) in - Some ({ pparam_desc; pparam_loc }, body) - | _, None -> None - | _, Some jkind -> - Desugaring_error.raise_with_loc pexp_loc - (Expected_newtype_with_jkind_annotation jkind) - - let require_param pexp_desc pexp_loc ~arity_attribute ~jkind = - match check_param pexp_desc pexp_loc ~jkind with - | Some x -> x - | None -> - Desugaring_error.raise_with_loc pexp_loc - (Expected_fun_or_newtype arity_attribute) - - (* Should only be called on [Pexp_fun] and [Pexp_newtype]. *) - let extract_fun_params = - let open struct - type continue_or_stop = - | Continue of Parsetree.expression - | Stop of function_constraint option * function_body - end in - (* Returns: the next parameter, together with whether there are possibly - more parameters available ("Continue") or whether all parameters have - been consumed ("Stop"). - - The returned attributes are the remaining unconsumed attributes on the - Pexp_fun or Pexp_newtype node. - - The [jkind] parameter gives the jkind at which to interpret the type - introduced by [expr = Pexp_newtype _]. It is only supplied in a recursive - call to [extract_next_fun_param] in the event that it sees a - [Jkind_annotation] attribute. - *) - let rec extract_next_fun_param expr ~jkind : - (function_param * attributes) option * continue_or_stop = - match expand_n_ary_expr expr with - | None -> ( - match check_param expr.pexp_desc expr.pexp_loc ~jkind with - | Some (param, body) -> - Some (param, expr.pexp_attributes), Continue body - | None -> None, Stop (None, Pfunction_body expr)) - | Some (Top_level, _) -> None, Stop (None, Pfunction_body expr) - | Some (Jkind_annotation next_jkind, unconsumed_attributes) -> - extract_next_fun_param - { expr with pexp_attributes = unconsumed_attributes } - ~jkind:(Some next_jkind) - | Some ((Fun_then after_fun as arity_attribute), unconsumed_attributes) -> - let param, body = - require_param expr.pexp_desc expr.pexp_loc ~arity_attribute ~jkind - in - let continue_or_stop = - match after_fun with - | Cases -> - let cases = require_function_cases body ~arity_attribute in - let function_body = - Pfunction_cases (cases, body.pexp_loc, body.pexp_attributes) - in - Stop (None, function_body) - | Constraint_then_cases -> - let function_constraint, body = require_constraint body in - let cases = require_function_cases body ~arity_attribute in - let function_body = - Pfunction_cases (cases, body.pexp_loc, body.pexp_attributes) - in - Stop (Some function_constraint, function_body) - in - Some (param, unconsumed_attributes), continue_or_stop - in - let rec loop expr ~rev_params = - let next_param, continue_or_stop = - extract_next_fun_param expr ~jkind:None - in - let rev_params = - match next_param with - | None -> rev_params - | Some (x, _) -> x :: rev_params - in - match continue_or_stop with - | Continue body -> loop body ~rev_params - | Stop (function_constraint, body) -> - let params = List.rev rev_params in - params, function_constraint, body - in - fun expr -> - (match expr.pexp_desc with - | Pexp_newtype _ | Pexp_fun _ -> () - | _ -> Misc.fatal_error "called on something that isn't a newtype or fun"); - let unconsumed_attributes = - match extract_next_fun_param expr ~jkind:None with - | Some (_, attributes), _ -> attributes - | None, _ -> Desugaring_error.raise expr Parameterless_function - in - loop expr ~rev_params:[], unconsumed_attributes - - (* Returns remaining unconsumed attributes on outermost expression *) - let of_expr = - let function_without_additional_params cases constraint_ loc : expression = - (* If the outermost node is function cases, we place the - attributes on the function node as a whole rather than on the - [Pfunction_cases] body. - *) - [], constraint_, Pfunction_cases (cases, loc, []) - in - (* Hack: be more permissive toward a way that a ppx can mishandle an - attribute, which is to duplicate the top-level Jane Syntax - attribute. - *) - let rec remove_top_level_attributes expr = - match expand_n_ary_expr expr with - | Some (Top_level, unconsumed_attributes) -> - remove_top_level_attributes - { expr with pexp_attributes = unconsumed_attributes } - | _ -> expr - in - fun expr -> - let expr = remove_top_level_attributes expr in - match expr.pexp_desc with - | Pexp_fun _ | Pexp_newtype _ -> Some (extract_fun_params expr) - | Pexp_function cases -> - let n_ary = - function_without_additional_params cases None expr.pexp_loc - in - Some (n_ary, expr.pexp_attributes) - | _ -> ( - match check_constraint expr with - | Some (constraint_, { pexp_desc = Pexp_function cases }) -> - let n_ary = - function_without_additional_params cases (Some constraint_) - expr.pexp_loc - in - Some (n_ary, expr.pexp_attributes) - | _ -> None) - - let n_ary_function_expr ext x = - let suffix, payload = Attribute_node.to_suffix_and_payload ext in - Ast_of.wrap_jane_syntax ?payload suffix x - - let expr_of = - let add_param ?after_fun_attribute { pparam_desc; pparam_loc } body = - let fun_ = - let loc = - { !Ast_helper.default_loc with loc_start = pparam_loc.loc_start } - in - match pparam_desc with - | Pparam_val (label, default, pat) -> - Ast_helper.Exp.fun_ label default pat body ~loc - [@alert "-prefer_jane_syntax"] - | Pparam_newtype (newtype, jkind) -> ( - match jkind with - | None -> Ast_helper.Exp.newtype newtype body ~loc - | Some jkind -> - n_ary_function_expr (Jkind_annotation jkind) - (Ast_helper.Exp.newtype newtype body ~loc)) - in - match after_fun_attribute with - | None -> fun_ - | Some after_fun -> n_ary_function_expr (Fun_then after_fun) fun_ - in - fun ~loc (params, constraint_, function_body) -> - (* See Note [Wrapping with make_entire_jane_syntax] *) - Expression.make_entire_jane_syntax ~loc feature (fun () -> - let body = - match function_body with - | Pfunction_body body -> body - | Pfunction_cases (cases, loc, attrs) -> - Ast_helper.Exp.function_ cases ~loc ~attrs - [@alert "-prefer_jane_syntax"] - in - let possibly_constrained_body = - match constraint_ with - | None -> body - | Some { mode_annotations; type_constraint } -> - let constrained_body = - (* We can't call [Location.ghostify] here, as we need this file - to build with the upstream compiler; see Note [Buildable with - upstream] in jane_syntax.mli for details. *) - let loc = { body.pexp_loc with loc_ghost = true } in - match type_constraint with - | Pconstraint ty -> - Ast_helper.Exp.constraint_ body (Some ty) ~loc mode_annotations - | Pcoerce (ty1, ty2) -> Ast_helper.Exp.coerce body ty1 ty2 ~loc - in - constrained_body - in - match params with - | [] -> possibly_constrained_body - | params -> - let init_params, last_param = Misc.split_last params in - let after_fun_attribute : Attribute_node.after_fun option = - match constraint_, function_body with - | Some _, Pfunction_cases _ -> Some Constraint_then_cases - | None, Pfunction_cases _ -> Some Cases - | Some _, Pfunction_body _ -> None - | None, Pfunction_body _ -> None - in - let body_with_last_param = - add_param last_param ?after_fun_attribute - possibly_constrained_body - in - List.fold_right add_param init_params body_with_last_param) -end - (** Labeled tuples *) module Labeled_tuples = struct module Ext = struct @@ -1963,7 +1502,6 @@ module Expression = struct | Jexp_comprehension of Comprehensions.expression | Jexp_immutable_array of Immutable_arrays.expression | Jexp_layout of Layouts.expression - | Jexp_n_ary_function of N_ary_functions.expression | Jexp_tuple of Labeled_tuples.expression let of_ast_internal (feat : Feature.t) expr = @@ -1977,10 +1515,6 @@ module Expression = struct | Language_extension Layouts -> let expr, attrs = Layouts.of_expr expr in Some (Jexp_layout expr, attrs) - | Builtin -> ( - match N_ary_functions.of_expr expr with - | Some (expr, attrs) -> Some (Jexp_n_ary_function expr, attrs) - | None -> None) | Language_extension Labeled_tuples -> let expr, attrs = Labeled_tuples.of_expr expr in Some (Jexp_tuple expr, attrs) @@ -1994,7 +1528,6 @@ module Expression = struct | Jexp_comprehension x -> Comprehensions.expr_of ~loc x | Jexp_immutable_array x -> Immutable_arrays.expr_of ~loc x | Jexp_layout x -> Layouts.expr_of ~loc x - | Jexp_n_ary_function x -> N_ary_functions.expr_of ~loc x | Jexp_tuple x -> Labeled_tuples.expr_of ~loc x in (* Performance hack: save an allocation if [attrs] is empty. *) diff --git a/vendor/parser-jane/for-parser-standard/jane_syntax.mli b/vendor/parser-jane/for-parser-standard/jane_syntax.mli index 3480876585..3cd98a6ba2 100644 --- a/vendor/parser-jane/for-parser-standard/jane_syntax.mli +++ b/vendor/parser-jane/for-parser-standard/jane_syntax.mli @@ -100,123 +100,39 @@ module Immutable_arrays : sig val pat_of : loc:Location.t -> pattern -> Parsetree.pattern end +(** The attribute placed on the inner [Ptyp_arrow] node in [x -> (y -> z)] + (meaning the [y -> z] node) to indicate parenthesization. This is relevant + for locals, as [local_ x -> (y -> z)] is different than + [local_ x -> y -> z]. +*) +module Arrow_curry : sig + val curry_attr_name : string + + val curry_attr : Location.t -> Parsetree.attribute +end + module Jkind : sig module Const : sig (** Constant jkind *) - type raw = string - (** Represent a user-written kind primitive/abbreviation, containing a string and its location *) - type t = private raw Location.loc + type t = Parsetree.jkind_const_annotation (** Constructs a jkind constant *) val mk : string -> Location.t -> t end - type t = + type t = Parsetree.jkind_annotation = | Default - | Primitive_layout_or_abbreviation of Const.t - | Mod of t * Parsetree.mode Location.loc list + | Abbreviation of Const.t + | Mod of t * Parsetree.modes | With of t * Parsetree.core_type | Kind_of of Parsetree.core_type type annotation = t Location.loc end -module N_ary_functions : sig - (** These types use the [P] prefix to match how they are represented in the - upstream compiler *) - - (** See the comment on [expression]. *) - type function_body = - | Pfunction_body of Parsetree.expression - | Pfunction_cases of Parsetree.case list * Location.t * Parsetree.attributes - (** In [Pfunction_cases (_, loc, attrs)], the location extends from the - start of the [function] keyword to the end of the last case. The - compiler will only use typechecking-related attributes from [attrs], - e.g. enabling or disabling a warning. - *) - - type function_param_desc = - | Pparam_val of - Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern - (** [Pparam_val (lbl, exp0, P)] represents the parameter: - - [P] - when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} - and [exp0] is [None] - - [~l:P] - when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} - and [exp0] is [None] - - [?l:P] - when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} - and [exp0] is [None] - - [?l:(P = E0)] - when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} - and [exp0] is [Some E0] - - Note: If [E0] is provided, only - {{!Asttypes.arg_label.Optional}[Optional]} is allowed. - *) - | Pparam_newtype of string Asttypes.loc * Jkind.annotation option - (** [Pparam_newtype (x, jkind)] represents the parameter [(type x)]. - [x] carries the location of the identifier, whereas [pparam_loc] is - the location of the [(type x)] as a whole. - - [jkind] is the same as [Lexp_newtype]'s jkind. - - Multiple parameters [(type a b c)] are represented as multiple - [Pparam_newtype] nodes, let's say: - - {[ [ { pparam_desc = Pparam_newtype (a, _); pparam_loc = loc }; - { pparam_desc = Pparam_newtype (b, _); pparam_loc = loc }; - { pparam_desc = Pparam_newtype (c, _); pparam_loc = loc }; - ] - ]} - - Here, [loc] gives the location of [(type a b c)], but is marked as a - ghost location. The locations on [a], [b], [c], correspond to the - variables [a], [b], and [c] in the source code. - *) - - type function_param = - { pparam_desc : function_param_desc; - pparam_loc : Location.t - } - - type type_constraint = - | Pconstraint of Parsetree.core_type - | Pcoerce of Parsetree.core_type option * Parsetree.core_type - - (** The mode annotation placed on a function let-binding when the function - has a type constraint on the body, e.g. - [let local_ f x : int -> int = ...]. - *) - type function_constraint = - { mode_annotations : Parsetree.mode Location.loc list; - type_constraint : type_constraint - } - - (** [([P1; ...; Pn], C, body)] represents any construct - involving [fun] or [function], including: - - [fun P1 ... Pn -> E] - when [body = Pfunction_body E] - - [fun P1 ... Pn -> function p1 -> e1 | ... | pm -> em] - when [body = Pfunction_cases [ p1 -> e1; ...; pm -> em ]] - - [C] represents a type constraint or coercion placed immediately - before the arrow, e.g. [fun P1 ... Pn : t1 :> t2 -> ...] - when [C = Some (Pcoerce (Some t1, t2))]. - - A function must have parameters. [Pexp_function (params, _, body)] must - have non-empty [params] or a [Pfunction_cases _] body. - *) - type expression = - function_param list * function_constraint option * function_body - - val expr_of : loc:Location.t -> expression -> Parsetree.expression -end - (** The ASTs for labeled tuples. When we merge this upstream, we'll replace existing [P{typ,exp,pat}_tuple] constructors with these. *) module Labeled_tuples : sig @@ -533,7 +449,6 @@ module Expression : sig | Jexp_comprehension of Comprehensions.expression | Jexp_immutable_array of Immutable_arrays.expression | Jexp_layout of Layouts.expression - | Jexp_n_ary_function of N_ary_functions.expression | Jexp_tuple of Labeled_tuples.expression include diff --git a/vendor/parser-jane/for-parser-standard/jane_syntax_parsing.ml b/vendor/parser-jane/for-parser-standard/jane_syntax_parsing.ml index cadbbe26c6..47fc24c4ec 100644 --- a/vendor/parser-jane/for-parser-standard/jane_syntax_parsing.ml +++ b/vendor/parser-jane/for-parser-standard/jane_syntax_parsing.ml @@ -13,8 +13,7 @@ In particular, for an language extension named [EXTNAME] (i.e., one that is enabled by [-extension EXTNAME] on the command line), the attribute (if used) must be [[@jane.ERASABILITY.EXTNAME]], and the extension node (if - used) must be [[%jane.ERASABILITY.EXTNAME]]. For built-in syntax, we use - [_builtin] instead of an language extension name. + used) must be [[%jane.ERASABILITY.EXTNAME]]. The [ERASABILITY] component indicates to tools such as ocamlformat and ppxlib whether or not the attribute is erasable. See the documentation of @@ -94,9 +93,7 @@ end (******************************************************************************) module Feature : sig - type t = - | Language_extension : _ Language_extension.t -> t - | Builtin + type t = Language_extension : _ Language_extension.t -> t type error = | Disabled_extension : _ Language_extension.t -> error @@ -110,42 +107,29 @@ module Feature : sig val is_erasable : t -> bool end = struct - type t = - | Language_extension : _ Language_extension.t -> t - | Builtin + type t = Language_extension : _ Language_extension.t -> t type error = | Disabled_extension : _ Language_extension.t -> error | Unknown_extension of string - let builtin_component = "_builtin" - let describe_uppercase = function | Language_extension ext -> "The extension \"" ^ Language_extension.to_string ext ^ "\"" - | Builtin -> "Built-in syntax" let extension_component = function | Language_extension ext -> Language_extension.to_string ext - | Builtin -> builtin_component let of_component str = - if String.equal str builtin_component - then Ok Builtin - else - match Language_extension.of_string str with - | Some (Pack ext) -> - if Language_extension.is_enabled ext - then Ok (Language_extension ext) - else Error (Disabled_extension ext) - | None -> Error (Unknown_extension str) + match Language_extension.of_string str with + | Some (Pack ext) -> + if Language_extension.is_enabled ext + then Ok (Language_extension ext) + else Error (Disabled_extension ext) + | None -> Error (Unknown_extension str) let is_erasable = function | Language_extension ext -> Language_extension.is_erasable ext - (* Builtin syntax changes don't involve additions or changes to concrete - syntax and are always erasable. - *) - | Builtin -> true end (** Was this embedded as an [[%extension_node]] or an [[@attribute]]? Not diff --git a/vendor/parser-jane/for-parser-standard/jane_syntax_parsing.mli b/vendor/parser-jane/for-parser-standard/jane_syntax_parsing.mli index e2869df666..7cf7ac0ea3 100644 --- a/vendor/parser-jane/for-parser-standard/jane_syntax_parsing.mli +++ b/vendor/parser-jane/for-parser-standard/jane_syntax_parsing.mli @@ -93,9 +93,7 @@ language extension (separated out by which one) or the collection of all built-in features. *) module Feature : sig - type t = - | Language_extension : _ Language_extension.t -> t - | Builtin + type t = Language_extension : _ Language_extension.t -> t (** The component of an attribute or extension name that identifies the feature. This is third component. diff --git a/vendor/parser-jane/for-parser-standard/language_extension.ml b/vendor/parser-jane/for-parser-standard/language_extension.ml index 5e8e3c95a7..7a05a4a5cf 100644 --- a/vendor/parser-jane/for-parser-standard/language_extension.ml +++ b/vendor/parser-jane/for-parser-standard/language_extension.ml @@ -54,7 +54,7 @@ end let get_level_ops : type a. a t -> (module Extension_level with type t = a) = function | Comprehensions -> (module Unit) - | Mode -> (module Unit) + | Mode -> (module Maturity) | Unique -> (module Unit) | Include_functor -> (module Unit) | Polymorphic_parameters -> (module Unit) @@ -63,14 +63,14 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) = | Layouts -> (module Maturity) | SIMD -> (module Unit) | Labeled_tuples -> (module Unit) - | Small_numbers -> (module Unit) + | Small_numbers -> (module Maturity) module Exist_pair = struct include Exist_pair let maturity : t -> Maturity.t = function | Pair (Comprehensions, ()) -> Beta - | Pair (Mode, ()) -> Stable + | Pair (Mode, m) -> m | Pair (Unique, ()) -> Alpha | Pair (Include_functor, ()) -> Stable | Pair (Polymorphic_parameters, ()) -> Stable @@ -79,16 +79,19 @@ module Exist_pair = struct | Pair (Layouts, m) -> m | Pair (SIMD, ()) -> Stable | Pair (Labeled_tuples, ()) -> Stable - | Pair (Small_numbers, ()) -> Beta + | Pair (Small_numbers, m) -> m let is_erasable : t -> bool = function Pair (ext, _) -> is_erasable ext let to_string = function | Pair (Layouts, m) -> to_string Layouts ^ "_" ^ maturity_to_string m + | Pair (Mode, m) -> to_string Mode ^ "_" ^ maturity_to_string m + | Pair (Small_numbers, m) -> + to_string Small_numbers ^ "_" ^ maturity_to_string m | Pair - ( (( Comprehensions | Mode | Unique | Include_functor - | Polymorphic_parameters | Immutable_arrays | Module_strengthening - | SIMD | Labeled_tuples | Small_numbers ) as ext), + ( (( Comprehensions | Unique | Include_functor | Polymorphic_parameters + | Immutable_arrays | Module_strengthening | SIMD | Labeled_tuples ) + as ext), _ ) -> to_string ext end diff --git a/vendor/parser-jane/for-parser-standard/language_extension.mli b/vendor/parser-jane/for-parser-standard/language_extension.mli index fb026200b4..40ddba38a7 100644 --- a/vendor/parser-jane/for-parser-standard/language_extension.mli +++ b/vendor/parser-jane/for-parser-standard/language_extension.mli @@ -13,7 +13,7 @@ type maturity = Language_extension_kernel.maturity = or off, while a [maturity t] can have different maturity settings. *) type 'a t = 'a Language_extension_kernel.t = | Comprehensions : unit t - | Mode : unit t + | Mode : maturity t | Unique : unit t | Include_functor : unit t | Polymorphic_parameters : unit t @@ -22,7 +22,7 @@ type 'a t = 'a Language_extension_kernel.t = | Layouts : maturity t | SIMD : unit t | Labeled_tuples : unit t - | Small_numbers : unit t + | Small_numbers : maturity t (** Existentially packed language extension *) module Exist : sig diff --git a/vendor/parser-jane/for-parser-standard/language_extension_kernel.ml b/vendor/parser-jane/for-parser-standard/language_extension_kernel.ml index 4fa3aaed21..757c0c9fc6 100644 --- a/vendor/parser-jane/for-parser-standard/language_extension_kernel.ml +++ b/vendor/parser-jane/for-parser-standard/language_extension_kernel.ml @@ -3,7 +3,7 @@ type maturity = Stable | Beta | Alpha (* Remember to update [all] when changing this type. *) type _ t = | Comprehensions : unit t - | Mode : unit t + | Mode : maturity t | Unique : unit t | Include_functor : unit t | Polymorphic_parameters : unit t @@ -12,7 +12,7 @@ type _ t = | Layouts : maturity t | SIMD : unit t | Labeled_tuples : unit t - | Small_numbers : unit t + | Small_numbers : maturity t type 'a language_extension_kernel = 'a t @@ -59,7 +59,9 @@ let to_string : type a. a t -> string = function let pair_of_string extn_name : Exist_pair.t option = match String.lowercase_ascii extn_name with | "comprehensions" -> Some (Pair (Comprehensions, ())) - | "mode" -> Some (Pair (Mode, ())) + | "mode" -> Some (Pair (Mode, Stable)) + | "mode_beta" -> Some (Pair (Mode, Beta)) + | "mode_alpha" -> Some (Pair (Mode, Alpha)) | "unique" -> Some (Pair (Unique, ())) | "include_functor" -> Some (Pair (Include_functor, ())) | "polymorphic_parameters" -> Some (Pair (Polymorphic_parameters, ())) @@ -70,7 +72,8 @@ let pair_of_string extn_name : Exist_pair.t option = | "layouts_beta" -> Some (Pair (Layouts, Beta)) | "simd" -> Some (Pair (SIMD, ())) | "labeled_tuples" -> Some (Pair (Labeled_tuples, ())) - | "small_numbers" -> Some (Pair (Small_numbers, ())) + | "small_numbers" -> Some (Pair (Small_numbers, Stable)) + | "small_numbers_beta" -> Some (Pair (Small_numbers, Beta)) | _ -> None let maturity_to_string = function diff --git a/vendor/parser-jane/for-parser-standard/language_extension_kernel.mli b/vendor/parser-jane/for-parser-standard/language_extension_kernel.mli index d963835b13..1d09c69fb4 100644 --- a/vendor/parser-jane/for-parser-standard/language_extension_kernel.mli +++ b/vendor/parser-jane/for-parser-standard/language_extension_kernel.mli @@ -12,7 +12,7 @@ type maturity = Stable | Beta | Alpha or off, while a [maturity t] can have different maturity settings. *) type _ t = | Comprehensions : unit t - | Mode : unit t + | Mode : maturity t | Unique : unit t | Include_functor : unit t | Polymorphic_parameters : unit t @@ -21,7 +21,7 @@ type _ t = | Layouts : maturity t | SIMD : unit t | Labeled_tuples : unit t - | Small_numbers : unit t + | Small_numbers : maturity t module Exist : sig type 'a extn = 'a t diff --git a/vendor/parser-jane/for-parser-standard/parser.mly b/vendor/parser-jane/for-parser-standard/parser.mly index e381d5a55b..8a65e636d1 100644 --- a/vendor/parser-jane/for-parser-standard/parser.mly +++ b/vendor/parser-jane/for-parser-standard/parser.mly @@ -30,7 +30,6 @@ open Parsetree open Ast_helper open Docstrings open Docstrings.WithMenhir -module N_ary = Jane_syntax.N_ary_functions let mkloc = Location.mkloc let mknoloc = Location.mknoloc @@ -175,15 +174,36 @@ let mkpat_with_modes ~loc ~pat ~cty ~modes = | cty, modes -> mkpat ~loc (Ppat_constraint (pat, cty, modes)) end -let ghpat_with_modes ~loc ~pat ~cty ~modes = +let ghpat_with_modes ~loc ~pat ~cty ~modes = let pat = mkpat_with_modes ~loc ~pat ~cty ~modes in { pat with ppat_loc = { pat.ppat_loc with loc_ghost = true }} -let add_mode_constraint_to_exp ~loc ~exp ~modes = +let mkexp_with_modes ~loc ~exp ~cty ~modes = match exp.pexp_desc with | Pexp_constraint (exp', cty', modes') -> - { exp with pexp_desc = Pexp_constraint (exp', cty', modes @ modes')} - | _ -> mkexp ~loc (Pexp_constraint (exp, None, modes)) + begin match cty, cty' with + | Some _, None -> + { exp with + pexp_desc = Pexp_constraint (exp', cty, modes @ modes'); + pexp_loc = make_loc loc + } + | None, _ -> + { exp with + pexp_desc = Pexp_constraint (exp', cty', modes @ modes'); + pexp_loc = make_loc loc + } + | _ -> + mkexp ~loc (Pexp_constraint (exp, cty, modes)) + end + | _ -> + begin match cty, modes with + | None, [] -> exp + | cty, modes -> mkexp ~loc (Pexp_constraint (exp, cty, modes)) + end + +let ghexp_with_modes ~loc ~exp ~cty ~modes = + let exp = mkexp_with_modes ~loc ~exp ~cty ~modes in + { exp with pexp_loc = { exp.pexp_loc with loc_ghost = true }} let exclave_ext_loc loc = mkloc "extension.exclave" loc @@ -194,14 +214,12 @@ let exclave_extension loc = let mkexp_exclave ~loc ~kwd_loc exp = ghexp ~loc (Pexp_apply(exclave_extension (make_loc kwd_loc), [Nolabel, exp])) -let curry_attr loc = - mk_attr ~loc:Location.none (mkloc "extension.curry" loc) (PStr []) - let is_curry_attr attr = - attr.attr_name.txt = "extension.curry" + attr.attr_name.txt = Jane_syntax.Arrow_curry.curry_attr_name let mktyp_curry typ loc = - {typ with ptyp_attributes = curry_attr loc :: typ.ptyp_attributes} + {typ with ptyp_attributes = + Jane_syntax.Arrow_curry.curry_attr loc :: typ.ptyp_attributes} let maybe_curry_typ typ loc = match typ.ptyp_desc with @@ -253,13 +271,13 @@ let mkstrexp e attrs = { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc } let mkexp_type_constraint ?(ghost=false) ~loc ~modes e t = - let desc = - match t with - | N_ary.Pconstraint t -> Pexp_constraint(e, Some t, modes) - | N_ary.Pcoerce(t1, t2) -> Pexp_coerce(e, t1, t2) - in - if ghost then ghexp ~loc desc - else mkexp ~loc desc + match t with + | Pconstraint t -> + let mk = if ghost then ghexp_with_modes else mkexp_with_modes in + mk ~loc ~exp:e ~cty:(Some t) ~modes + | Pcoerce(t1, t2) -> + let mk = if ghost then ghexp else mkexp ?attrs:None in + mk ~loc (Pexp_coerce(e, t1, t2)) let mkexp_opt_type_constraint ~loc ~modes e = function | None -> e @@ -549,7 +567,7 @@ let mk_newtypes ~loc newtypes exp = in [let_binding_body_no_punning]. *) let wrap_type_annotation ~loc ?(typloc=loc) ~modes newtypes core_type body = let mk_newtypes = mk_newtypes ~loc in - let exp = mkexp ~loc (Pexp_constraint(body,Some core_type,modes)) in + let exp = mkexp_with_modes ~loc ~exp:body ~cty:(Some core_type) ~modes in let exp = mk_newtypes newtypes exp in let inner_type = Typ.varify_constructors (List.map fst newtypes) core_type in let ltyp = @@ -651,7 +669,7 @@ type let_binding = lb_expression: expression; lb_constraint: value_constraint option; lb_is_pun: bool; - lb_modes: mode Location.loc list; + lb_modes: modes; lb_attributes: attributes; lb_docs: docs Lazy.t; lb_text: text Lazy.t; @@ -735,7 +753,6 @@ let class_of_let_bindings ~loc lbs body = parameter. *) let all_params_as_newtypes = - let open N_ary in let is_newtype { pparam_desc; _ } = match pparam_desc with | Pparam_newtype _ -> true @@ -759,30 +776,28 @@ let mkghost_newtype_function_body newtypes body_constraint body ~loc = let wrapped_body = match body_constraint with | None -> body - | Some { N_ary.type_constraint; mode_annotations } -> + | Some { type_constraint; mode_annotations } -> let {Location.loc_start; loc_end} = body.pexp_loc in let loc = loc_start, loc_end in mkexp_type_constraint ~ghost:true ~loc ~modes:mode_annotations body type_constraint in mk_newtypes ~loc newtypes wrapped_body -let n_ary_function expr ~attrs ~loc = - wrap_exp_attrs ~loc (N_ary.expr_of expr ~loc:(make_loc loc)) attrs - let mkfunction ~loc ~attrs params body_constraint body = match body with - | N_ary.Pfunction_cases _ -> - n_ary_function (params, body_constraint, body) ~loc ~attrs - | N_ary.Pfunction_body body_exp -> begin + | Pfunction_cases _ -> + mkexp_attrs (Pexp_function (params, body_constraint, body)) attrs ~loc + | Pfunction_body body_exp -> begin (* If all the params are newtypes, then we don't create a function node; - we create a newtype node. *) + we create nested newtype nodes. *) match all_params_as_newtypes params with - | None -> n_ary_function (params, body_constraint, body) ~loc ~attrs + | None -> + mkexp_attrs (Pexp_function (params, body_constraint, body)) attrs ~loc | Some newtypes -> wrap_exp_attrs ~loc (mkghost_newtype_function_body newtypes body_constraint body_exp - ~loc) + ~loc) attrs end @@ -1681,7 +1696,7 @@ paren_module_expr: e = expr { e } | e = expr COLON ty = package_type - { ghexp ~loc:$loc (Pexp_constraint (e, Some ty, [])) } + { ghexp_with_modes ~loc:$loc ~exp:e ~cty:(Some ty) ~modes:[] } | e = expr COLON ty1 = package_type COLONGREATER ty2 = package_type { ghexp ~loc:$loc (Pexp_coerce (e, Some ty1, ty2)) } | e = expr COLONGREATER ty2 = package_type @@ -2554,8 +2569,15 @@ class_type_declarations: | FUNCTION ext_attributes match_cases { let loc = make_loc $sloc in let cases = $3 in - mkfunction [] None (Pfunction_cases (cases, loc, [])) - ~loc:$sloc ~attrs:$2 + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + mkfunction [] None (Pfunction_cases (cases, loc, [])) ~attrs:$2 + ~loc:$sloc } ; @@ -2585,22 +2607,25 @@ seq_expr: labeled_simple_pattern: QUESTION LPAREN modes0=optional_mode_expr_legacy x=label_let_pattern opt_default RPAREN { let lbl, pat, cty, modes = x in + let loc = $startpos(modes0), $endpos(x) in (Optional lbl, $5, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:(modes0 @ modes)) + mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) } | QUESTION label_var { (Optional (fst $2), None, snd $2) } | OPTLABEL LPAREN modes0=optional_mode_expr_legacy x=let_pattern opt_default RPAREN { let pat, cty, modes = x in + let loc = $startpos(modes0), $endpos(x) in (Optional $1, $5, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:(modes0 @ modes)) + mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) } | OPTLABEL pattern_var { (Optional $1, None, $2) } | TILDE LPAREN modes0=optional_mode_expr_legacy x=label_let_pattern RPAREN { let lbl, pat, cty, modes = x in + let loc = $startpos(modes0), $endpos(x) in (Labelled lbl, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:(modes0 @ modes)) + mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) } | TILDE label_var { (Labelled (fst $2), None, snd $2) } @@ -2608,39 +2633,44 @@ labeled_simple_pattern: { (Labelled $1, None, $2) } | LABEL LPAREN modes0=optional_mode_expr_legacy x=let_pattern_required_modes RPAREN { let pat, cty, modes = x in + let loc = $startpos(modes0), $endpos(x) in (Labelled $1, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:(modes0 @ modes)) + mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) } | LABEL LPAREN modes=mode_expr_legacy pat=pattern RPAREN - { (Labelled $1, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty:None ~modes) + { let loc = $startpos(modes), $endpos(pat) in + (Labelled $1, None, + mkpat_with_modes ~loc ~pat ~cty:None ~modes) } | simple_pattern { (Nolabel, None, $1) } | LPAREN modes=mode_expr_legacy x=let_pattern_no_modes RPAREN { let pat, cty = x in + let loc = $startpos(modes), $endpos(x) in (Nolabel, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes) + mkpat_with_modes ~loc ~pat ~cty ~modes) } | LPAREN modes0=optional_mode_expr_legacy x=let_pattern_required_modes RPAREN { let pat, cty, modes = x in + let loc = $startpos(modes0), $endpos(x) in (Nolabel, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:(modes0 @ modes)) + mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) } | LABEL LPAREN x=poly_pattern_no_modes RPAREN { let pat, cty = x in (Labelled $1, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:[]) + mkpat_with_modes ~loc:$loc(x) ~pat ~cty ~modes:[]) } | LABEL LPAREN modes=mode_expr_legacy x=poly_pattern_no_modes RPAREN { let pat, cty = x in + let loc = $startpos(modes), $endpos(x) in (Labelled $1, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes) + mkpat_with_modes ~loc ~pat ~cty ~modes) } | LPAREN x=poly_pattern_no_modes RPAREN { let pat, cty = x in (Nolabel, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:[]) + mkpat_with_modes ~loc:$loc(x) ~pat ~cty ~modes:[]) } ; @@ -2656,7 +2686,7 @@ pattern_var: { $1 } ; label_let_pattern: - x = label_var modes = optional_at_mode_expr + x = label_var modes = optional_at_mode_expr { let lab, pat = x in lab, pat, None, modes } @@ -2743,7 +2773,7 @@ let_pattern_no_modes: fun_expr: simple_expr %prec below_HASH { $1 } - | expr_attrs + | fun_expr_attrs { let desc, attrs = $1 in mkexp_attrs ~loc:$sloc desc attrs } /* Cf #5939: we used to accept (fun p when e0 -> e) */ @@ -2751,7 +2781,7 @@ fun_expr: MINUSGREATER fun_body { let body_constraint = Option.map - (fun x : N_ary.function_constraint -> + (fun x -> { type_constraint = Pconstraint x ; mode_annotations = [] }) @@ -2786,14 +2816,14 @@ fun_expr: { not_expecting $loc($1) "wildcard \"_\"" } /* END AVOID */ | mode=mode_legacy exp=seq_expr - { add_mode_constraint_to_exp ~loc:$sloc ~exp ~modes:[mode] } + { mkexp_with_modes ~loc:$sloc ~exp ~cty:None ~modes:[mode] } | EXCLAVE seq_expr { mkexp_exclave ~loc:$sloc ~kwd_loc:($loc($1)) $2 } ; %inline expr: | or_function(fun_expr) { $1 } ; -%inline expr_attrs: +%inline fun_expr_attrs: | LET MODULE ext_attributes mkrhs(module_name) module_binding_body IN seq_expr { Pexp_letmodule($4, $5, $7), $3 } | LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr @@ -2922,7 +2952,7 @@ comprehension_clause_binding: over to the RHS of the binding, so we need everything to be visible. *) | attributes mode_legacy pattern IN expr { let expr = - add_mode_constraint_to_exp ~loc:$sloc ~exp:$5 ~modes:[$2] + mkexp_with_modes ~loc:$sloc ~exp:$5 ~cty:None ~modes:[$2] in Jane_syntax.Comprehensions. { pattern = $3 @@ -3111,9 +3141,9 @@ let_binding_body_no_punning: let typ, modes1 = $3 in let t = Option.map (function - | N_ary.Pconstraint t -> + | Pconstraint t -> Pvc_constraint { locally_abstract_univars = []; typ=t } - | N_ary.Pcoerce (ground, coercion) -> Pvc_coercion { ground; coercion} + | Pcoerce (ground, coercion) -> Pvc_coercion { ground; coercion} ) typ in let modes = modes0 @ modes1 in @@ -3240,13 +3270,14 @@ strict_binding_modes: (* CR zqian: The above [type_constraint] should be replaced by [constraint_] to support mode annotation *) { fun mode_annotations -> - let constraint_ : N_ary.function_constraint option = + let constraint_ : function_constraint option = match $2 with | None -> None | Some type_constraint -> Some { type_constraint; mode_annotations } in let exp = mkfunction $1 constraint_ $4 ~loc:$sloc ~attrs:(None, []) in { exp with pexp_loc = { exp.pexp_loc with loc_ghost = true } } + } ; %inline strict_binding: @@ -3257,15 +3288,15 @@ fun_body: | FUNCTION ext_attributes match_cases { let ext, attrs = $2 in match ext with - | None -> N_ary.Pfunction_cases ($3, make_loc $sloc, attrs) + | None -> Pfunction_cases ($3, make_loc $sloc, attrs) | Some _ -> (* function%foo extension nodes interrupt the arity *) - let cases = N_ary.Pfunction_cases ($3, make_loc $sloc, []) in + let cases = Pfunction_cases ($3, make_loc $sloc, []) in let function_ = mkfunction [] None cases ~loc:$sloc ~attrs:$2 in - N_ary.Pfunction_body function_ + Pfunction_body function_ } | fun_seq_expr - { N_ary.Pfunction_body $1 } + { Pfunction_body $1 } ; %inline match_cases: xs = preceded_or_separated_nonempty_llist(BAR, match_case) @@ -3291,20 +3322,20 @@ fun_param_as_list: in List.map (fun (newtype, jkind) -> - { N_ary.pparam_loc = loc; + { pparam_loc = loc; pparam_desc = Pparam_newtype (newtype, jkind) }) ty_params } | LPAREN TYPE mkrhs(LIDENT) COLON jkind_annotation RPAREN - { [ { N_ary.pparam_loc = make_loc $sloc; + { [ { pparam_loc = make_loc $sloc; pparam_desc = Pparam_newtype ($3, Some $5) } ] } | labeled_simple_pattern { let a, b, c = $1 in - [ { N_ary.pparam_loc = make_loc $sloc; + [ { pparam_loc = make_loc $sloc; pparam_desc = Pparam_val (a, b, c) } ] @@ -3434,9 +3465,9 @@ record_expr_content: { es } ; type_constraint: - COLON core_type { N_ary.Pconstraint $2 } - | COLON core_type COLONGREATER core_type { N_ary.Pcoerce (Some $2, $4) } - | COLONGREATER core_type { N_ary.Pcoerce (None, $2) } + COLON core_type { Pconstraint $2 } + | COLON core_type COLONGREATER core_type { Pcoerce (Some $2, $4) } + | COLONGREATER core_type { Pcoerce (None, $2) } | COLON error { syntax_error() } | COLONGREATER error { syntax_error() } ; @@ -3743,7 +3774,7 @@ value_description: { let attrs = attrs1 @ attrs2 in let loc = make_loc $sloc in let docs = symbol_docs $sloc in - Val.mk id ty ~modalities ~attrs ~loc ~docs, + Val.mk id ty ~attrs ~modalities ~loc ~docs, ext } ; @@ -3756,13 +3787,14 @@ primitive_declaration: id = mkrhs(val_ident) COLON ty = possibly_poly(core_type) + modalities = optional_atat_modalities_expr EQUAL prim = raw_string+ attrs2 = post_item_attributes { let attrs = attrs1 @ attrs2 in let loc = make_loc $sloc in let docs = symbol_docs $sloc in - Val.mk id ty ~prim ~attrs ~loc ~docs, + Val.mk id ty ~prim ~attrs ~modalities ~loc ~docs, ext } ; @@ -3906,8 +3938,7 @@ jkind: } | mkrhs(ident) { let {txt; loc} = $1 in - Jane_syntax.Jkind.(Primitive_layout_or_abbreviation - (Const.mk txt loc)) + Jane_syntax.Jkind.(Abbreviation (Const.mk txt loc)) } | KIND_OF ty=core_type { Jane_syntax.Jkind.Kind_of ty @@ -4574,9 +4605,24 @@ atomic_type: { [] } | ty = atomic_type { [ty] } - | LPAREN tys = separated_nontrivial_llist(COMMA, core_type) RPAREN + | LPAREN + tys = separated_nontrivial_llist(COMMA, one_type_parameter_of_several) + RPAREN { tys } +(* Layout annotations on type expressions typically require parens, as in [('a : + float64)]. But this is unnecessary when the type expression is used as the + parameter of a tconstr with more than one argument, as in [(int, 'b : + float64) t]. *) +%inline one_type_parameter_of_several: + | core_type { $1 } + | QUOTE id=ident COLON jkind=jkind_annotation + { Jane_syntax.Layouts.type_of ~loc:(make_loc $sloc) @@ + Ltyp_var { name = Some id; jkind } } + | UNDERSCORE COLON jkind=jkind_annotation + { Jane_syntax.Layouts.type_of ~loc:(make_loc $sloc) @@ + Ltyp_var { name = None; jkind } } + %inline package_type: module_type { let (lid, cstrs, attrs) = package_type_of_module_type $1 in let descr = Ptyp_package (lid, cstrs) in diff --git a/vendor/parser-jane/for-parser-standard/parsetree.mli b/vendor/parser-jane/for-parser-standard/parsetree.mli index 63ac7be204..2320fa2d3d 100644 --- a/vendor/parser-jane/for-parser-standard/parsetree.mli +++ b/vendor/parser-jane/for-parser-standard/parsetree.mli @@ -46,8 +46,10 @@ type constant = type location_stack = Location.t list type modality = | Modality of string [@@unboxed] +type modalities = modality loc list type mode = | Mode of string [@@unboxed] +type modes = mode loc list (** {1 Extension points} *) @@ -91,7 +93,7 @@ and core_type = and core_type_desc = | Ptyp_any (** [_] *) | Ptyp_var of string (** A type variable such as ['a] *) - | Ptyp_arrow of arg_label * core_type * core_type * mode loc list * mode loc list + | Ptyp_arrow of arg_label * core_type * core_type * modes * modes (** [Ptyp_arrow(lbl, T1, T2, M1, M2)] represents: - [T1 @ M1 -> T2 @ M2] when [lbl] is {{!arg_label.Nolabel}[Nolabel]}, @@ -273,7 +275,7 @@ and pattern_desc = *) | Ppat_array of pattern list (** Pattern [[| P1; ...; Pn |]] *) | Ppat_or of pattern * pattern (** Pattern [P1 | P2] *) - | Ppat_constraint of pattern * core_type option * mode loc list + | Ppat_constraint of pattern * core_type option * modes (** [Ppat_constraint(tyopt, modes)] represents: - [(P : ty @@ modes)] when [tyopt] is [Some ty] - [(P @ modes)] when [tyopt] is [None] @@ -323,33 +325,21 @@ and expression_desc = - [let rec P1 = E1 and ... and Pn = EN in E] when [flag] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. *) - | Pexp_function of case list (** [function P1 -> E1 | ... | Pn -> En] *) - | Pexp_fun of arg_label * expression option * pattern * expression - (** [Pexp_fun(lbl, exp0, P, E1)] represents: - - [fun P -> E1] - when [lbl] is {{!arg_label.Nolabel}[Nolabel]} - and [exp0] is [None] - - [fun ~l:P -> E1] - when [lbl] is {{!arg_label.Labelled}[Labelled l]} - and [exp0] is [None] - - [fun ?l:P -> E1] - when [lbl] is {{!arg_label.Optional}[Optional l]} - and [exp0] is [None] - - [fun ?l:(P = E0) -> E1] - when [lbl] is {{!arg_label.Optional}[Optional l]} - and [exp0] is [Some E0] - - Notes: - - If [E0] is provided, only - {{!arg_label.Optional}[Optional]} is allowed. - - [fun P1 P2 .. Pn -> E1] is represented as nested - {{!expression_desc.Pexp_fun}[Pexp_fun]}. - - [let f P = E] is represented using - {{!expression_desc.Pexp_fun}[Pexp_fun]}. - - While Position arguments ([lbl:[%call_pos] -> ...]) are parsed as - {{!Asttypes.arg_label.Labelled}[Labelled l]}, they are converted to - {{!Types.arg_label.Position}[Position l]} arguments for type-checking. - *) + | Pexp_function of + function_param list * function_constraint option * function_body + (** [Pexp_function ([P1; ...; Pn], C, body)] represents any construct + involving [fun] or [function], including: + - [fun P1 ... Pn -> E] + when [body = Pfunction_body E] + - [fun P1 ... Pn -> function p1 -> e1 | ... | pm -> em] + when [body = Pfunction_cases [ p1 -> e1; ...; pm -> em ]] + + [C] represents a type constraint or coercion placed immediately before the + arrow, e.g. [fun P1 ... Pn : ty -> ...] when [C = Some (Pconstraint ty)]. + + A function must have parameters. [Pexp_function (params, _, body)] must + have non-empty [params] or a [Pfunction_cases _] body. + *) | Pexp_apply of expression * (arg_label * expression) list (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] represents [E0 ~l1:E1 ... ~ln:En] @@ -403,7 +393,7 @@ and expression_desc = - [for i = E1 downto E2 do E3 done] when [direction] is {{!Asttypes.direction_flag.Downto}[Downto]} *) - | Pexp_constraint of expression * core_type option * mode loc list (** [(E : T @@ modes)] *) + | Pexp_constraint of expression * core_type option * modes (** [(E : T @@ modes)] *) | Pexp_coerce of expression * core_type option * core_type (** [Pexp_coerce(E, from, T)] represents - [(E :> T)] when [from] is [None], @@ -470,13 +460,83 @@ and binding_op = pbop_loc : Location.t; } +and function_param_desc = + | Pparam_val of arg_label * expression option * pattern + (** [Pparam_val (lbl, exp0, P)] represents the parameter: + - [P] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} + and [exp0] is [None] + - [~l:P] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} + and [exp0] is [None] + - [?l:P] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [None] + - [?l:(P = E0)] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [Some E0] + + Note: If [E0] is provided, only + {{!Asttypes.arg_label.Optional}[Optional]} is allowed. + *) + | Pparam_newtype of string loc * jkind_annotation loc option + (** [Pparam_newtype x] represents the parameter [(type x)]. + [x] carries the location of the identifier, whereas the [pparam_loc] + on the enclosing [function_param] node is the location of the [(type x)] + as a whole. + + Multiple parameters [(type a b c)] are represented as multiple + [Pparam_newtype] nodes, let's say: + + {[ [ { pparam_kind = Pparam_newtype a; pparam_loc = loc1 }; + { pparam_kind = Pparam_newtype b; pparam_loc = loc2 }; + { pparam_kind = Pparam_newtype c; pparam_loc = loc3 }; + ] + ]} + + Here, the first loc [loc1] is the location of [(type a b c)], and the + subsequent locs [loc2] and [loc3] are the same as [loc1], except marked as + ghost locations. The locations on [a], [b], [c], correspond to the + variables [a], [b], and [c] in the source code. + *) + +and function_param = + { pparam_loc : Location.t; + pparam_desc : function_param_desc; + } + +and function_body = + | Pfunction_body of expression + | Pfunction_cases of case list * Location.t * attributes + (** In [Pfunction_cases (_, loc, attrs)], the location extends from the + start of the [function] keyword to the end of the last case. The compiler + will only use typechecking-related attributes from [attrs], e.g. enabling + or disabling a warning. + *) +(** See the comment on {{!expression_desc.Pexp_function}[Pexp_function]}. *) + +and type_constraint = + | Pconstraint of core_type + | Pcoerce of core_type option * core_type +(** See the comment on {{!expression_desc.Pexp_function}[Pexp_function]}. *) + +and function_constraint = + { mode_annotations : modes; + (** The mode annotation placed on a function let-binding when the function + has a type constraint on the body, e.g. + [let local_ f x : int -> int = ...]. + *) + type_constraint : type_constraint; + } +(** See the comment on {{!expression_desc.Pexp_function}[Pexp_function]}. *) + (** {2 Value descriptions} *) and value_description = { pval_name: string loc; pval_type: core_type; - pval_modalities: modality loc list; + pval_modalities : modalities; pval_prim: string list; pval_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) pval_loc: Location.t; @@ -539,7 +599,7 @@ and label_declaration = { pld_name: string loc; pld_mutable: mutable_flag; - pld_modalities: modality loc list; + pld_modalities: modalities; pld_type: core_type; pld_loc: Location.t; pld_attributes: attributes; (** [l : T [\@id1] [\@id2]] *) @@ -567,7 +627,7 @@ and constructor_declaration = and constructor_argument = { - pca_modalities: modality loc list; + pca_modalities: modalities; pca_type: core_type; pca_loc: Location.t; } @@ -1073,7 +1133,7 @@ and value_binding = pvb_pat: pattern; pvb_expr: expression; pvb_constraint: value_constraint option; - pvb_modes: mode loc list; + pvb_modes: modes; pvb_attributes: attributes; pvb_loc: Location.t; }(** [let pat : type_constraint = exp] *) @@ -1087,6 +1147,15 @@ and module_binding = } (** Values of type [module_binding] represents [module X = ME] *) +and jkind_const_annotation = string Location.loc + +and jkind_annotation = + | Default + | Abbreviation of jkind_const_annotation + | Mod of jkind_annotation * modes + | With of jkind_annotation * core_type + | Kind_of of core_type + (** {1 Toplevel} *) (** {2 Toplevel phrases} *) diff --git a/vendor/parser-jane/for-parser-standard/printast.ml b/vendor/parser-jane/for-parser-standard/printast.ml index 4ea30d5f6e..f7284ea345 100644 --- a/vendor/parser-jane/for-parser-standard/printast.ml +++ b/vendor/parser-jane/for-parser-standard/printast.ml @@ -135,17 +135,19 @@ let typevars ppf vs = (* Don't use Pprintast.tyvar, as that causes a dependency cycle with Jane_syntax, which depends on this module for debugging. *) +let modality i ppf modality = + line i ppf "modality %a\n" fmt_string_loc + (Location.map (fun (Modality x) -> x) modality) + let modalities i ppf modalities = - line i ppf "modalities\n"; - list i string_loc ppf ( - List.map (Location.map (fun (Modality x) -> x)) modalities - ) + List.iter (fun m -> modality i ppf m) modalities + +let mode i ppf mode = + line i ppf "mode %a\n" fmt_string_loc + (Location.map (fun (Mode x) -> x) mode) let modes i ppf modes = - line i ppf "modes\n"; - list i string_loc ppf ( - List.map (Location.map (fun (Mode x) -> x)) modes - ) + List.iter (fun m -> mode i ppf m) modes let rec core_type i ppf x = line i ppf "core_type %a\n" fmt_location x.ptyp_loc; @@ -158,8 +160,8 @@ let rec core_type i ppf x = line i ppf "Ptyp_arrow\n"; arg_label i ppf l; core_type i ppf ct1; - core_type i ppf ct2; modes i ppf m1; + core_type i ppf ct2; modes i ppf m2; | Ptyp_tuple l -> line i ppf "Ptyp_tuple\n"; @@ -246,7 +248,7 @@ and pattern i ppf x = | Ppat_constraint (p, ct, m) -> line i ppf "Ppat_constraint\n"; pattern i ppf p; - option i core_type ppf ct; + Option.iter (core_type i ppf) ct; modes i ppf m; | Ppat_type (li) -> line i ppf "Ppat_type\n"; @@ -274,15 +276,11 @@ and expression i ppf x = line i ppf "Pexp_let %a\n" fmt_rec_flag rf; list i value_binding ppf l; expression i ppf e; - | Pexp_function l -> + | Pexp_function (params, c, body) -> line i ppf "Pexp_function\n"; - list i case ppf l; - | Pexp_fun (l, eo, p, e) -> - line i ppf "Pexp_fun\n"; - arg_label i ppf l; - option i expression ppf eo; - pattern i ppf p; - expression i ppf e; + list i function_param ppf params; + option i function_constraint ppf c; + function_body i ppf body | Pexp_apply (e, l) -> line i ppf "Pexp_apply\n"; expression i ppf e; @@ -342,7 +340,7 @@ and expression i ppf x = | Pexp_constraint (e, ct, m) -> line i ppf "Pexp_constraint\n"; expression i ppf e; - option i core_type ppf ct; + Option.iter (core_type i ppf) ct; modes i ppf m; | Pexp_coerce (e, cto1, cto2) -> line i ppf "Pexp_coerce\n"; @@ -401,13 +399,68 @@ and expression i ppf x = | Pexp_unreachable -> line i ppf "Pexp_unreachable" +and jkind_annotation i ppf (jkind : jkind_annotation) = + match jkind with + | Default -> line i ppf "Default\n" + | Abbreviation jkind -> + line i ppf "Abbreviation \"%s\"\n" jkind.txt + | Mod (jkind, m) -> + line i ppf "Mod\n"; + jkind_annotation (i+1) ppf jkind; + modes (i+1) ppf m + | With (jkind, type_) -> + line i ppf "With\n"; + jkind_annotation (i+1) ppf jkind; + core_type (i+1) ppf type_ + | Kind_of type_ -> + line i ppf "Kind_of\n"; + core_type (i+1) ppf type_ + +and function_param i ppf { pparam_desc = desc; pparam_loc = loc } = + match desc with + | Pparam_val (l, eo, p) -> + line i ppf "Pparam_val %a\n" fmt_location loc; + arg_label (i+1) ppf l; + option (i+1) expression ppf eo; + pattern (i+1) ppf p + | Pparam_newtype (ty, jkind) -> + line i ppf "Pparam_newtype \"%s\" %a\n" ty.txt fmt_location loc; + option (i+1) + (fun i ppf jkind -> jkind_annotation i ppf jkind.txt) + ppf + jkind + +and function_body i ppf body = + match body with + | Pfunction_body e -> + line i ppf "Pfunction_body\n"; + expression (i+1) ppf e + | Pfunction_cases (cases, loc, attrs) -> + line i ppf "Pfunction_cases %a\n" fmt_location loc; + attributes (i+1) ppf attrs; + list (i+1) case ppf cases + +and type_constraint i ppf type_constraint = + match type_constraint with + | Pconstraint ty -> + line i ppf "Pconstraint\n"; + core_type (i+1) ppf ty + | Pcoerce (ty1, ty2) -> + line i ppf "Pcoerce\n"; + option (i+1) core_type ppf ty1; + core_type (i+1) ppf ty2 + +and function_constraint i ppf { type_constraint = c; mode_annotations } = + type_constraint i ppf c; + modes i ppf mode_annotations + and value_description i ppf x = line i ppf "value_description %a %a\n" fmt_string_loc x.pval_name fmt_location x.pval_loc; attributes i ppf x.pval_attributes; core_type (i+1) ppf x.pval_type; - list (i+1) string ppf x.pval_prim; - modalities (i+1) ppf x.pval_modalities + modalities (i+1) ppf x.pval_modalities; + list (i+1) string ppf x.pval_prim and type_parameter i ppf (x, _variance) = core_type i ppf x diff --git a/vendor/parser-jane/imported_commit.txt b/vendor/parser-jane/imported_commit.txt index 31572e8af8..cae89ef8d0 100644 --- a/vendor/parser-jane/imported_commit.txt +++ b/vendor/parser-jane/imported_commit.txt @@ -1 +1 @@ -79f7056b4a06c10a67208c9d2e74f90243f4c807 +915acd68e493261e1806dc8af45ba7d6eb241d49 diff --git a/vendor/parser-standard/ast_helper.ml b/vendor/parser-standard/ast_helper.ml index 4314225db8..dbbdd1dc93 100644 --- a/vendor/parser-standard/ast_helper.ml +++ b/vendor/parser-standard/ast_helper.ml @@ -192,8 +192,7 @@ module Exp = struct let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) + let function_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_function (a, b, c)) let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) @@ -419,12 +418,12 @@ end module Val = struct let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) ?(modalities = []) name typ = + ?(prim = []) ?(modalities=[]) name typ = { pval_name = name; pval_type = typ; - pval_modalities = modalities; pval_attributes = add_docs_attrs docs attrs; + pval_modalities = modalities; pval_loc = loc; pval_prim = prim; } diff --git a/vendor/parser-standard/ast_mapper.ml b/vendor/parser-standard/ast_mapper.ml index d7d9f3122f..3d7bccd8a1 100644 --- a/vendor/parser-standard/ast_mapper.ml +++ b/vendor/parser-standard/ast_mapper.ml @@ -29,8 +29,8 @@ module String = Misc.Stdlib.String type mapper = { attribute: mapper -> attribute -> attribute; attributes: mapper -> attribute list -> attribute list; - modes : mapper -> mode loc list -> mode loc list; - modalities : mapper -> modality loc list -> modality loc list; + modes : mapper -> modes -> modes; + modalities : mapper -> modalities -> modalities; binding_op: mapper -> binding_op -> binding_op; case: mapper -> case -> case; cases: mapper -> case list -> case list; @@ -572,7 +572,39 @@ module E = struct module C = Jane_syntax.Comprehensions module IA = Jane_syntax.Immutable_arrays module L = Jane_syntax.Layouts - module N_ary = Jane_syntax.N_ary_functions + module LT = Jane_syntax.Labeled_tuples + + let map_function_param sub { pparam_loc = loc; pparam_desc = desc } = + let loc = sub.location sub loc in + let desc = + match desc with + | Pparam_val (label, def, pat) -> + Pparam_val (label, Option.map (sub.expr sub) def, sub.pat sub pat) + | Pparam_newtype (newtype, jkind) -> + Pparam_newtype + ( map_loc sub newtype + , map_opt (map_loc_txt sub sub.jkind_annotation) jkind + ) + in + { pparam_loc = loc; pparam_desc = desc } + + let map_function_body sub body = + match body with + | Pfunction_body exp -> Pfunction_body (sub.expr sub exp) + | Pfunction_cases (cases, loc, attrs) -> + Pfunction_cases + (sub.cases sub cases, sub.location sub loc, sub.attributes sub attrs) + + let map_type_constraint sub constraint_ = + match constraint_ with + | Pconstraint ty -> Pconstraint (sub.typ sub ty) + | Pcoerce (ty1, ty2) -> + Pcoerce (Option.map (sub.typ sub) ty1, sub.typ sub ty2) + + let map_function_constraint sub { mode_annotations; type_constraint } = + { mode_annotations = sub.modes sub mode_annotations; + type_constraint = map_type_constraint sub type_constraint; + } let map_iterator sub : C.iterator -> C.iterator = function | Range { start; stop; direction } -> @@ -619,49 +651,6 @@ module E = struct let inner_expr = sub.expr sub inner_expr in Lexp_newtype (str, jkind, inner_expr) - let map_function_param sub : N_ary.function_param -> N_ary.function_param = - fun { pparam_loc = loc; pparam_desc = desc } -> - let loc = sub.location sub loc in - let desc : N_ary.function_param_desc = - match desc with - | Pparam_val (label, def, pat) -> - Pparam_val (label, Option.map (sub.expr sub) def, sub.pat sub pat) - | Pparam_newtype (newtype, jkind) -> - Pparam_newtype - ( map_loc sub newtype - , map_opt (map_loc_txt sub sub.jkind_annotation) jkind - ) - in - { pparam_loc = loc; pparam_desc = desc } - - let map_type_constraint sub : N_ary.type_constraint -> N_ary.type_constraint = - function - | Pconstraint ty -> Pconstraint (sub.typ sub ty) - | Pcoerce (ty1, ty2) -> - Pcoerce (Option.map (sub.typ sub) ty1, sub.typ sub ty2) - - let map_function_constraint sub - : N_ary.function_constraint -> N_ary.function_constraint = - function - | { mode_annotations; type_constraint } -> - { mode_annotations = sub.modes sub mode_annotations; - type_constraint = map_type_constraint sub type_constraint; - } - - let map_function_body sub : N_ary.function_body -> N_ary.function_body = - function - | Pfunction_body exp -> Pfunction_body (sub.expr sub exp) - | Pfunction_cases (cases, loc, attrs) -> - Pfunction_cases - (sub.cases sub cases, sub.location sub loc, sub.attributes sub attrs) - - let map_n_ary_exp sub : N_ary.expression -> N_ary.expression = function - | (params, constraint_, body) -> - let params = List.map (map_function_param sub) params in - let constraint_ = Option.map (map_function_constraint sub) constraint_ in - let body = map_function_body sub body in - params, constraint_, body - let map_ltexp sub el = List.map (map_snd (sub.expr sub)) el (* CR labeled tuples: Eventually mappers may want to see the labels. *) @@ -670,7 +659,6 @@ module E = struct | Jexp_comprehension x -> Jexp_comprehension (map_cexp sub x) | Jexp_immutable_array x -> Jexp_immutable_array (map_iaexp sub x) | Jexp_layout x -> Jexp_layout (map_layout_exp sub x) - | Jexp_n_ary_function x -> Jexp_n_ary_function (map_n_ary_exp sub x) | Jexp_tuple ltexp -> Jexp_tuple (map_ltexp sub ltexp) let map sub @@ -691,12 +679,11 @@ module E = struct | Pexp_let (r, vbs, e) -> let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - (fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) [@alert "-prefer_jane_syntax"]) - | Pexp_function pel -> - (function_ ~loc ~attrs (sub.cases sub pel) - [@alert "-prefer_jane_syntax"]) + | Pexp_function (ps, c, b) -> + function_ ~loc ~attrs + (List.map (map_function_param sub) ps) + (map_opt (map_function_constraint sub) c) + (map_function_body sub b) | Pexp_apply (e, l) -> apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) | Pexp_match (e, pel) -> @@ -942,7 +929,7 @@ let default_mapper = type_exception = T.map_type_exception; extension_constructor = T.map_extension_constructor; value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; pval_modalities; + (fun this {pval_name; pval_type; pval_modalities; pval_prim; pval_loc; pval_attributes} -> Val.mk (map_loc this pval_name) @@ -1114,11 +1101,11 @@ let default_mapper = let open Jane_syntax in function | Default -> Default - | Primitive_layout_or_abbreviation s -> + | Abbreviation s -> let {txt; loc} = - map_loc this (s : Jkind.Const.t :> _ loc) + map_loc this s in - Primitive_layout_or_abbreviation (Jkind.Const.mk txt loc) + Abbreviation (Jkind.Const.mk txt loc) | Mod (t, mode_list) -> Mod (this.jkind_annotation this t, this.modes this mode_list) | With (t, ty) -> diff --git a/vendor/parser-standard/jane_syntax.ml b/vendor/parser-standard/jane_syntax.ml index 8998adbe94..e22c385b72 100644 --- a/vendor/parser-standard/jane_syntax.ml +++ b/vendor/parser-standard/jane_syntax.ml @@ -39,22 +39,10 @@ end = struct end module Of_ast (Ext : Extension) : sig - module Desugaring_error : sig - type error = - | Not_this_embedding of Embedded_name.t - | Non_embedding - end - type unwrapped := string list * payload * attributes - (* Find and remove a jane-syntax attribute marker, returning an error + (* Find and remove a jane-syntax attribute marker, throwing an exception if the attribute name does not have the right format or extension. *) - val unwrap_jane_syntax_attributes : - attributes -> (unwrapped, Desugaring_error.error) result - - (* The same as [unwrap_jane_syntax_attributes], except throwing - an exception instead of returning an error. - *) val unwrap_jane_syntax_attributes_exn : loc:Location.t -> attributes -> unwrapped end = struct @@ -338,19 +326,28 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) : Make_payload_protocol_of_structure_item_encodable (Make_structure_item_encodable_of_stringable (Stringable)) +module Arrow_curry = struct + let curry_attr_name = "extension.curry" + + let curry_attr loc = + Ast_helper.Attr.mk ~loc:Location.none + (Location.mkloc curry_attr_name loc) + (PStr []) +end + (* only used for [Jkind] below *) module Mode = struct module Protocol = Make_payload_protocol_of_stringable (struct - type t = mode + type t = mode - let indefinite_article_and_name = "a", "mode" + let indefinite_article_and_name = "a", "mode" - let to_string (Mode s) = s + let to_string (Mode s) = s - let of_string' s = Mode s + let of_string' s = Mode s - let of_string s = Some (of_string' s) - end) + let of_string s = Some (of_string' s) + end) let list_as_payload = Protocol.Encode.list_as_payload @@ -359,9 +356,7 @@ end module Jkind = struct module Const : sig - type raw = string - - type t = private raw loc + type t = Parsetree.jkind_const_annotation val mk : string -> Location.t -> t @@ -390,10 +385,10 @@ module Jkind = struct let to_structure_item = Protocol.to_structure_item end - type t = + type t = Parsetree.jkind_annotation = | Default - | Primitive_layout_or_abbreviation of Const.t - | Mod of t * mode loc list + | Abbreviation of Const.t + | Mod of t * modes | With of t * core_type | Kind_of of core_type @@ -449,8 +444,8 @@ module Jkind = struct let to_structure_item t = to_structure_item (Location.mknoloc t) in match t_loc.txt with | Default -> struct_item_of_list "default" [] t_loc.loc - | Primitive_layout_or_abbreviation c -> - struct_item_of_list "prim" [Const.to_structure_item c] t_loc.loc + | Abbreviation c -> + struct_item_of_list "abbrev" [Const.to_structure_item c] t_loc.loc | Mod (t, modes) -> let mode_list_item = struct_item_of_attr @@ -475,9 +470,7 @@ module Jkind = struct | Some ("mod", [item_of_t; item_of_mode_expr], loc) -> bind (of_structure_item item_of_t) (fun { txt = t } -> bind (struct_item_to_attr item_of_mode_expr) (fun attr -> - let modes = - Mode.list_from_payload ~loc attr.attr_payload - in + let modes = Mode.list_from_payload ~loc attr.attr_payload in ret loc (Mod (t, modes)))) | Some ("with", [item_of_t; item_of_ty], loc) -> bind (of_structure_item item_of_t) (fun { txt = t } -> @@ -485,9 +478,8 @@ module Jkind = struct ret loc (With (t, ty)))) | Some ("kind_of", [item_of_ty], loc) -> bind (struct_item_to_type item_of_ty) (fun ty -> ret loc (Kind_of ty)) - | Some ("prim", [item], loc) -> - bind (Const.of_structure_item item) (fun c -> - ret loc (Primitive_layout_or_abbreviation c)) + | Some ("abbrev", [item], loc) -> + bind (Const.of_structure_item item) (fun c -> ret loc (Abbreviation c)) | Some _ | None -> None end @@ -789,459 +781,6 @@ module Immutable_arrays = struct | _ -> failwith "Malformed immutable array pattern" end -module N_ary_functions = struct - module Ext = struct - let feature : Feature.t = Builtin - end - - module Ast_of = Ast_of (Expression) (Ext) - module Of_ast = Of_ast (Ext) - open Ext - - type function_body = - | Pfunction_body of expression - | Pfunction_cases of case list * Location.t * attributes - - type function_param_desc = - | Pparam_val of arg_label * expression option * pattern - | Pparam_newtype of string loc * Jkind.annotation option - - type function_param = - { pparam_desc : function_param_desc; - pparam_loc : Location.t - } - - type type_constraint = - | Pconstraint of core_type - | Pcoerce of core_type option * core_type - - type function_constraint = - { mode_annotations : mode loc list; - type_constraint : type_constraint - } - - type expression = - function_param list * function_constraint option * function_body - - (** An attribute of the form [@jane.erasable._builtin.*] that's relevant - to n-ary functions. The "*" in the example is what we call the "suffix". - See the below BNF for the meaning of the attributes. - *) - module Attribute_node = struct - type after_fun = - | Cases - | Constraint_then_cases - - type t = - | Top_level - | Fun_then of after_fun - | Jkind_annotation of Jkind.annotation - - (* We return an [of_suffix_result] from [of_suffix] rather than having - [of_suffix] interpret the payload for two reasons: - 1. It's nice to keep the string production / matching extremely - visually simple so it's easy to check that [to_suffix_and_payload] - and [of_suffix] correspond. - 2. We want to raise a [Desugaring_error.Has_payload] in the case that - a [No_payload t] has an improper payload, but this creates a - dependency cycle between [Attribute_node] and [Desugaring_error]. - Moving the interpretation of the payload to the caller of - [of_suffix] breaks this cycle. - *) - - type of_suffix_result = - | No_payload of t - | Payload of (payload -> loc:Location.t -> t) - | Unknown_suffix - - let to_suffix_and_payload = function - | Top_level -> [], None - | Fun_then Cases -> ["cases"], None - | Fun_then Constraint_then_cases -> ["constraint"; "cases"], None - | Jkind_annotation jkind_annotation -> - let payload = Jkind_annotation.Encode.as_payload jkind_annotation in - ["jkind_annotation"], Some payload - - let of_suffix suffix = - match suffix with - | [] -> No_payload Top_level - | ["cases"] -> No_payload (Fun_then Cases) - | ["constraint"; "cases"] -> No_payload (Fun_then Constraint_then_cases) - | ["jkind_annotation"] -> - Payload - (fun payload ~loc -> - assert_extension_enabled ~loc Layouts - (Stable : Language_extension.maturity); - let jkind_annotation = - Jkind_annotation.Decode.from_payload payload ~loc - in - Jkind_annotation jkind_annotation) - | _ -> Unknown_suffix - - let format ppf t = - let suffix, _ = to_suffix_and_payload t in - Embedded_name.pp_quoted_name ppf (Embedded_name.of_feature feature suffix) - end - - module Desugaring_error = struct - type error = - | Has_payload of payload - | Expected_constraint_or_coerce - | Expected_function_cases of Attribute_node.t - | Expected_fun_or_newtype of Attribute_node.t - | Expected_newtype_with_jkind_annotation of Jkind.annotation - | Parameterless_function - - let report_error ~loc = function - | Has_payload payload -> - Location.errorf ~loc - "Syntactic arity attribute has an unexpected payload:@;%a" - (Printast.payload 0) payload - | Expected_constraint_or_coerce -> - Location.errorf ~loc - "Expected a Pexp_constraint or Pexp_coerce node at this position." - | Expected_function_cases attribute -> - Location.errorf ~loc - "Expected a Pexp_function node in this position, as the enclosing \ - Pexp_fun is annotated with %a." - Attribute_node.format attribute - | Expected_fun_or_newtype attribute -> - Location.errorf ~loc - "Only Pexp_fun or Pexp_newtype may carry the attribute %a." - Attribute_node.format attribute - | Expected_newtype_with_jkind_annotation annotation -> - Location.errorf ~loc "Only Pexp_newtype may carry the attribute %a." - Attribute_node.format (Attribute_node.Jkind_annotation annotation) - | Parameterless_function -> - Location.errorf ~loc - "The expression is a Jane Syntax encoding of a function with no \ - parameters, which is an invalid expression." - - exception Error of Location.t * error - - let () = - Location.register_error_of_exn (function - | Error (loc, err) -> Some (report_error ~loc err) - | _ -> None) - - let raise_with_loc loc err = raise (Error (loc, err)) - - let raise expr err = raise (Error (expr.pexp_loc, err)) - end - - (* The desugared-to-OCaml version of an n-ary function is described by the - following BNF, where [{% '...' | expr %}] refers to the result of - [Expression.make_jane_syntax] (via n_ary_function_expr) as described at the - top of [jane_syntax_parsing.mli]. Within the '...' string, I use <...> - brackets to denote string interpolation. - - {v - (* The entry point. - - The encoding only puts attributes on: - - [fun] nodes - - constraint/coercion nodes, on the rare occasions - that a constraint should be interpreted at the [local] mode - - This ensures that we rarely put attributes on the *body* of the - function, which means that ppxes that move or transform the body - of a function won't make Jane Syntax complain. - *) - n_ary_function ::= - | nested_n_ary_function - (* A function need not have [fun] params; it can be a function - or a constrained function. These need not have extra attributes, - except in the rare case that the function is constrained at the - local mode. - *) - | pexp_function - | constraint_with_mode_then(pexp_function) - - nested_n_ary_function ::= - | fun_then(nested_n_ary_function) - | fun_then(constraint_with_mode_then(expression)) - | {% '_builtin.cases' | fun_then(pexp_function) } - | {% '_builtin.constraint.cases' | - fun_then(constraint_with_mode_then(pexp_function)) } - | fun_then(expression) - - - fun_then(body) ::= - | 'fun' pattern '->' body (* Pexp_fun *) - | 'fun' '(' 'type' ident ')' '->' body (* Pexp_newtype *) - |{% '_builtin.jkind_annotation' | - 'fun' '(' 'type' ident ')' '->' body %} (* Pexp_newtype *) - - pexp_function ::= - | 'function' cases - - constraint_then(ast) ::= - | ast (':' type)? ':>' type (* Pexp_coerce *) - | ast ':' type (* Pexp_constraint *) - - constraint_with_mode_then(ast) ::= - | constraint_then(ast) - | {% '_builtin.local_constraint' | constraint_then(ast) %} - v} - *) - - let expand_n_ary_expr expr = - match Of_ast.unwrap_jane_syntax_attributes expr.pexp_attributes with - | Error (Not_this_embedding _ | Non_embedding) -> None - | Ok (suffix, payload, attributes) -> - let attribute_node = - match Attribute_node.of_suffix suffix, payload with - | No_payload t, PStr [] -> Some t - | Payload f, payload -> Some (f payload ~loc:expr.pexp_loc) - | No_payload _, payload -> - Desugaring_error.raise expr (Has_payload payload) - | Unknown_suffix, _ -> None - in - Option.map (fun x -> x, attributes) attribute_node - - let require_function_cases expr ~arity_attribute = - match expr.pexp_desc with - | Pexp_function cases -> cases - | _ -> Desugaring_error.raise expr (Expected_function_cases arity_attribute) - - let check_constraint expr = - match expr.pexp_desc with - | Pexp_constraint (e, Some ty, m) -> - Some ({ mode_annotations = m; type_constraint = Pconstraint ty }, e) - | Pexp_coerce (e, ty1, ty2) -> - Some ({ mode_annotations = []; type_constraint = Pcoerce (ty1, ty2) }, e) - | _ -> None - - let require_constraint expr = - match check_constraint expr with - | Some constraint_ -> constraint_ - | None -> Desugaring_error.raise expr Expected_constraint_or_coerce - - let check_param pexp_desc (pexp_loc : Location.t) ~jkind = - match pexp_desc, jkind with - | Pexp_fun (lbl, def, pat, body), None -> - let pparam_loc : Location.t = - { loc_ghost = true; - loc_start = pexp_loc.loc_start; - loc_end = pat.ppat_loc.loc_end - } - in - let pparam_desc = Pparam_val (lbl, def, pat) in - Some ({ pparam_desc; pparam_loc }, body) - | Pexp_newtype (newtype, body), jkind -> - (* This imperfectly estimates where a newtype parameter ends: it uses - the end of the type name rather than the closing paren. The closing - paren location is not tracked anywhere in the parsetree. We don't - think merlin is affected. - *) - let pparam_loc : Location.t = - { loc_ghost = true; - loc_start = pexp_loc.loc_start; - loc_end = newtype.loc.loc_end - } - in - let pparam_desc = Pparam_newtype (newtype, jkind) in - Some ({ pparam_desc; pparam_loc }, body) - | _, None -> None - | _, Some jkind -> - Desugaring_error.raise_with_loc pexp_loc - (Expected_newtype_with_jkind_annotation jkind) - - let require_param pexp_desc pexp_loc ~arity_attribute ~jkind = - match check_param pexp_desc pexp_loc ~jkind with - | Some x -> x - | None -> - Desugaring_error.raise_with_loc pexp_loc - (Expected_fun_or_newtype arity_attribute) - - (* Should only be called on [Pexp_fun] and [Pexp_newtype]. *) - let extract_fun_params = - let open struct - type continue_or_stop = - | Continue of Parsetree.expression - | Stop of function_constraint option * function_body - end in - (* Returns: the next parameter, together with whether there are possibly - more parameters available ("Continue") or whether all parameters have - been consumed ("Stop"). - - The returned attributes are the remaining unconsumed attributes on the - Pexp_fun or Pexp_newtype node. - - The [jkind] parameter gives the jkind at which to interpret the type - introduced by [expr = Pexp_newtype _]. It is only supplied in a recursive - call to [extract_next_fun_param] in the event that it sees a - [Jkind_annotation] attribute. - *) - let rec extract_next_fun_param expr ~jkind : - (function_param * attributes) option * continue_or_stop = - match expand_n_ary_expr expr with - | None -> ( - match check_param expr.pexp_desc expr.pexp_loc ~jkind with - | Some (param, body) -> - Some (param, expr.pexp_attributes), Continue body - | None -> None, Stop (None, Pfunction_body expr)) - | Some (Top_level, _) -> None, Stop (None, Pfunction_body expr) - | Some (Jkind_annotation next_jkind, unconsumed_attributes) -> - extract_next_fun_param - { expr with pexp_attributes = unconsumed_attributes } - ~jkind:(Some next_jkind) - | Some ((Fun_then after_fun as arity_attribute), unconsumed_attributes) -> - let param, body = - require_param expr.pexp_desc expr.pexp_loc ~arity_attribute ~jkind - in - let continue_or_stop = - match after_fun with - | Cases -> - let cases = require_function_cases body ~arity_attribute in - let function_body = - Pfunction_cases (cases, body.pexp_loc, body.pexp_attributes) - in - Stop (None, function_body) - | Constraint_then_cases -> - let function_constraint, body = require_constraint body in - let cases = require_function_cases body ~arity_attribute in - let function_body = - Pfunction_cases (cases, body.pexp_loc, body.pexp_attributes) - in - Stop (Some function_constraint, function_body) - in - Some (param, unconsumed_attributes), continue_or_stop - in - let rec loop expr ~rev_params = - let next_param, continue_or_stop = - extract_next_fun_param expr ~jkind:None - in - let rev_params = - match next_param with - | None -> rev_params - | Some (x, _) -> x :: rev_params - in - match continue_or_stop with - | Continue body -> loop body ~rev_params - | Stop (function_constraint, body) -> - let params = List.rev rev_params in - params, function_constraint, body - in - fun expr -> - (match expr.pexp_desc with - | Pexp_newtype _ | Pexp_fun _ -> () - | _ -> Misc.fatal_error "called on something that isn't a newtype or fun"); - let unconsumed_attributes = - match extract_next_fun_param expr ~jkind:None with - | Some (_, attributes), _ -> attributes - | None, _ -> Desugaring_error.raise expr Parameterless_function - in - loop expr ~rev_params:[], unconsumed_attributes - - (* Returns remaining unconsumed attributes on outermost expression *) - let of_expr = - let function_without_additional_params cases constraint_ loc : expression = - (* If the outermost node is function cases, we place the - attributes on the function node as a whole rather than on the - [Pfunction_cases] body. - *) - [], constraint_, Pfunction_cases (cases, loc, []) - in - (* Hack: be more permissive toward a way that a ppx can mishandle an - attribute, which is to duplicate the top-level Jane Syntax - attribute. - *) - let rec remove_top_level_attributes expr = - match expand_n_ary_expr expr with - | Some (Top_level, unconsumed_attributes) -> - remove_top_level_attributes - { expr with pexp_attributes = unconsumed_attributes } - | _ -> expr - in - fun expr -> - let expr = remove_top_level_attributes expr in - match expr.pexp_desc with - | Pexp_fun _ | Pexp_newtype _ -> Some (extract_fun_params expr) - | Pexp_function cases -> - let n_ary = - function_without_additional_params cases None expr.pexp_loc - in - Some (n_ary, expr.pexp_attributes) - | _ -> ( - match check_constraint expr with - | Some (constraint_, { pexp_desc = Pexp_function cases }) -> - let n_ary = - function_without_additional_params cases (Some constraint_) - expr.pexp_loc - in - Some (n_ary, expr.pexp_attributes) - | _ -> None) - - let n_ary_function_expr ext x = - let suffix, payload = Attribute_node.to_suffix_and_payload ext in - Ast_of.wrap_jane_syntax ?payload suffix x - - let expr_of = - let add_param ?after_fun_attribute { pparam_desc; pparam_loc } body = - let fun_ = - let loc = - { !Ast_helper.default_loc with loc_start = pparam_loc.loc_start } - in - match pparam_desc with - | Pparam_val (label, default, pat) -> - Ast_helper.Exp.fun_ label default pat body ~loc - [@alert "-prefer_jane_syntax"] - | Pparam_newtype (newtype, jkind) -> ( - match jkind with - | None -> Ast_helper.Exp.newtype newtype body ~loc - | Some jkind -> - n_ary_function_expr (Jkind_annotation jkind) - (Ast_helper.Exp.newtype newtype body ~loc)) - in - match after_fun_attribute with - | None -> fun_ - | Some after_fun -> n_ary_function_expr (Fun_then after_fun) fun_ - in - fun ~loc (params, constraint_, function_body) -> - (* See Note [Wrapping with make_entire_jane_syntax] *) - Expression.make_entire_jane_syntax ~loc feature (fun () -> - let body = - match function_body with - | Pfunction_body body -> body - | Pfunction_cases (cases, loc, attrs) -> - Ast_helper.Exp.function_ cases ~loc ~attrs - [@alert "-prefer_jane_syntax"] - in - let possibly_constrained_body = - match constraint_ with - | None -> body - | Some { mode_annotations; type_constraint } -> - let constrained_body = - (* We can't call [Location.ghostify] here, as we need this file - to build with the upstream compiler; see Note [Buildable with - upstream] in jane_syntax.mli for details. *) - let loc = { body.pexp_loc with loc_ghost = true } in - match type_constraint with - | Pconstraint ty -> - Ast_helper.Exp.constraint_ body (Some ty) ~loc mode_annotations - | Pcoerce (ty1, ty2) -> Ast_helper.Exp.coerce body ty1 ty2 ~loc - in - constrained_body - in - match params with - | [] -> possibly_constrained_body - | params -> - let init_params, last_param = Misc.split_last params in - let after_fun_attribute : Attribute_node.after_fun option = - match constraint_, function_body with - | Some _, Pfunction_cases _ -> Some Constraint_then_cases - | None, Pfunction_cases _ -> Some Cases - | Some _, Pfunction_body _ -> None - | None, Pfunction_body _ -> None - in - let body_with_last_param = - add_param last_param ?after_fun_attribute - possibly_constrained_body - in - List.fold_right add_param init_params body_with_last_param) -end - (** Labeled tuples *) module Labeled_tuples = struct module Ext = struct @@ -1963,7 +1502,6 @@ module Expression = struct | Jexp_comprehension of Comprehensions.expression | Jexp_immutable_array of Immutable_arrays.expression | Jexp_layout of Layouts.expression - | Jexp_n_ary_function of N_ary_functions.expression | Jexp_tuple of Labeled_tuples.expression let of_ast_internal (feat : Feature.t) expr = @@ -1977,10 +1515,6 @@ module Expression = struct | Language_extension Layouts -> let expr, attrs = Layouts.of_expr expr in Some (Jexp_layout expr, attrs) - | Builtin -> ( - match N_ary_functions.of_expr expr with - | Some (expr, attrs) -> Some (Jexp_n_ary_function expr, attrs) - | None -> None) | Language_extension Labeled_tuples -> let expr, attrs = Labeled_tuples.of_expr expr in Some (Jexp_tuple expr, attrs) @@ -1994,7 +1528,6 @@ module Expression = struct | Jexp_comprehension x -> Comprehensions.expr_of ~loc x | Jexp_immutable_array x -> Immutable_arrays.expr_of ~loc x | Jexp_layout x -> Layouts.expr_of ~loc x - | Jexp_n_ary_function x -> N_ary_functions.expr_of ~loc x | Jexp_tuple x -> Labeled_tuples.expr_of ~loc x in (* Performance hack: save an allocation if [attrs] is empty. *) diff --git a/vendor/parser-standard/jane_syntax.mli b/vendor/parser-standard/jane_syntax.mli index 3480876585..3cd98a6ba2 100644 --- a/vendor/parser-standard/jane_syntax.mli +++ b/vendor/parser-standard/jane_syntax.mli @@ -100,123 +100,39 @@ module Immutable_arrays : sig val pat_of : loc:Location.t -> pattern -> Parsetree.pattern end +(** The attribute placed on the inner [Ptyp_arrow] node in [x -> (y -> z)] + (meaning the [y -> z] node) to indicate parenthesization. This is relevant + for locals, as [local_ x -> (y -> z)] is different than + [local_ x -> y -> z]. +*) +module Arrow_curry : sig + val curry_attr_name : string + + val curry_attr : Location.t -> Parsetree.attribute +end + module Jkind : sig module Const : sig (** Constant jkind *) - type raw = string - (** Represent a user-written kind primitive/abbreviation, containing a string and its location *) - type t = private raw Location.loc + type t = Parsetree.jkind_const_annotation (** Constructs a jkind constant *) val mk : string -> Location.t -> t end - type t = + type t = Parsetree.jkind_annotation = | Default - | Primitive_layout_or_abbreviation of Const.t - | Mod of t * Parsetree.mode Location.loc list + | Abbreviation of Const.t + | Mod of t * Parsetree.modes | With of t * Parsetree.core_type | Kind_of of Parsetree.core_type type annotation = t Location.loc end -module N_ary_functions : sig - (** These types use the [P] prefix to match how they are represented in the - upstream compiler *) - - (** See the comment on [expression]. *) - type function_body = - | Pfunction_body of Parsetree.expression - | Pfunction_cases of Parsetree.case list * Location.t * Parsetree.attributes - (** In [Pfunction_cases (_, loc, attrs)], the location extends from the - start of the [function] keyword to the end of the last case. The - compiler will only use typechecking-related attributes from [attrs], - e.g. enabling or disabling a warning. - *) - - type function_param_desc = - | Pparam_val of - Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern - (** [Pparam_val (lbl, exp0, P)] represents the parameter: - - [P] - when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} - and [exp0] is [None] - - [~l:P] - when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} - and [exp0] is [None] - - [?l:P] - when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} - and [exp0] is [None] - - [?l:(P = E0)] - when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} - and [exp0] is [Some E0] - - Note: If [E0] is provided, only - {{!Asttypes.arg_label.Optional}[Optional]} is allowed. - *) - | Pparam_newtype of string Asttypes.loc * Jkind.annotation option - (** [Pparam_newtype (x, jkind)] represents the parameter [(type x)]. - [x] carries the location of the identifier, whereas [pparam_loc] is - the location of the [(type x)] as a whole. - - [jkind] is the same as [Lexp_newtype]'s jkind. - - Multiple parameters [(type a b c)] are represented as multiple - [Pparam_newtype] nodes, let's say: - - {[ [ { pparam_desc = Pparam_newtype (a, _); pparam_loc = loc }; - { pparam_desc = Pparam_newtype (b, _); pparam_loc = loc }; - { pparam_desc = Pparam_newtype (c, _); pparam_loc = loc }; - ] - ]} - - Here, [loc] gives the location of [(type a b c)], but is marked as a - ghost location. The locations on [a], [b], [c], correspond to the - variables [a], [b], and [c] in the source code. - *) - - type function_param = - { pparam_desc : function_param_desc; - pparam_loc : Location.t - } - - type type_constraint = - | Pconstraint of Parsetree.core_type - | Pcoerce of Parsetree.core_type option * Parsetree.core_type - - (** The mode annotation placed on a function let-binding when the function - has a type constraint on the body, e.g. - [let local_ f x : int -> int = ...]. - *) - type function_constraint = - { mode_annotations : Parsetree.mode Location.loc list; - type_constraint : type_constraint - } - - (** [([P1; ...; Pn], C, body)] represents any construct - involving [fun] or [function], including: - - [fun P1 ... Pn -> E] - when [body = Pfunction_body E] - - [fun P1 ... Pn -> function p1 -> e1 | ... | pm -> em] - when [body = Pfunction_cases [ p1 -> e1; ...; pm -> em ]] - - [C] represents a type constraint or coercion placed immediately - before the arrow, e.g. [fun P1 ... Pn : t1 :> t2 -> ...] - when [C = Some (Pcoerce (Some t1, t2))]. - - A function must have parameters. [Pexp_function (params, _, body)] must - have non-empty [params] or a [Pfunction_cases _] body. - *) - type expression = - function_param list * function_constraint option * function_body - - val expr_of : loc:Location.t -> expression -> Parsetree.expression -end - (** The ASTs for labeled tuples. When we merge this upstream, we'll replace existing [P{typ,exp,pat}_tuple] constructors with these. *) module Labeled_tuples : sig @@ -533,7 +449,6 @@ module Expression : sig | Jexp_comprehension of Comprehensions.expression | Jexp_immutable_array of Immutable_arrays.expression | Jexp_layout of Layouts.expression - | Jexp_n_ary_function of N_ary_functions.expression | Jexp_tuple of Labeled_tuples.expression include diff --git a/vendor/parser-standard/jane_syntax_parsing.ml b/vendor/parser-standard/jane_syntax_parsing.ml index e19879cd11..1892e83fb9 100644 --- a/vendor/parser-standard/jane_syntax_parsing.ml +++ b/vendor/parser-standard/jane_syntax_parsing.ml @@ -13,8 +13,7 @@ In particular, for an language extension named [EXTNAME] (i.e., one that is enabled by [-extension EXTNAME] on the command line), the attribute (if used) must be [[@jane.ERASABILITY.EXTNAME]], and the extension node (if - used) must be [[%jane.ERASABILITY.EXTNAME]]. For built-in syntax, we use - [_builtin] instead of an language extension name. + used) must be [[%jane.ERASABILITY.EXTNAME]]. The [ERASABILITY] component indicates to tools such as ocamlformat and ppxlib whether or not the attribute is erasable. See the documentation of @@ -94,9 +93,7 @@ end (******************************************************************************) module Feature : sig - type t = - | Language_extension : _ Language_extension.t -> t - | Builtin + type t = Language_extension : _ Language_extension.t -> t type error = | Disabled_extension : _ Language_extension.t -> error @@ -110,42 +107,29 @@ module Feature : sig val is_erasable : t -> bool end = struct - type t = - | Language_extension : _ Language_extension.t -> t - | Builtin + type t = Language_extension : _ Language_extension.t -> t type error = | Disabled_extension : _ Language_extension.t -> error | Unknown_extension of string - let builtin_component = "_builtin" - let describe_uppercase = function | Language_extension ext -> "The extension \"" ^ Language_extension.to_string ext ^ "\"" - | Builtin -> "Built-in syntax" let extension_component = function | Language_extension ext -> Language_extension.to_string ext - | Builtin -> builtin_component let of_component str = - if String.equal str builtin_component - then Ok Builtin - else - match Language_extension.of_string str with - | Some (Pack ext) -> - if Language_extension.is_enabled ext - then Ok (Language_extension ext) - else Error (Disabled_extension ext) - | None -> Error (Unknown_extension str) + match Language_extension.of_string str with + | Some (Pack ext) -> + if Language_extension.is_enabled ext + then Ok (Language_extension ext) + else Error (Disabled_extension ext) + | None -> Error (Unknown_extension str) let is_erasable = function | Language_extension ext -> Language_extension.is_erasable ext - (* Builtin syntax changes don't involve additions or changes to concrete - syntax and are always erasable. - *) - | Builtin -> true end (** Was this embedded as an [[%extension_node]] or an [[@attribute]]? Not diff --git a/vendor/parser-standard/jane_syntax_parsing.mli b/vendor/parser-standard/jane_syntax_parsing.mli index e2869df666..7cf7ac0ea3 100644 --- a/vendor/parser-standard/jane_syntax_parsing.mli +++ b/vendor/parser-standard/jane_syntax_parsing.mli @@ -93,9 +93,7 @@ language extension (separated out by which one) or the collection of all built-in features. *) module Feature : sig - type t = - | Language_extension : _ Language_extension.t -> t - | Builtin + type t = Language_extension : _ Language_extension.t -> t (** The component of an attribute or extension name that identifies the feature. This is third component. diff --git a/vendor/parser-standard/language_extension.ml b/vendor/parser-standard/language_extension.ml index 5e8e3c95a7..7a05a4a5cf 100644 --- a/vendor/parser-standard/language_extension.ml +++ b/vendor/parser-standard/language_extension.ml @@ -54,7 +54,7 @@ end let get_level_ops : type a. a t -> (module Extension_level with type t = a) = function | Comprehensions -> (module Unit) - | Mode -> (module Unit) + | Mode -> (module Maturity) | Unique -> (module Unit) | Include_functor -> (module Unit) | Polymorphic_parameters -> (module Unit) @@ -63,14 +63,14 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) = | Layouts -> (module Maturity) | SIMD -> (module Unit) | Labeled_tuples -> (module Unit) - | Small_numbers -> (module Unit) + | Small_numbers -> (module Maturity) module Exist_pair = struct include Exist_pair let maturity : t -> Maturity.t = function | Pair (Comprehensions, ()) -> Beta - | Pair (Mode, ()) -> Stable + | Pair (Mode, m) -> m | Pair (Unique, ()) -> Alpha | Pair (Include_functor, ()) -> Stable | Pair (Polymorphic_parameters, ()) -> Stable @@ -79,16 +79,19 @@ module Exist_pair = struct | Pair (Layouts, m) -> m | Pair (SIMD, ()) -> Stable | Pair (Labeled_tuples, ()) -> Stable - | Pair (Small_numbers, ()) -> Beta + | Pair (Small_numbers, m) -> m let is_erasable : t -> bool = function Pair (ext, _) -> is_erasable ext let to_string = function | Pair (Layouts, m) -> to_string Layouts ^ "_" ^ maturity_to_string m + | Pair (Mode, m) -> to_string Mode ^ "_" ^ maturity_to_string m + | Pair (Small_numbers, m) -> + to_string Small_numbers ^ "_" ^ maturity_to_string m | Pair - ( (( Comprehensions | Mode | Unique | Include_functor - | Polymorphic_parameters | Immutable_arrays | Module_strengthening - | SIMD | Labeled_tuples | Small_numbers ) as ext), + ( (( Comprehensions | Unique | Include_functor | Polymorphic_parameters + | Immutable_arrays | Module_strengthening | SIMD | Labeled_tuples ) + as ext), _ ) -> to_string ext end diff --git a/vendor/parser-standard/language_extension.mli b/vendor/parser-standard/language_extension.mli index fb026200b4..40ddba38a7 100644 --- a/vendor/parser-standard/language_extension.mli +++ b/vendor/parser-standard/language_extension.mli @@ -13,7 +13,7 @@ type maturity = Language_extension_kernel.maturity = or off, while a [maturity t] can have different maturity settings. *) type 'a t = 'a Language_extension_kernel.t = | Comprehensions : unit t - | Mode : unit t + | Mode : maturity t | Unique : unit t | Include_functor : unit t | Polymorphic_parameters : unit t @@ -22,7 +22,7 @@ type 'a t = 'a Language_extension_kernel.t = | Layouts : maturity t | SIMD : unit t | Labeled_tuples : unit t - | Small_numbers : unit t + | Small_numbers : maturity t (** Existentially packed language extension *) module Exist : sig diff --git a/vendor/parser-standard/language_extension_kernel.ml b/vendor/parser-standard/language_extension_kernel.ml index 4fa3aaed21..757c0c9fc6 100644 --- a/vendor/parser-standard/language_extension_kernel.ml +++ b/vendor/parser-standard/language_extension_kernel.ml @@ -3,7 +3,7 @@ type maturity = Stable | Beta | Alpha (* Remember to update [all] when changing this type. *) type _ t = | Comprehensions : unit t - | Mode : unit t + | Mode : maturity t | Unique : unit t | Include_functor : unit t | Polymorphic_parameters : unit t @@ -12,7 +12,7 @@ type _ t = | Layouts : maturity t | SIMD : unit t | Labeled_tuples : unit t - | Small_numbers : unit t + | Small_numbers : maturity t type 'a language_extension_kernel = 'a t @@ -59,7 +59,9 @@ let to_string : type a. a t -> string = function let pair_of_string extn_name : Exist_pair.t option = match String.lowercase_ascii extn_name with | "comprehensions" -> Some (Pair (Comprehensions, ())) - | "mode" -> Some (Pair (Mode, ())) + | "mode" -> Some (Pair (Mode, Stable)) + | "mode_beta" -> Some (Pair (Mode, Beta)) + | "mode_alpha" -> Some (Pair (Mode, Alpha)) | "unique" -> Some (Pair (Unique, ())) | "include_functor" -> Some (Pair (Include_functor, ())) | "polymorphic_parameters" -> Some (Pair (Polymorphic_parameters, ())) @@ -70,7 +72,8 @@ let pair_of_string extn_name : Exist_pair.t option = | "layouts_beta" -> Some (Pair (Layouts, Beta)) | "simd" -> Some (Pair (SIMD, ())) | "labeled_tuples" -> Some (Pair (Labeled_tuples, ())) - | "small_numbers" -> Some (Pair (Small_numbers, ())) + | "small_numbers" -> Some (Pair (Small_numbers, Stable)) + | "small_numbers_beta" -> Some (Pair (Small_numbers, Beta)) | _ -> None let maturity_to_string = function diff --git a/vendor/parser-standard/language_extension_kernel.mli b/vendor/parser-standard/language_extension_kernel.mli index d963835b13..1d09c69fb4 100644 --- a/vendor/parser-standard/language_extension_kernel.mli +++ b/vendor/parser-standard/language_extension_kernel.mli @@ -12,7 +12,7 @@ type maturity = Stable | Beta | Alpha or off, while a [maturity t] can have different maturity settings. *) type _ t = | Comprehensions : unit t - | Mode : unit t + | Mode : maturity t | Unique : unit t | Include_functor : unit t | Polymorphic_parameters : unit t @@ -21,7 +21,7 @@ type _ t = | Layouts : maturity t | SIMD : unit t | Labeled_tuples : unit t - | Small_numbers : unit t + | Small_numbers : maturity t module Exist : sig type 'a extn = 'a t diff --git a/vendor/parser-standard/parser.mly b/vendor/parser-standard/parser.mly index a2575cfbef..155cb9e660 100644 --- a/vendor/parser-standard/parser.mly +++ b/vendor/parser-standard/parser.mly @@ -30,7 +30,6 @@ open Parsetree open Ast_helper open Docstrings open Docstrings.WithMenhir -module N_ary = Jane_syntax.N_ary_functions let mkloc = Location.mkloc let mknoloc = Location.mknoloc @@ -174,15 +173,36 @@ let mkpat_with_modes ~loc ~pat ~cty ~modes = | cty, modes -> mkpat ~loc (Ppat_constraint (pat, cty, modes)) end -let ghpat_with_modes ~loc ~pat ~cty ~modes = +let ghpat_with_modes ~loc ~pat ~cty ~modes = let pat = mkpat_with_modes ~loc ~pat ~cty ~modes in { pat with ppat_loc = { pat.ppat_loc with loc_ghost = true }} -let add_mode_constraint_to_exp ~loc ~exp ~modes = +let mkexp_with_modes ~loc ~exp ~cty ~modes = match exp.pexp_desc with | Pexp_constraint (exp', cty', modes') -> - { exp with pexp_desc = Pexp_constraint (exp', cty', modes @ modes')} - | _ -> mkexp ~loc (Pexp_constraint (exp, None, modes)) + begin match cty, cty' with + | Some _, None -> + { exp with + pexp_desc = Pexp_constraint (exp', cty, modes @ modes'); + pexp_loc = make_loc loc + } + | None, _ -> + { exp with + pexp_desc = Pexp_constraint (exp', cty', modes @ modes'); + pexp_loc = make_loc loc + } + | _ -> + mkexp ~loc (Pexp_constraint (exp, cty, modes)) + end + | _ -> + begin match cty, modes with + | None, [] -> exp + | cty, modes -> mkexp ~loc (Pexp_constraint (exp, cty, modes)) + end + +let ghexp_with_modes ~loc ~exp ~cty ~modes = + let exp = mkexp_with_modes ~loc ~exp ~cty ~modes in + { exp with pexp_loc = { exp.pexp_loc with loc_ghost = true }} let exclave_ext_loc loc = mkloc "extension.exclave" loc @@ -193,14 +213,12 @@ let exclave_extension loc = let mkexp_exclave ~loc ~kwd_loc exp = ghexp ~loc (Pexp_apply(exclave_extension (make_loc kwd_loc), [Nolabel, exp])) -let curry_attr loc = - mk_attr ~loc:Location.none (mkloc "extension.curry" loc) (PStr []) - let is_curry_attr attr = - attr.attr_name.txt = "extension.curry" + attr.attr_name.txt = Jane_syntax.Arrow_curry.curry_attr_name let mktyp_curry typ loc = - {typ with ptyp_attributes = curry_attr loc :: typ.ptyp_attributes} + {typ with ptyp_attributes = + Jane_syntax.Arrow_curry.curry_attr loc :: typ.ptyp_attributes} let maybe_curry_typ typ loc = match typ.ptyp_desc with @@ -252,13 +270,13 @@ let mkstrexp e attrs = { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc } let mkexp_type_constraint ?(ghost=false) ~loc ~modes e t = - let desc = - match t with - | N_ary.Pconstraint t -> Pexp_constraint(e, Some t, modes) - | N_ary.Pcoerce(t1, t2) -> Pexp_coerce(e, t1, t2) - in - if ghost then ghexp ~loc desc - else mkexp ~loc desc + match t with + | Pconstraint t -> + let mk = if ghost then ghexp_with_modes else mkexp_with_modes in + mk ~loc ~exp:e ~cty:(Some t) ~modes + | Pcoerce(t1, t2) -> + let mk = if ghost then ghexp else mkexp ?attrs:None in + mk ~loc (Pexp_coerce(e, t1, t2)) let mkexp_opt_type_constraint ~loc ~modes e = function | None -> e @@ -543,7 +561,7 @@ let mk_newtypes ~loc newtypes exp = in [let_binding_body_no_punning]. *) let wrap_type_annotation ~loc ?(typloc=loc) ~modes newtypes core_type body = let mk_newtypes = mk_newtypes ~loc in - let exp = mkexp ~loc (Pexp_constraint(body,Some core_type,modes)) in + let exp = mkexp_with_modes ~loc ~exp:body ~cty:(Some core_type) ~modes in let exp = mk_newtypes newtypes exp in let inner_type = Typ.varify_constructors (List.map fst newtypes) core_type in let ltyp = @@ -645,7 +663,7 @@ type let_binding = lb_expression: expression; lb_constraint: value_constraint option; lb_is_pun: bool; - lb_modes: mode Location.loc list; + lb_modes: modes; lb_attributes: attributes; lb_docs: docs Lazy.t; lb_text: text Lazy.t; @@ -729,7 +747,6 @@ let class_of_let_bindings ~loc lbs body = parameter. *) let all_params_as_newtypes = - let open N_ary in let is_newtype { pparam_desc; _ } = match pparam_desc with | Pparam_newtype _ -> true @@ -753,30 +770,28 @@ let mkghost_newtype_function_body newtypes body_constraint body ~loc = let wrapped_body = match body_constraint with | None -> body - | Some { N_ary.type_constraint; mode_annotations } -> + | Some { type_constraint; mode_annotations } -> let {Location.loc_start; loc_end} = body.pexp_loc in let loc = loc_start, loc_end in mkexp_type_constraint ~ghost:true ~loc ~modes:mode_annotations body type_constraint in mk_newtypes ~loc newtypes wrapped_body -let n_ary_function expr ~attrs ~loc = - wrap_exp_attrs ~loc (N_ary.expr_of expr ~loc:(make_loc loc)) attrs - let mkfunction ~loc ~attrs params body_constraint body = match body with - | N_ary.Pfunction_cases _ -> - n_ary_function (params, body_constraint, body) ~loc ~attrs - | N_ary.Pfunction_body body_exp -> begin + | Pfunction_cases _ -> + mkexp_attrs (Pexp_function (params, body_constraint, body)) attrs ~loc + | Pfunction_body body_exp -> begin (* If all the params are newtypes, then we don't create a function node; - we create a newtype node. *) + we create nested newtype nodes. *) match all_params_as_newtypes params with - | None -> n_ary_function (params, body_constraint, body) ~loc ~attrs + | None -> + mkexp_attrs (Pexp_function (params, body_constraint, body)) attrs ~loc | Some newtypes -> wrap_exp_attrs ~loc (mkghost_newtype_function_body newtypes body_constraint body_exp - ~loc) + ~loc) attrs end @@ -1682,7 +1697,7 @@ paren_module_expr: e = expr { e } | e = expr COLON ty = package_type - { ghexp ~loc:$loc (Pexp_constraint (e, Some ty, [])) } + { ghexp_with_modes ~loc:$loc ~exp:e ~cty:(Some ty) ~modes:[] } | e = expr COLON ty1 = package_type COLONGREATER ty2 = package_type { ghexp ~loc:$loc (Pexp_coerce (e, Some ty1, ty2)) } | e = expr COLONGREATER ty2 = package_type @@ -2555,8 +2570,15 @@ class_type_declarations: | FUNCTION ext_attributes match_cases { let loc = make_loc $sloc in let cases = $3 in - mkfunction [] None (Pfunction_cases (cases, loc, [])) - ~loc:$sloc ~attrs:$2 + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + mkfunction [] None (Pfunction_cases (cases, loc, [])) ~attrs:$2 + ~loc:$sloc } ; @@ -2586,22 +2608,25 @@ seq_expr: labeled_simple_pattern: QUESTION LPAREN modes0=optional_mode_expr_legacy x=label_let_pattern opt_default RPAREN { let lbl, pat, cty, modes = x in + let loc = $startpos(modes0), $endpos(x) in (Optional lbl, $5, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:(modes0 @ modes)) + mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) } | QUESTION label_var { (Optional (fst $2), None, snd $2) } | OPTLABEL LPAREN modes0=optional_mode_expr_legacy x=let_pattern opt_default RPAREN { let pat, cty, modes = x in + let loc = $startpos(modes0), $endpos(x) in (Optional $1, $5, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:(modes0 @ modes)) + mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) } | OPTLABEL pattern_var { (Optional $1, None, $2) } | TILDE LPAREN modes0=optional_mode_expr_legacy x=label_let_pattern RPAREN { let lbl, pat, cty, modes = x in + let loc = $startpos(modes0), $endpos(x) in (Labelled lbl, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:(modes0 @ modes)) + mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) } | TILDE label_var { (Labelled (fst $2), None, snd $2) } @@ -2609,39 +2634,44 @@ labeled_simple_pattern: { (Labelled $1, None, $2) } | LABEL LPAREN modes0=optional_mode_expr_legacy x=let_pattern_required_modes RPAREN { let pat, cty, modes = x in + let loc = $startpos(modes0), $endpos(x) in (Labelled $1, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:(modes0 @ modes)) + mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) } | LABEL LPAREN modes=mode_expr_legacy pat=pattern RPAREN - { (Labelled $1, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty:None ~modes) + { let loc = $startpos(modes), $endpos(pat) in + (Labelled $1, None, + mkpat_with_modes ~loc ~pat ~cty:None ~modes) } | simple_pattern { (Nolabel, None, $1) } | LPAREN modes=mode_expr_legacy x=let_pattern_no_modes RPAREN { let pat, cty = x in + let loc = $startpos(modes), $endpos(x) in (Nolabel, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes) + mkpat_with_modes ~loc ~pat ~cty ~modes) } | LPAREN modes0=optional_mode_expr_legacy x=let_pattern_required_modes RPAREN { let pat, cty, modes = x in + let loc = $startpos(modes0), $endpos(x) in (Nolabel, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:(modes0 @ modes)) + mkpat_with_modes ~loc ~pat ~cty ~modes:(modes0 @ modes)) } | LABEL LPAREN x=poly_pattern_no_modes RPAREN { let pat, cty = x in (Labelled $1, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:[]) + mkpat_with_modes ~loc:$loc(x) ~pat ~cty ~modes:[]) } | LABEL LPAREN modes=mode_expr_legacy x=poly_pattern_no_modes RPAREN { let pat, cty = x in + let loc = $startpos(modes), $endpos(x) in (Labelled $1, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes) + mkpat_with_modes ~loc ~pat ~cty ~modes) } | LPAREN x=poly_pattern_no_modes RPAREN { let pat, cty = x in (Nolabel, None, - mkpat_with_modes ~loc:$sloc ~pat ~cty ~modes:[]) + mkpat_with_modes ~loc:$loc(x) ~pat ~cty ~modes:[]) } ; @@ -2657,7 +2687,7 @@ pattern_var: { $1 } ; label_let_pattern: - x = label_var modes = optional_at_mode_expr + x = label_var modes = optional_at_mode_expr { let lab, pat = x in lab, pat, None, modes } @@ -2744,7 +2774,7 @@ let_pattern_no_modes: fun_expr: simple_expr %prec below_HASH { $1 } - | expr_attrs + | fun_expr_attrs { let desc, attrs = $1 in mkexp_attrs ~loc:$sloc desc attrs } /* Cf #5939: we used to accept (fun p when e0 -> e) */ @@ -2752,7 +2782,7 @@ fun_expr: MINUSGREATER fun_body { let body_constraint = Option.map - (fun x : N_ary.function_constraint -> + (fun x -> { type_constraint = Pconstraint x ; mode_annotations = [] }) @@ -2783,14 +2813,14 @@ fun_expr: | fun_expr attribute { Exp.attr $1 $2 } | mode=mode_legacy exp=seq_expr - { add_mode_constraint_to_exp ~loc:$sloc ~exp ~modes:[mode] } + { mkexp_with_modes ~loc:$sloc ~exp ~cty:None ~modes:[mode] } | EXCLAVE seq_expr { mkexp_exclave ~loc:$sloc ~kwd_loc:($loc($1)) $2 } ; %inline expr: | or_function(fun_expr) { $1 } ; -%inline expr_attrs: +%inline fun_expr_attrs: | LET MODULE ext_attributes mkrhs(module_name) module_binding_body IN seq_expr { Pexp_letmodule($4, $5, $7), $3 } | LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr @@ -2919,7 +2949,7 @@ comprehension_clause_binding: over to the RHS of the binding, so we need everything to be visible. *) | attributes mode_legacy pattern IN expr { let expr = - add_mode_constraint_to_exp ~loc:$sloc ~exp:$5 ~modes:[$2] + mkexp_with_modes ~loc:$sloc ~exp:$5 ~cty:None ~modes:[$2] in Jane_syntax.Comprehensions. { pattern = $3 @@ -3112,9 +3142,9 @@ let_binding_body_no_punning: let typ, modes1 = $3 in let t = Option.map (function - | N_ary.Pconstraint t -> + | Pconstraint t -> Pvc_constraint { locally_abstract_univars = []; typ=t } - | N_ary.Pcoerce (ground, coercion) -> Pvc_coercion { ground; coercion} + | Pcoerce (ground, coercion) -> Pvc_coercion { ground; coercion} ) typ in let modes = modes0 @ modes1 in @@ -3241,13 +3271,14 @@ strict_binding_modes: (* CR zqian: The above [type_constraint] should be replaced by [constraint_] to support mode annotation *) { fun mode_annotations -> - let constraint_ : N_ary.function_constraint option = + let constraint_ : function_constraint option = match $2 with | None -> None | Some type_constraint -> Some { type_constraint; mode_annotations } in let exp = mkfunction $1 constraint_ $4 ~loc:$sloc ~attrs:(None, []) in { exp with pexp_loc = { exp.pexp_loc with loc_ghost = true } } + } ; %inline strict_binding: @@ -3258,15 +3289,15 @@ fun_body: | FUNCTION ext_attributes match_cases { let ext, attrs = $2 in match ext with - | None -> N_ary.Pfunction_cases ($3, make_loc $sloc, attrs) + | None -> Pfunction_cases ($3, make_loc $sloc, attrs) | Some _ -> (* function%foo extension nodes interrupt the arity *) - let cases = N_ary.Pfunction_cases ($3, make_loc $sloc, []) in + let cases = Pfunction_cases ($3, make_loc $sloc, []) in let function_ = mkfunction [] None cases ~loc:$sloc ~attrs:$2 in - N_ary.Pfunction_body function_ + Pfunction_body function_ } | fun_seq_expr - { N_ary.Pfunction_body $1 } + { Pfunction_body $1 } ; %inline match_cases: xs = preceded_or_separated_nonempty_llist(BAR, match_case) @@ -3292,20 +3323,20 @@ fun_param_as_list: in List.map (fun (newtype, jkind) -> - { N_ary.pparam_loc = loc; + { pparam_loc = loc; pparam_desc = Pparam_newtype (newtype, jkind) }) ty_params } | LPAREN TYPE mkrhs(LIDENT) COLON jkind_annotation RPAREN - { [ { N_ary.pparam_loc = make_loc $sloc; + { [ { pparam_loc = make_loc $sloc; pparam_desc = Pparam_newtype ($3, Some $5) } ] } | labeled_simple_pattern { let a, b, c = $1 in - [ { N_ary.pparam_loc = make_loc $sloc; + [ { pparam_loc = make_loc $sloc; pparam_desc = Pparam_val (a, b, c) } ] @@ -3435,9 +3466,9 @@ record_expr_content: { es } ; type_constraint: - COLON core_type { N_ary.Pconstraint $2 } - | COLON core_type COLONGREATER core_type { N_ary.Pcoerce (Some $2, $4) } - | COLONGREATER core_type { N_ary.Pcoerce (None, $2) } + COLON core_type { Pconstraint $2 } + | COLON core_type COLONGREATER core_type { Pcoerce (Some $2, $4) } + | COLONGREATER core_type { Pcoerce (None, $2) } | COLON error { syntax_error() } | COLONGREATER error { syntax_error() } ; @@ -3747,7 +3778,7 @@ value_description: { let attrs = attrs1 @ attrs2 in let loc = make_loc $sloc in let docs = symbol_docs $sloc in - Val.mk id ty ~modalities ~attrs ~loc ~docs, + Val.mk id ty ~attrs ~modalities ~loc ~docs, ext } ; @@ -3911,8 +3942,7 @@ jkind: } | mkrhs(ident) { let {txt; loc} = $1 in - Jane_syntax.Jkind.(Primitive_layout_or_abbreviation - (Const.mk txt loc)) + Jane_syntax.Jkind.(Abbreviation (Const.mk txt loc)) } | KIND_OF ty=core_type { Jane_syntax.Jkind.Kind_of ty @@ -4597,9 +4627,24 @@ atomic_type: { [] } | ty = atomic_type { [ty] } - | LPAREN tys = separated_nontrivial_llist(COMMA, core_type) RPAREN + | LPAREN + tys = separated_nontrivial_llist(COMMA, one_type_parameter_of_several) + RPAREN { tys } +(* Layout annotations on type expressions typically require parens, as in [('a : + float64)]. But this is unnecessary when the type expression is used as the + parameter of a tconstr with more than one argument, as in [(int, 'b : + float64) t]. *) +%inline one_type_parameter_of_several: + | core_type { $1 } + | QUOTE id=ident COLON jkind=jkind_annotation + { Jane_syntax.Layouts.type_of ~loc:(make_loc $sloc) @@ + Ltyp_var { name = Some id; jkind } } + | UNDERSCORE COLON jkind=jkind_annotation + { Jane_syntax.Layouts.type_of ~loc:(make_loc $sloc) @@ + Ltyp_var { name = None; jkind } } + %inline package_type: module_type { let (lid, cstrs, attrs) = package_type_of_module_type $1 in let descr = Ptyp_package (lid, cstrs) in diff --git a/vendor/parser-standard/parsetree.mli b/vendor/parser-standard/parsetree.mli index 13b46b30c8..d7abcb822d 100644 --- a/vendor/parser-standard/parsetree.mli +++ b/vendor/parser-standard/parsetree.mli @@ -46,8 +46,10 @@ type constant = type location_stack = Location.t list type modality = | Modality of string [@@unboxed] +type modalities = modality loc list type mode = | Mode of string [@@unboxed] +type modes = mode loc list (** {1 Extension points} *) @@ -91,7 +93,7 @@ and core_type = and core_type_desc = | Ptyp_any (** [_] *) | Ptyp_var of string (** A type variable such as ['a] *) - | Ptyp_arrow of arg_label * core_type * core_type * mode loc list * mode loc list + | Ptyp_arrow of arg_label * core_type * core_type * modes * modes (** [Ptyp_arrow(lbl, T1, T2, M1, M2)] represents: - [T1 @ M1 -> T2 @ M2] when [lbl] is {{!arg_label.Nolabel}[Nolabel]}, @@ -289,7 +291,7 @@ and pattern_desc = *) | Ppat_array of pattern list (** Pattern [[| P1; ...; Pn |]] *) | Ppat_or of pattern * pattern (** Pattern [P1 | P2] *) - | Ppat_constraint of pattern * core_type option * mode loc list + | Ppat_constraint of pattern * core_type option * modes (** [Ppat_constraint(tyopt, modes)] represents: - [(P : ty @@ modes)] when [tyopt] is [Some ty] - [(P @ modes)] when [tyopt] is [None] @@ -339,33 +341,21 @@ and expression_desc = - [let rec P1 = E1 and ... and Pn = EN in E] when [flag] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. *) - | Pexp_function of case list (** [function P1 -> E1 | ... | Pn -> En] *) - | Pexp_fun of arg_label * expression option * pattern * expression - (** [Pexp_fun(lbl, exp0, P, E1)] represents: - - [fun P -> E1] - when [lbl] is {{!arg_label.Nolabel}[Nolabel]} - and [exp0] is [None] - - [fun ~l:P -> E1] - when [lbl] is {{!arg_label.Labelled}[Labelled l]} - and [exp0] is [None] - - [fun ?l:P -> E1] - when [lbl] is {{!arg_label.Optional}[Optional l]} - and [exp0] is [None] - - [fun ?l:(P = E0) -> E1] - when [lbl] is {{!arg_label.Optional}[Optional l]} - and [exp0] is [Some E0] - - Notes: - - If [E0] is provided, only - {{!arg_label.Optional}[Optional]} is allowed. - - [fun P1 P2 .. Pn -> E1] is represented as nested - {{!expression_desc.Pexp_fun}[Pexp_fun]}. - - [let f P = E] is represented using - {{!expression_desc.Pexp_fun}[Pexp_fun]}. - - While Position arguments ([lbl:[%call_pos] -> ...]) are parsed as - {{!Asttypes.arg_label.Labelled}[Labelled l]}, they are converted to - {{!Types.arg_label.Position}[Position l]} arguments for type-checking. - *) + | Pexp_function of + function_param list * function_constraint option * function_body + (** [Pexp_function ([P1; ...; Pn], C, body)] represents any construct + involving [fun] or [function], including: + - [fun P1 ... Pn -> E] + when [body = Pfunction_body E] + - [fun P1 ... Pn -> function p1 -> e1 | ... | pm -> em] + when [body = Pfunction_cases [ p1 -> e1; ...; pm -> em ]] + + [C] represents a type constraint or coercion placed immediately before the + arrow, e.g. [fun P1 ... Pn : ty -> ...] when [C = Some (Pconstraint ty)]. + + A function must have parameters. [Pexp_function (params, _, body)] must + have non-empty [params] or a [Pfunction_cases _] body. + *) | Pexp_apply of expression * (arg_label * expression) list (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] represents [E0 ~l1:E1 ... ~ln:En] @@ -426,7 +416,7 @@ and expression_desc = - [for i = E1 downto E2 do E3 done] when [direction] is {{!Asttypes.direction_flag.Downto}[Downto]} *) - | Pexp_constraint of expression * core_type option * mode loc list (** [(E : T @@ modes)] *) + | Pexp_constraint of expression * core_type option * modes (** [(E : T @@ modes)] *) | Pexp_coerce of expression * core_type option * core_type (** [Pexp_coerce(E, from, T)] represents - [(E :> T)] when [from] is [None], @@ -494,13 +484,83 @@ and binding_op = pbop_loc : Location.t; } +and function_param_desc = + | Pparam_val of arg_label * expression option * pattern + (** [Pparam_val (lbl, exp0, P)] represents the parameter: + - [P] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} + and [exp0] is [None] + - [~l:P] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} + and [exp0] is [None] + - [?l:P] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [None] + - [?l:(P = E0)] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [Some E0] + + Note: If [E0] is provided, only + {{!Asttypes.arg_label.Optional}[Optional]} is allowed. + *) + | Pparam_newtype of string loc * jkind_annotation loc option + (** [Pparam_newtype x] represents the parameter [(type x)]. + [x] carries the location of the identifier, whereas the [pparam_loc] + on the enclosing [function_param] node is the location of the [(type x)] + as a whole. + + Multiple parameters [(type a b c)] are represented as multiple + [Pparam_newtype] nodes, let's say: + + {[ [ { pparam_kind = Pparam_newtype a; pparam_loc = loc1 }; + { pparam_kind = Pparam_newtype b; pparam_loc = loc2 }; + { pparam_kind = Pparam_newtype c; pparam_loc = loc3 }; + ] + ]} + + Here, the first loc [loc1] is the location of [(type a b c)], and the + subsequent locs [loc2] and [loc3] are the same as [loc1], except marked as + ghost locations. The locations on [a], [b], [c], correspond to the + variables [a], [b], and [c] in the source code. + *) + +and function_param = + { pparam_loc : Location.t; + pparam_desc : function_param_desc; + } + +and function_body = + | Pfunction_body of expression + | Pfunction_cases of case list * Location.t * attributes + (** In [Pfunction_cases (_, loc, attrs)], the location extends from the + start of the [function] keyword to the end of the last case. The compiler + will only use typechecking-related attributes from [attrs], e.g. enabling + or disabling a warning. + *) +(** See the comment on {{!expression_desc.Pexp_function}[Pexp_function]}. *) + +and type_constraint = + | Pconstraint of core_type + | Pcoerce of core_type option * core_type +(** See the comment on {{!expression_desc.Pexp_function}[Pexp_function]}. *) + +and function_constraint = + { mode_annotations : modes; + (** The mode annotation placed on a function let-binding when the function + has a type constraint on the body, e.g. + [let local_ f x : int -> int = ...]. + *) + type_constraint : type_constraint; + } +(** See the comment on {{!expression_desc.Pexp_function}[Pexp_function]}. *) + (** {2 Value descriptions} *) and value_description = { pval_name: string loc; pval_type: core_type; - pval_modalities: modality loc list; + pval_modalities : modalities; pval_prim: string list; pval_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) pval_loc: Location.t; @@ -563,7 +623,7 @@ and label_declaration = { pld_name: string loc; pld_mutable: mutable_flag; - pld_modalities: modality loc list; + pld_modalities: modalities; pld_type: core_type; pld_loc: Location.t; pld_attributes: attributes; (** [l : T [\@id1] [\@id2]] *) @@ -591,7 +651,7 @@ and constructor_declaration = and constructor_argument = { - pca_modalities: modality loc list; + pca_modalities: modalities; pca_type: core_type; pca_loc: Location.t; } @@ -1098,7 +1158,7 @@ and value_binding = pvb_pat: pattern; pvb_expr: expression; pvb_constraint: value_constraint option; - pvb_modes: mode loc list; + pvb_modes: modes; pvb_attributes: attributes; pvb_loc: Location.t; }(** [let pat : type_constraint = exp] *) @@ -1112,6 +1172,15 @@ and module_binding = } (** Values of type [module_binding] represents [module X = ME] *) +and jkind_const_annotation = string Location.loc + +and jkind_annotation = + | Default + | Abbreviation of jkind_const_annotation + | Mod of jkind_annotation * modes + | With of jkind_annotation * core_type + | Kind_of of core_type + (** {1 Toplevel} *) (** {2 Toplevel phrases} *) diff --git a/vendor/parser-standard/printast.ml b/vendor/parser-standard/printast.ml index c5f094bef2..cb0371f768 100644 --- a/vendor/parser-standard/printast.ml +++ b/vendor/parser-standard/printast.ml @@ -135,17 +135,19 @@ let typevars ppf vs = (* Don't use Pprintast.tyvar, as that causes a dependency cycle with Jane_syntax, which depends on this module for debugging. *) +let modality i ppf modality = + line i ppf "modality %a\n" fmt_string_loc + (Location.map (fun (Modality x) -> x) modality) + let modalities i ppf modalities = - line i ppf "modalities\n"; - list i string_loc ppf ( - List.map (Location.map (fun (Modality x) -> x)) modalities - ) + List.iter (fun m -> modality i ppf m) modalities + +let mode i ppf mode = + line i ppf "mode %a\n" fmt_string_loc + (Location.map (fun (Mode x) -> x) mode) let modes i ppf modes = - line i ppf "modes\n"; - list i string_loc ppf ( - List.map (Location.map (fun (Mode x) -> x)) modes - ) + List.iter (fun m -> mode i ppf m) modes let labeled_tuple_element f i ppf (l, ct) = option i string ppf l; @@ -162,8 +164,8 @@ let rec core_type i ppf x = line i ppf "Ptyp_arrow\n"; arg_label i ppf l; core_type i ppf ct1; - core_type i ppf ct2; modes i ppf m1; + core_type i ppf ct2; modes i ppf m2; | Ptyp_tuple l -> line i ppf "Ptyp_tuple\n"; @@ -256,7 +258,7 @@ and pattern i ppf x = | Ppat_constraint (p, ct, m) -> line i ppf "Ppat_constraint\n"; pattern i ppf p; - option i core_type ppf ct; + Option.iter (core_type i ppf) ct; modes i ppf m; | Ppat_type (li) -> line i ppf "Ppat_type\n"; @@ -284,15 +286,11 @@ and expression i ppf x = line i ppf "Pexp_let %a\n" fmt_rec_flag rf; list i value_binding ppf l; expression i ppf e; - | Pexp_function l -> + | Pexp_function (params, c, body) -> line i ppf "Pexp_function\n"; - list i case ppf l; - | Pexp_fun (l, eo, p, e) -> - line i ppf "Pexp_fun\n"; - arg_label i ppf l; - option i expression ppf eo; - pattern i ppf p; - expression i ppf e; + list i function_param ppf params; + option i function_constraint ppf c; + function_body i ppf body | Pexp_apply (e, l) -> line i ppf "Pexp_apply\n"; expression i ppf e; @@ -355,7 +353,7 @@ and expression i ppf x = | Pexp_constraint (e, ct, m) -> line i ppf "Pexp_constraint\n"; expression i ppf e; - option i core_type ppf ct; + Option.iter (core_type i ppf) ct; modes i ppf m; | Pexp_coerce (e, cto1, cto2) -> line i ppf "Pexp_coerce\n"; @@ -416,13 +414,68 @@ and expression i ppf x = | Pexp_hole -> line i ppf "Pexp_hole" +and jkind_annotation i ppf (jkind : jkind_annotation) = + match jkind with + | Default -> line i ppf "Default\n" + | Abbreviation jkind -> + line i ppf "Abbreviation \"%s\"\n" jkind.txt + | Mod (jkind, m) -> + line i ppf "Mod\n"; + jkind_annotation (i+1) ppf jkind; + modes (i+1) ppf m + | With (jkind, type_) -> + line i ppf "With\n"; + jkind_annotation (i+1) ppf jkind; + core_type (i+1) ppf type_ + | Kind_of type_ -> + line i ppf "Kind_of\n"; + core_type (i+1) ppf type_ + +and function_param i ppf { pparam_desc = desc; pparam_loc = loc } = + match desc with + | Pparam_val (l, eo, p) -> + line i ppf "Pparam_val %a\n" fmt_location loc; + arg_label (i+1) ppf l; + option (i+1) expression ppf eo; + pattern (i+1) ppf p + | Pparam_newtype (ty, jkind) -> + line i ppf "Pparam_newtype \"%s\" %a\n" ty.txt fmt_location loc; + option (i+1) + (fun i ppf jkind -> jkind_annotation i ppf jkind.txt) + ppf + jkind + +and function_body i ppf body = + match body with + | Pfunction_body e -> + line i ppf "Pfunction_body\n"; + expression (i+1) ppf e + | Pfunction_cases (cases, loc, attrs) -> + line i ppf "Pfunction_cases %a\n" fmt_location loc; + attributes (i+1) ppf attrs; + list (i+1) case ppf cases + +and type_constraint i ppf type_constraint = + match type_constraint with + | Pconstraint ty -> + line i ppf "Pconstraint\n"; + core_type (i+1) ppf ty + | Pcoerce (ty1, ty2) -> + line i ppf "Pcoerce\n"; + option (i+1) core_type ppf ty1; + core_type (i+1) ppf ty2 + +and function_constraint i ppf { type_constraint = c; mode_annotations } = + type_constraint i ppf c; + modes i ppf mode_annotations + and value_description i ppf x = line i ppf "value_description %a %a\n" fmt_string_loc x.pval_name fmt_location x.pval_loc; attributes i ppf x.pval_attributes; core_type (i+1) ppf x.pval_type; - list (i+1) string ppf x.pval_prim; - modalities (i+1) ppf x.pval_modalities + modalities (i+1) ppf x.pval_modalities; + list (i+1) string ppf x.pval_prim and type_parameter i ppf (x, _variance) = core_type i ppf x