[Meja] 4.08 support

meja/ocaml/dune

@@ -1,5 +1,5 @@
 (library
  (name meja_ocaml)
  (public_name meja.ocaml)
- (libraries core_kernel meja.lib ocaml-compiler-libs.common)
+ (libraries core_kernel meja.lib ocaml-compiler-libs.common meja.of_ocaml)
  (preprocess (pps ppxlib.metaquot)))

meja/ocaml/of_ocaml/dune

@@ -0,0 +1,9 @@
+(library
+ (name of_ocaml)
+ (public_name meja.of_ocaml)
+ (libraries core_kernel meja.lib ocaml-compiler-libs.common)
+ (modules of_ocaml))
+
+(rule
+ (targets of_ocaml.ml)
+ (action (copy# of_ocaml_%{ocaml_version}.ml of_ocaml.ml)))

meja/ocaml/of_ocaml.ml → meja/ocaml/of_ocaml/of_ocaml_4.07.1.ml

@@ -138,3 +138,6 @@ and to_module_sig_desc ~loc decl =
 
 and to_module_sig ~loc decl =
   {msig_loc= loc; msig_desc= to_module_sig_desc ~loc decl}
+
+(** Versioned utility function for to_ocaml. *)
+let open_of_name name = name

meja/ocaml/of_ocaml/of_ocaml_4.08.0.ml

@@ -0,0 +1,147 @@
+open Path
+open Longident
+open Core_kernel
+open Meja_lib.Parsetypes
+open Types
+open Location
+
+let rec longident_of_path = function
+  | Pident ident ->
+      Lident (Ident.name ident)
+  | Pdot (path, ident) ->
+      Ldot (longident_of_path path, ident)
+  | Papply (path1, path2) ->
+      Lapply (longident_of_path path1, longident_of_path path2)
+
+let rec to_type_desc ~loc desc =
+  let to_type_expr = to_type_expr ~loc in
+  match desc with
+  | Tvar x | Tunivar x ->
+      Ptyp_var (Option.map ~f:(fun x -> mkloc x loc) x, Explicit)
+  | Tarrow (label, typ1, typ2, _) ->
+      Ptyp_arrow (to_type_expr typ1, to_type_expr typ2, Explicit, label)
+  | Ttuple typs ->
+      Ptyp_tuple (List.map ~f:to_type_expr typs)
+  | Tconstr (path, params, _) ->
+      let var_ident = mkloc (longident_of_path path) loc in
+      Ptyp_ctor
+        { var_ident
+        ; var_params= List.map ~f:to_type_expr params
+        ; var_implicit_params= [] }
+  | Tlink typ | Tsubst typ ->
+      (to_type_expr typ).type_desc
+  | Tpoly (typ, typs) ->
+      Ptyp_poly (List.map ~f:to_type_expr typs, to_type_expr typ)
+  | Tpackage (path, _bound_names, typs) ->
+      (* We don't have packaged module types implemented here, but we can treat
+         them as if they were [Tctor]s; there is no overlap between valid paths
+         to packages and valid paths to type constructors. *)
+      let var_ident = mkloc (longident_of_path path) loc in
+      Ptyp_ctor
+        { var_ident
+        ; var_params= List.map ~f:to_type_expr typs
+        ; var_implicit_params= [] }
+  | Tobject _ | Tfield _ | Tnil | Tvariant _ ->
+      (* This type isn't supported here. For now, just replace it with a
+         variable, so we can still manipulate values including it. *)
+      Ptyp_var (None, Explicit)
+
+and to_type_expr ~loc typ =
+  {type_desc= to_type_desc ~loc typ.desc; type_loc= loc}
+
+let to_field_decl {ld_id; ld_type; ld_loc; _} =
+  { fld_ident= mkloc (Ident.name ld_id) ld_loc
+  ; fld_type= to_type_expr ~loc:ld_loc ld_type
+  ; fld_loc= ld_loc }
+
+let to_ctor_args ~loc = function
+  | Cstr_tuple typs ->
+      Ctor_tuple (List.map ~f:(to_type_expr ~loc) typs)
+  | Cstr_record labels ->
+      Ctor_record (List.map ~f:to_field_decl labels)
+
+let to_ctor_decl {cd_id; cd_args; cd_res; cd_loc; _} =
+  { ctor_ident= mkloc (Ident.name cd_id) cd_loc
+  ; ctor_args= to_ctor_args ~loc:cd_loc cd_args
+  ; ctor_ret= Option.map cd_res ~f:(to_type_expr ~loc:cd_loc)
+  ; ctor_loc= cd_loc }
+
+let to_type_decl_desc decl =
+  match (decl.type_manifest, decl.type_kind) with
+  | Some typ, _ ->
+      TAlias (to_type_expr ~loc:decl.type_loc typ)
+  | None, Type_abstract ->
+      TAbstract
+  | None, Type_open ->
+      TOpen
+  | None, Type_record (labels, _) ->
+      TRecord (List.map labels ~f:to_field_decl)
+  | None, Type_variant ctors ->
+      TVariant (List.map ctors ~f:to_ctor_decl)
+
+let can_create_signature_item item =
+  match item with Sig_typext _ | Sig_class _ -> false | _ -> true
+
+(** TODO: Handle the new visibility parameter. *)
+let rec to_signature_item item =
+  match item with
+  | Sig_value (ident, {val_type; val_loc; _}, _visibility) ->
+      { sig_desc=
+          Psig_value
+            ( mkloc (Ident.name ident) val_loc
+            , to_type_expr ~loc:val_loc val_type )
+      ; sig_loc= val_loc }
+  | Sig_type (ident, decl, _rec_status, _visibility) ->
+      (* TODO: handle rec_status *)
+      let tdec_desc = to_type_decl_desc decl in
+      { sig_desc=
+          Psig_type
+            { tdec_ident= mkloc (Ident.name ident) decl.type_loc
+            ; tdec_params=
+                List.map ~f:(to_type_expr ~loc:decl.type_loc) decl.type_params
+            ; tdec_implicit_params= []
+            ; tdec_desc
+            ; tdec_loc= decl.type_loc }
+      ; sig_loc= decl.type_loc }
+  | Sig_module (ident, _module_presence, decl, _, _visibility) ->
+      { sig_desc=
+          Psig_module
+            ( mkloc (Ident.name ident) decl.md_loc
+            , to_module_sig ~loc:decl.md_loc (Some decl.md_type) )
+      ; sig_loc= decl.md_loc }
+  | Sig_modtype (ident, decl, _visibility) ->
+      { sig_desc=
+          Psig_modtype
+            ( mkloc (Ident.name ident) decl.mtd_loc
+            , to_module_sig ~loc:decl.mtd_loc decl.mtd_type )
+      ; sig_loc= decl.mtd_loc }
+  | _ ->
+      failwith "Cannot create a signature item from this OCaml signature item."
+
+and to_signature items =
+  List.filter_map items ~f:(fun item ->
+      if can_create_signature_item item then Some (to_signature_item item)
+      else None )
+
+and to_module_sig_desc ~loc decl =
+  match decl with
+  | None ->
+      Pmty_abstract
+  | Some (Mty_ident path | Mty_alias path) ->
+      Pmty_name (mkloc (longident_of_path path) loc)
+  | Some (Mty_signature signature) ->
+      Pmty_sig (to_signature signature)
+  | Some (Mty_functor (name, f, mty)) ->
+      Pmty_functor
+        ( mkloc (Ident.name name) loc
+        , to_module_sig ~loc f
+        , to_module_sig ~loc (Some mty) )
+
+and to_module_sig ~loc decl =
+  {msig_loc= loc; msig_desc= to_module_sig_desc ~loc decl}
+
+(** Versioned utility function for to_ocaml. *)
+let open_of_name name =
+  { Parsetree.pmod_desc= Pmod_ident name
+  ; pmod_loc= name.loc
+  ; pmod_attributes= [] }

meja/ocaml/to_ocaml.ml

@@ -246,7 +246,7 @@ let rec of_statement_desc ?loc = function
   | Pstmt_modtype (name, msig) ->
       Str.modtype ?loc (Mtd.mk ?loc ?typ:(of_module_sig msig) name)
   | Pstmt_open name ->
-      Str.open_ ?loc (Opn.mk ?loc name)
+      Str.open_ ?loc (Opn.mk ?loc (Of_ocaml.open_of_name name))
   | Pstmt_typeext (variant, ctors) ->
       let params =
         List.map variant.var_params ~f:(fun typ -> (of_type_expr typ, Invariant)

meja/src/compiler_internals/compiler_internals_4.07.1.ml

@@ -0,0 +1,5 @@
+module Location = struct
+  include Location
+
+  let error_of_printer ?(loc = none) fmt = error_of_printer loc fmt
+end

meja/src/compiler_internals/compiler_internals_4.08.0.ml

@@ -0,0 +1,3 @@
+module Location = struct
+  include Location
+end

meja/src/compiler_internals/dune

@@ -0,0 +1,9 @@
+(library
+ (name compiler_internals)
+ (public_name meja.ocaml_compiler_internals)
+ (libraries core_kernel ocaml-compiler-libs.common)
+ (modules compiler_internals))
+
+(rule
+ (targets compiler_internals.ml)
+ (action (copy# compiler_internals_%{ocaml_version}.ml compiler_internals.ml)))

meja/src/dune

@@ -1,7 +1,7 @@
 (library
  (name meja_lib)
  (public_name meja.lib)
- (libraries core_kernel ocaml-compiler-libs.common)
+ (libraries core_kernel meja.ocaml_compiler_internals)
  (preprocess (pps ppx_jane)))
 
 (menhir

meja/src/envi.ml

@@ -1,3 +1,4 @@
+open Compiler_internals
 open Core_kernel
 open Ast_types
 open Type0
@@ -1308,6 +1309,6 @@ let report_error ppf = function
 let () =
   Location.register_error_of_exn (function
     | Error (loc, err) ->
-        Some (Location.error_of_printer loc report_error err)
+        Some (Location.error_of_printer ~loc report_error err)
     | _ ->
         None )

meja/src/parser_errors.ml

@@ -1,3 +1,5 @@
+open Compiler_internals
+
 type error =
   | Fun_no_fat_arrow
   | Missing_semi
@@ -21,6 +23,6 @@ let report_error ppf = function
 let () =
   Location.register_error_of_exn (function
     | Error (loc, err) ->
-        Some (Location.error_of_printer loc report_error err)
+        Some (Location.error_of_printer ~loc report_error err)
     | _ ->
         None )

meja/src/typechecker.ml

@@ -1,3 +1,4 @@
+open Compiler_internals
 open Core_kernel
 open Ast_types
 open Parsetypes
@@ -1451,6 +1452,6 @@ let rec report_error ppf = function
 let () =
   Location.register_error_of_exn (function
     | Error (loc, err) ->
-        Some (Location.error_of_printer loc report_error err)
+        Some (Location.error_of_printer ~loc report_error err)
     | _ ->
         None )

meja/src/typet.ml

@@ -1,3 +1,4 @@
+open Compiler_internals
 open Core_kernel
 open Ast_types
 open Parsetypes
@@ -472,6 +473,6 @@ let report_error ppf = function
 let () =
   Location.register_error_of_exn (function
     | Error (loc, err) ->
-        Some (Location.error_of_printer loc report_error err)
+        Some (Location.error_of_printer ~loc report_error err)
     | _ ->
         None )