diff --git a/ocaml/.depend b/ocaml/.depend index 312988d0e33..1043c3bacf6 100644 --- a/ocaml/.depend +++ b/ocaml/.depend @@ -1138,8 +1138,7 @@ typing/mode.cmi : \ typing/mode_intf.cmi typing/mode_intf.cmi : \ typing/solver_intf.cmi \ - typing/solver.cmi \ - utils/misc.cmi + typing/solver.cmi typing/mtype.cmo : \ typing/types.cmi \ typing/subst.cmi \ @@ -1991,6 +1990,7 @@ typing/typedtree.cmo : \ parsing/longident.cmi \ parsing/location.cmi \ typing/jkind.cmi \ + parsing/jane_syntax.cmi \ parsing/jane_asttypes.cmi \ typing/ident.cmi \ typing/env.cmi \ @@ -2006,6 +2006,7 @@ typing/typedtree.cmx : \ parsing/longident.cmx \ parsing/location.cmx \ typing/jkind.cmx \ + parsing/jane_syntax.cmx \ parsing/jane_asttypes.cmx \ typing/ident.cmx \ typing/env.cmx \ @@ -2021,6 +2022,7 @@ typing/typedtree.cmi : \ parsing/longident.cmi \ parsing/location.cmi \ typing/jkind.cmi \ + parsing/jane_syntax.cmi \ parsing/jane_asttypes.cmi \ typing/ident.cmi \ typing/env.cmi \ @@ -4176,13 +4178,11 @@ lambda/transl_array_comprehension.cmi : \ lambda/debuginfo.cmi lambda/transl_comprehension_utils.cmo : \ utils/targetint.cmi \ - typing/primitive.cmi \ lambda/lambda.cmi \ typing/ident.cmi \ lambda/transl_comprehension_utils.cmi lambda/transl_comprehension_utils.cmx : \ utils/targetint.cmx \ - typing/primitive.cmx \ lambda/lambda.cmx \ typing/ident.cmx \ lambda/transl_comprehension_utils.cmi diff --git a/ocaml/boot/menhir/parser.ml b/ocaml/boot/menhir/parser.ml index 3c2a97ce2ab..5b6e6153dbb 100644 --- a/ocaml/boot/menhir/parser.ml +++ b/ocaml/boot/menhir/parser.ml @@ -379,7 +379,7 @@ let mkexp_with_modes ?(ghost=false) ~loc modes exp = let loc = if ghost then ghost_loc loc else make_loc loc in - Mode.expr_of_coerce ~loc modes exp + Jane_syntax.Modes.expr_of ~loc (Coerce (modes, exp)) (* For modes-related attributes, no need to call [register_attr] because they result from native syntax which is only parsed at proper places that are diff --git a/ocaml/parsing/ast_invariants.ml b/ocaml/parsing/ast_invariants.ml index 50033b25040..2172fac7b8c 100644 --- a/ocaml/parsing/ast_invariants.ml +++ b/ocaml/parsing/ast_invariants.ml @@ -147,6 +147,7 @@ let iterator = | Jexp_comprehension _ | Jexp_immutable_array _ | Jexp_layout _ + | Jexp_modes _ -> () in let expr self exp = diff --git a/ocaml/parsing/ast_iterator.ml b/ocaml/parsing/ast_iterator.ml index 591d9871bdf..1f4f42cbb80 100644 --- a/ocaml/parsing/ast_iterator.ml +++ b/ocaml/parsing/ast_iterator.ml @@ -43,7 +43,6 @@ type iterator = { constructor_declaration: iterator -> constructor_declaration -> unit; expr: iterator -> expression -> unit; expr_jane_syntax: iterator -> Jane_syntax.Expression.t -> unit; - expr_mode_syntax: iterator -> Jane_syntax.Mode_expr.t -> expression -> unit; extension: iterator -> extension -> unit; extension_constructor: iterator -> extension_constructor -> unit; include_declaration: iterator -> include_declaration -> unit; @@ -467,6 +466,7 @@ module E = struct module L = Jane_syntax.Layouts module N_ary = Jane_syntax.N_ary_functions module LT = Jane_syntax.Labeled_tuples + module Modes = Jane_syntax.Modes let iter_iterator sub : C.iterator -> _ = function | Range { start; stop; direction = _ } -> @@ -543,24 +543,22 @@ module E = struct let iter_labeled_tuple sub : LT.expression -> _ = function | el -> List.iter (iter_snd (sub.expr sub)) el + let iter_modes_exp sub : Modes.expression -> _ = function + | Coerce (modes, expr) -> + sub.modes sub modes; + sub.expr sub expr + let iter_jst sub : Jane_syntax.Expression.t -> _ = function | Jexp_comprehension comp_exp -> iter_comp_exp sub comp_exp | Jexp_immutable_array iarr_exp -> iter_iarr_exp sub iarr_exp | Jexp_layout layout_exp -> iter_layout_exp sub layout_exp | Jexp_n_ary_function n_ary_exp -> iter_n_ary_function sub n_ary_exp | Jexp_tuple lt_exp -> iter_labeled_tuple sub lt_exp - - let iter_mode sub modes expr = - sub.modes sub modes; - sub.expr sub expr + | Jexp_modes mode_exp -> iter_modes_exp sub mode_exp let iter sub ({pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} as expr)= sub.location sub loc; - match Jane_syntax.Mode_expr.coerce_of_expr expr with - | Some (modes, e) -> - sub.expr_mode_syntax sub modes e - | None -> match Jane_syntax.Expression.of_ast expr with | Some (jexp, attrs) -> sub.attributes sub attrs; @@ -827,7 +825,6 @@ let default_iterator = pat_mode_syntax = P.iter_mode; expr = E.iter; expr_jane_syntax = E.iter_jst; - expr_mode_syntax = E.iter_mode; binding_op = E.iter_binding_op; module_declaration = diff --git a/ocaml/parsing/ast_iterator.mli b/ocaml/parsing/ast_iterator.mli index eec163b7680..96c4624d557 100644 --- a/ocaml/parsing/ast_iterator.mli +++ b/ocaml/parsing/ast_iterator.mli @@ -46,7 +46,6 @@ type iterator = { constructor_declaration: iterator -> constructor_declaration -> unit; expr: iterator -> expression -> unit; expr_jane_syntax : iterator -> Jane_syntax.Expression.t -> unit; - expr_mode_syntax: iterator -> Jane_syntax.Mode_expr.t -> expression -> unit; extension: iterator -> extension -> unit; extension_constructor: iterator -> extension_constructor -> unit; include_declaration: iterator -> include_declaration -> unit; diff --git a/ocaml/parsing/ast_mapper.ml b/ocaml/parsing/ast_mapper.ml index e2d518f5986..aef6c139d02 100644 --- a/ocaml/parsing/ast_mapper.ml +++ b/ocaml/parsing/ast_mapper.ml @@ -105,6 +105,18 @@ let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} let map_loc_txt sub f {loc; txt} = {loc = sub.location sub loc; txt = f sub txt} +let map_mode_expr sub (mode_expr : Jane_syntax.Mode_expr.t) + : Jane_syntax.Mode_expr.t = + map_loc_txt sub + (fun sub modes -> + List.map + (fun (mode : Jane_syntax.Mode_expr.Const.t) -> + let { loc; txt } = (mode :> string loc) in + let loc = sub.location sub loc in + Jane_syntax.Mode_expr.Const.mk txt loc) + modes) + mode_expr + module C = struct (* Constants *) @@ -536,6 +548,7 @@ module E = struct module L = Jane_syntax.Layouts module N_ary = Jane_syntax.N_ary_functions module LT = Jane_syntax.Labeled_tuples + module Modes = Jane_syntax.Modes let map_iterator sub : C.iterator -> C.iterator = function | Range { start; stop; direction } -> @@ -629,6 +642,11 @@ module E = struct (* CR labeled tuples: Eventually mappers may want to see the labels. *) | el -> List.map (map_snd (sub.expr sub)) el + let map_modes_exp sub : Modes.expression -> Modes.expression = function + (* CR modes: One day mappers might want to see the modes *) + | Coerce (modes, exp) -> + Coerce (map_mode_expr sub modes, sub.expr sub exp) + let map_jst sub : Jane_syntax.Expression.t -> Jane_syntax.Expression.t = function | Jexp_comprehension x -> Jexp_comprehension (map_cexp sub x) @@ -636,6 +654,7 @@ module E = struct | 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) + | Jexp_modes mode_exp -> Jexp_modes (map_modes_exp sub mode_exp) let map sub ({pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} as exp) = diff --git a/ocaml/parsing/depend.ml b/ocaml/parsing/depend.ml index 3f06e47f42c..4f8a7e324e0 100644 --- a/ocaml/parsing/depend.ml +++ b/ocaml/parsing/depend.ml @@ -332,6 +332,11 @@ and add_expr_jane_syntax bv : Jane_syntax.Expression.t -> _ = function | Jexp_layout x -> add_layout_expr bv x | Jexp_n_ary_function n_ary -> add_n_ary_function bv n_ary | Jexp_tuple x -> add_labeled_tuple_expr bv x + | Jexp_modes x -> add_modes_expr bv x + +and add_modes_expr bv : Jane_syntax.Modes.expression -> _ = + function + | Coerce (_modes, exp) -> add_expr bv exp and add_comprehension_expr bv : Jane_syntax.Comprehensions.expression -> _ = function diff --git a/ocaml/parsing/jane_syntax.ml b/ocaml/parsing/jane_syntax.ml index af31f0eb002..3df5da9f78b 100644 --- a/ocaml/parsing/jane_syntax.ml +++ b/ocaml/parsing/jane_syntax.ml @@ -459,8 +459,6 @@ module Mode_expr = struct let attribute_name = attribute_or_extension_name - let extension_name = attribute_or_extension_name - let payload_of { txt; _ } = match txt with | [] -> None @@ -508,26 +506,38 @@ module Mode_expr = struct let loc = { loc with loc_ghost = true } in let txt = List.map Const.ghostify txt in { loc; txt } +end + +(** Some mode-related constructs *) +module Modes = struct + let feature : Feature.t = Language_extension Mode + + type nonrec expression = Coerce of Mode_expr.t * expression - let coerce_of_expr { pexp_desc; _ } = + let extension_name = Mode_expr.attribute_or_extension_name + + let of_expr ({ pexp_desc; pexp_attributes; _ } as expr) = match pexp_desc with | Pexp_apply ( { pexp_desc = Pexp_extension ({ txt; _ }, payload); pexp_loc; _ }, [(Nolabel, body)] ) when txt = extension_name -> - let modes = of_payload ~loc:pexp_loc payload in - Some (modes, body) - | _ -> None - - let expr_of_coerce ~loc modes body = - match payload_of modes with + let modes = Mode_expr.of_payload ~loc:pexp_loc payload in + Coerce (modes, body), pexp_attributes + | _ -> + Misc.fatal_errorf "Improperly encoded modes expression: %a" + (Printast.expression 0) expr + + let expr_of ~loc (Coerce (modes, body)) = + match Mode_expr.payload_of modes with | None -> body | Some payload -> let ext = Ast_helper.Exp.extension ~loc:modes.loc (Location.mknoloc extension_name, payload) in - Ast_helper.Exp.apply ~loc ext [Nolabel, body] + Expression.make_entire_jane_syntax ~loc feature (fun () -> + Ast_helper.Exp.apply ~loc ext [Nolabel, body]) end (** List and array comprehensions *) @@ -1911,6 +1921,7 @@ module Expression = struct | Jexp_layout of Layouts.expression | Jexp_n_ary_function of N_ary_functions.expression | Jexp_tuple of Labeled_tuples.expression + | Jexp_modes of Modes.expression let of_ast_internal (feat : Feature.t) expr = match feat with @@ -1930,6 +1941,9 @@ module Expression = struct | Language_extension Labeled_tuples -> let expr, attrs = Labeled_tuples.of_expr expr in Some (Jexp_tuple expr, attrs) + | Language_extension Mode -> + let expr, attrs = Modes.of_expr expr in + Some (Jexp_modes expr, attrs) | _ -> None let of_ast = Expression.make_of_ast ~of_ast_internal @@ -1942,6 +1956,7 @@ module Expression = struct | 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 + | Jexp_modes x -> Modes.expr_of ~loc x in (* Performance hack: save an allocation if [attrs] is empty. *) match attrs with diff --git a/ocaml/parsing/jane_syntax.mli b/ocaml/parsing/jane_syntax.mli index 822c5750cdc..7141eb4d61f 100644 --- a/ocaml/parsing/jane_syntax.mli +++ b/ocaml/parsing/jane_syntax.mli @@ -159,20 +159,27 @@ module Mode_expr : sig attribute is found. *) val of_attrs : Parsetree.attributes -> t * Parsetree.attributes - (** Decode mode coercion and returns the mode and the body. - For example, return [Some (local, expr)] on input [local_ expr]. - Returns [None] if the given expression is not a mode coercion. *) - val coerce_of_expr : Parsetree.expression -> (t * Parsetree.expression) option - - (** Encode a mode coercion like [local_ expr] into an expression *) - val expr_of_coerce : - loc:Location.t -> t -> Parsetree.expression -> Parsetree.expression - (** In some cases, a single mode expression appears twice in the parsetree; one of them needs to be made ghost to make our internal tools happy. *) val ghostify : t -> t end +(** A subset of the mode-related syntax extensions that is embedded + using full-blown Jane Syntax. By "full-blown" Jane Syntax, we + mean the [Expression], [Pattern], (etc.) modules below that + attempt to create a variant of all possible Jane Street syntax + for the syntactic form. + + We avoid full-blown Jane Syntax when it isn't very lightweight to fit the + new construct into the (somewhat opinionated) framework. Mode coercions are + lightweight to fit into full-blown Jane Syntax. +*) +module Modes : sig + type expression = Coerce of Mode_expr.t * Parsetree.expression + + val expr_of : loc:Location.t -> expression -> Parsetree.expression +end + module N_ary_functions : sig (** These types use the [P] prefix to match how they are represented in the upstream compiler *) @@ -586,6 +593,7 @@ module Expression : sig | Jexp_layout of Layouts.expression | Jexp_n_ary_function of N_ary_functions.expression | Jexp_tuple of Labeled_tuples.expression + | Jexp_modes of Modes.expression include AST diff --git a/ocaml/parsing/parser.mly b/ocaml/parsing/parser.mly index b419a5ca16b..f2400bfd58e 100644 --- a/ocaml/parsing/parser.mly +++ b/ocaml/parsing/parser.mly @@ -154,7 +154,7 @@ let mkexp_with_modes ?(ghost=false) ~loc modes exp = let loc = if ghost then ghost_loc loc else make_loc loc in - Mode.expr_of_coerce ~loc modes exp + Jane_syntax.Modes.expr_of ~loc (Coerce (modes, exp)) (* For modes-related attributes, no need to call [register_attr] because they result from native syntax which is only parsed at proper places that are diff --git a/ocaml/parsing/pprintast.ml b/ocaml/parsing/pprintast.ml index cfdb8a9f78c..2c51616e24d 100644 --- a/ocaml/parsing/pprintast.ml +++ b/ocaml/parsing/pprintast.ml @@ -788,10 +788,6 @@ and sugar_expr ctxt f e = expressions that aren't already self-delimiting. *) and expression ?(jane_syntax_parens = false) ctxt f x = - match Jane_syntax.Mode_expr.coerce_of_expr x with - | Some (m, body) -> - pp f "@[<2>%s %a@]" (modes m) (expression ctxt) body - | None -> match Jane_syntax.Expression.of_ast x with | Some (jexpr, attrs) -> jane_syntax_expr ctxt attrs f jexpr ~parens:jane_syntax_parens @@ -1484,9 +1480,6 @@ and payload ctxt f = function pp f " when "; expression ctxt f e and pp_print_pexp_function ctxt sep f x = - (* do not print [@jane.erasable.mode] on expressions *) - let _, attrs = maybe_modes_of_attrs x.pexp_attributes in - let x = { x with pexp_attributes = attrs } in (* We go to some trouble to print nested [Pexp_newtype]/[Lexp_newtype] as newtype parameters of the same "fun" (rather than printing several nested "fun (type a) -> ..."). This isn't necessary for round-tripping -- it just @@ -1586,15 +1579,35 @@ and binding ctxt f {pvb_pat=p; pvb_expr=x; pvb_constraint = ct; _} = (* [in] is not printed *) and bindings ctxt f (rf,l) = let binding kwd rf f x = - let modes, attrs = maybe_modes_of_attrs x.pvb_attributes in + let modes_on_binding, attrs = + Jane_syntax.Mode_expr.maybe_of_attrs x.pvb_attributes + in let x = - match modes, Jane_syntax.Mode_expr.coerce_of_expr x.pvb_expr with - | Some _ , Some (_, sbody) -> - {x with pvb_expr = sbody} + (* For [let local_ x = e in ...] and [let x @ local = e in ...], + the parser puts attributes on both the let-binding and on e. + + The below code is meant to print the modes only in one place, + not both. (We print it on the let-binding, not the expression.) + *) + match modes_on_binding, Jane_syntax.Expression.of_ast x.pvb_expr with + | Some modes_on_binding, + Some (Jexp_modes (Coerce (modes_on_expr, sbody)), _) -> + (* Sanity check: only suppress the printing of one mode expression if + the mode expressions are in fact identical. + *) + let mode_names (modes : Jane_syntax.Mode_expr.t) = + List.map Location.get_txt (modes.txt :> string loc list) + in + if + List.equal String.equal + (mode_names modes_on_binding) + (mode_names modes_on_expr) + then {x with pvb_expr = sbody} + else x | _ -> x in pp f "@[<2>%s %a%s%a@]%a" kwd rec_flag rf - (match modes with Some s -> s ^ " " | None -> "") + (match modes_on_binding with Some s -> modes s ^ " " | None -> "") (binding ctxt) x (item_attributes ctxt) attrs in match l with @@ -2006,6 +2019,11 @@ and jane_syntax_expr ctxt attrs f (jexp : Jane_syntax.Expression.t) ~parens = if parens then pp f "(%a)" (n_ary_function_expr reset_ctxt) x else n_ary_function_expr ctxt f x | Jexp_tuple ltexp -> labeled_tuple_expr ctxt f ltexp + | Jexp_modes mexp -> mode_expr ctxt f mexp + +and mode_expr ctxt f (mexp : Jane_syntax.Modes.expression) = + match mexp with + | Coerce (m, body) -> pp f "@[<2>%s %a@]" (modes m) (expression ctxt) body and comprehension_expr ctxt f (cexp : Jane_syntax.Comprehensions.expression) = let punct, comp = match cexp with diff --git a/ocaml/typing/printtyped.ml b/ocaml/typing/printtyped.ml index 1ad744a11d5..fe97eb97338 100644 --- a/ocaml/typing/printtyped.ml +++ b/ocaml/typing/printtyped.ml @@ -378,6 +378,14 @@ and expression_extra i ppf x attrs = | Texp_newtype (s, lay) -> line i ppf "Texp_newtype %a\n" (typevar_jkind ~print_quote:false) (s, lay); attributes i ppf attrs; + | Texp_mode_coerce modes -> + let modes = (modes :> string Location.loc list Location.loc) in + line i ppf "Texp_mode_coerce %s\n" + (String.concat "," + (List.map + (fun loc -> Printf.sprintf "\"%s\"" loc.txt) + modes.txt)); + attributes i ppf attrs; and alloc_mode: type l r. _ -> _ -> (l * r) Mode.Alloc.t -> _ = fun i ppf m -> line i ppf "alloc_mode %a\n" (Mode.Alloc.print ()) m diff --git a/ocaml/typing/tast_iterator.ml b/ocaml/typing/tast_iterator.ml index ca7379efb6e..211783c8ba4 100644 --- a/ocaml/typing/tast_iterator.ml +++ b/ocaml/typing/tast_iterator.ml @@ -265,6 +265,7 @@ let extra sub = function sub.typ sub cty2 | Texp_newtype _ -> () | Texp_poly cto -> Option.iter (sub.typ sub) cto + | Texp_mode_coerce _ -> () let function_param sub { fp_loc; fp_kind; fp_newtypes; _ } = sub.location sub fp_loc; diff --git a/ocaml/typing/tast_mapper.ml b/ocaml/typing/tast_mapper.ml index 3f3a9a301ca..9d150253fd2 100644 --- a/ocaml/typing/tast_mapper.ml +++ b/ocaml/typing/tast_mapper.ml @@ -366,6 +366,7 @@ let extra sub = function Texp_coerce (Option.map (sub.typ sub) cty1, sub.typ sub cty2) | Texp_newtype _ as d -> d | Texp_poly cto -> Texp_poly (Option.map (sub.typ sub) cto) + | Texp_mode_coerce modes -> Texp_mode_coerce modes let function_body sub body = match body with diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index 9e5884b372c..14d5e520ac8 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -869,9 +869,13 @@ let expect_mode_cross env ty (expected_mode : expected_mode) = in { expected_mode with mode; strictly_local } -let alloc_mode_from_exp_attrs exp = - let modes, _ = Jane_syntax.Mode_expr.of_attrs exp.pexp_attributes in - Typemode.transl_alloc_mode modes +(* Value binding elaboration can insert alloc mode attributes on the forged + [Pexp_constraint] node. Use this function to detect + and remove these inserted attributes. +*) +let alloc_mode_from_pexp_constraint_typ_attrs styp = + let modes, rest = Jane_syntax.Mode_expr.of_attrs styp.ptyp_attributes in + { styp with ptyp_attributes = rest }, Typemode.transl_alloc_mode modes let alloc_mode_from_pat_attrs pat = let modes, _ = Jane_syntax.Mode_expr.of_attrs pat.ppat_attributes in @@ -3927,16 +3931,6 @@ end = struct let expr e = let rec loop e = - match Jane_syntax.Mode_expr.coerce_of_expr e with - | Some (modes, exp) -> - if List.exists - (fun m -> - let {txt; _} = (m : Jane_syntax.Mode_expr.Const.t :> _ Location.loc) in - txt = "local") - modes.txt - then Local e.pexp_loc - else loop exp - | None -> match Jane_syntax.Expression.of_ast e with | Some (jexp, _attrs) -> begin match jexp with @@ -3946,6 +3940,16 @@ end = struct | Jexp_layout (Lexp_newtype (_, _, e)) -> loop e | Jexp_n_ary_function _ -> Not e.pexp_loc | Jexp_tuple _ -> Not e.pexp_loc + | Jexp_modes (Coerce (modes, exp)) -> + if List.exists + (fun m -> + let {txt; _} = + (m : Jane_syntax.Mode_expr.Const.t :> _ Location.loc) + in + txt = "local") + modes.txt + then Local e.pexp_loc + else loop exp end | None -> match e.pexp_desc with @@ -4163,9 +4167,6 @@ let type_approx_fun_one_param let rec type_approx env sexp ty_expected = let loc = sexp.pexp_loc in - match Jane_syntax.Mode_expr.coerce_of_expr sexp with - | Some (_, e) -> type_approx env e ty_expected - | None -> match Jane_syntax.Expression.of_ast sexp with | Some (jexp, _attrs) -> type_approx_aux_jane_syntax ~loc env jexp ty_expected | None -> match sexp.pexp_desc with @@ -4210,6 +4211,7 @@ and type_approx_aux_jane_syntax type_approx_function ~loc env params c body ty_expected | Jexp_tuple l -> type_tuple_approx env loc ty_expected l + | Jexp_modes (Coerce (_, e)) -> type_approx env e ty_expected and type_tuple_approx (env: Env.t) loc ty_expected l = let labeled_tys = List.map @@ -4643,9 +4645,6 @@ let unify_exp ?sdesc_for_hint env exp expected_ty = the "expected type" provided by the context. *) let rec is_inferred sexp = - match Jane_syntax.Mode_expr.coerce_of_expr sexp with - | Some (_, exp) -> is_inferred exp - | None -> match Jane_syntax.Expression.of_ast sexp with | Some (jexp, _attrs) -> is_inferred_jane_syntax jexp | None -> match sexp.pexp_desc with @@ -4661,6 +4660,7 @@ and is_inferred_jane_syntax : Jane_syntax.Expression.t -> _ = function | Jexp_layout (Lexp_constant _ | Lexp_newtype _) -> false | Jexp_n_ary_function _ -> false | Jexp_tuple _ -> false + | Jexp_modes (Coerce (_, exp)) -> is_inferred exp (* check if the type of %apply or %revapply matches the type expected by the specialized typing rule for those primitives. @@ -4956,8 +4956,12 @@ let may_lower_contravariant_then_generalize env exp = let vb_exp_constraint {pvb_expr=expr; pvb_pat=pat; pvb_constraint=ct; pvb_attributes=attrs; _ } = let open Ast_helper in let mode_annot_attr, _ = Jane_syntax.Mode_expr.extract_attr attrs in - let mode_annot_attrs = - Option.fold ~none:[] ~some:(fun x -> [x]) mode_annot_attr + (* This added mode attribute is read and removed by + [alloc_mode_from_pexp_constraint_typ_attributes]. *) + let add_mode_annot_attrs typ = + match mode_annot_attr with + | None -> typ + | Some attr -> { typ with ptyp_attributes = attr :: typ.ptyp_attributes } in match ct with | None -> expr @@ -4966,7 +4970,7 @@ let vb_exp_constraint {pvb_expr=expr; pvb_pat=pat; pvb_constraint=ct; pvb_attrib | Ptyp_poly _ -> expr | _ -> let loc = { expr.pexp_loc with Location.loc_ghost = true } in - Exp.constraint_ ~loc ~attrs:mode_annot_attrs expr typ + Exp.constraint_ ~loc expr (add_mode_annot_attrs typ) end | Some (Pvc_coercion { ground; coercion}) -> let loc = { expr.pexp_loc with Location.loc_ghost = true } in @@ -4974,7 +4978,7 @@ let vb_exp_constraint {pvb_expr=expr; pvb_pat=pat; pvb_constraint=ct; pvb_attrib | Some (Pvc_constraint { locally_abstract_univars=vars;typ}) -> let loc_start = pat.ppat_loc.Location.loc_start in let loc = { expr.pexp_loc with loc_start; loc_ghost=true } in - let expr = Exp.constraint_ ~loc ~attrs:mode_annot_attrs expr typ in + let expr = Exp.constraint_ ~loc expr (add_mode_annot_attrs typ) in List.fold_right (Exp.newtype ~loc) vars expr let vb_pat_constraint @@ -5075,33 +5079,6 @@ and type_expect_ submode ~env ~loc:exp.exp_loc ~reason:Other mode expected_mode; exp in - match Jane_syntax.Mode_expr.coerce_of_expr sexp with - | Some (modes, sbody) -> - let expected_mode = List.fold_left (fun expected_mode mode -> - let mode = (mode : Jane_syntax.Mode_expr.Const.t :> _ Location.loc) in - match mode.txt with - | "unique" -> - let expected_mode = mode_unique expected_mode in - expect_mode_cross env ty_expected expected_mode - | "once" -> - let expected_mode = expect_mode_cross env ty_expected expected_mode in - submode ~loc ~env ~reason:Other - (Value.min_with_linearity Linearity.once) expected_mode; - mode_once expected_mode - | "local" -> - let expected_mode = expect_mode_cross env ty_expected expected_mode in - submode ~loc ~env ~reason:Other - (Value.min_with_regionality Regionality.local) expected_mode; - mode_strictly_local expected_mode - | s -> - Misc.fatal_errorf "Unrecognized mode %s - should not parse" s - ) expected_mode modes.txt - in - let exp = - type_expect ~recarg env expected_mode sbody ty_expected_explained - in - {exp with exp_loc = loc} - | None -> match Jane_syntax.Expression.of_ast sexp with | Some (jexp, attributes) -> type_expect_jane_syntax @@ -5827,8 +5804,9 @@ and type_expect_ exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_constraint (sarg, sty) -> + let sty, type_mode = alloc_mode_from_pexp_constraint_typ_attrs sty in let (ty, exp_extra) = - type_constraint env sty (alloc_mode_from_exp_attrs sexp) + type_constraint env sty type_mode in let ty' = instance ty in let error_message_attr_opt = @@ -5847,7 +5825,12 @@ and type_expect_ | Pexp_coerce(sarg, sty, sty') -> let arg, ty', exp_extra = type_coerce (expression_constraint sarg) env expected_mode loc sty sty' - (alloc_mode_from_exp_attrs sexp) ~loc_arg:sarg.pexp_loc + (* CR modes: We could consider changing value binding elaboration to + put modes on forged [Pexp_coerce] nodes, as we do for + [Pexp_constraint]. Then we could use that mode here instead of + legacy. + *) + Alloc.Const.legacy ~loc_arg:sarg.pexp_loc in rue { exp_desc = arg.exp_desc; @@ -7674,7 +7657,8 @@ and type_construct env (expected_mode : expected_mode) loc lid sarg | Jexp_comprehension _ | Jexp_immutable_array _ | Jexp_n_ary_function _ - | Jexp_layout _), _) -> [se] + | Jexp_layout _ + | Jexp_modes _ ), _) -> [se] | None -> match se.pexp_desc with | Pexp_tuple sel when constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs @@ -8215,9 +8199,6 @@ and type_newtype_expr and type_let ?check ?check_strict ?(force_toplevel = false) existential_context env rec_flag spat_sexp_list allow_modules = let rec sexp_is_fun sexp = - match Jane_syntax.Mode_expr.coerce_of_expr sexp with - | Some (_, e) -> sexp_is_fun e - | None -> match Jane_syntax.Expression.of_ast sexp with | Some (jexp, _attrs) -> jexp_is_fun jexp | None -> match sexp.pexp_desc with @@ -8232,6 +8213,7 @@ and type_let ?check ?check_strict ?(force_toplevel = false) | Jexp_layout (Lexp_newtype (_, _, e)) -> sexp_is_fun e | Jexp_n_ary_function _ -> true | Jexp_tuple _ -> false + | Jexp_modes (Coerce (_, e)) -> sexp_is_fun e in let vb_is_fun { pvb_expr = sexp; _ } = sexp_is_fun sexp in let entirely_functions = List.for_all vb_is_fun spat_sexp_list in @@ -8664,6 +8646,43 @@ and type_expect_jane_syntax | Jexp_tuple x -> type_tuple ~loc ~env ~expected_mode ~ty_expected ~explanation ~attributes x + | Jexp_modes x -> + type_mode_expr + ~loc ~env ~expected_mode ~ty_expected ~explanation ~attributes x + +and type_mode_expr + ~loc ~env ~expected_mode ~ty_expected ~explanation ~attributes + : Jane_syntax.Modes.expression -> _ = function + | Coerce (modes, sbody) -> + let expected_mode = List.fold_left (fun expected_mode mode -> + let mode = (mode : Jane_syntax.Mode_expr.Const.t :> _ Location.loc) in + match mode.txt with + | "unique" -> + let expected_mode = mode_unique expected_mode in + expect_mode_cross env ty_expected expected_mode + | "once" -> + let expected_mode = expect_mode_cross env ty_expected expected_mode in + submode ~loc ~env ~reason:Other + (Value.min_with_linearity Linearity.once) expected_mode; + mode_once expected_mode + | "local" -> + let expected_mode = expect_mode_cross env ty_expected expected_mode in + submode ~loc ~env ~reason:Other + (Value.min_with_regionality Regionality.local) expected_mode; + mode_strictly_local expected_mode + | s -> + Misc.fatal_errorf "Unrecognized mode %s - should not parse" s + ) expected_mode modes.txt + in + let exp = + type_expect env expected_mode sbody (mk_expected ty_expected ?explanation) + in + {exp with + (* CR modes: We should consider not overriding [exp_loc] here -- that would + be more consistent to the typing of [Pexp_constraint]. + *) + exp_loc = loc; + exp_extra = (Texp_mode_coerce modes, loc, attributes) :: exp.exp_extra} and type_n_ary_function ~loc ~env ~(expected_mode : expected_mode) ~ty_expected diff --git a/ocaml/typing/typedtree.ml b/ocaml/typing/typedtree.ml index a28d2c6ba91..a1bac2872b3 100644 --- a/ocaml/typing/typedtree.ml +++ b/ocaml/typing/typedtree.ml @@ -121,6 +121,7 @@ and exp_extra = | Texp_coerce of core_type option * core_type | Texp_poly of core_type option | Texp_newtype of string * Jkind.annotation option + | Texp_mode_coerce of Jane_syntax.Mode_expr.t and expression_desc = Texp_ident of diff --git a/ocaml/typing/typedtree.mli b/ocaml/typing/typedtree.mli index fc6094900c6..95c8ed025da 100644 --- a/ocaml/typing/typedtree.mli +++ b/ocaml/typing/typedtree.mli @@ -209,6 +209,12 @@ and exp_extra = (** Used for method bodies. *) | Texp_newtype of string * Jkind.annotation option (** fun (type t : immediate) -> *) + | Texp_mode_coerce of Jane_syntax.Mode_expr.t + (** local_ E *) + +(* CR modes: Consider fusing [Texp_mode_coerce] and [Texp_constraint] when + the syntax changes. +*) (** Jkinds in the typed tree: Compilation of the typed tree to lambda sometimes requires jkind information. Our approach is to diff --git a/ocaml/typing/untypeast.ml b/ocaml/typing/untypeast.ml index 06e198620df..83b7b8bf99d 100644 --- a/ocaml/typing/untypeast.ml +++ b/ocaml/typing/untypeast.ml @@ -438,6 +438,10 @@ let exp_extra sub (extra, loc, attrs) sexp = Jane_syntax.Layouts.expr_of ~loc (Lexp_newtype(add_loc s, jkind, sexp)) |> add_jane_syntax_attributes + | Texp_mode_coerce modes -> + Jane_syntax.Modes.expr_of ~loc + (Coerce (modes, sexp)) + |> add_jane_syntax_attributes in Exp.mk ~loc ~attrs:!attrs desc @@ -528,7 +532,8 @@ let expression sub exp = (Pcoerce (Option.map (sub.typ sub) ty1, sub.typ sub ty2)) | Some (Texp_constraint ty) -> Some (Pconstraint (sub.typ sub ty)) - | Some (Texp_poly _ | Texp_newtype _) | None -> None + | Some (Texp_poly _ | Texp_newtype _ | Texp_mode_coerce _) + | None -> None in let constraint_ = Option.map