Skip to content

Commit

Permalink
Initial implementation of layout annotations
Browse files Browse the repository at this point in the history
This was taken from ccasin/ocaml-jst#1,
but rebased and cleaned. There are a handful of failing tests,
still, but they're all newly introduced in this patch.
  • Loading branch information
goldfirere committed Jun 9, 2023
1 parent b0f5ecc commit c81636a
Show file tree
Hide file tree
Showing 68 changed files with 2,167 additions and 766 deletions.
26 changes: 17 additions & 9 deletions ocaml/parsing/ast_helper.ml
Original file line number Diff line number Diff line change
Expand Up @@ -69,14 +69,15 @@ module Typ = struct
let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b))
let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b))
let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c))
let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b))
let poly ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_poly (a, b, c))
let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b))
let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a)
let layout ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_layout (a, b))

let force_poly t =
match t.ptyp_desc with
| Ptyp_poly _ -> t
| _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *)
| _ -> poly ~loc:t.ptyp_loc [] t [] (* -> ghost? *)

let varify_constructors var_names t =
let check_variable vl loc v =
Expand Down Expand Up @@ -114,14 +115,16 @@ module Typ = struct
| Ptyp_variant(row_field_list, flag, lbl_lst_option) ->
Ptyp_variant(List.map loop_row_field row_field_list,
flag, lbl_lst_option)
| Ptyp_poly(string_lst, core_type) ->
| Ptyp_poly(string_lst, core_type, layouts) ->
List.iter (fun v ->
check_variable var_names t.ptyp_loc v.txt) string_lst;
Ptyp_poly(string_lst, loop core_type)
Ptyp_poly(string_lst, loop core_type, layouts)
| Ptyp_package(longident,lst) ->
Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
| Ptyp_extension (s, arg) ->
Ptyp_extension (s, arg)
| Ptyp_layout (t, layout) ->
Ptyp_layout (loop t, layout)
in
{t with ptyp_desc = desc}
and loop_row_field field =
Expand Down Expand Up @@ -212,7 +215,7 @@ module Exp = struct
let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a)
let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b))
let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a)
let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b))
let newtype ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_newtype (a, b, c))
let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a)
let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b))
let letop ?loc ?attrs let_ ands body =
Expand Down Expand Up @@ -517,11 +520,13 @@ module Type = struct
let mk ?(loc = !default_loc) ?(attrs = [])
?(docs = empty_docs) ?(text = [])
?(params = [])
?layout
?(cstrs = [])
?(kind = Ptype_abstract)
?(priv = Public)
?manifest
name =
let layout_attrs = Option.to_list layout in
{
ptype_name = name;
ptype_params = params;
Expand All @@ -530,15 +535,17 @@ module Type = struct
ptype_private = priv;
ptype_manifest = manifest;
ptype_attributes =
add_text_attrs text (add_docs_attrs docs attrs);
layout_attrs @ add_text_attrs text (add_docs_attrs docs attrs);
ptype_loc = loc;
}

let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info)
?(vars = []) ?(args = Pcstr_tuple []) ?res name =
?(vars = [],[]) ?(args = Pcstr_tuple []) ?res name =
let vars, layouts = vars in
{
pcd_name = name;
pcd_vars = vars;
pcd_layouts = layouts;
pcd_args = args;
pcd_res = res;
pcd_loc = loc;
Expand Down Expand Up @@ -588,10 +595,11 @@ module Te = struct
}

let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
?(info = empty_info) ?(vars = []) ?(args = Pcstr_tuple []) ?res name =
?(info = empty_info) ?(vars = [],[]) ?(args = Pcstr_tuple []) ?res name =
let vars, layouts = vars in
{
pext_name = name;
pext_kind = Pext_decl(vars, args, res);
pext_kind = Pext_decl(vars, args, res, layouts);
pext_loc = loc;
pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
}
Expand Down
15 changes: 11 additions & 4 deletions ocaml/parsing/ast_helper.mli
Original file line number Diff line number Diff line change
Expand Up @@ -80,10 +80,13 @@ module Typ :
val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type
val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag
-> label list option -> core_type
val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type
val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type
-> layout_annotation option list -> core_type
val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list
-> core_type
val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type
val layout: ?loc:loc -> ?attrs:attrs -> core_type
-> layout_annotation -> core_type

val force_poly: core_type -> core_type

Expand Down Expand Up @@ -181,7 +184,8 @@ module Exp:
val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option
-> expression
val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression
val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression
-> layout_annotation option -> expression
val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression
val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression
-> expression
Expand All @@ -206,12 +210,14 @@ module Type:
sig
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
?params:(core_type * (variance * injectivity)) list ->
?layout:attribute ->
?cstrs:(core_type * core_type * loc) list ->
?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str ->
type_declaration

val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info ->
?vars:str list -> ?args:constructor_arguments -> ?res:core_type ->
?vars:(str list * layout_annotation option list) ->
?args:constructor_arguments -> ?res:core_type ->
str ->
constructor_declaration
val field: ?loc:loc -> ?attrs:attrs -> ?info:info ->
Expand All @@ -232,7 +238,8 @@ module Te:
str -> extension_constructor_kind -> extension_constructor

val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
?vars:str list -> ?args:constructor_arguments -> ?res:core_type ->
?vars:(str list * layout_annotation option list) ->
?args:constructor_arguments -> ?res:core_type ->
str ->
extension_constructor
val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
Expand Down
29 changes: 24 additions & 5 deletions ocaml/parsing/ast_iterator.ml
Original file line number Diff line number Diff line change
Expand Up @@ -47,6 +47,7 @@ type iterator = {
include_declaration: iterator -> include_declaration -> unit;
include_description: iterator -> include_description -> unit;
label_declaration: iterator -> label_declaration -> unit;
layout_annotation:iterator -> Asttypes.const_layout -> unit;
location: iterator -> Location.t -> unit;
module_binding: iterator -> module_binding -> unit;
module_declaration: iterator -> module_declaration -> unit;
Expand Down Expand Up @@ -90,6 +91,9 @@ let iter_tuple3 f1 f2 f3 (x, y, z) = f1 x; f2 y; f3 z
let iter_opt f = function None -> () | Some x -> f x

let iter_loc sub {loc; txt = _} = sub.location sub loc
let iter_loc2 sub f { loc; txt } =
sub.location sub loc;
f sub txt

module T = struct
(* Type expressions for the core language *)
Expand All @@ -116,6 +120,9 @@ module T = struct
| Otag (_, t) -> sub.typ sub t
| Oinherit t -> sub.typ sub t

let type_vars_layouts sub (tvls : type_vars_layouts) =
List.iter (iter_opt (iter_loc2 sub sub.layout_annotation)) tvls

let iter_jst _sub : Jane_syntax.Core_type.t -> _ = function
| _ -> .

Expand Down Expand Up @@ -143,11 +150,17 @@ module T = struct
| Ptyp_alias (t, _) -> sub.typ sub t
| Ptyp_variant (rl, _b, _ll) ->
List.iter (row_field sub) rl
| Ptyp_poly (_, t) -> sub.typ sub t
| Ptyp_poly (_, t, lays) ->
sub.typ sub t;
type_vars_layouts sub lays
| Ptyp_package (lid, l) ->
iter_loc sub lid;
List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l
| Ptyp_extension x -> sub.extension sub x
| Ptyp_layout (t, layout) ->
sub.typ sub t;
iter_loc sub layout;
sub.layout_annotation sub layout.txt

let iter_type_declaration sub
{ptype_name; ptype_params; ptype_cstrs;
Expand Down Expand Up @@ -197,10 +210,11 @@ module T = struct
sub.attributes sub ptyexn_attributes

let iter_extension_constructor_kind sub = function
Pext_decl(vars, ctl, cto) ->
Pext_decl(vars, ctl, cto, layouts) ->
List.iter (iter_loc sub) vars;
iter_constructor_arguments sub ctl;
iter_opt (sub.typ sub) cto
iter_opt (sub.typ sub) cto;
type_vars_layouts sub layouts
| Pext_rebind li ->
iter_loc sub li

Expand Down Expand Up @@ -501,7 +515,9 @@ module E = struct
| Pexp_poly (e, t) ->
sub.expr sub e; iter_opt (sub.typ sub) t
| Pexp_object cls -> sub.class_structure sub cls
| Pexp_newtype (_s, e) -> sub.expr sub e
| Pexp_newtype (_s, e, l) ->
iter_opt (iter_loc2 sub sub.layout_annotation) l;
sub.expr sub e
| Pexp_pack me -> sub.module_expr sub me
| Pexp_open (o, e) ->
sub.open_declaration sub o; sub.expr sub e
Expand Down Expand Up @@ -753,10 +769,11 @@ let default_iterator =


constructor_declaration =
(fun this {pcd_name; pcd_vars; pcd_args;
(fun this {pcd_name; pcd_vars; pcd_layouts; pcd_args;
pcd_res; pcd_loc; pcd_attributes} ->
iter_loc this pcd_name;
List.iter (iter_loc this) pcd_vars;
T.type_vars_layouts this pcd_layouts;
T.iter_constructor_arguments this pcd_args;
iter_opt (this.typ this) pcd_res;
this.location this pcd_loc;
Expand Down Expand Up @@ -795,4 +812,6 @@ let default_iterator =
| PTyp x -> this.typ this x
| PPat (x, g) -> this.pat this x; iter_opt (this.expr this) g
);

layout_annotation = (fun _this _l -> ());
}
1 change: 1 addition & 0 deletions ocaml/parsing/ast_iterator.mli
Original file line number Diff line number Diff line change
Expand Up @@ -50,6 +50,7 @@ type iterator = {
include_declaration: iterator -> include_declaration -> unit;
include_description: iterator -> include_description -> unit;
label_declaration: iterator -> label_declaration -> unit;
layout_annotation: iterator -> Asttypes.const_layout -> unit;
location: iterator -> Location.t -> unit;
module_binding: iterator -> module_binding -> unit;
module_declaration: iterator -> module_declaration -> unit;
Expand Down
30 changes: 23 additions & 7 deletions ocaml/parsing/ast_mapper.ml
Original file line number Diff line number Diff line change
Expand Up @@ -54,6 +54,7 @@ type mapper = {
include_declaration: mapper -> include_declaration -> include_declaration;
include_description: mapper -> include_description -> include_description;
label_declaration: mapper -> label_declaration -> label_declaration;
layout_annotation: mapper -> Asttypes.const_layout -> Asttypes.const_layout;
location: mapper -> Location.t -> Location.t;
module_binding: mapper -> module_binding -> module_binding;
module_declaration: mapper -> module_declaration -> module_declaration;
Expand Down Expand Up @@ -95,6 +96,8 @@ let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
let map_opt f = function None -> None | Some x -> Some (f x)

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}

module C = struct
(* Constants *)
Expand Down Expand Up @@ -138,6 +141,9 @@ module T = struct
in
Of.mk ~loc ~attrs desc

let type_vars_layouts sub (tvls : type_vars_layouts) =
List.map (map_opt (map_loc_txt sub sub.layout_annotation)) tvls

let map_jst _sub : Jane_syntax.Core_type.t -> Jane_syntax.Core_type.t =
function
| _ -> .
Expand Down Expand Up @@ -170,12 +176,17 @@ module T = struct
| Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s
| Ptyp_variant (rl, b, ll) ->
variant ~loc ~attrs (List.map (row_field sub) rl) b ll
| Ptyp_poly (sl, t) -> poly ~loc ~attrs
(List.map (map_loc sub) sl) (sub.typ sub t)
| Ptyp_poly (sl, t, lays) ->
poly ~loc ~attrs (List.map (map_loc sub) sl)
(sub.typ sub t)
(type_vars_layouts sub lays)
| Ptyp_package (lid, l) ->
package ~loc ~attrs (map_loc sub lid)
(List.map (map_tuple (map_loc sub) (sub.typ sub)) l)
| Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x)
| Ptyp_layout (t, lay) -> layout ~loc ~attrs
(sub.typ sub t)
(map_loc_txt sub sub.layout_annotation lay)

let map_type_declaration sub
{ptype_name; ptype_params; ptype_cstrs;
Expand Down Expand Up @@ -229,10 +240,11 @@ module T = struct
(sub.extension_constructor sub ptyexn_constructor)

let map_extension_constructor_kind sub = function
Pext_decl(vars, ctl, cto) ->
Pext_decl(vars, ctl, cto, layouts) ->
Pext_decl(List.map (map_loc sub) vars,
map_constructor_arguments sub ctl,
map_opt (sub.typ sub) cto)
map_opt (sub.typ sub) cto,
type_vars_layouts sub layouts)
| Pext_rebind li ->
Pext_rebind (map_loc sub li)

Expand Down Expand Up @@ -583,8 +595,9 @@ module E = struct
| Pexp_poly (e, t) ->
poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t)
| Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls)
| Pexp_newtype (s, e) ->
| Pexp_newtype (s, e, l) ->
newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e)
(map_opt (map_loc_txt sub sub.layout_annotation) l)
| Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me)
| Pexp_open (o, e) ->
open_ ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e)
Expand Down Expand Up @@ -855,11 +868,12 @@ let default_mapper =


constructor_declaration =
(fun this {pcd_name; pcd_vars; pcd_args;
(fun this {pcd_name; pcd_vars; pcd_layouts; pcd_args;
pcd_res; pcd_loc; pcd_attributes} ->
Type.constructor
(map_loc this pcd_name)
~vars:(List.map (map_loc this) pcd_vars)
~vars:(List.map (map_loc this) pcd_vars,
List.map (Option.map (map_loc this)) pcd_layouts)
~args:(T.map_constructor_arguments this pcd_args)
?res:(map_opt (this.typ this) pcd_res)
~loc:(this.location this pcd_loc)
Expand Down Expand Up @@ -906,6 +920,8 @@ let default_mapper =
| PTyp x -> PTyp (this.typ this x)
| PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)
);

layout_annotation = (fun _this l -> l);
}

let extension_of_error {kind; main; sub} =
Expand Down
1 change: 1 addition & 0 deletions ocaml/parsing/ast_mapper.mli
Original file line number Diff line number Diff line change
Expand Up @@ -92,6 +92,7 @@ type mapper = {
type *)

label_declaration: mapper -> label_declaration -> label_declaration;
layout_annotation: mapper -> Asttypes.const_layout -> Asttypes.const_layout;
location: mapper -> Location.t -> Location.t;
module_binding: mapper -> module_binding -> module_binding;
module_declaration: mapper -> module_declaration -> module_declaration;
Expand Down
13 changes: 7 additions & 6 deletions ocaml/parsing/asttypes.mli
Original file line number Diff line number Diff line change
Expand Up @@ -49,6 +49,11 @@ type global_flag =
| Nonlocal
| Nothing

type 'a loc = 'a Location.loc = {
txt : 'a;
loc : Location.t;
}

(* constant layouts are parsed as layout annotations, and also used
in the type checker as already-inferred (i.e. non-variable) layouts *)
type const_layout =
Expand All @@ -57,6 +62,7 @@ type const_layout =
| Void
| Immediate64
| Immediate
type layout_annotation = const_layout loc

type label = string

Expand All @@ -65,12 +71,6 @@ type arg_label =
| Labelled of string (** [label:T -> ...] *)
| Optional of string (** [?label:T -> ...] *)

type 'a loc = 'a Location.loc = {
txt : 'a;
loc : Location.t;
}


type variance =
| Covariant
| Contravariant
Expand All @@ -79,3 +79,4 @@ type variance =
type injectivity =
| Injective
| NoInjectivity

4 changes: 2 additions & 2 deletions ocaml/parsing/builtin_attributes.mli
Original file line number Diff line number Diff line change
Expand Up @@ -199,5 +199,5 @@ val tailcall : Parsetree.attributes ->
(* CR layouts: we should eventually be able to delete ~legacy_immediate (after we
turn on layouts by default). *)
val layout : legacy_immediate:bool -> Parsetree.attributes ->
(Asttypes.const_layout Location.loc option,
Asttypes.const_layout Location.loc) result
(Asttypes.layout_annotation option,
Asttypes.layout_annotation) result
Loading

0 comments on commit c81636a

Please sign in to comment.