Skip to content

Commit

Permalink
Adjust to OCaml 5.1.1
Browse files Browse the repository at this point in the history
  • Loading branch information
@AltGr
AltGr committed Jul 26, 2024
1 parent 993e286 commit b6c9cc0
Show file tree
Hide file tree
Showing 8 changed files with 103 additions and 87 deletions.
2 changes: 1 addition & 1 deletion learn-ocaml-client.opam
View file
Original file line number Diff line number Diff line change
Expand Up @@ -31,7 +31,7 @@ depends: [
"ipaddr" {>= "2.9.0" }
"lwt" {>= "4.0.0"}
"lwt_ssl"
"ocaml" {(>= "4.14") & (< "5.1~")}
"ocaml" {(>= "5.1") & (< "5.2~")}
"ocamlfind" {build}
"ocp-indent-nlfork"
"json-data-encoding" {>= "0.7"}
Expand Down
11 changes: 6 additions & 5 deletions learn-ocaml-client.opam.locked
View file
Original file line number Diff line number Diff line change
Expand Up @@ -79,20 +79,21 @@ depends: [
"lwt_ssl" {= "1.1.3"}
"macaddr" {= "5.6.0"}
"magic-mime" {= "1.2.0"}
"menhir" {= "20220210"}
"menhirLib" {= "20220210"}
"menhirSdk" {= "20220210"}
"menhir" {= "20240715"}
"menhirCST" {= "20240715"}
"menhirLib" {= "20240715"}
"menhirSdk" {= "20240715"}
"mirage-crypto" {= "0.11.3"}
"mirage-crypto-ec" {= "0.11.3"}
"mirage-crypto-pk" {= "0.11.3"}
"mirage-crypto-rng" {= "0.11.3"}
"num" {= "1.4"}
"ocaml" {= "5.0.0"}
"ocaml" {= "5.1.1"}
"ocaml-compiler-libs" {= "v0.12.4"}
"ocaml-config" {= "3"}
"ocaml-options-vanilla" {= "1"}
"ocaml-syntax-shims" {= "1.0.0"}
"ocamlbuild" {= "0.14.1"}
"ocamlbuild" {= "0.15.0"}
"ocamlfind" {= "1.9.6"}
"ocp-indent-nlfork" {= "1.5.5"}
"ocp-ocamlres" {= "0.4"}
Expand Down
2 changes: 1 addition & 1 deletion learn-ocaml.opam
View file
Original file line number Diff line number Diff line change
Expand Up @@ -46,7 +46,7 @@ depends: [
"magic-mime"
"markup"
"markup-lwt"
"ocaml" {(>= "4.14") & (< "5.1~")}
"ocaml" {(>= "5.1") & (< "5.2~")}
"ocamlfind" {build}
"ocp-indent-nlfork" {>= "1.5.5"}
"json-data-encoding" {>= "0.7"}
Expand Down
11 changes: 6 additions & 5 deletions learn-ocaml.opam.locked
View file
Original file line number Diff line number Diff line change
Expand Up @@ -89,20 +89,21 @@ depends: [
"magic-mime" {= "1.2.0"}
"markup" {= "1.0.3"}
"markup-lwt" {= "0.5.0"}
"menhir" {= "20220210"}
"menhirLib" {= "20220210"}
"menhirSdk" {= "20220210"}
"menhir" {= "20240715"}
"menhirCST" {= "20240715"}
"menhirLib" {= "20240715"}
"menhirSdk" {= "20240715"}
"mirage-crypto" {= "0.11.3"}
"mirage-crypto-ec" {= "0.11.3"}
"mirage-crypto-pk" {= "0.11.3"}
"mirage-crypto-rng" {= "0.11.3"}
"num" {= "1.4"}
"ocaml" {= "5.0.0"}
"ocaml" {= "5.1.1"}
"ocaml-compiler-libs" {= "v0.12.4"}
"ocaml-config" {= "3"}
"ocaml-options-vanilla" {= "1"}
"ocaml-syntax-shims" {= "1.0.0"}
"ocamlbuild" {= "0.14.1"}
"ocamlbuild" {= "0.15.0"}
"ocamlfind" {= "1.9.6"}
"ocp-indent-nlfork" {= "1.5.5"}
"ocp-ocamlres" {= "0.4"}
Expand Down
77 changes: 39 additions & 38 deletions src/grader/introspection.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -246,45 +246,46 @@ let register_sampler modname id tyname f =
sampler must be found in the cmi file (no mli file allowed)@."
modname tyname
| sampler_desc, (sampled_ty_path, sampled_ty_decl) ->
Ctype.begin_def();
let ty_args =
List.map (fun _ -> Ctype.newvar ()) sampled_ty_decl.type_params
let () =
Ctype.with_local_level @@ fun () ->
let ty_args =
List.map (fun _ -> Ctype.newvar ()) sampled_ty_decl.type_params
in
let ty_target =
Ctype.newty (Tconstr (sampled_ty_path, ty_args, ref Mnil))
in
let fn_args =
List.map (fun ty -> Ctype.newconstr gen_sampler_type [ty]) ty_args
in
let sampler_ty_expected =
List.fold_right (fun fn_arg ty ->
Ctype.newty (Tarrow (Asttypes.Nolabel, fn_arg, ty, commu_var ())))
fn_args (Ctype.newconstr gen_sampler_type [ty_target])
in
(try
Ctype.unify env
sampler_ty_expected
(Ctype.instance sampler_desc.val_type)
with Ctype.Unify _ ->
Format.kasprintf failwith
"Mismatching type for sampling function %s.sample_%s.@;\
The type must be@ @[<hov>%aunit -> %a%s@]@."
modname tyname
(Format.pp_print_list
(fun ppf -> Format.fprintf ppf "(unit -> %a) ->@ " (Printtyp.type_expr)))
ty_args
(fun ppf -> function
| [] -> ()
| [arg] -> Format.fprintf ppf "%a " Printtyp.type_expr arg
| args ->
Format.fprintf ppf "(%a) "
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.pp_print_string ppf ", ")
Printtyp.type_expr)
args)
ty_args
tyname);
in
let ty_target =
Ctype.newty (Tconstr (sampled_ty_path, ty_args, ref Mnil))
in
let fn_args =
List.map (fun ty -> Ctype.newconstr gen_sampler_type [ty]) ty_args
in
let sampler_ty_expected =
List.fold_right (fun fn_arg ty ->
Ctype.newty (Tarrow (Asttypes.Nolabel, fn_arg, ty, commu_var ())))
fn_args (Ctype.newconstr gen_sampler_type [ty_target])
in
(try
Ctype.unify env
sampler_ty_expected
(Ctype.instance sampler_desc.val_type)
with Ctype.Unify _ ->
Format.kasprintf failwith
"Mismatching type for sampling function %s.sample_%s.@;\
The type must be@ @[<hov>%aunit -> %a%s@]@."
modname tyname
(Format.pp_print_list
(fun ppf -> Format.fprintf ppf "(unit -> %a) ->@ " (Printtyp.type_expr)))
ty_args
(fun ppf -> function
| [] -> ()
| [arg] -> Format.fprintf ppf "%a " Printtyp.type_expr arg
| args ->
Format.fprintf ppf "(%a) "
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.pp_print_string ppf ", ")
Printtyp.type_expr)
args)
ty_args
tyname);
Ctype.end_def ();
let def_name = "sample_" ^ tyname in
Toploop.toplevel_env :=
Env.add_value (Ident.create_local def_name) sampler_desc
Expand Down
5 changes: 4 additions & 1 deletion src/toploop/dune
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,7 +19,10 @@
(wrapped false)
(modes byte)
(flags :standard -warn-error A-4-42-44-45-48-9-58)
(libraries js_of_ocaml-compiler toploop)
(foreign_stubs
(language c)
(names stubs))
(libraries js_of_ocaml-compiler js_of_ocaml-compiler.runtime compiler-libs.bytecomp toploop)
(modules Toploop_jsoo)
(preprocess (pps js_of_ocaml-ppx))
)
Expand Down
6 changes: 6 additions & 0 deletions src/toploop/stubs.c
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,6 @@
#include <stdlib.h>
#include <stdio.h>
void jsoo_get_bytecode_sections () {
fprintf(stderr, "Unimplemented Javascript primitive jsoo_get_bytecode_sections!\n");
exit(1);
}
76 changes: 40 additions & 36 deletions src/toploop/toploop_ext.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -336,43 +336,45 @@ let install_printer modname id tyname pr =
must be found in the cmi file (no mli file allowed).@."
modname tyname
| printer_desc, (ty_path, ty_decl) ->
Ctype.begin_def();
let ty_args = List.map (fun _ -> Ctype.newvar ()) ty_decl.type_params in
let ty_target =
Ctype.expand_head env
(Ctype.newty (Tconstr (ty_path, ty_args, ref Mnil)))
Ctype.with_local_level @@ fun () ->
let ty_args = List.map (fun _ -> Ctype.newvar ()) ty_decl.type_params in
let ty_target =
Ctype.expand_head env
(Ctype.newty (Tconstr (ty_path, ty_args, ref Mnil)))
in
let printer_ty_expected =
List.fold_right (fun argty ty -> gen_printer_type argty @-> ty)
ty_args
(gen_printer_type ty_target)
in
(try
Ctype.unify env
printer_ty_expected
(Ctype.instance printer_desc.val_type)
with Ctype.Unify _ ->
Format.printf
"Warning: mismatching type for print function %s.print_%s.@;\
The type must be@ @[<hov>%aformatter -> %a%s -> unit@]@."
modname tyname
(Format.pp_print_list
(fun ppf -> Format.fprintf ppf "(formatter -> %a -> unit) ->@ "
(Printtyp.type_expr)))
ty_args
(fun ppf -> function
| [] -> ()
| [arg] -> Format.fprintf ppf "%a " Printtyp.type_expr arg
| args ->
Format.fprintf ppf "(%a) "
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.pp_print_string ppf ", ")
Printtyp.type_expr)
args)
ty_args
tyname);
Ctype.generalize printer_ty_expected;
ty_target
in
let printer_ty_expected =
List.fold_right (fun argty ty -> gen_printer_type argty @-> ty)
ty_args
(gen_printer_type ty_target)
in
(try
Ctype.unify env
printer_ty_expected
(Ctype.instance printer_desc.val_type)
with Ctype.Unify _ ->
Format.printf
"Warning: mismatching type for print function %s.print_%s.@;\
The type must be@ @[<hov>%aformatter -> %a%s -> unit@]@."
modname tyname
(Format.pp_print_list
(fun ppf -> Format.fprintf ppf "(formatter -> %a -> unit) ->@ "
(Printtyp.type_expr)))
ty_args
(fun ppf -> function
| [] -> ()
| [arg] -> Format.fprintf ppf "%a " Printtyp.type_expr arg
| args ->
Format.fprintf ppf "(%a) "
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.pp_print_string ppf ", ")
Printtyp.type_expr)
args)
ty_args
tyname);
Ctype.end_def ();
Ctype.generalize printer_ty_expected;
let register_as_path = inmodpath ("print_"^tyname) in
let rec build_generic v = function
| [] ->
Expand Down Expand Up @@ -415,8 +417,10 @@ let install_printer modname id tyname pr =
the module is fully loaded would risk crashes (e.g. on extensible
variants) *)
let rec path_to_longident = function
| Path.Pdot (p, s) -> Longident.Ldot (path_to_longident p, s)
| Path.Pdot (p, s) | Path.Pextra_ty (p, Path.Pcstr_ty s) ->
Longident.Ldot (path_to_longident p, s)
| Path.Pident i -> Longident.Lident (Ident.name i)
| Path.Pextra_ty (p, Path.Pext_ty) -> path_to_longident p
| Path.Papply _ -> assert false
in
pending_installed_printers :=
Expand Down

0 comments on commit b6c9cc0

Please sign in to comment.