├── .gitignore ├── .ocamlformat ├── CONTRIBUTING.md ├── LICENSE.md ├── Makefile ├── README.md ├── dune-project ├── examples ├── __init__.py ├── dune ├── init │ ├── dune │ ├── python_init.c │ ├── python_init.ml │ └── python_init.mli ├── ocaml.ml ├── setup.py ├── test.py ├── toploop_bindings.ml └── toploop_bindings.mli ├── pythonlib.opam └── src ├── broadcast.ml ├── broadcast.mli ├── class_wrapper.ml ├── class_wrapper.mli ├── defunc.ml ├── defunc.mli ├── dune ├── import.ml ├── module_env.ml ├── module_env.mli ├── py_module.ml ├── py_module.mli ├── py_traceback.ml ├── py_traceback.mli ├── py_typerep.ml ├── py_typerep.mli ├── python_lib.ml ├── type.ml ├── type.mli ├── type_lexer.mll └── type_parser.mly /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | _opam 5 | 6 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This repository contains open source software that is developed and 2 | maintained by [Jane Street][js]. 3 | 4 | Contributions to this project are welcome and should be submitted via 5 | GitHub pull requests. 6 | 7 | Signing contributions 8 | --------------------- 9 | 10 | We require that you sign your contributions. Your signature certifies 11 | that you wrote the patch or otherwise have the right to pass it on as 12 | an open-source patch. The rules are pretty simple: if you can certify 13 | the below (from [developercertificate.org][dco]): 14 | 15 | ``` 16 | Developer Certificate of Origin 17 | Version 1.1 18 | 19 | Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 20 | 1 Letterman Drive 21 | Suite D4700 22 | San Francisco, CA, 94129 23 | 24 | Everyone is permitted to copy and distribute verbatim copies of this 25 | license document, but changing it is not allowed. 26 | 27 | 28 | Developer's Certificate of Origin 1.1 29 | 30 | By making a contribution to this project, I certify that: 31 | 32 | (a) The contribution was created in whole or in part by me and I 33 | have the right to submit it under the open source license 34 | indicated in the file; or 35 | 36 | (b) The contribution is based upon previous work that, to the best 37 | of my knowledge, is covered under an appropriate open source 38 | license and I have the right under that license to submit that 39 | work with modifications, whether created in whole or in part 40 | by me, under the same open source license (unless I am 41 | permitted to submit under a different license), as indicated 42 | in the file; or 43 | 44 | (c) The contribution was provided directly to me by some other 45 | person who certified (a), (b) or (c) and I have not modified 46 | it. 47 | 48 | (d) I understand and agree that this project and the contribution 49 | are public and that a record of the contribution (including all 50 | personal information I submit with it, including my sign-off) is 51 | maintained indefinitely and may be redistributed consistent with 52 | this project or the open source license(s) involved. 53 | ``` 54 | 55 | Then you just add a line to every git commit message: 56 | 57 | ``` 58 | Signed-off-by: Joe Smith 59 | ``` 60 | 61 | Use your real name (sorry, no pseudonyms or anonymous contributions.) 62 | 63 | If you set your `user.name` and `user.email` git configs, you can sign 64 | your commit automatically with git commit -s. 65 | 66 | [dco]: http://developercertificate.org/ 67 | [js]: https://opensource.janestreet.com/ 68 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2019--2024 Jane Street Group, LLC 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | default: 4 | dune build 5 | 6 | install: 7 | dune install $(INSTALL_ARGS) 8 | 9 | uninstall: 10 | dune uninstall $(INSTALL_ARGS) 11 | 12 | reinstall: uninstall install 13 | 14 | clean: 15 | dune clean 16 | 17 | .PHONY: default install uninstall reinstall clean 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | `pythonlib` makes it easier to write wrappers around ocaml functions 2 | so that they can be called from python. 3 | 4 | Example 5 | ------- 6 | 7 | This example is taken from the `examples` directory. The ocaml code 8 | defines a function that takes as argument an integer n, performs some 9 | computations based on n and return a float value. 10 | This function is attached to a newly defined python module named `ocaml_module`. 11 | 12 | ```ocaml 13 | open Base 14 | 15 | let approx_pi = 16 | let%map_open.Python_lib n = positional "n" int ~docstring:"" 17 | in 18 | let sum = 19 | List.init n ~f:(fun i -> let i = Float.of_int (1 + i) in 1.0 /. (i *. i)) 20 | |> List.reduce_exn ~f:(+.) 21 | in 22 | Float.sqrt (sum *. 6.) |> python_of_float 23 | 24 | let () = 25 | if not (Py.is_initialized ()) 26 | then Py.initialize (); 27 | let mod_ = Py_module.create "example_module" in 28 | Py_module.set mod_ "approx_pi" approx_pi 29 | ``` 30 | 31 | This code is compiled to a static library `ocaml.so`, together with a small 32 | C library defining the `PyInit_ocaml` function that starts the ocaml runtime 33 | and exposes the example module. 34 | The python code then imports this library and can use the ocaml functions. 35 | 36 | ```python 37 | # This requires the ocaml.bc.so file to be copied as ocaml.so in the python path 38 | from ocaml import example_module, toploop 39 | 40 | # Import the module defined in the ocaml code and run the function. 41 | import ocaml_module 42 | print(ocaml_module.approx_pi(1000)) 43 | ``` 44 | 45 | `pythonlib` also handles keyword arguments as well as basic types such as 46 | int, float, string, list, etc. 47 | Further examples can be found in the `examples` directory. 48 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | 3 | (formatting disabled) 4 | -------------------------------------------------------------------------------- /examples/__init__.py: -------------------------------------------------------------------------------- 1 | # This is defining some custom jupyter magics which allow for 2 | # the nice %ocaml and %%ocaml syntax that we get in the notebook. 3 | # See: https://ipython.readthedocs.io/en/stable/config/custommagics.html 4 | import os 5 | from .sharedlib import ocaml 6 | from .sharedlib.ocaml import toploop 7 | 8 | _topdir = os.path.dirname(os.path.abspath(ocaml.__file__)) 9 | toploop.add_topdir(_topdir) 10 | 11 | 12 | def _register_ipython_magic(): 13 | try: 14 | from wurlitzer import sys_pipes 15 | from IPython.core.magic import register_line_magic, register_cell_magic 16 | 17 | # [@register_line_magic] registers itself as a side effect thus 18 | # the immediate deletion following the definition 19 | 20 | @register_line_magic 21 | def ocaml(line): 22 | with sys_pipes(): 23 | return toploop.get(line) 24 | 25 | del ocaml 26 | 27 | @register_line_magic 28 | def ocaml_t(line): 29 | type_, body = line.split(":", maxsplit=1) 30 | with sys_pipes(): 31 | return toploop.get(type_, body) 32 | 33 | del ocaml_t 34 | 35 | @register_cell_magic 36 | def ocaml(line, cell): 37 | with sys_pipes(): 38 | return toploop.eval(cell) 39 | 40 | del ocaml 41 | except: 42 | pass 43 | 44 | 45 | _register_ipython_magic() 46 | -------------------------------------------------------------------------------- /examples/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names ocaml) 3 | (preprocess 4 | (pps ppx_let ppx_python)) 5 | (modes 6 | (byte shared_object)) 7 | (flags :standard -linkall) 8 | (libraries base compiler-libs.toplevel pyml python_lib python_ocaml_init)) 9 | -------------------------------------------------------------------------------- /examples/init/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (foreign_stubs 3 | (language c) 4 | (names python_init) 5 | (flags -w -g -fPIC -Wall -O2 -I /usr/include/python3.6m)) 6 | (name python_ocaml_init) 7 | (libraries) 8 | (flags :standard -linkall) 9 | (preprocess 10 | (pps ppx_jane ppx_python))) 11 | -------------------------------------------------------------------------------- /examples/init/python_init.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | static struct PyModuleDef ocamlmodule = { 5 | PyModuleDef_HEAD_INIT, "ocaml", /* name of module */ 6 | }; 7 | 8 | /* Forward declaration of a function in the python-ocaml.so. See 9 | * [lib/python-ocaml/pyml/src/pyml_stubs.c] 10 | * 11 | * We type out the forward declaration again because PyML doesn't have a public 12 | * C API and doesn't make available any header files we could include. */ 13 | void pyml_return_to_python(); 14 | PyObject *PyInit_ocaml() { 15 | static char *argv[2] = {"python", NULL}; 16 | caml_startup(argv); 17 | pyml_return_to_python(); 18 | PyObject *m = PyModule_Create(&ocamlmodule); 19 | PyObject *toploop = PyImport_ImportModule("toploop"); 20 | int status = PyModule_AddObject(m, "toploop", toploop); 21 | if (status != 0) 22 | return NULL; 23 | PyObject *example_module = PyImport_ImportModule("example_module"); 24 | status = PyModule_AddObject(m, "example_module", example_module); 25 | if (status != 0) 26 | return NULL; 27 | return m; 28 | } 29 | -------------------------------------------------------------------------------- /examples/init/python_init.ml: -------------------------------------------------------------------------------- 1 | (* Hacky way to trigger a dependency to the PyInit_ocaml function. *) 2 | external pyinit : unit -> unit = "PyInit_ocaml" 3 | 4 | let () = ignore (pyinit : unit -> unit) 5 | -------------------------------------------------------------------------------- /examples/init/python_init.mli: -------------------------------------------------------------------------------- 1 | (* Intentionally left blank. *) 2 | -------------------------------------------------------------------------------- /examples/ocaml.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Python_lib 3 | open Python_lib.Let_syntax 4 | 5 | type t = 6 | { foo : string 7 | ; bar : (int * float) list 8 | } 9 | [@@deriving python] 10 | 11 | let add = 12 | let%map_open arg1 = positional "lhs" int ~docstring:"" 13 | and arg2 = positional "rhs" int ~docstring:"" in 14 | fun () -> python_of_int (arg1 + arg2) 15 | ;; 16 | 17 | let make_t = 18 | let%map_open foo = positional "foo" string ~docstring:"" 19 | and repeats = keyword "repeats" int ~docstring:"" 20 | and bar1 = keyword "bar1" int ~default:42 ~docstring:"" 21 | and bar2 = keyword "bar2" float ~default:3.14 ~docstring:"" in 22 | fun () -> python_of_t { foo; bar = List.init repeats ~f:(fun i -> bar1 + i, bar2) } 23 | ;; 24 | 25 | let cartesian_product = 26 | let%map_open l1 = positional "l1" (list pyobject) ~docstring:"" 27 | and l2 = positional "l2" (list pyobject) ~docstring:"" in 28 | fun () -> List.cartesian_product l1 l2 |> python_of_list Py.Tuple.of_pair 29 | ;; 30 | 31 | let approx_pi = 32 | let%map_open n = positional "n" int ~docstring:"" in 33 | fun () -> 34 | let sum = 35 | List.init n ~f:(fun i -> 36 | let i = Float.of_int (1 + i) in 37 | 1.0 /. (i *. i)) 38 | |> List.reduce_exn ~f:( +. ) 39 | in 40 | Float.sqrt (sum *. 6.) |> python_of_float 41 | ;; 42 | 43 | let map = 44 | let%map_open list = positional "list" (list int) ~docstring:"" 45 | and fn = keyword "fn" (typerep (Function (Int, Int))) ~docstring:"" in 46 | fun () -> List.map list ~f:fn |> [%python_of: int list] 47 | ;; 48 | 49 | let () = 50 | if not (Py.is_initialized ()) then Py.initialize (); 51 | let mod_ = Py_module.create "example_module" in 52 | Py_module.set mod_ "add" add; 53 | Py_module.set mod_ "make_t" make_t; 54 | Py_module.set mod_ "cartesian_product" cartesian_product; 55 | Py_module.set mod_ "approx_pi" approx_pi; 56 | Py_module.set mod_ "map" map; 57 | Toploop_bindings.register_module ~module_name:"toploop" 58 | ;; 59 | -------------------------------------------------------------------------------- /examples/setup.py: -------------------------------------------------------------------------------- 1 | from setuptools import setup 2 | 3 | setup( 4 | name="ocaml", 5 | version="0.0.5", 6 | author="", 7 | author_email="", 8 | packages=["ocaml"], 9 | package_dir={"ocaml": "."}, 10 | package_data={"ocaml": ["sharedlib/ocaml.so", "sharedlib/stdlib.cmi"]}, 11 | install_requires=["wurlitzer"], 12 | ) 13 | -------------------------------------------------------------------------------- /examples/test.py: -------------------------------------------------------------------------------- 1 | 2 | # This tries to copy the generated shared library to ocaml.so in the 3 | # current directory so that the import could work. 4 | import os 5 | import shutil 6 | import sys 7 | 8 | for src in ["ocaml.bc.so", "_build/default/examples/ocaml.bc.so"]: 9 | if os.path.exists(src): 10 | shutil.copyfile(src, "ocaml.so") 11 | sys.path.append(".") 12 | from ocaml import example_module, toploop 13 | 14 | print(example_module.add(42, 42)) 15 | 16 | print(example_module.make_t("my-t", repeats=3)) 17 | print(example_module.make_t("my-t", repeats=3, bar2=2.71828)) 18 | 19 | print(example_module.cartesian_product([1, 2], [(3, 4), "5"])) 20 | 21 | print(example_module.approx_pi(1000)) 22 | 23 | print(example_module.map(list(range(5)), fn=lambda x: x * x)) 24 | 25 | toploop.eval('Printf.printf "hello from ocaml\n%!";;') 26 | ocaml_fn = toploop.get( 27 | "(int * string) list -> string list", 28 | 'List.map (fun (d, s) -> Printf.sprintf "%d: %s" (d+1) (String.uppercase_ascii s))', 29 | ) 30 | 31 | line1, line2 = ocaml_fn([(3141592, "first-line"), (2718281, "second-line")]) 32 | print(line1) 33 | print(line2) 34 | 35 | # Note that the ocaml toploop has a persisted state. 36 | toploop.eval("let x = 42;;") 37 | x = toploop.get("float", "float_of_int x") 38 | print(x) 39 | 40 | fn = toploop.get("((int -> int) * int) -> int", "fun (f, v) -> f (2 * v) + 1") 41 | print(fn((lambda x: x * x, 5))) 42 | 43 | counter = toploop.get("fun () -> let v = ref 0 in fun () -> v := !v + 1; !v") 44 | cnt1 = counter() 45 | cnt2 = counter() 46 | print([cnt1() for v in range(5)], cnt2()) 47 | 48 | # Type inference can be used to avoid specifying the type. 49 | fn = toploop.get("fun x (y, z) -> Int.to_string x ^ y ^ Int.to_string z") 50 | print(fn(4)) 51 | print(fn(4)("abc", 5)) 52 | 53 | # Polymorphic functions can be used. 54 | pair = toploop.get("fun x -> x, x") 55 | x0, x1 = pair("test") 56 | print(x0, x1) 57 | 58 | map_fn = toploop.get("fun (x, f) -> List.map f x") 59 | print(map_fn([1, 2, 3], lambda x: x * x)) 60 | print(map_fn.__doc__) 61 | -------------------------------------------------------------------------------- /examples/toploop_bindings.ml: -------------------------------------------------------------------------------- 1 | (* This module provides bindings to the ocaml toplevel. 2 | This allows one to run ocaml blocks from python and exchange values between the 3 | ocaml and python runtimes. 4 | 5 | The toplevel module returns [Obj.t] object so we rely heavily on [Obj.repr] 6 | to get some typed values out of it. This should be type-safe as we also 7 | ask the toplevel loop to check the types. 8 | *) 9 | module F = Format 10 | open Base 11 | open Python_lib 12 | open Python_lib.Let_syntax 13 | module Typerep = Typerep_lib.Std.Typerep 14 | 15 | let is_initialized = ref false 16 | 17 | let maybe_initialize () = 18 | if not !is_initialized 19 | then ( 20 | is_initialized := true; 21 | Clflags.debug := true; 22 | Clflags.verbose := false; 23 | Warnings.parse_options false "-58"; 24 | Location.formatter_for_warnings := F.err_formatter; 25 | Toploop.set_paths (); 26 | !Toploop.toplevel_startup_hook (); 27 | (* required for side-effect initialization in Topdirs *) 28 | Toploop.initialize_toplevel_env (); 29 | let lexing = Lexing.from_string "type pyobject;;" in 30 | let phrases = !Toploop.parse_use_file lexing in 31 | List.iter phrases ~f:(fun phrase -> 32 | let ok = Toploop.execute_phrase false F.std_formatter phrase in 33 | ignore (ok : bool)); 34 | Py_typerep.Named_types.register_exn 35 | ~name:"pyobject" 36 | ~ocaml_type:"pyobject" 37 | ~python_to_ocaml:Fn.id 38 | ~ocaml_to_python:Fn.id) 39 | ;; 40 | 41 | let exn_to_string exn ~code = 42 | let print_loc _ _report ppf (location : Location.t) = 43 | F.fprintf 44 | ppf 45 | "ocaml evaluation error on lines %d:%d to %d:%d\n" 46 | location.loc_start.pos_lnum 47 | location.loc_start.pos_cnum 48 | location.loc_end.pos_lnum 49 | location.loc_end.pos_cnum 50 | in 51 | let default_printer = Location.default_report_printer () in 52 | let report report_printer report ppf x = 53 | let location = report.Location.main.loc in 54 | F.pp_print_newline ppf (); 55 | let min_line_number = location.loc_start.pos_lnum - 5 in 56 | let max_line_number = location.loc_end.pos_lnum + 5 in 57 | String.rstrip code ~drop:(function 58 | | ' ' | '\r' | '\n' | '\t' -> true 59 | | _ -> false) 60 | |> String.split ~on:'\n' 61 | |> List.filter_mapi ~f:(fun lnum line -> 62 | let lnum = 1 + lnum in 63 | if min_line_number <= lnum && lnum <= max_line_number 64 | then ( 65 | let marker = 66 | if location.loc_start.pos_lnum <= lnum && lnum <= location.loc_end.pos_lnum 67 | then ">" 68 | else " " 69 | in 70 | Some (Printf.sprintf "%s%3d: %s" marker lnum line)) 71 | else None) 72 | |> String.concat ~sep:"\n" 73 | |> F.pp_print_string ppf; 74 | F.pp_print_newline ppf (); 75 | default_printer.Location.pp_main_txt report_printer report ppf x 76 | in 77 | let buffer = Buffer.create 256 in 78 | let formatter = F.formatter_of_buffer buffer in 79 | let report_printer () : Location.report_printer = 80 | { default_printer with 81 | Location.pp_main_loc = print_loc 82 | ; pp_submsg_loc = print_loc 83 | ; pp_main_txt = report 84 | } 85 | in 86 | Location.report_printer := report_printer; 87 | Location.report_exception formatter exn; 88 | Buffer.contents buffer 89 | ;; 90 | 91 | let toploop_eval str ~verbose = 92 | try 93 | maybe_initialize (); 94 | let lexing = Lexing.from_string str in 95 | let phrases = !Toploop.parse_use_file lexing in 96 | List.iter phrases ~f:(fun phrase -> 97 | let ok = Toploop.execute_phrase verbose F.std_formatter phrase in 98 | ignore (ok : bool)); 99 | F.pp_print_flush F.std_formatter () 100 | with 101 | | Py.Err _ as err -> raise err 102 | | exn -> raise (Py.Err (SyntaxError, exn_to_string exn ~code:str)) 103 | ;; 104 | 105 | let dummy_loc = 106 | { Warnings.loc_start = Lexing.dummy_pos; loc_end = Lexing.dummy_pos; loc_ghost = false } 107 | ;; 108 | 109 | let toploop_eval_and_get typerep str = 110 | let eval_value (type a) (typerep : a Typerep.t) = 111 | toploop_eval 112 | ~verbose:false 113 | (Printf.sprintf "let out : %s = (%s);;" (Py_typerep.to_ocaml typerep) str); 114 | let path, _, _ = 115 | Env.lookup_value ~loc:dummy_loc (Lident "out") !Toploop.toplevel_env 116 | in 117 | let obj = Toploop.eval_value_path !Toploop.toplevel_env path in 118 | Py_typerep.ocaml_to_python typerep (Stdlib.Obj.obj obj) 119 | in 120 | let (T typerep) = Py_typerep.parse typerep in 121 | eval_value typerep 122 | ;; 123 | 124 | let toploop_eval_and_get_no_type str = 125 | toploop_eval ~verbose:false (Printf.sprintf "let out = (%s);;" str); 126 | let path, value_description, _mode = 127 | Env.lookup_value ~loc:dummy_loc (Lident "out") !Toploop.toplevel_env 128 | in 129 | let obj = Toploop.eval_value_path !Toploop.toplevel_env path in 130 | let (T typerep) = 131 | Type.of_type_desc value_description.val_type.desc ~env:(Module_env.create ()) 132 | |> Or_error.ok_exn 133 | |> Py_typerep.of_type 134 | in 135 | Py_typerep.ocaml_to_python typerep (Stdlib.Obj.obj obj) 136 | ;; 137 | 138 | let register_module ~module_name = 139 | let modl = Py_module.create module_name in 140 | Py_module.set_unit 141 | modl 142 | "eval" 143 | (let%map_open str = positional "str" string ~docstring:"ocaml code to run" 144 | and verbose = keyword "verbose" bool ~default:false ~docstring:"verbose" in 145 | fun () -> toploop_eval str ~verbose) 146 | ~docstring: 147 | {| 148 | Evaluates an ocaml expression. 149 | 150 | This takes a argument a string containing some ocaml code. This string is parsed, 151 | typechecked and evaluated in a toplevel. 152 | The global variable scope is shared between multiple calls to this function. 153 | |}; 154 | Py_module.set_function 155 | modl 156 | "get" 157 | (function 158 | | [| str |] -> Py.String.to_string str |> toploop_eval_and_get_no_type 159 | | [| typerep; str |] -> 160 | toploop_eval_and_get (Py.String.to_string typerep) (Py.String.to_string str) 161 | | _ -> raise (Py.Err (SyntaxError, "expected one or two arguments"))) 162 | ~docstring: 163 | {| 164 | Evaluates an ocaml expression and returns the result as a python object. 165 | 166 | This takes one or two arguments. When two arguments are given, the first 167 | one is a type representation of the object to be transfered from ocaml to 168 | python. The second one is a string containing some ocaml code. This string 169 | is parsed, typechecked (its type has to match the type argument) and 170 | evaluated in a toplevel in the same way it is when running eval. 171 | 172 | Supported types can involve bool, int, string, float, list, option, 173 | only a single arrow is allowed in which case a function is returned. 174 | Examples of types would be: 175 | - int 176 | - unit -> string 177 | - (string * int option) list -> string * string 178 | 179 | Returns: 180 | A python object which type depends on the type argumnent. 181 | |}; 182 | Py_module.set_unit 183 | modl 184 | "add_topdir" 185 | (let%map_open dir = positional "dir" string ~docstring:"directory to add" in 186 | fun () -> 187 | if !is_initialized then failwith "can only add directories before initialization."; 188 | Topdirs.dir_directory dir) 189 | ~docstring: 190 | {| 191 | Adds a new top-level directory in the cmi search path. 192 | 193 | This can only be executed before the first call to eval or dir. Otherwise an exception 194 | is raised. 195 | |}; 196 | Py_module.set_unit 197 | modl 198 | "add_named_type" 199 | (let%map_open name = positional "name" string ~docstring:"type name" 200 | and ocaml_type = positional "ocaml_type" string ~docstring:"ocaml type" in 201 | fun () -> Py_typerep.register_named_type ~name ~ocaml_type) 202 | ~docstring: 203 | {| 204 | Registers an ocaml type so that it can be transfered to python in a caspule. 205 | |} 206 | ;; 207 | -------------------------------------------------------------------------------- /examples/toploop_bindings.mli: -------------------------------------------------------------------------------- 1 | val register_module : module_name:string -> unit 2 | -------------------------------------------------------------------------------- /pythonlib.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Jane Street developers" 3 | authors: ["Jane Street Group, LLC"] 4 | homepage: "https://github.com/janestreet/pythonlib" 5 | bug-reports: "https://github.com/janestreet/pythonlib/issues" 6 | dev-repo: "git+https://github.com/janestreet/pythonlib.git" 7 | doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/pythonlib/index.html" 8 | license: "MIT" 9 | build: [ 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ] 12 | depends: [ 13 | "ocaml" {>= "4.11.0" & < "4.13.0"} 14 | "base" 15 | "core" 16 | "expect_test_helpers_core" 17 | "ppx_bin_prot" 18 | "ppx_compare" 19 | "ppx_expect" 20 | "ppx_here" 21 | "ppx_let" 22 | "ppx_python" 23 | "ppx_sexp_conv" 24 | "ppx_string" 25 | "stdio" 26 | "typerep" 27 | "dune" {>= "2.0.0"} 28 | "pyml" {>= "20211015"} 29 | ] 30 | available: arch != "arm32" & arch != "x86_32" 31 | synopsis: "A library to help writing wrappers around ocaml code for python" 32 | description: " 33 | This library helps exposing ocaml functions to python. The python runtime interaction is handled by pyml. 34 | " 35 | -------------------------------------------------------------------------------- /src/broadcast.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | open! Import 3 | 4 | (* The regular non-empty list module depends on core, which we don't want to do, so we 5 | define our own version here. *) 6 | module Nonempty_list = struct 7 | type 'a t = ( :: ) of 'a * 'a list 8 | 9 | let to_list (hd :: tl) : _ list = hd :: tl 10 | let append (hd :: tl) t = hd :: (tl @ to_list t) 11 | end 12 | 13 | module T = struct 14 | (* Note that [Single_value foo] and [List_or_series [foo]] are not the same thing, in 15 | the first case only a single value was passed, and in the second case a list of 16 | length 1 was passed. 17 | This is helpful so that the functions can return a single value in this case. 18 | 19 | Note also that the purpose of [list_arg_names] is to solely print informative error 20 | messages. Because [Single_value]s can never be involved in causing errors, we don't 21 | store arg names for those. This also means that, for a [t] constructed via merging, 22 | [list_arg_names] does NOT contain the arg names of ALL [t]s used to produce it - 23 | instead, it wll only contain the arg names of [List_or_series] values which were 24 | merged. 25 | *) 26 | 27 | type 'a t = 28 | | Single_value of 'a 29 | | List_or_series of 30 | { values : 'a list 31 | ; list_arg_names : string Nonempty_list.t 32 | ; index : pyobject option 33 | (* This is [Some _] if [t] was created from a pandas series, else [None]. *) 34 | } 35 | 36 | let map t ~f = 37 | match t with 38 | | Single_value v -> Single_value (f v) 39 | | List_or_series { values; list_arg_names; index } -> 40 | List_or_series { values = List.map values ~f; list_arg_names; index } 41 | ;; 42 | 43 | let merge t2 t1 = 44 | let str_of_arg_names arg_names = 45 | Nonempty_list.to_list arg_names 46 | |> List.map ~f:(fun str -> "'" ^ str ^ "'") 47 | |> String.concat ~sep:"," 48 | in 49 | let zip_exn (vs1, list_arg_names1) (vs2, list_arg_names2) = 50 | let n1 = List.length vs1 in 51 | let n2 = List.length vs2 in 52 | if n1 <> n2 53 | then 54 | value_errorf 55 | "mismatching number of values: argument(s) %s had %d values, while argument(s) \ 56 | %s had %d values" 57 | (str_of_arg_names list_arg_names1) 58 | n1 59 | (str_of_arg_names list_arg_names2) 60 | n2; 61 | let values = List.zip_exn vs1 vs2 in 62 | let list_arg_names = Nonempty_list.append list_arg_names1 list_arg_names2 in 63 | values, list_arg_names 64 | in 65 | match t1, t2 with 66 | | Single_value v1, Single_value v2 -> Single_value (v1, v2) 67 | | Single_value v1, List_or_series { values = vs2; list_arg_names; index } -> 68 | List_or_series 69 | { values = List.map vs2 ~f:(fun v2 -> v1, v2); list_arg_names; index } 70 | | List_or_series { values = vs1; list_arg_names; index }, Single_value v2 -> 71 | List_or_series 72 | { values = List.map vs1 ~f:(fun v1 -> v1, v2); list_arg_names; index } 73 | | ( List_or_series { values = vs1; list_arg_names = list_arg_names1; index = i1 } 74 | , List_or_series { values = vs2; list_arg_names = list_arg_names2; index = i2 } ) -> 75 | let index = 76 | match i1, i2 with 77 | | Some i1, Some i2 -> 78 | if not (Py.Object.call_method i1 "equals" [| i2 |] |> bool_of_python) 79 | then 80 | value_errorf 81 | "series indexes for argument(s) %s and %s differ" 82 | (str_of_arg_names list_arg_names1) 83 | (str_of_arg_names list_arg_names2) 84 | else Some i1 85 | | (Some _ as i), None | None, (Some _ as i) -> i 86 | | None, None -> None 87 | in 88 | let values, list_arg_names = 89 | zip_exn (vs1, list_arg_names1) (vs2, list_arg_names2) 90 | in 91 | List_or_series { values; list_arg_names; index } 92 | ;; 93 | 94 | include Applicative.Make (struct 95 | type nonrec 'a t = 'a t 96 | 97 | let return x = Single_value x 98 | let apply t_f t = merge t t_f |> map ~f:(fun (f, x) -> f x) 99 | let map = `Custom map 100 | end) 101 | end 102 | 103 | include T 104 | 105 | module Open_on_rhs_intf = struct 106 | module type S = Applicative.S with type 'a t := 'a t 107 | end 108 | 109 | include Applicative.Make_let_syntax (T) (Open_on_rhs_intf) (T) 110 | 111 | let to_list = function 112 | | Single_value a -> [ a ] 113 | | List_or_series { values; _ } -> values 114 | ;; 115 | 116 | let create pyobject of_python ~arg_name = 117 | let map pyobject = Py.List.to_list_map of_python pyobject in 118 | if Py.List.check pyobject 119 | then 120 | List_or_series { values = map pyobject; list_arg_names = [ arg_name ]; index = None } 121 | else ( 122 | match Lazy.force pd_series with 123 | | Some pd_series when Py.Object.is_instance pyobject pd_series -> 124 | (* Make sure to use "Series.array" instead of "Series.values". Because, given a 125 | series of datetimes, calling df['start'].values produces an array of datetime64s. 126 | However, accessing each element directly (e.g. df['start'][0] ) gives us 127 | Timestamp which contains timezone information. 128 | 129 | Relevant links: 130 | https://stackoverflow.com/questions/21989286/why-pandas-series-return-the-element-of-my-numpy-datetime64-array-as-timestamp 131 | https://pandas.pydata.org/docs/reference/api/pandas.Series.values.html 132 | *) 133 | let values = Option.value_exn (Py.Object.get_attr_string pyobject "array") |> map in 134 | let index = Some (Option.value_exn (Py.Object.get_attr_string pyobject "index")) in 135 | List_or_series { values; list_arg_names = [ arg_name ]; index } 136 | | Some _ | None -> Single_value (of_python pyobject)) 137 | ;; 138 | 139 | let constant x = Single_value x 140 | 141 | let many values ~arg_name = 142 | List_or_series { values; list_arg_names = [ arg_name ]; index = None } 143 | ;; 144 | 145 | let zip2 arg1 arg2 = arg1 |> merge arg2 146 | 147 | let zip3 arg1 arg2 arg3 = 148 | arg1 |> merge arg2 |> merge arg3 |> map ~f:(fun ((v1, v2), v3) -> v1, v2, v3) 149 | ;; 150 | 151 | let zip4 arg1 arg2 arg3 arg4 = 152 | arg1 153 | |> merge arg2 154 | |> merge arg3 155 | |> merge arg4 156 | |> map ~f:(fun (((v1, v2), v3), v4) -> v1, v2, v3, v4) 157 | ;; 158 | 159 | let python_of_t t values ~to_python = 160 | let same_length_exn vs1 vs2 = 161 | let n1 = List.length vs1 in 162 | let n2 = List.length vs2 in 163 | if n1 <> n2 164 | then value_errorf "internal error, unexpected number of outputs %d <> %d" n2 n1 165 | in 166 | match t with 167 | | Single_value _ -> 168 | (match values with 169 | | [ v ] -> to_python v 170 | | _ -> 171 | value_errorf "internal error, expected a single output got %d" (List.length values)) 172 | | List_or_series { values = l; index; list_arg_names = _ } -> 173 | same_length_exn l values; 174 | (match index with 175 | | None -> Py.List.of_list_map to_python values 176 | | Some index -> 177 | let pd_series = Option.value_exn (Lazy.force pd_series) in 178 | Py.Callable.to_function pd_series [| Py.List.of_list_map to_python values; index |]) 179 | ;; 180 | 181 | let python_of_t' values ~to_python = python_of_t values (to_list values) ~to_python 182 | 183 | let index t = 184 | match t with 185 | | Single_value _ -> None 186 | | List_or_series { values = _; index; list_arg_names = _ } -> index 187 | ;; 188 | 189 | let df_of_t t ~data ~kwargs = 190 | let df = Lazy.force pd_dataframe in 191 | match df, index t with 192 | | None, _ -> data 193 | | Some df, None -> 194 | (* The following is equivalent to pandas.Dataframe(data, index=None, **kwargs) *) 195 | Py.Callable.to_function_with_keywords df [| data |] kwargs 196 | | Some df, Some index -> 197 | (* The following is equivalent to pandas.Dataframe(data, index, **kwargs) *) 198 | Py.Callable.to_function_with_keywords df [| data; index |] kwargs 199 | ;; 200 | -------------------------------------------------------------------------------- /src/broadcast.mli: -------------------------------------------------------------------------------- 1 | (* A module to handle argument broadcasting. 2 | Note that this does not support list of lists or series of lists properly. 3 | *) 4 | 5 | open! Base 6 | open! Import 7 | 8 | type 'a t 9 | 10 | module Open_on_rhs_intf : sig 11 | module type S = Applicative.S with type 'a t := 'a t 12 | end 13 | 14 | include Applicative.S with type 'a t := 'a t 15 | 16 | include 17 | Applicative.Let_syntax 18 | with type 'a t := 'a t 19 | and module Open_on_rhs_intf := Open_on_rhs_intf 20 | 21 | val create : pyobject -> (pyobject -> 'a) -> arg_name:string -> 'a t 22 | val constant : 'a -> 'a t 23 | val many : 'a list -> arg_name:string -> 'a t 24 | val map : 'a t -> f:('a -> 'b) -> 'b t 25 | 26 | (** NOTE: [merge] flips the order of its arguments. This is to reflect it's intended usage 27 | in pipelines via [|>]. *) 28 | val merge : 'a t -> 'b t -> ('b * 'a) t 29 | 30 | val zip2 : 'a t -> 'b t -> ('a * 'b) t 31 | val zip3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t 32 | val zip4 : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t 33 | val to_list : 'a t -> 'a list 34 | val python_of_t : 'a t -> 'b list -> to_python:('b -> pyobject) -> pyobject 35 | val python_of_t' : 'a t -> to_python:('a -> pyobject) -> pyobject 36 | 37 | (** Some if [t] was created from a pandas series, else [None]. *) 38 | val index : _ t -> pyobject option 39 | 40 | (** Creates a dataframe that maintains the original indexing of [t]. 41 | 42 | This effectively calls pandas.DataFrame(data, index, **kwargs) where index is the 43 | index of [t]. 44 | *) 45 | val df_of_t : _ t -> data:pyobject -> kwargs:(string * pyobject) list -> pyobject 46 | -------------------------------------------------------------------------------- /src/class_wrapper.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Import 3 | 4 | module Id : sig 5 | type t 6 | 7 | val create : unit -> t 8 | val to_string : t -> string 9 | end = struct 10 | type t = int 11 | 12 | let create = 13 | let current = ref 0 in 14 | fun () -> 15 | Int.incr current; 16 | !current 17 | ;; 18 | 19 | let to_string = Int.to_string 20 | end 21 | 22 | let content_field = "_content" 23 | 24 | type 'a t = 25 | { wrap : 'a -> Py.Object.t 26 | ; unwrap : Py.Object.t -> 'a 27 | ; name : string 28 | ; mutable cls_object : Py.Object.t option 29 | } 30 | 31 | let set_cls_object_exn t pyobject = 32 | if Option.is_some t.cls_object 33 | then Printf.failwithf "cls_object for %s has already been set" t.name (); 34 | t.cls_object <- Some pyobject 35 | ;; 36 | 37 | module Init = struct 38 | type 'a cls = 'a t 39 | 40 | type 'a fn = 41 | | No_keywords of ('a cls -> args:pyobject list -> 'a) 42 | | With_keywords of 43 | ('a cls 44 | -> args:pyobject list 45 | -> keywords:(string, pyobject, String.comparator_witness) Map.t 46 | -> 'a) 47 | 48 | type 'a t = 49 | { fn : 'a fn 50 | ; docstring : string option 51 | } 52 | 53 | let create ?docstring fn = { docstring; fn = No_keywords fn } 54 | let create_with_keywords ?docstring fn = { fn = With_keywords fn; docstring } 55 | 56 | let defunc ?docstring defunc = 57 | let docstring = Defunc.params_docstring ?docstring defunc in 58 | let fn cls ~args ~keywords = 59 | let fn = Defunc.apply_ defunc (Array.of_list args) keywords in 60 | fn cls 61 | in 62 | create_with_keywords ~docstring fn 63 | ;; 64 | 65 | let no_arg ?docstring fn = 66 | let fn cls ~args ~keywords = 67 | if not (List.is_empty args) then value_errorf "no argument expected"; 68 | if not (Map.is_empty keywords) then value_errorf "no keyword argument expected"; 69 | fn cls 70 | in 71 | create_with_keywords ?docstring fn 72 | ;; 73 | end 74 | 75 | module Method = struct 76 | type 'a cls = 'a t 77 | 78 | type 'a fn = 79 | | No_keywords of (self:'a * pyobject -> args:pyobject list -> pyobject) 80 | | No_keywords_raw of (self:pyobject -> args:pyobject list -> pyobject) 81 | | With_keywords of 82 | (self:'a * pyobject 83 | -> args:pyobject list 84 | -> keywords:(string, pyobject, String.comparator_witness) Map.t 85 | -> pyobject) 86 | 87 | type 'a t = 88 | { name : string 89 | ; fn : 'a fn 90 | ; docstring : string option 91 | } 92 | 93 | let create ?docstring name fn = { name; fn = No_keywords fn; docstring } 94 | let create_raw ?docstring name fn = { name; fn = No_keywords_raw fn; docstring } 95 | let create_with_keywords ?docstring name fn = { name; fn = With_keywords fn; docstring } 96 | 97 | let defunc ?docstring name defunc = 98 | let docstring = Defunc.params_docstring ?docstring defunc in 99 | let fn ~self ~args ~keywords = 100 | let fn = Defunc.apply_ defunc (Array.of_list args) keywords in 101 | fn ~self 102 | in 103 | create_with_keywords ~docstring name fn 104 | ;; 105 | 106 | let no_arg ?docstring name fn = 107 | let fn ~self ~args ~keywords = 108 | if not (List.is_empty args) then value_errorf "no argument expected"; 109 | if not (Map.is_empty keywords) then value_errorf "no keyword argument expected"; 110 | fn ~self 111 | in 112 | create_with_keywords ?docstring name fn 113 | ;; 114 | end 115 | 116 | let wrap_capsule t obj = t.wrap obj 117 | 118 | let unwrap_exn t pyobj = 119 | let pyobj = 120 | match Py.Object.get_attr_string pyobj content_field with 121 | | None -> Printf.failwithf "no %s field in object" content_field () 122 | | Some content -> content 123 | in 124 | if not (Py.Capsule.check pyobj) then failwith "not an ocaml capsule"; 125 | t.unwrap pyobj 126 | ;; 127 | 128 | let unwrap t pyobj = 129 | try Some (unwrap_exn t pyobj) with 130 | | _ -> None 131 | ;; 132 | 133 | let wrap t obj = 134 | let cls = Option.value_exn t.cls_object in 135 | Py.Object.call_function_obj_args cls [| wrap_capsule t obj |] 136 | ;; 137 | 138 | let make ?to_string_repr ?to_string ?eq ?init ?(fields = []) name ~methods = 139 | let id = Id.create () in 140 | let t = 141 | let wrap, unwrap = Py.Capsule.make (Printf.sprintf "%s-%s" name (Id.to_string id)) in 142 | { wrap; unwrap; cls_object = None; name } 143 | in 144 | let methods = 145 | let to_string = 146 | Option.map to_string ~f:(fun fn ~self ~args:_ -> 147 | fn t (fst self) |> Py.String.of_string) 148 | in 149 | let to_string_repr = 150 | Option.map to_string_repr ~f:(fun fn ~self ~args:_ -> 151 | fn t (fst self) |> Py.String.of_string) 152 | in 153 | let to_string_repr = Option.first_some to_string_repr to_string in 154 | let eq = 155 | Option.map eq ~f:(fun fn ~self ~args -> 156 | let rhs = 157 | match args with 158 | | [] -> failwith "eq with no argument" 159 | | _ :: _ :: _ -> Printf.failwithf "eq with %d arguments" (List.length args) () 160 | | [ rhs ] -> rhs 161 | in 162 | fn t (fst self) (unwrap_exn t rhs) |> Py.Bool.of_bool) 163 | in 164 | List.filter_map 165 | [ "__str__", to_string; "__repr__", to_string_repr; "__eq__", eq ] 166 | ~f:(fun (name, fn) -> Option.map fn ~f:(fun fn -> Method.create name fn)) 167 | @ methods t 168 | in 169 | let methods = 170 | List.map methods ~f:(fun { Method.name; fn; docstring } -> 171 | let fn = 172 | let self_and_args args = 173 | let args = Array.to_list args in 174 | match args with 175 | | [] -> failwith "empty input" 176 | | p :: q -> p, q 177 | in 178 | match (fn : _ Method.fn) with 179 | | No_keywords fn -> 180 | Py.Callable.of_function ~name ?docstring (fun args -> 181 | let self, args = self_and_args args in 182 | fn ~self:(unwrap_exn t self, self) ~args) 183 | | No_keywords_raw fn -> 184 | Py.Callable.of_function ~name ?docstring (fun args -> 185 | let self, args = self_and_args args in 186 | fn ~self ~args) 187 | | With_keywords fn -> 188 | Py.Callable.of_function_with_keywords ~name ?docstring (fun args keywords -> 189 | let self, args = self_and_args args in 190 | let keywords = Py_module.keywords_of_python keywords |> Or_error.ok_exn in 191 | fn ~self:(unwrap_exn t self, self) ~args ~keywords) 192 | in 193 | name, fn) 194 | in 195 | let init = 196 | let name = "__init__" in 197 | let fn = 198 | let docstring = Option.bind init ~f:(fun i -> i.Init.docstring) in 199 | Py.Callable.of_function_as_tuple_and_dict ~name ?docstring (fun tuple kwargs -> 200 | try 201 | let self, args = 202 | match Py.Tuple.to_list tuple with 203 | | [] -> failwith "empty input" 204 | | p :: q -> p, q 205 | in 206 | let content = 207 | match args with 208 | (* Do not call the __init__ function when given a capsule as input 209 | as this is used when wrapping values. *) 210 | | [ capsule ] when Py.Capsule.check capsule -> capsule 211 | | _ -> 212 | (match init with 213 | | Some init -> 214 | let v = 215 | match (init.fn : _ Init.fn) with 216 | | No_keywords fn -> fn t ~args 217 | | With_keywords fn -> 218 | let keywords = 219 | Py_module.keywords_of_python kwargs |> Or_error.ok_exn 220 | in 221 | fn t ~args ~keywords 222 | in 223 | wrap_capsule t v 224 | | None -> Py.none) 225 | in 226 | Py.Object.set_attr_string self content_field content; 227 | Py.none 228 | with 229 | | Py.Err _ as pyerr -> raise pyerr 230 | | exn -> 231 | let msg = Printf.sprintf "ocaml error %s" (Exn.to_string_mach exn) in 232 | raise (Py.Err (ValueError, msg))) 233 | in 234 | name, fn 235 | in 236 | let cls_object = 237 | if List.exists fields ~f:(fun (field_name, _) -> 238 | String.equal field_name content_field) 239 | then 240 | value_errorf 241 | "'%s' is not an acceptable field name because it is reserved for internal use by \ 242 | OCaml's class_wrapper" 243 | content_field; 244 | let fields = (content_field, Py.none) :: fields in 245 | Py.Class.init name ~fields ~methods:(init :: methods) 246 | in 247 | set_cls_object_exn t cls_object; 248 | t 249 | ;; 250 | 251 | let register_in_module t modl = 252 | Py_module.set_value modl t.name (Option.value_exn t.cls_object) 253 | ;; 254 | 255 | let clear_content _t pyobject = Py.Object.set_attr_string pyobject content_field Py.none 256 | let cls_object t = Option.value_exn t.cls_object 257 | let name t = t.name 258 | let is_instance t pyobject = Py.Object.is_instance pyobject (cls_object t) 259 | 260 | let set_content t pyobject v = 261 | Py.Object.set_attr_string pyobject content_field (wrap_capsule t v) 262 | ;; 263 | -------------------------------------------------------------------------------- /src/class_wrapper.mli: -------------------------------------------------------------------------------- 1 | open Base 2 | open Import 3 | 4 | type _ t 5 | 6 | val wrap : 'a t -> 'a -> pyobject 7 | val unwrap_exn : 'a t -> pyobject -> 'a 8 | val unwrap : 'a t -> pyobject -> 'a option 9 | 10 | module Init : sig 11 | type 'a cls = 'a t 12 | type 'a t 13 | 14 | val create : ?docstring:string -> ('a cls -> args:pyobject list -> 'a) -> 'a t 15 | val defunc : ?docstring:string -> ('a cls -> 'a) Defunc.t -> 'a t 16 | val no_arg : ?docstring:string -> ('a cls -> 'a) -> 'a t 17 | end 18 | 19 | module Method : sig 20 | type 'a cls = 'a t 21 | type 'a t 22 | 23 | val create 24 | : ?docstring:string 25 | -> string 26 | (** In the [methods] callbacks, [self] contains both the embeded ocaml 27 | value as well as the Python wrapper object. *) 28 | -> (self:'a * pyobject -> args:pyobject list -> pyobject) 29 | -> 'a t 30 | 31 | val create_raw 32 | : ?docstring:string 33 | -> string (** In the raw callbacks, [self] contains only the Python wrapper object. *) 34 | -> (self:pyobject -> args:pyobject list -> pyobject) 35 | -> 'a t 36 | 37 | val create_with_keywords 38 | : ?docstring:string 39 | -> string 40 | -> (self:'a * pyobject 41 | -> args:pyobject list 42 | -> keywords:(string, pyobject, String.comparator_witness) Map.t 43 | -> pyobject) 44 | -> 'a t 45 | 46 | val defunc 47 | : ?docstring:string 48 | -> string 49 | -> (self:'a * pyobject -> pyobject) Defunc.t 50 | -> 'a t 51 | 52 | val no_arg : ?docstring:string -> string -> (self:'a * pyobject -> pyobject) -> 'a t 53 | end 54 | 55 | val make 56 | : ?to_string_repr:('a t -> 'a -> string) 57 | -> ?to_string:('a t -> 'a -> string) 58 | -> ?eq:('a t -> 'a -> 'a -> bool) 59 | -> ?init:'a Init.t 60 | -> ?fields:(string * pyobject) list 61 | -> string 62 | -> methods:('a t -> 'a Method.t list) 63 | -> 'a t 64 | 65 | val register_in_module : 'a t -> Py_module.t -> unit 66 | val clear_content : 'a t -> pyobject -> unit 67 | val set_content : 'a t -> pyobject -> 'a -> unit 68 | val cls_object : 'a t -> pyobject 69 | val name : 'a t -> string 70 | val is_instance : 'a t -> pyobject -> bool 71 | -------------------------------------------------------------------------------- /src/defunc.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Import 3 | 4 | module Of_python = struct 5 | type 'a t = 6 | { type_name : string 7 | ; conv : pyobject -> 'a 8 | } 9 | 10 | let create ~type_name ~conv = { type_name; conv } 11 | 12 | let map { type_name; conv } ~f = 13 | { type_name; conv = (fun py_obj -> py_obj |> conv |> f) } 14 | ;; 15 | end 16 | 17 | module Arg = struct 18 | type 'a t = 19 | { name : string 20 | ; of_python : 'a Of_python.t 21 | ; docstring : string 22 | ; kind : [ `positional | `keyword of 'a option | `positional_or_keyword of 'a option ] 23 | } 24 | end 25 | 26 | module Opt_arg = struct 27 | type 'a t = 28 | { name : string 29 | ; of_python : 'a Of_python.t 30 | ; docstring : string 31 | } 32 | end 33 | 34 | module Docstring = struct 35 | type t = string 36 | end 37 | 38 | module T0 = struct 39 | type _ t = 40 | | Return : 'a -> 'a t 41 | | Map : 'a t * ('a -> 'b) -> 'b t 42 | | Both : 'a t * 'b t -> ('a * 'b) t 43 | | Arg : 'a Arg.t -> 'a t 44 | | Opt_arg : 'a Opt_arg.t -> 'a option t 45 | | Star_args : Docstring.t -> pyobject list t 46 | | Star_kwargs : Docstring.t -> (string, pyobject, String.comparator_witness) Map.t t 47 | 48 | let return x = Return x 49 | let map t ~f = Map (t, f) 50 | let both t t' = Both (t, t') 51 | let apply f x = both f x |> map ~f:(fun (f, x) -> f x) 52 | let map = `Custom map 53 | end 54 | 55 | module T = struct 56 | include T0 57 | include Applicative.Make (T0) 58 | end 59 | 60 | include T 61 | 62 | module Open_on_rhs_intf = struct 63 | module type S = Applicative.S 64 | end 65 | 66 | include Applicative.Make_let_syntax (T) (Open_on_rhs_intf) (T) 67 | 68 | let valid_char c = Char.(is_alphanum c || c = '_') 69 | 70 | let check_valid_arg_name name = 71 | if String.is_empty name 72 | then failwith "cannot use an empty name" 73 | else ( 74 | let first_char = name.[0] in 75 | if Char.(first_char < 'a' || first_char > 'z') 76 | then Printf.failwithf "arg name %s does not start with a lowercase letter" name () 77 | else if String.exists name ~f:(fun c -> not (valid_char c)) 78 | then Printf.failwithf "arg name %s contains some invalid characters" name () 79 | else ()) 80 | ;; 81 | 82 | let no_arg fn = return () |> map ~f:fn 83 | 84 | module State = struct 85 | type t = 86 | { pos : int 87 | ; after_star_args : bool 88 | ; after_star_kwargs : bool 89 | } 90 | 91 | let init = { pos = 0; after_star_args = false; after_star_kwargs = false } 92 | end 93 | 94 | let apply_ (type a) (t : a t) args kwargs = 95 | let try_of_python v ~of_python ~name = 96 | try of_python.Of_python.conv v with 97 | | Py.Err_with_traceback (_, msg, _) | Py.Err (_, msg) -> 98 | value_errorf "error processing arg %s (%s): %s" name of_python.type_name msg 99 | | e -> 100 | value_errorf 101 | "error processing arg %s (%s): %s" 102 | name 103 | of_python.type_name 104 | (Exn.to_string e) 105 | in 106 | (* data: [true] for "is kwarg", [false] for "not kwarg" *) 107 | let kwnames = Hashtbl.create (module String) in 108 | let check_and_add_kwnames ?(is_kwarg = true) name = 109 | match Hashtbl.add kwnames ~key:name ~data:is_kwarg with 110 | | `Ok -> () 111 | | `Duplicate -> value_errorf "multiple keyword arguments with name %s" name 112 | in 113 | let positional_arguments () = 114 | let rec loop : type a. a t -> string list = function 115 | | Return _ -> [] 116 | | Map (t, _) -> loop t 117 | | Both (t, t') -> 118 | let args = loop t in 119 | let args' = loop t' in 120 | args @ args' 121 | | Arg { name; kind = `positional | `positional_or_keyword _; _ } -> [ name ] 122 | | Arg { kind = `keyword _; _ } -> [] 123 | | Opt_arg _ -> [] 124 | | Star_args _ -> [ "other args" ] 125 | | Star_kwargs _ -> [] 126 | in 127 | loop t 128 | in 129 | let rec loop : type a. a t -> state:State.t -> a * State.t = 130 | fun t ~state -> 131 | match t with 132 | | Return a -> a, state 133 | | Map (t, f) -> 134 | let v, state = loop t ~state in 135 | f v, state 136 | | Both (t, t') -> 137 | let v, state = loop t ~state in 138 | let v', state = loop t' ~state in 139 | (v, v'), state 140 | | Arg { name; of_python; docstring = _; kind = `positional } -> 141 | if state.after_star_args 142 | then value_errorf "positional argument after *args (%s)" name; 143 | let pos = state.pos in 144 | if pos >= Array.length args 145 | then 146 | value_errorf 147 | "not enough arguments (got %d, expected %s)" 148 | (Array.length args) 149 | (positional_arguments () |> String.concat ~sep:", "); 150 | try_of_python args.(pos) ~of_python ~name, { state with pos = pos + 1 } 151 | | Opt_arg { name; of_python; docstring = _ } -> 152 | if state.after_star_kwargs 153 | then value_errorf "keyword argument after **kwargs (%s)" name; 154 | check_and_add_kwnames name; 155 | let v = Map.find kwargs name in 156 | Option.map v ~f:(try_of_python ~of_python ~name), state 157 | | Arg { name; of_python; docstring = _; kind = `keyword default } -> 158 | if state.after_star_kwargs 159 | then value_errorf "keyword argument after **kwargs (%s)" name; 160 | check_and_add_kwnames name; 161 | (match Map.find kwargs name with 162 | | Some v -> try_of_python v ~of_python ~name, state 163 | | None -> 164 | (match default with 165 | | Some default -> default, state 166 | | None -> value_errorf "missing keyword argument: %s" name)) 167 | | Arg { name; of_python; docstring = _; kind = `positional_or_keyword default } -> 168 | let pos = state.pos in 169 | (match pos >= Array.length args with 170 | | false -> 171 | (* use positional args *) 172 | check_and_add_kwnames name ~is_kwarg:false; 173 | (* only check for name conflict, since we don't consume the name in kwargs *) 174 | try_of_python args.(pos) ~of_python ~name, { state with pos = pos + 1 } 175 | | true -> 176 | (* use keyword args *) 177 | if state.after_star_kwargs 178 | then value_errorf "positional-or-keyword argument after **kwargs (%s)" name; 179 | check_and_add_kwnames name; 180 | (match Map.find kwargs name with 181 | | Some v -> try_of_python v ~of_python ~name, state 182 | | None -> 183 | (match default with 184 | | Some default -> default, state 185 | | None -> value_errorf "missing positional-or-keyword argument: %s" name))) 186 | | Star_args _docstring -> 187 | if state.after_star_args then value_errorf "multiple *args"; 188 | let total_args_len = Array.length args in 189 | let args = 190 | Array.sub args ~pos:state.pos ~len:(Array.length args - state.pos) 191 | |> Array.to_list 192 | in 193 | args, { state with pos = total_args_len; after_star_args = true } 194 | | Star_kwargs _docstring -> 195 | if state.after_star_kwargs then value_errorf "multiple **kwargs"; 196 | let remaining_kwargs = 197 | Map.filter_keys kwargs ~f:(fun key -> 198 | match Hashtbl.find kwnames key with 199 | | None -> 200 | Hashtbl.set kwnames ~key ~data:true; 201 | true 202 | | Some true -> false 203 | | Some false -> 204 | value_errorf "keyword argument '%s' already set by positional argument" key) 205 | in 206 | remaining_kwargs, { state with after_star_kwargs = true } 207 | in 208 | let v, final_state = loop t ~state:State.init in 209 | Map.iter_keys kwargs ~f:(fun key -> 210 | match Hashtbl.find kwnames key with 211 | | None -> value_errorf "unexpected keyword argument %s" key 212 | | Some true -> () 213 | | Some false -> 214 | value_errorf "keyword argument '%s' already set by positional argument" key); 215 | if final_state.pos <> Array.length args 216 | then 217 | value_errorf 218 | "expected %d arguments (%s), got %d" 219 | final_state.pos 220 | (positional_arguments () |> String.concat ~sep:", ") 221 | (Array.length args); 222 | v 223 | ;; 224 | 225 | let apply (type a) (t : (unit -> a) t) args kwargs = 226 | let f = apply_ t args kwargs in 227 | f () 228 | ;; 229 | 230 | let params_docstring t = 231 | let sprintf = Printf.sprintf in 232 | let escape_trailing_underscore s = 233 | (* Sphinx has an unresolved issue with trailing underscores in argument names. They 234 | have to be manually escaped. 235 | 236 | https://github.com/sphinx-doc/sphinx/issues/519 237 | *) 238 | String.chop_suffix s ~suffix:"_" 239 | |> Option.value_map ~default:s ~f:(fun s -> s ^ "\\_") 240 | in 241 | let arg_docstring arg ~pos = 242 | let arg_name = escape_trailing_underscore arg.Arg.name in 243 | match arg.Arg.kind with 244 | | `positional -> 245 | [ sprintf ":param %s: (positional %d) %s" arg_name pos arg.docstring 246 | ; sprintf ":type %s: %s" arg_name arg.of_python.type_name 247 | ] 248 | |> String.concat ~sep:"\n" 249 | | `keyword default -> 250 | let default = 251 | match default with 252 | | None -> "mandatory keyword" 253 | | Some _ -> "keyword with default" 254 | in 255 | [ sprintf ":param %s: (%s) %s" arg_name default arg.docstring 256 | ; sprintf ":type %s: %s" arg_name arg.of_python.type_name 257 | ] 258 | |> String.concat ~sep:"\n" 259 | | `positional_or_keyword default -> 260 | let default = 261 | match default with 262 | | None -> "mandatory" 263 | | Some _ -> "with default" 264 | in 265 | let arg_name = escape_trailing_underscore arg.name in 266 | [ sprintf 267 | ":param %s: (positional %d or keyword) (%s) %s" 268 | arg_name 269 | pos 270 | default 271 | arg.docstring 272 | ; sprintf ":type %s: %s" arg_name arg.of_python.type_name 273 | ] 274 | |> String.concat ~sep:"\n" 275 | in 276 | let opt_arg_docstring (arg : _ Opt_arg.t) = 277 | let arg_name = escape_trailing_underscore arg.Opt_arg.name in 278 | [ sprintf ":param %s: (optional keyword) %s" arg_name arg.docstring 279 | ; sprintf ":type %s: %s" arg_name arg.of_python.type_name 280 | ] 281 | |> String.concat ~sep:"\n" 282 | in 283 | let star_args_docstring doc = sprintf ":param args: (variadic args) %s" doc in 284 | let star_kwargs_docstring doc = sprintf ":param kwargs: %s" doc in 285 | let rec loop : type a. a t -> pos:int -> _ list * int = 286 | fun t ~pos -> 287 | match t with 288 | | Return _ -> [], pos 289 | | Map (t, _) -> loop t ~pos 290 | | Both (t1, t2) -> 291 | let params1, pos = loop t1 ~pos in 292 | let params2, pos = loop t2 ~pos in 293 | params1 @ params2, pos 294 | | Arg ({ kind = `positional; _ } as arg) -> [ `pos (arg_docstring arg ~pos) ], pos + 1 295 | | Arg ({ kind = `keyword None; _ } as arg) -> 296 | [ `kw_mandatory (arg_docstring arg ~pos) ], pos 297 | | Arg ({ kind = `keyword (Some _); _ } as arg) -> 298 | [ `kw_opt (arg_docstring arg ~pos) ], pos 299 | | Arg ({ kind = `positional_or_keyword _; _ } as arg) -> 300 | [ `pos (arg_docstring arg ~pos) ], pos + 1 301 | | Opt_arg opt_arg -> [ `kw_opt (opt_arg_docstring opt_arg) ], pos 302 | | Star_args doc -> 303 | (* There should be no other positional arg past this one *) 304 | [ `other (star_args_docstring doc) ], Int.max_value_30_bits 305 | | Star_kwargs doc -> [ `other (star_kwargs_docstring doc) ], pos 306 | in 307 | let params, _pos = loop t ~pos:0 in 308 | let params = 309 | List.stable_sort params ~compare:(fun param1 param2 -> 310 | (* Positional parameters are first, then mandatory keywords, then optional keywords. *) 311 | match param1, param2 with 312 | | `pos _, `kw_mandatory _ -> -1 313 | | `kw_mandatory _, `pos _ -> 1 314 | | `pos _, `kw_opt _ -> -1 315 | | `kw_opt _, `pos _ -> 1 316 | | `kw_mandatory _, `kw_opt _ -> -1 317 | | `kw_opt _, `kw_mandatory _ -> 1 318 | | _ -> 0) 319 | |> List.map ~f:(function 320 | | `pos str | `pos_or_kw str | `kw_mandatory str | `kw_opt str | `other str -> 321 | str) 322 | in 323 | if List.is_empty params then None else String.concat params ~sep:"\n\n" |> Option.some 324 | ;; 325 | 326 | let params_docstring ?docstring t = 327 | [ params_docstring t; docstring ] 328 | |> List.filter_opt 329 | |> String.concat ~sep:"\n\n" 330 | |> Printf.sprintf "\n%s" 331 | ;; 332 | 333 | module Param = struct 334 | let map (o : _ Of_python.t) ~f = 335 | Of_python.create ~type_name:o.type_name ~conv:(fun pyobject -> o.conv pyobject |> f) 336 | ;; 337 | 338 | let choice (o1 : _ Of_python.t) (o2 : _ Of_python.t) = 339 | Of_python.create 340 | ~type_name:(Printf.sprintf "%s | %s" o1.type_name o2.type_name) 341 | ~conv:(fun pyobject -> 342 | try Either.First (o1.conv pyobject) with 343 | | _ -> Second (o2.conv pyobject)) 344 | ;; 345 | 346 | let choice' o1 o2 = choice o1 o2 |> map ~f:Either.value 347 | 348 | let positional_only name of_python ~docstring = 349 | check_valid_arg_name name; 350 | Arg { name; of_python; docstring; kind = `positional } 351 | ;; 352 | 353 | let positional_or_keyword ?default name of_python ~docstring = 354 | check_valid_arg_name name; 355 | Arg { name; of_python; docstring; kind = `positional_or_keyword default } 356 | ;; 357 | 358 | let keyword ?default name of_python ~docstring = 359 | check_valid_arg_name name; 360 | Arg { name; of_python; docstring; kind = `keyword default } 361 | ;; 362 | 363 | let keyword_opt name of_python ~docstring = 364 | check_valid_arg_name name; 365 | Opt_arg { name; of_python; docstring } 366 | ;; 367 | 368 | let int = Of_python.create ~type_name:"int" ~conv:int_of_python 369 | let float = Of_python.create ~type_name:"float" ~conv:float_of_python 370 | let bool = Of_python.create ~type_name:"bool" ~conv:bool_of_python 371 | 372 | let char = 373 | Of_python.create ~type_name:"char" ~conv:(fun pyobject -> 374 | let string = string_of_python pyobject in 375 | match String.to_list string with 376 | | [ c ] -> c 377 | | _ -> value_errorf "expected a single character, got \"%s\"" string) 378 | ;; 379 | 380 | let string = Of_python.create ~type_name:"string" ~conv:string_of_python 381 | 382 | let callable = 383 | Of_python.create ~type_name:"callback" ~conv:(fun pyobject -> 384 | let () = 385 | if not (Py.Callable.check pyobject) 386 | then 387 | value_errorf 388 | "expected a function or callable object, got %s" 389 | (Py.Type.get pyobject |> Py.Type.name) 390 | () 391 | in 392 | Py.Callable.to_function pyobject) 393 | ;; 394 | 395 | let path = 396 | Of_python.create ~type_name:"path" ~conv:(fun pyobject -> 397 | try string_of_python pyobject with 398 | | _ -> 399 | if Py.Object.is_instance pyobject (Lazy.force path_cls) 400 | then ( 401 | let str = get_from_builtins "str" in 402 | Py.Object.call_function_obj_args str [| pyobject |] |> string_of_python) 403 | else 404 | value_errorf 405 | "expected a str or instance of Path, got %s" 406 | (Py.Type.get pyobject |> Py.Type.name) 407 | ()) 408 | ;; 409 | 410 | (* Rather than using typerep, it would be nice to have a [function] combinator 411 | and let users write e.g [function (pair int int) int] for addition. 412 | 413 | However when calling a (python) closure from ocaml with some parameters 414 | these parameters will have to be converted from ocaml to python. 415 | Currently [params] only handles the conversion from python to ocaml which is 416 | problematic. 417 | *) 418 | let typerep tr = 419 | Of_python.create 420 | ~type_name:(Py_typerep.to_ocaml tr) 421 | ~conv:(Py_typerep.python_to_ocaml tr) 422 | ;; 423 | 424 | let pyobject = Of_python.create ~type_name:"obj" ~conv:Fn.id 425 | 426 | let check_tuple_len pyobject ~expected_length = 427 | if not (Py.Tuple.check pyobject) 428 | then 429 | Printf.failwithf "expected a tuple got %s" (Py.Type.get pyobject |> Py.Type.name) (); 430 | let length = Py.Tuple.size pyobject in 431 | if expected_length <> length 432 | then 433 | Printf.failwithf 434 | "expected a tuple with %d elements, got %d" 435 | expected_length 436 | length 437 | () 438 | ;; 439 | 440 | let pair (o1 : _ Of_python.t) (o2 : _ Of_python.t) = 441 | Of_python.create 442 | ~type_name:(Printf.sprintf "Tuple[%s, %s]" o1.type_name o2.type_name) 443 | ~conv:(fun pyobject -> 444 | check_tuple_len pyobject ~expected_length:2; 445 | let p1, p2 = Py.Tuple.to_tuple2 pyobject in 446 | o1.conv p1, o2.conv p2) 447 | ;; 448 | 449 | let triple (o1 : _ Of_python.t) (o2 : _ Of_python.t) (o3 : _ Of_python.t) = 450 | Of_python.create 451 | ~type_name: 452 | (Printf.sprintf "Tuple[%s, %s, %s]" o1.type_name o2.type_name o3.type_name) 453 | ~conv:(fun pyobject -> 454 | check_tuple_len pyobject ~expected_length:3; 455 | let p1, p2, p3 = Py.Tuple.to_tuple3 pyobject in 456 | o1.conv p1, o2.conv p2, o3.conv p3) 457 | ;; 458 | 459 | let quadruple 460 | (o1 : _ Of_python.t) 461 | (o2 : _ Of_python.t) 462 | (o3 : _ Of_python.t) 463 | (o4 : _ Of_python.t) 464 | = 465 | Of_python.create 466 | ~type_name: 467 | (Printf.sprintf 468 | "Tuple[%s, %s, %s, %s]" 469 | o1.type_name 470 | o2.type_name 471 | o3.type_name 472 | o4.type_name) 473 | ~conv:(fun pyobject -> 474 | check_tuple_len pyobject ~expected_length:3; 475 | let p1, p2, p3, p4 = Py.Tuple.to_tuple4 pyobject in 476 | o1.conv p1, o2.conv p2, o3.conv p3, o4.conv p4) 477 | ;; 478 | 479 | let quintuple 480 | (o1 : _ Of_python.t) 481 | (o2 : _ Of_python.t) 482 | (o3 : _ Of_python.t) 483 | (o4 : _ Of_python.t) 484 | (o5 : _ Of_python.t) 485 | = 486 | Of_python.create 487 | ~type_name: 488 | (Printf.sprintf 489 | "Tuple[%s, %s, %s, %s, %s]" 490 | o1.type_name 491 | o2.type_name 492 | o3.type_name 493 | o4.type_name 494 | o5.type_name) 495 | ~conv:(fun pyobject -> 496 | check_tuple_len pyobject ~expected_length:3; 497 | let p1, p2, p3, p4, p5 = Py.Tuple.to_tuple5 pyobject in 498 | o1.conv p1, o2.conv p2, o3.conv p3, o4.conv p4, o5.conv p5) 499 | ;; 500 | 501 | let option (o : _ Of_python.t) = 502 | Of_python.create 503 | ~type_name:(Printf.sprintf "Optional[%s]" o.type_name) 504 | ~conv:(fun python_value -> 505 | if Py.is_null python_value || Py.is_none python_value 506 | then None 507 | else Some (o.conv python_value)) 508 | ;; 509 | 510 | let list (o : _ Of_python.t) = 511 | Of_python.create 512 | ~type_name:(Printf.sprintf "List[%s]" o.type_name) 513 | ~conv:(fun python_value -> 514 | (match Py.Type.get python_value with 515 | | List | Tuple -> () 516 | | otherwise -> 517 | Printf.failwithf "not a list or a tuple (%s)" (Py.Type.name otherwise) ()); 518 | py_list_to_list_map_safe o.conv python_value) 519 | ;; 520 | 521 | let list_or_iter (o : _ Of_python.t) = 522 | Of_python.create ~type_name:(Printf.sprintf "List[%s]" o.type_name) ~conv:(fun p -> 523 | match iterable_to_list p with 524 | | None -> 525 | Printf.failwithf "not a list/tuple/iter (%s)" (Py.Type.get p |> Py.Type.name) () 526 | | Some l -> py_list_to_list_map_safe o.conv l) 527 | ;; 528 | 529 | let array_or_iter (o : _ Of_python.t) = 530 | Of_python.create ~type_name:(Printf.sprintf "List[%s]" o.type_name) ~conv:(fun p -> 531 | match iterable_to_list p with 532 | | None -> 533 | Printf.failwithf "not a list/tuple/iter (%s)" (Py.Type.get p |> Py.Type.name) () 534 | | Some l -> py_list_to_array_map_safe o.conv l) 535 | ;; 536 | 537 | let one_or_tuple_or_list (o : _ Of_python.t) = 538 | Of_python.create 539 | ~type_name:(Printf.sprintf "ListOrSingleElt[%s]" o.type_name) 540 | ~conv:(One_or_tuple_or_list.t_of_python o.conv) 541 | ;; 542 | 543 | let one_or_tuple_or_list_relaxed (o : _ Of_python.t) = 544 | Of_python.create 545 | ~type_name:(Printf.sprintf "ListOrSingleElt[%s] (relaxed)" o.type_name) 546 | ~conv:(One_or_tuple_or_list_or_error.t_of_python o.conv ~type_name:o.type_name) 547 | ;; 548 | 549 | let with_broadcast (o : _ Of_python.t) ~arg_name = 550 | Of_python.create 551 | ~type_name:(Printf.sprintf "ListWithBroadcast[%s]" o.type_name) 552 | ~conv:(fun pyobject -> Broadcast.create pyobject o.conv ~arg_name) 553 | ;; 554 | 555 | let positional_or_keyword_broadcast arg_name of_python = 556 | positional_or_keyword arg_name (with_broadcast of_python ~arg_name) 557 | ;; 558 | 559 | let keyword_broadcast ?default arg_name of_python = 560 | let default = Option.map default ~f:Broadcast.constant in 561 | keyword ?default arg_name (with_broadcast of_python ~arg_name) 562 | ;; 563 | 564 | let keyword_opt_broadcast arg_name of_python = 565 | keyword_opt arg_name (with_broadcast of_python ~arg_name) 566 | ;; 567 | 568 | let keyword_opt_broadcast' arg_name of_python = 569 | keyword arg_name (option (with_broadcast of_python ~arg_name)) ~default:None 570 | ;; 571 | 572 | let dict ~(key : _ Of_python.t) ~(value : _ Of_python.t) = 573 | Of_python.create 574 | ~type_name:(Printf.sprintf "Dict[%s, %s]" key.type_name value.type_name) 575 | ~conv:(Py.Dict.to_bindings_map key.conv value.conv) 576 | ;; 577 | 578 | let star_args ~docstring = Star_args docstring 579 | let star_kwargs ~docstring = Star_kwargs docstring 580 | 581 | let kind_to_string : type a b. (a, b) Bigarray.kind -> string = function 582 | | Float32 -> "np.float32" 583 | | Float64 -> "np.float64" 584 | | Int8_unsigned -> "np.uint8" 585 | | Int8_signed -> "np.int8" 586 | | Int16_unsigned -> "np.uint16" 587 | | Int16_signed -> "np.int16" 588 | | Int32 -> "np.int32" 589 | | Int64 -> "np.int64" 590 | | Int -> "np.int" 591 | | Char -> "np.byte" 592 | | Nativeint -> "np.int" 593 | | Complex32 -> "np.complex32" 594 | | Complex64 -> "np.complex64" 595 | ;; 596 | 597 | let layout_to_string : type c. c Bigarray.layout -> string = function 598 | | C_layout -> "C" 599 | | Fortran_layout -> "F" 600 | ;; 601 | 602 | let to_numpy_array ?dims kind layout p = 603 | if not (Py.Object.is_instance p (Py.Array.pyarray_type ())) 604 | then value_errorf "expected a numpy array, got %s" (Py.Type.get p |> Py.Type.name); 605 | let bigarray = Numpy.to_bigarray kind layout p in 606 | Option.iter dims ~f:(fun dims -> 607 | let num_dims = Bigarray.Genarray.num_dims bigarray in 608 | if dims <> num_dims 609 | then value_errorf "expected a numpy array with %d dims, got %d" dims num_dims); 610 | bigarray 611 | ;; 612 | 613 | let numpy_type_name ?dims kind layout = 614 | Printf.sprintf 615 | "np.array(dtype=%s, order='%s'%s)" 616 | (kind_to_string kind) 617 | (layout_to_string layout) 618 | (Option.value_map dims ~default:"" ~f:(Printf.sprintf ", dims=%d")) 619 | ;; 620 | 621 | let numpy_array kind layout = 622 | Of_python.create 623 | ~type_name:(numpy_type_name kind layout) 624 | ~conv:(to_numpy_array kind layout) 625 | ;; 626 | 627 | let numpy_array1 kind layout = 628 | Of_python.create ~type_name:(numpy_type_name ~dims:1 kind layout) ~conv:(fun p -> 629 | to_numpy_array ~dims:1 kind layout p |> Bigarray.array1_of_genarray) 630 | ;; 631 | 632 | let numpy_array2 kind layout = 633 | Of_python.create ~type_name:(numpy_type_name ~dims:2 kind layout) ~conv:(fun p -> 634 | to_numpy_array ~dims:2 kind layout p |> Bigarray.array2_of_genarray) 635 | ;; 636 | 637 | let numpy_array3 kind layout = 638 | Of_python.create ~type_name:(numpy_type_name ~dims:3 kind layout) ~conv:(fun p -> 639 | to_numpy_array ~dims:3 kind layout p |> Bigarray.array3_of_genarray) 640 | ;; 641 | 642 | let array_of_bigarray (kind : _ Bigarray.kind) to_array_value = 643 | numpy_array1 kind C_layout 644 | |> map ~f:(fun bigarray -> 645 | Array.init (Bigarray.Array1.dim bigarray) ~f:(fun i -> 646 | (* [unsafe_get] should be safe here, but not opting for it because pyocaml is not 647 | performance critical *) 648 | Bigarray.Array1.get bigarray i |> to_array_value)) 649 | ;; 650 | 651 | let int_numpy_array_1d_arg = 652 | let nativeint = array_of_bigarray Nativeint Nativeint.to_int_exn in 653 | let int64 = array_of_bigarray Int64 Int64.to_int_exn in 654 | let int32 = array_of_bigarray Int32 Int32.to_int_exn in 655 | choice' (choice' nativeint int64) int32 656 | ;; 657 | 658 | let float_numpy_array_1d_arg = 659 | let float64 = array_of_bigarray Float64 Fn.id in 660 | let float32 = array_of_bigarray Float32 Fn.id in 661 | choice' float64 float32 662 | ;; 663 | 664 | let int_sequence_arg = choice' int_numpy_array_1d_arg (array_or_iter int) 665 | let float_sequence_arg = choice' float_numpy_array_1d_arg (array_or_iter float) 666 | 667 | let%expect_test "test positional argument" = 668 | if Py.is_initialized () |> not then Py.initialize (); 669 | let defunc = 670 | let open Let_syntax in 671 | let%map a1 = positional_only "a1" int ~docstring:"positional a1" in 672 | fun () -> a1 673 | in 674 | apply defunc [| Py.Int.of_int 1 |] Core.String.Map.empty 675 | |> Int.to_string 676 | |> Core.print_endline; 677 | [%expect {| 1 |}]; 678 | (* too many positional arguments *) 679 | Expect_test_helpers_base.require_does_raise [%here] (fun () -> 680 | let _result = apply defunc [| Py.Int.of_int 1; Py.none |] Core.String.Map.empty in 681 | ()); 682 | [%expect {| ("Pyml__Py.Err(24, \"expected 1 arguments (a1), got 2\")") |}]; 683 | (* passed in a keyword argument *) 684 | Expect_test_helpers_base.require_does_raise [%here] (fun () -> 685 | let _result = apply defunc [||] (Core.String.Map.singleton "a1" Py.none) in 686 | ()); 687 | [%expect {| ("Pyml__Py.Err(24, \"not enough arguments (got 0, expected a1)\")") |}] 688 | ;; 689 | 690 | let%expect_test "test keyword argument" = 691 | if Py.is_initialized () |> not then Py.initialize (); 692 | let defunc = 693 | let open Let_syntax in 694 | let%map a1 = keyword "a1" int ~docstring:"keyword a1" in 695 | fun () -> a1 696 | in 697 | apply defunc [||] (Core.String.Map.singleton "a1" (Py.Int.of_int 1)) 698 | |> Int.to_string 699 | |> Core.print_endline; 700 | [%expect {| 1 |}]; 701 | (* too many keyword arguments *) 702 | Expect_test_helpers_base.require_does_raise [%here] (fun () -> 703 | let _result = 704 | apply 705 | defunc 706 | [||] 707 | (Core.String.Map.of_alist_exn [ "a1", Py.Int.of_int 1; "a2", Py.none ]) 708 | in 709 | ()); 710 | [%expect {| ("Pyml__Py.Err(24, \"unexpected keyword argument a2\")") |}]; 711 | (* passed in a positional argument *) 712 | Expect_test_helpers_base.require_does_raise [%here] (fun () -> 713 | let _result = apply defunc [| Py.none |] Core.String.Map.empty in 714 | ()); 715 | [%expect {| ("Pyml__Py.Err(24, \"missing keyword argument: a1\")") |}] 716 | ;; 717 | 718 | let%expect_test "test positional-or-keyword docstring" = 719 | if Py.is_initialized () |> not then Py.initialize (); 720 | (* Common use-cases *) 721 | let defunc = 722 | let open Let_syntax in 723 | let%map a1 = positional_only "a1" int ~docstring:"positional a1" 724 | and a2 = positional_or_keyword "a2" int ~docstring:"positional-or-keyword a2" 725 | and a3 = positional_or_keyword "a3" int ~docstring:"positional-or-keyword a3" 726 | and a4 = keyword "a4" int ~docstring:"keyword a4" in 727 | fun () -> ([ a1; a2; a3; a4 ] : int list) |> ignore 728 | in 729 | (* docstring *) 730 | params_docstring defunc |> Core.print_endline; 731 | [%expect 732 | {| 733 | :param a1: (positional 0) positional a1 734 | :type a1: int 735 | 736 | :param a2: (positional 1 or keyword) (mandatory) positional-or-keyword a2 737 | :type a2: int 738 | 739 | :param a3: (positional 2 or keyword) (mandatory) positional-or-keyword a3 740 | :type a3: int 741 | 742 | :param a4: (mandatory keyword) keyword a4 743 | :type a4: int 744 | |}] 745 | ;; 746 | 747 | let%expect_test "test positional-or-keyword argument" = 748 | if Py.is_initialized () |> not then Py.initialize (); 749 | (* Common use-cases *) 750 | let defunc = 751 | let open Let_syntax in 752 | let%map a1 = positional_only "a1" int ~docstring:"positional a1" 753 | and a2 = positional_or_keyword "a2" int ~docstring:"positional-or-keyword a2" 754 | and a3 = keyword "a3" int ~docstring:"keyword a3" 755 | and star_args = star_args ~docstring:"star_args" 756 | and star_kwargs = star_kwargs ~docstring:"star_kwargs" in 757 | fun () -> 758 | let star_args = 759 | List.map ~f:Py.Object.to_string star_args 760 | |> sexp_of_list sexp_of_string 761 | |> Sexp.to_string 762 | in 763 | let star_kwargs = 764 | Map.map ~f:Py.Object.to_string star_kwargs 765 | |> Core.String.Map.sexp_of_t sexp_of_string 766 | |> Sexp.to_string 767 | in 768 | Core.print_endline 769 | [%string "%{a1#Int} %{a2#Int} %{a3#Int} %{star_args} %{star_kwargs}"] 770 | in 771 | (* as positional *) 772 | apply 773 | defunc 774 | [| Py.Int.of_int 1; Py.Int.of_int 2; Py.Int.of_int 4 |] 775 | (Core.String.Map.singleton "a3" (Py.Int.of_int 3)); 776 | [%expect {| 1 2 3 (4) () |}]; 777 | (* as keyword *) 778 | apply 779 | defunc 780 | [| Py.Int.of_int 1 |] 781 | (Core.String.Map.of_alist_exn 782 | [ "a2", Py.Int.of_int 2; "a3", Py.Int.of_int 3; "a5", Py.Int.of_int 5 ]); 783 | [%expect {| 1 2 3 () ((a5 5)) |}] 784 | ;; 785 | 786 | let%expect_test "test positional-or-keyword optional argument" = 787 | if Py.is_initialized () |> not then Py.initialize (); 788 | (* Common use-cases *) 789 | let defunc = 790 | let open Let_syntax in 791 | let%map a1 = positional_only "a1" int ~docstring:"positional a1" 792 | and a2 = 793 | positional_or_keyword "a2" int ~default:22 ~docstring:"positional-or-keyword a2" 794 | and a3 = keyword "a3" int ~docstring:"keyword a3" 795 | and star_args = star_args ~docstring:"star_args" 796 | and star_kwargs = star_kwargs ~docstring:"star_kwargs" in 797 | fun () -> 798 | let star_args = 799 | List.map ~f:Py.Object.to_string star_args 800 | |> sexp_of_list sexp_of_string 801 | |> Sexp.to_string 802 | in 803 | let star_kwargs = 804 | Map.map ~f:Py.Object.to_string star_kwargs 805 | |> Core.String.Map.sexp_of_t sexp_of_string 806 | |> Sexp.to_string 807 | in 808 | Core.print_endline 809 | [%string "%{a1#Int} %{a2#Int} %{a3#Int} %{star_args} %{star_kwargs}"] 810 | in 811 | (* as positional *) 812 | apply 813 | defunc 814 | [| Py.Int.of_int 1; Py.Int.of_int 2; Py.Int.of_int 4 |] 815 | (Core.String.Map.singleton "a3" (Py.Int.of_int 3)); 816 | [%expect {| 1 2 3 (4) () |}]; 817 | (* as keyword *) 818 | apply 819 | defunc 820 | [| Py.Int.of_int 1 |] 821 | (Core.String.Map.of_alist_exn 822 | [ "a2", Py.Int.of_int 2; "a3", Py.Int.of_int 3; "a5", Py.Int.of_int 5 ]); 823 | [%expect {| 1 2 3 () ((a5 5)) |}]; 824 | (* as default *) 825 | apply defunc [| Py.Int.of_int 1 |] (Core.String.Map.singleton "a3" (Py.Int.of_int 3)); 826 | [%expect {| 1 22 3 () () |}]; 827 | (* docstring *) 828 | params_docstring defunc |> Core.print_endline; 829 | [%expect 830 | {| 831 | :param a1: (positional 0) positional a1 832 | :type a1: int 833 | 834 | :param a2: (positional 1 or keyword) (with default) positional-or-keyword a2 835 | :type a2: int 836 | 837 | :param a3: (mandatory keyword) keyword a3 838 | :type a3: int 839 | 840 | :param args: (variadic args) star_args 841 | 842 | :param kwargs: star_kwargs 843 | |}] 844 | ;; 845 | 846 | let%expect_test "test positional-or-keyword argument (out-of-order special case)" = 847 | if Py.is_initialized () |> not then Py.initialize (); 848 | (* Success only when there are enough positional arguments *) 849 | let defunc = 850 | let open Let_syntax in 851 | let%map a1 = positional_only "a1" int ~docstring:"positional a1" 852 | and a2 = positional_or_keyword "a2" int ~docstring:"positional-or-keyword a2" 853 | and a3 = positional_only "a3" int ~docstring:"positional a3" in 854 | fun () -> Core.print_endline [%string "%{a1#Int} %{a2#Int} %{a3#Int}"] 855 | in 856 | apply 857 | defunc 858 | [| Py.Int.of_int 1; Py.Int.of_int 2; Py.Int.of_int 3 |] 859 | Core.String.Map.empty; 860 | [%expect {| 1 2 3 |}] 861 | ;; 862 | 863 | let%expect_test "test positional-or-keyword argument (priority)" = 864 | if Py.is_initialized () |> not then Py.initialize (); 865 | (* positional argument prioritizes *) 866 | let defunc = 867 | let open Let_syntax in 868 | let%map a1 = positional_only "a1" int ~docstring:"positional a1" 869 | and a2 = positional_or_keyword "a2" int ~docstring:"positional-or-keyword a2" 870 | and a3 = positional_only "a3" int ~docstring:"positional a3" in 871 | fun () -> Core.print_endline [%string "%{a1#Int} %{a2#Int} %{a3#Int}"] 872 | in 873 | Expect_test_helpers_base.require_does_raise [%here] (fun () -> 874 | apply 875 | defunc 876 | [| Py.Int.of_int 1; Py.Int.of_int 2; Py.Int.of_int 3 |] 877 | (Core.String.Map.singleton "a2" (Py.Int.of_int 4))); 878 | [%expect 879 | {| ("Pyml__Py.Err(24, \"keyword argument 'a2' already set by positional argument\")") |}] 880 | ;; 881 | 882 | let%expect_test "test positional-or-keyword argument (name conflict)" = 883 | if Py.is_initialized () |> not then Py.initialize (); 884 | (* name conflict *) 885 | (let defunc = 886 | let open Let_syntax in 887 | let%map a1 = positional_only "a1" int ~docstring:"positional a1" 888 | and a2 = positional_or_keyword "a2" int ~docstring:"positional-or-keyword a2" 889 | and a2_kw = keyword "a2" int ~docstring:"keyword a2" in 890 | fun () -> Core.print_endline [%string "%{a1#Int} %{a2#Int} %{a2_kw#Int}"] 891 | in 892 | Expect_test_helpers_base.require_does_raise [%here] (fun () -> 893 | apply 894 | defunc 895 | [| Py.Int.of_int 1; Py.Int.of_int 2; Py.Int.of_int 3 |] 896 | (Core.String.Map.singleton "a2" (Py.Int.of_int 4)))); 897 | [%expect {| ("Pyml__Py.Err(24, \"multiple keyword arguments with name a2\")") |}]; 898 | (* name conflict: different order of arguments *) 899 | let defunc = 900 | let open Let_syntax in 901 | let%map a1 = positional_only "a1" int ~docstring:"positional a1" 902 | and a2_kw = keyword "a2" int ~docstring:"keyword a2" 903 | and a2 = positional_or_keyword "a2" int ~docstring:"positional-or-keyword a2" in 904 | fun () -> Core.print_endline [%string "%{a1#Int} %{a2#Int} %{a2_kw#Int}"] 905 | in 906 | Expect_test_helpers_base.require_does_raise [%here] (fun () -> 907 | apply 908 | defunc 909 | [| Py.Int.of_int 1; Py.Int.of_int 2; Py.Int.of_int 3 |] 910 | (Core.String.Map.singleton "a2" (Py.Int.of_int 4))); 911 | [%expect {| ("Pyml__Py.Err(24, \"multiple keyword arguments with name a2\")") |}]; 912 | (* name conflict: kwarg which is duplicated is not set *) 913 | let defunc = 914 | let open Let_syntax in 915 | let%map a1 = positional_only "a1" int ~docstring:"positional a1" 916 | and a2 = positional_or_keyword "a2" int ~docstring:"positional-or-keyword a2" 917 | and a2_kw = keyword "a2" int ~docstring:"keyword a2" in 918 | fun () -> Core.print_endline [%string "%{a1#Int} %{a2#Int} %{a2_kw#Int}"] 919 | in 920 | Expect_test_helpers_base.require_does_raise [%here] (fun () -> 921 | apply defunc [| Py.Int.of_int 1; Py.Int.of_int 2 |] Core.String.Map.empty); 922 | [%expect {| ("Pyml__Py.Err(24, \"multiple keyword arguments with name a2\")") |}]; 923 | (* name conflict: kwarg with default which is duplicated is not set *) 924 | let defunc = 925 | let open Let_syntax in 926 | let%map a1 = positional_only "a1" int ~docstring:"positional a1" 927 | and a2 = positional_or_keyword "a2" int ~docstring:"positional-or-keyword a2" 928 | and a2_kw = keyword "a2" int ~docstring:"keyword a2" ~default:2 in 929 | fun () -> Core.print_endline [%string "%{a1#Int} %{a2#Int} %{a2_kw#Int}"] 930 | in 931 | Expect_test_helpers_base.require_does_raise [%here] (fun () -> 932 | apply defunc [| Py.Int.of_int 1; Py.Int.of_int 2 |] Core.String.Map.empty); 933 | [%expect {| ("Pyml__Py.Err(24, \"multiple keyword arguments with name a2\")") |}] 934 | ;; 935 | end 936 | -------------------------------------------------------------------------------- /src/defunc.mli: -------------------------------------------------------------------------------- 1 | open Base 2 | open Import 3 | 4 | type _ t 5 | 6 | module Of_python : sig 7 | type 'a t = private 8 | { type_name : string 9 | ; conv : pyobject -> 'a 10 | } 11 | 12 | val create : type_name:string -> conv:(pyobject -> 'a) -> 'a t 13 | 14 | (** [map t ~f] has the same [type_name] as [t]. *) 15 | val map : 'a t -> f:('a -> 'b) -> 'b t 16 | end 17 | 18 | include Applicative.S with type 'a t := 'a t 19 | include Applicative.Let_syntax with type 'a t := 'a t 20 | 21 | val params_docstring : ?docstring:string -> 'a t -> string 22 | val no_arg : (unit -> 'a) -> 'a t 23 | 24 | (* Be cautious when using [apply_] that it does not ensure that all the parameters 25 | have been used *before* evaluating the wrapped function. *) 26 | val apply_ 27 | : 'a t 28 | -> pyobject array 29 | -> (string, pyobject, String.comparator_witness) Map.t 30 | -> 'a 31 | 32 | val apply 33 | : (unit -> 'a) t 34 | -> pyobject array 35 | -> (string, pyobject, String.comparator_witness) Map.t 36 | -> 'a 37 | 38 | module Param : sig 39 | (** [choice x y] first attempts conversion using x.conv. if that fails, it attempts y.conv *) 40 | val choice : 'a Of_python.t -> 'b Of_python.t -> ('a, 'b) Either.t Of_python.t 41 | 42 | val choice' : 'a Of_python.t -> 'a Of_python.t -> 'a Of_python.t 43 | val map : 'a Of_python.t -> f:('a -> 'b) -> 'b Of_python.t 44 | val positional_only : string -> 'a Of_python.t -> docstring:string -> 'a t 45 | 46 | val positional_or_keyword 47 | : ?default:'a 48 | -> string 49 | -> 'a Of_python.t 50 | -> docstring:string 51 | -> 'a t 52 | 53 | val keyword : ?default:'a -> string -> 'a Of_python.t -> docstring:string -> 'a t 54 | val int : int Of_python.t 55 | 56 | (** [int_sequence_arg] converts integer sequences in a fast way if possible, e.g. going 57 | via numpy and bigarray if possible *) 58 | val int_sequence_arg : int array Of_python.t 59 | 60 | val float : float Of_python.t 61 | 62 | (** [float_sequence_arg] converts float sequences in a fast way if possible, e.g. going 63 | via numpy and bigarray if possible *) 64 | val float_sequence_arg : float array Of_python.t 65 | 66 | val bool : bool Of_python.t 67 | val char : char Of_python.t 68 | val string : string Of_python.t 69 | val callable : (pyobject array -> pyobject) Of_python.t 70 | val path : string Of_python.t 71 | val typerep : 'a Typerep_lib.Std.Typerep.t -> 'a Of_python.t 72 | 73 | (** WARNING: Do not use [pyobject] together with [Broadcast.t] - if you do, every value 74 | passed to the relevant python argument will be interpreted as a constant for the 75 | purposes of the broadcast, even if the value is a list or pandas series, which is 76 | probably not what you want. *) 77 | val pyobject : pyobject Of_python.t 78 | 79 | val pair : 'a Of_python.t -> 'b Of_python.t -> ('a * 'b) Of_python.t 80 | 81 | val triple 82 | : 'a Of_python.t 83 | -> 'b Of_python.t 84 | -> 'c Of_python.t 85 | -> ('a * 'b * 'c) Of_python.t 86 | 87 | val quadruple 88 | : 'a Of_python.t 89 | -> 'b Of_python.t 90 | -> 'c Of_python.t 91 | -> 'd Of_python.t 92 | -> ('a * 'b * 'c * 'd) Of_python.t 93 | 94 | val quintuple 95 | : 'a Of_python.t 96 | -> 'b Of_python.t 97 | -> 'c Of_python.t 98 | -> 'd Of_python.t 99 | -> 'e Of_python.t 100 | -> ('a * 'b * 'c * 'd * 'e) Of_python.t 101 | 102 | val option : 'a Of_python.t -> 'a option Of_python.t 103 | val list : 'a Of_python.t -> 'a list Of_python.t 104 | val array_or_iter : 'a Of_python.t -> 'a array Of_python.t 105 | val list_or_iter : 'a Of_python.t -> 'a list Of_python.t 106 | 107 | (* 'a should not be encoded as a python tuple, list or none. *) 108 | val one_or_tuple_or_list : 'a Of_python.t -> 'a list Of_python.t 109 | 110 | (* [one_or_tuple_or_list_relaxed] can be used to allow individual items in a list to 111 | be invalid. *) 112 | val one_or_tuple_or_list_relaxed : 'a Of_python.t -> 'a Or_error.t list Of_python.t 113 | val with_broadcast : 'a Of_python.t -> arg_name:string -> 'a Broadcast.t Of_python.t 114 | 115 | val positional_or_keyword_broadcast 116 | : string 117 | -> 'a Of_python.t 118 | -> docstring:string 119 | -> 'a Broadcast.t t 120 | 121 | (** Convenience wrapper around [keyword] and [with_broadcast] that ensures the same 122 | [arg_name] is passed to each. *) 123 | val keyword_broadcast 124 | : ?default:'a 125 | -> string 126 | -> 'a Of_python.t 127 | -> docstring:string 128 | -> 'a Broadcast.t t 129 | 130 | val keyword_opt_broadcast 131 | : string 132 | -> 'a Of_python.t 133 | -> docstring:string 134 | -> 'a Broadcast.t option t 135 | 136 | (** Works just like [keyword_opt_broadcast] but uses [keyword] instead of [keyword_opt], 137 | which is deprecated. In practice, this means that this will treat [None] the same as 138 | not passing in the arg, instead of failing. *) 139 | val keyword_opt_broadcast' 140 | : string 141 | -> 'a Of_python.t 142 | -> docstring:string 143 | -> 'a Broadcast.t option t 144 | 145 | val dict : key:'a Of_python.t -> value:'b Of_python.t -> ('a * 'b) list Of_python.t 146 | val star_args : docstring:string -> pyobject list t 147 | 148 | val star_kwargs 149 | : docstring:string 150 | -> (string, pyobject, String.comparator_witness) Map.t t 151 | 152 | (* A numpy array, note that the memory is shared between the ocaml and python sides. *) 153 | val numpy_array 154 | : ('a, 'b) Bigarray.kind 155 | -> 'c Bigarray.layout 156 | -> ('a, 'b, 'c) Bigarray.Genarray.t Of_python.t 157 | 158 | val numpy_array1 159 | : ('a, 'b) Bigarray.kind 160 | -> 'c Bigarray.layout 161 | -> ('a, 'b, 'c) Bigarray.Array1.t Of_python.t 162 | 163 | val numpy_array2 164 | : ('a, 'b) Bigarray.kind 165 | -> 'c Bigarray.layout 166 | -> ('a, 'b, 'c) Bigarray.Array2.t Of_python.t 167 | 168 | val numpy_array3 169 | : ('a, 'b) Bigarray.kind 170 | -> 'c Bigarray.layout 171 | -> ('a, 'b, 'c) Bigarray.Array3.t Of_python.t 172 | end 173 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name python_lib) 3 | (public_name pythonlib) 4 | (libraries base core expect_test_helpers_core.expect_test_helpers_base 5 | compiler-libs.common pyml stdio typerep) 6 | (preprocess 7 | (pps ppx_bin_prot ppx_compare ppx_expect ppx_here ppx_let ppx_python 8 | ppx_sexp_conv ppx_string))) 9 | 10 | (ocamllex type_lexer) 11 | 12 | (ocamlyacc type_parser) 13 | -------------------------------------------------------------------------------- /src/import.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Poly 3 | include Ppx_python_runtime 4 | 5 | type pyobject = Pytypes.pyobject 6 | 7 | let python_of_pyobject = Fn.id 8 | let pyobject_of_python = Fn.id 9 | 10 | let py_list_to_container_map_safe f pyobject ~container_init = 11 | (* Use [Py.Sequence] rather than [Py.List] so that this works on both 12 | tuples and lists. *) 13 | container_init (Py.Sequence.length pyobject) ~f:(fun i -> 14 | Py.Sequence.get_item pyobject i |> Py.check_not_null |> f) 15 | ;; 16 | 17 | let py_list_to_list_map_safe f pyobject = 18 | py_list_to_container_map_safe f pyobject ~container_init:(List.init :> _ -> f:_ -> _) 19 | ;; 20 | 21 | let py_list_to_array_map_safe f pyobject = 22 | py_list_to_container_map_safe f pyobject ~container_init:(Array.init :> _ -> f:_ -> _) 23 | ;; 24 | 25 | module Of_pythonable (Pythonable : sig 26 | type t [@@deriving python] 27 | end) 28 | (Conv : sig 29 | type pythonable 30 | type t 31 | 32 | val to_pythonable : t -> pythonable 33 | val of_pythonable : pythonable -> t 34 | end 35 | with type pythonable := Pythonable.t) : sig 36 | type t [@@deriving python] 37 | end 38 | with type t := Conv.t = struct 39 | let python_of_t t = Conv.to_pythonable t |> Pythonable.python_of_t 40 | let t_of_python pyobject = Pythonable.t_of_python pyobject |> Conv.of_pythonable 41 | end 42 | 43 | module Convert_as_string (M : Stringable.S) = struct 44 | let python_of_t t = M.to_string t |> python_of_string 45 | let t_of_python p = string_of_python p |> M.of_string 46 | end 47 | 48 | let get_class p = 49 | Option.bind (Py.Object.get_attr_string p "__class__") ~f:(fun cls -> 50 | Option.map (Py.Object.get_attr_string cls "__name__") ~f:Py.String.to_string) 51 | ;; 52 | 53 | let get_class_exn p = 54 | (* In theory, this should never raise as all python objects have a "__class__" 55 | attribute. *) 56 | let cls = Py.Object.find_attr_string p "__class__" in 57 | Py.Object.find_attr_string cls "__name__" |> Py.String.to_string 58 | ;; 59 | 60 | let value_error str = raise (Py.Err (ValueError, str)) 61 | let value_errorf fmt = Printf.ksprintf value_error fmt 62 | 63 | let get_from_builtins = 64 | let cache = Hashtbl.create (module String) in 65 | fun str -> 66 | Hashtbl.find_or_add cache str ~default:(fun () -> 67 | match Py.Module.get (Py.Eval.get_builtins ()) str with 68 | | pyobject -> pyobject 69 | (* In some very specific conditions, the builtins module may contain some objects that 70 | are not in __main__.__builtins__, e.g. when using the %run macro in an 71 | ipython kernel. 72 | *) 73 | | exception _ -> Py.Module.get (Py.import "builtins") str) 74 | ;; 75 | 76 | module One_or_tuple = struct 77 | (* 'a should not be encoded as a python tuple or none! *) 78 | type 'a t = 'a list 79 | 80 | let python_of_t python_of_a t = 81 | match t with 82 | | [] -> Py.none 83 | | [ v ] -> python_of_a v 84 | | vs -> Py.Tuple.of_list_map python_of_a vs 85 | ;; 86 | 87 | let t_of_python a_of_python p = 88 | try [ a_of_python p ] with 89 | | _ -> 90 | if p = Py.none 91 | then [] 92 | else if Py.Tuple.check p 93 | then Py.Tuple.to_list_map a_of_python p 94 | else failwith "incorrect python type" 95 | ;; 96 | end 97 | 98 | let to_list p = 99 | let list = get_from_builtins "list" in 100 | Py.Object.call_function_obj_args list [| p |] 101 | ;; 102 | 103 | let iterable_to_list p = 104 | if Py.List.check p 105 | then Some p 106 | else ( 107 | match get_class p with 108 | | Some "Series" -> 109 | (* [Py.List.to_list] assumes the python object to follow the 110 | PySequence[1] protocol. Most importantly, it expects the python object 111 | to implement the PySequence_GetItem[2] C function which is used to 112 | access individual elements. 113 | 114 | [Py.List.to_list] fails for a Series object that is sliced to represent a non 115 | contiguous layout (such as by doing series[::2] in python). Because a pandas 116 | Series object does not follow the PySequence protocol, we cannot use the 117 | [Py.List] module to access its individual elements or iterate over it. Even in 118 | Python, we cannot use the construct series[i] (where i is the index) to access 119 | its individual elements. The recommended way to access individual elements in 120 | Python is to use its [iloc] or [at] attributes. 121 | 122 | It may help to know that iterating over sequence in python using the [for ... in 123 | ...] syntax works by first obtaining an iterator to that sequence using the 124 | python builtin function [iter]. 125 | 126 | In OCaml, we can similarly use the [Py.Iter] module to iterate over the Series 127 | object, if we first obtain an iterator to it, using [Py.Object.get_iter]. This is 128 | one way we can interface with a pandas Series in OCaml. Some other alternatives 129 | include: 130 | 131 | 1. converting to a python list (using the [Series.tolist] method) 132 | 2. converting to a numpy array (using the [Series.to_numpy] method) 133 | 3. converting to a pandas array (using the [Series.array] attribute) 134 | 135 | Our profiling results (as of Dec 4, 2019) indicate that converting to a python 136 | list is ~60% faster than converting to a numpy array (next best alternative). 137 | 138 | It was interesting to observe that [Py.List.to_list] works as expected for a 139 | Series that is not sliced. But fails for sliced series with non contiguous 140 | elements. However, for correctness guarantees and performance reasons, we went 141 | ahead with converting the series to a python list before calling 142 | [Py.List.to_list_map]. 143 | 144 | References: 145 | 146 | [1] https://docs.python.org/3.6/c-api/sequence.html 147 | [2] https://docs.python.org/3.6/c-api/sequence.html#c.PySequence_GetItem 148 | [3] https://github.com/pandas-dev/pandas/issues/30042 149 | *) 150 | let p = Py.Module.get_function_with_keywords p "tolist" [||] [] in 151 | Some p 152 | | Some "ndarray" -> 153 | let p = Py.Module.get_function_with_keywords p "tolist" [||] [] in 154 | Some p 155 | | Some "range" -> to_list p |> Option.some 156 | | _ -> if Py.Iter.check p then to_list p |> Option.some else None) 157 | ;; 158 | 159 | module One_or_tuple_or_list = struct 160 | (* 'a should not be encoded as a python tuple, list or none! *) 161 | type 'a t = 'a list 162 | 163 | let python_of_t = One_or_tuple.python_of_t 164 | 165 | let t_of_python a_of_python p = 166 | try One_or_tuple.t_of_python a_of_python p with 167 | | _ -> 168 | (match iterable_to_list p with 169 | | Some l -> py_list_to_list_map_safe a_of_python l 170 | | None -> failwith "incorrect python type") 171 | ;; 172 | end 173 | 174 | module Or_error_python = struct 175 | type 'a t = 'a Or_error.t 176 | 177 | let value_error_obj str = 178 | let value_error = get_from_builtins "ValueError" in 179 | Py.Object.call_function_obj_args value_error [| python_of_string str |] 180 | ;; 181 | 182 | let of_error pyobject = 183 | let pyexception = get_from_builtins "Exception" in 184 | if Py.Object.is_instance pyobject pyexception 185 | then 186 | Option.value_exn 187 | ~message:"no args field on python exception" 188 | (Py.Object.get_attr_string pyobject "args") 189 | |> list_of_python Py.Object.to_string 190 | |> String.concat ~sep:", " 191 | |> Option.some 192 | else None 193 | ;; 194 | 195 | let t_of_python ok_of_python p = 196 | match of_error p with 197 | | Some error -> Or_error.error_string error 198 | | None -> 199 | (match ok_of_python p with 200 | | v -> Ok v 201 | | exception exn -> Or_error.of_exn exn) 202 | ;; 203 | 204 | let python_of_t python_of_a t = 205 | match t with 206 | | Ok a -> python_of_a a 207 | | Error err -> Error.to_string_hum err |> value_error_obj 208 | ;; 209 | end 210 | 211 | module One_or_tuple_or_list_or_error = struct 212 | type 'a t = 'a Or_error_python.t list 213 | 214 | let python_of_t = One_or_tuple_or_list.python_of_t 215 | 216 | let t_of_python a_of_python p ~type_name = 217 | match One_or_tuple.t_of_python a_of_python p with 218 | | v -> List.map v ~f:(fun v -> Ok v) 219 | | exception _ -> 220 | (match iterable_to_list p with 221 | | Some p -> 222 | py_list_to_list_map_safe 223 | (fun p -> 224 | Or_error_python.t_of_python a_of_python p 225 | |> Or_error.tag ~tag:("trying to parse as " ^ type_name)) 226 | p 227 | | None -> failwith "incorrect python type") 228 | ;; 229 | end 230 | 231 | let python_print str = 232 | let print = get_from_builtins "print" in 233 | Py.Object.call_function_obj_args print [| Py.String.of_string str |] 234 | |> (ignore : pyobject -> unit) 235 | ;; 236 | 237 | let python_printf fmt = Printf.ksprintf python_print fmt 238 | 239 | let python_eprint str = 240 | let print = get_from_builtins "print" in 241 | let stderr = Py.Module.get (Py.import "sys") "stderr" in 242 | Py.Callable.to_function_with_keywords 243 | print 244 | [| Py.String.of_string str |] 245 | [ "file", stderr ] 246 | |> (ignore : pyobject -> unit) 247 | ;; 248 | 249 | let python_eprintf fmt = Printf.ksprintf python_eprint fmt 250 | let builtins = lazy (Py.Module.builtins ()) 251 | let pandas = lazy (Py.Import.import_module_opt "pandas") 252 | let numpy = lazy (Py.Import.import_module_opt "numpy") 253 | let datetime = lazy (Py.Import.import_module "datetime") 254 | let pathlib = lazy (Py.Import.import_module "pathlib") 255 | let path_cls = lazy (Py.Module.get (Lazy.force pathlib) "Path") 256 | let pyarrow = lazy (Py.Import.import_module_opt "pyarrow") 257 | 258 | let%test_module _ = 259 | (module struct 260 | let () = if not (Py.is_initialized ()) then Py.initialize () 261 | 262 | let does_not_exist = 263 | lazy (Py.Import.import_module_opt "does_not_exist_no_really_240206") 264 | ;; 265 | 266 | let%test "Py.Import.import_module_opt on a non-existing module" = 267 | match Lazy.force does_not_exist with 268 | | None -> true 269 | | Some (_ : pyobject) -> false 270 | ;; 271 | 272 | let%test "pathlib can be loaded" = 273 | let (_ : pyobject) = Lazy.force pathlib in 274 | true 275 | ;; 276 | 277 | let%test "Loading pandas doesn't raise" = 278 | match Lazy.force pandas with 279 | | None -> true 280 | | Some (_ : pyobject) -> true 281 | ;; 282 | end) 283 | ;; 284 | 285 | let pd_series = 286 | lazy (Lazy.force pandas |> Option.map ~f:(fun pd -> Py.Module.get pd "Series")) 287 | ;; 288 | 289 | let pd_dataframe = 290 | lazy (Lazy.force pandas |> Option.map ~f:(fun pd -> Py.Module.get pd "DataFrame")) 291 | ;; 292 | 293 | let issue_deprecation_warning msg = 294 | let warnings = Py.Import.import_module "warnings" in 295 | let deprecation_warning = get_from_builtins "DeprecationWarning" in 296 | let (_ : pyobject) = 297 | Py.Module.get_function warnings "warn" [| python_of_string msg; deprecation_warning |] 298 | in 299 | () 300 | ;; 301 | -------------------------------------------------------------------------------- /src/module_env.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | module Path : sig 4 | type t 5 | 6 | val empty : t 7 | val append : t -> string -> t 8 | val names : t -> string list 9 | end = struct 10 | type t = string list 11 | 12 | let empty = [] 13 | let append t v = v :: t 14 | let names t = List.rev t 15 | end 16 | 17 | type t = 18 | { path : Path.t 19 | ; types : unit Ident.Tbl.t 20 | ; modules : unit Ident.Tbl.t 21 | ; parent : t option 22 | } 23 | 24 | let path t = t.path 25 | 26 | let create () = 27 | { path = Path.empty 28 | ; types = Ident.Tbl.create 4 29 | ; modules = Ident.Tbl.create 4 30 | ; parent = None 31 | } 32 | ;; 33 | 34 | let enter_module t ~module_ident = 35 | let module_t = 36 | { path = Path.append t.path (Ident.name module_ident) 37 | ; types = Ident.Tbl.create 4 38 | ; modules = Ident.Tbl.create 4 39 | ; parent = Some t 40 | } 41 | in 42 | Ident.Tbl.replace t.modules module_ident (); 43 | module_t 44 | ;; 45 | 46 | let add_type t ~type_ident = Ident.Tbl.replace t.types type_ident () 47 | 48 | let find_type t ~type_ident = 49 | let rec walk t = 50 | if Ident.Tbl.mem t.types type_ident 51 | then Some t.path 52 | else ( 53 | match t.parent with 54 | | None -> None 55 | | Some parent -> walk parent) 56 | in 57 | walk t 58 | ;; 59 | 60 | let find_module t ~module_ident = 61 | let rec walk t = 62 | if Ident.Tbl.mem t.modules module_ident 63 | then Some t.path 64 | else ( 65 | match t.parent with 66 | | None -> None 67 | | Some parent -> walk parent) 68 | in 69 | walk t 70 | ;; 71 | 72 | let%expect_test "module-env" = 73 | let path_to_string path = Path.names path |> String.concat ~sep:"." in 74 | let t = create () in 75 | let ident_t = Ident.create_local "t" in 76 | let ident_t2 = Ident.create_local "t" in 77 | let ident_u = Ident.create_local "u" in 78 | let ident_v = Ident.create_local "v" in 79 | let ident_w = Ident.create_local "w" in 80 | let module_ident = Ident.create_local "module-ident" in 81 | add_type t ~type_ident:ident_t; 82 | add_type t ~type_ident:ident_u; 83 | add_type t ~type_ident:ident_v; 84 | let submodule_t = enter_module t ~module_ident in 85 | add_type submodule_t ~type_ident:ident_t2; 86 | add_type submodule_t ~type_ident:ident_u; 87 | let find_and_print ident = 88 | match find_type submodule_t ~type_ident:ident with 89 | | None -> Stdio.printf "cannot find %s\n" (Ident.name ident) 90 | | Some path -> Stdio.printf "found %s.%s\n" (path_to_string path) (Ident.name ident) 91 | in 92 | find_and_print ident_t; 93 | find_and_print ident_t2; 94 | find_and_print ident_u; 95 | find_and_print ident_v; 96 | find_and_print ident_w; 97 | [%expect 98 | {| 99 | found .t 100 | found module-ident.t 101 | found module-ident.u 102 | found .v 103 | cannot find w 104 | |}] 105 | ;; 106 | -------------------------------------------------------------------------------- /src/module_env.mli: -------------------------------------------------------------------------------- 1 | module Path : sig 2 | type t 3 | 4 | val empty : t 5 | val append : t -> string -> t 6 | val names : t -> string list 7 | end 8 | 9 | type t 10 | 11 | val create : unit -> t 12 | val path : t -> Path.t 13 | val enter_module : t -> module_ident:Ident.t -> t 14 | val add_type : t -> type_ident:Ident.t -> unit 15 | val find_type : t -> type_ident:Ident.t -> Path.t option 16 | val find_module : t -> module_ident:Ident.t -> Path.t option 17 | -------------------------------------------------------------------------------- /src/py_module.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Import 3 | 4 | type t = 5 | { module_name : string 6 | ; modl : pyobject 7 | } 8 | 9 | let create ?docstring module_name = 10 | let modl = Py.Import.add_module module_name in 11 | Option.iter docstring ~f:(Py.Module.set_docstring modl); 12 | { module_name; modl } 13 | ;; 14 | 15 | let module_name t = t.module_name 16 | 17 | let create_with_eval ~name ~py_source = 18 | let modl = Py.Import.add_module name in 19 | let modl_dict = Py.Module.get_dict modl in 20 | (* Set __file__ to "", because it doesn't come from a real file that Python tools 21 | can expect to be able to read. It seems like non-filename values are acceptable in 22 | this case (see [1] which recommends "") 23 | 24 | [1]: https://docs.python.org/3/library/functions.html#compile 25 | *) 26 | Py.Dict.set_item_string modl_dict "__file__" (python_of_string ""); 27 | Py.Dict.set_item_string modl_dict "__builtins__" (Py.Eval.get_builtins ()); 28 | let _ = Py.Run.eval ~globals:modl_dict ~locals:modl_dict ~start:File py_source in 29 | { module_name = name; modl } 30 | ;; 31 | 32 | let import module_name = { module_name; modl = Py.import module_name } 33 | let set_value t = Py.Module.set t.modl 34 | let pyobject t = t.modl 35 | 36 | let keywords_of_python pyobject = 37 | match Py.Type.get pyobject with 38 | | Null | None -> Ok (Map.empty (module String)) 39 | | Dict -> 40 | (match Py.Dict.to_bindings_string pyobject |> Map.of_alist (module String) with 41 | | `Ok map -> Ok map 42 | | `Duplicate_key d -> Or_error.errorf "duplicate keyword %s" d) 43 | | otherwise -> 44 | Or_error.errorf "expected dict for keywords, got %s" (Py.Type.name otherwise) 45 | ;; 46 | 47 | let set_function t ?docstring name fn = 48 | set_value t name (Py.Callable.of_function ~name ?docstring fn) 49 | ;; 50 | 51 | let set_function_with_keywords t ?docstring name fn = 52 | let fn args keywords = 53 | let keywords = 54 | match keywords_of_python keywords with 55 | | Ok keywords -> keywords 56 | | Error err -> raise (Py.Err (ValueError, Error.to_string_hum err)) 57 | in 58 | fn args keywords 59 | in 60 | set_value t name (Py.Callable.of_function_with_keywords ~name ?docstring fn) 61 | ;; 62 | 63 | let set t ?docstring name defunc = 64 | let docstring = Defunc.params_docstring ?docstring defunc in 65 | set_function_with_keywords t ~docstring name (Defunc.apply defunc) 66 | ;; 67 | 68 | let set_unit t ?docstring name defunc = 69 | let docstring = Defunc.params_docstring ?docstring defunc in 70 | set_function_with_keywords t ~docstring name (fun args kwargs -> 71 | Defunc.apply defunc args kwargs; 72 | Py.none) 73 | ;; 74 | 75 | let set_no_arg t ?docstring name fn = 76 | set_function_with_keywords t ?docstring name (fun args keywords -> 77 | if not (Array.is_empty args) 78 | then value_errorf "no positional argument expected (got %d)" (Array.length args); 79 | if not (Map.is_empty keywords) 80 | then value_errorf "no keyword argument expected (got %d)" (Map.length keywords); 81 | fn ()) 82 | ;; 83 | 84 | module Raw = struct 85 | let set modl = set { modl; module_name = "" } 86 | end 87 | -------------------------------------------------------------------------------- /src/py_module.mli: -------------------------------------------------------------------------------- 1 | open Import 2 | open Base 3 | 4 | type t 5 | 6 | (** [create ?docstring module_name] creates a new python module with the specified name. 7 | This module can directly be imported from python. 8 | *) 9 | val create : ?docstring:string -> string -> t 10 | 11 | (** [module_name t] returns the name used to create the module. *) 12 | val module_name : t -> string 13 | 14 | (** [create_with_eval ~name ~py_source] creates a new module defined by evaluating 15 | [py_source] which contains some python code. 16 | *) 17 | val create_with_eval : name:string -> py_source:string -> t 18 | 19 | (** [import module_name] imports an already existing module. *) 20 | val import : string -> t 21 | 22 | (** [set_value t name obj] sets the field [name] on module [t] to hold value 23 | [obj]. This can be accessed via [t.name] in python. 24 | *) 25 | val set_value : t -> string -> pyobject -> unit 26 | 27 | (** [pyobject t] returns the underlying python object for a module. *) 28 | val pyobject : t -> pyobject 29 | 30 | (** [set_function t ?docstring name fn] adds to module [t] a function named [name] 31 | which evaluates as the [fn] closure. 32 | This only handles positional arguments. 33 | *) 34 | val set_function 35 | : t 36 | -> ?docstring:string 37 | -> string 38 | -> (pyobject array -> pyobject) 39 | -> unit 40 | 41 | (** [set_function_with_keywords t ?docstring name fn] adds to module [t] 42 | a function named [name] which evaluates as the [fn] closure. 43 | This handles both positional and keyword arguments. 44 | *) 45 | val set_function_with_keywords 46 | : t 47 | -> ?docstring:string 48 | -> string 49 | -> (pyobject array -> (string, pyobject, String.comparator_witness) Map.t -> pyobject) 50 | -> unit 51 | 52 | (** [set t ?docstring name fn] sets a function on module [t] named [name]. This 53 | function is defined by defunc [fn]. 54 | *) 55 | val set : t -> ?docstring:string -> string -> (unit -> pyobject) Defunc.t -> unit 56 | 57 | (** [set_unit] is a specialized version of [set] for function that return [unit]. 58 | *) 59 | val set_unit : t -> ?docstring:string -> string -> (unit -> unit) Defunc.t -> unit 60 | 61 | (** [set_no_arg t ?docstring name fn] sets a function on module [t] named [name]. This 62 | function does not take any positional or keyword argument. 63 | *) 64 | val set_no_arg : t -> ?docstring:string -> string -> (unit -> pyobject) -> unit 65 | 66 | (** Helper function to get keywords from a python object. 67 | When no keyword is present, null is used; otherwise a 68 | python dictionary with string key gets used. 69 | *) 70 | val keywords_of_python 71 | : pyobject 72 | -> (string, pyobject, String.comparator_witness) Map.t Or_error.t 73 | 74 | module Raw : sig 75 | val set : pyobject -> ?docstring:string -> string -> (unit -> pyobject) Defunc.t -> unit 76 | end 77 | -------------------------------------------------------------------------------- /src/py_traceback.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | include Py.Traceback 3 | 4 | module Unstable = struct 5 | module Frame = struct 6 | module Serializable = struct 7 | type t = 8 | { filename : string 9 | ; function_name : string 10 | ; line_number : int 11 | } 12 | [@@deriving bin_io, sexp] 13 | end 14 | 15 | type t = frame = 16 | { filename : string 17 | ; function_name : string 18 | ; line_number : int 19 | ; py_frame : Py.Object.t option 20 | } 21 | 22 | module Conv = struct 23 | type nonrec t = t 24 | 25 | let of_binable { Serializable.filename; function_name; line_number } = 26 | { filename; function_name; line_number; py_frame = None } 27 | ;; 28 | 29 | let to_binable { filename; function_name; line_number; py_frame = _ } = 30 | { Serializable.filename; function_name; line_number } 31 | ;; 32 | 33 | let caller_identity = Bin_prot.Shape.Uuid.of_string "Py_traceback" 34 | end 35 | 36 | include Binable.Of_binable_with_uuid (Serializable) (Conv) 37 | 38 | let t_of_sexp = Fn.compose Conv.of_binable Serializable.t_of_sexp 39 | let sexp_of_t = Fn.compose Serializable.sexp_of_t Conv.to_binable 40 | end 41 | 42 | type t = Frame.t list [@@deriving bin_io, sexp] 43 | end 44 | 45 | let raise_py_err_with_backtrace ?(unwrap_more = fun _ -> None) ?backtrace exn = 46 | let rec loop acc_traceback = function 47 | | Exn.Reraised (reraised, exn) -> 48 | let frame = 49 | { Py.Traceback.filename = "exn.ml" 50 | ; function_name = Printf.sprintf "reraise<%s>" reraised 51 | ; line_number = 0 52 | ; py_frame = None 53 | } 54 | in 55 | loop ([ frame ] :: acc_traceback) exn 56 | | exn -> 57 | (match unwrap_more exn with 58 | | None -> List.concat (List.rev acc_traceback), exn 59 | | Some (backtraces, unwrapped_exn) -> 60 | if phys_equal unwrapped_exn exn 61 | then failwith "[unwrap_more exn] returns [exn] and causes an infinite loop" 62 | else 63 | loop (List.map ~f:of_ocaml_backtrace backtraces @ acc_traceback) unwrapped_exn) 64 | in 65 | let additional_traceback, exn = loop [] exn in 66 | (* The [additional_traceback] information is from function calls less recent than the 67 | ones from [Backtrace.Exn.most_recent] *) 68 | let traceback = 69 | Option.value_map backtrace ~f:of_ocaml_backtrace ~default:[] @ additional_traceback 70 | in 71 | let raise_py_err_with_traceback py_err msg = 72 | raise (Py.Err_with_traceback (py_err, msg, traceback)) 73 | in 74 | match exn with 75 | | Py.E_with_traceback _ | Py.Err_with_traceback _ -> raise exn 76 | | Py.E (py_err_type, py_err, py_tb) -> 77 | let original_traceback = of_pyobject_traceback py_tb in 78 | raise (Py.E_with_traceback (py_err_type, py_err, original_traceback @ traceback)) 79 | | Py.Err (py_err, msg) -> raise_py_err_with_traceback py_err msg 80 | | exn -> 81 | raise_py_err_with_traceback 82 | ValueError 83 | [%string "OCaml error: %{Exn.to_string_mach exn}"] 84 | ;; 85 | -------------------------------------------------------------------------------- /src/py_traceback.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | (** [Py_traceback] is a wrapper around [Py.Traceback] which provides more functionalities 4 | to Python/OCaml traceback manipulation. *) 5 | 6 | include module type of Py.Traceback 7 | 8 | module Unstable : sig 9 | (** Serialization (bin_prot and sexp) are implemented so that the raw frame python objects are dropped. *) 10 | type nonrec t = t [@@deriving bin_io, sexp] 11 | end 12 | 13 | (** Raise a Python exception that will include the OCaml backtrace information as part 14 | of the Python exception traceback. 15 | [unwrap_more] can be specified to extract nested exceptions and provide additional 16 | backtraces if relevant. Note that [unwrap_more exn] returning [exn] would raise. *) 17 | val raise_py_err_with_backtrace 18 | : ?unwrap_more:(exn -> (Stdlib.Printexc.raw_backtrace list * exn) option) 19 | -> ?backtrace:Stdlib.Printexc.raw_backtrace 20 | -> exn 21 | -> 'a 22 | -------------------------------------------------------------------------------- /src/py_typerep.ml: -------------------------------------------------------------------------------- 1 | module Typerep = Typerep_lib.Std.Typerep 2 | open Base 3 | open Import 4 | 5 | (* Register some named types so that supported types can easily be extended. *) 6 | module Named_types : sig 7 | val register_exn 8 | : name:string 9 | -> ocaml_type:string 10 | -> python_to_ocaml:(pyobject -> 'a) 11 | -> ocaml_to_python:('a -> pyobject) 12 | -> unit 13 | 14 | val mem : string -> bool 15 | val find_ocaml_type : name:string -> string option 16 | val typerep_exn : string -> Typerep.packed 17 | val ocaml_to_python : 'a Typerep.t -> 'a -> name:string -> pyobject 18 | val python_to_ocaml : 'a Typerep.t -> pyobject -> name:string -> 'a 19 | val ocaml_type : name:string -> string 20 | end = struct 21 | type 'a t = 22 | { typename : 'a Typerep_lib.Typename.typename 23 | ; typerep : 'a Typerep.t 24 | ; ocaml_type : string 25 | ; python_to_ocaml : pyobject -> 'a 26 | ; ocaml_to_python : 'a -> pyobject 27 | } 28 | 29 | type packed = T : 'a t -> packed 30 | 31 | let store = Hashtbl.create (module String) 32 | 33 | let register_exn (type a) ~name ~ocaml_type ~python_to_ocaml ~ocaml_to_python = 34 | let typename = Typerep_lib.Typename.create ~name () in 35 | let typerep = 36 | let module T0 = struct 37 | type named = a 38 | type t = a 39 | 40 | let typename_of_named = typename 41 | let typename_of_t = typename 42 | let witness = Type_equal.T 43 | end 44 | in 45 | Typerep.Named (Typerep.Named.T0 (module T0), None) 46 | in 47 | let t = { typename; typerep; ocaml_type; python_to_ocaml; ocaml_to_python } in 48 | Hashtbl.add_exn store ~key:name ~data:(T t) 49 | ;; 50 | 51 | let mem = Hashtbl.mem store 52 | 53 | let find_ocaml_type ~name = 54 | Option.map (Hashtbl.find store name) ~f:(fun (T t) -> t.ocaml_type) 55 | ;; 56 | 57 | let find_exn ~name = 58 | match Hashtbl.find store name with 59 | | None -> Printf.failwithf "not a registered name type: %s" name () 60 | | Some packed -> packed 61 | ;; 62 | 63 | let typerep_exn s = 64 | let (T t) = Hashtbl.find_exn store s in 65 | Typerep.T t.typerep 66 | ;; 67 | 68 | let ocaml_type ~name = 69 | let (T t) = find_exn ~name in 70 | t.ocaml_type 71 | ;; 72 | 73 | let ocaml_to_python typerep o ~name = 74 | let (T t) = find_exn ~name in 75 | match Typerep.same_witness typerep t.typerep with 76 | | None -> Printf.failwithf "type witness mismatch: %s" name () 77 | | Some equal -> 78 | let o = Type_equal.conv equal o in 79 | t.ocaml_to_python o 80 | ;; 81 | 82 | let python_to_ocaml typerep pyobj ~name = 83 | let (T t) = find_exn ~name in 84 | match Typerep.same_witness t.typerep typerep with 85 | | None -> Printf.failwithf "type witness mismatch: %s" name () 86 | | Some equal -> t.python_to_ocaml pyobj |> Type_equal.conv equal 87 | ;; 88 | end 89 | 90 | let rec to_ocaml : type a. a Typerep.t -> string = function 91 | | Unit -> "unit" 92 | | Int -> "int" 93 | | String -> "string" 94 | | Float -> "float" 95 | | Bool -> "bool" 96 | | Option t -> Printf.sprintf "(%s) option" (to_ocaml t) 97 | | List t -> Printf.sprintf "(%s) list" (to_ocaml t) 98 | | Array t -> Printf.sprintf "(%s) array" (to_ocaml t) 99 | | Tuple (T2 (t1, t2)) -> tuple_to_ocaml [ to_ocaml t1; to_ocaml t2 ] 100 | | Tuple (T3 (t1, t2, t3)) -> tuple_to_ocaml [ to_ocaml t1; to_ocaml t2; to_ocaml t3 ] 101 | | Tuple (T4 (t1, t2, t3, t4)) -> 102 | tuple_to_ocaml [ to_ocaml t1; to_ocaml t2; to_ocaml t3; to_ocaml t4 ] 103 | | Tuple (T5 (t1, t2, t3, t4, t5)) -> 104 | tuple_to_ocaml [ to_ocaml t1; to_ocaml t2; to_ocaml t3; to_ocaml t4; to_ocaml t5 ] 105 | | Int32 -> failwith "not supported" 106 | | Int64 -> failwith "not supported" 107 | | Nativeint -> failwith "not supported" 108 | | Char -> failwith "not supported" 109 | | Bytes -> failwith "not supported" 110 | | Lazy _ -> failwith "not supported" 111 | | Ref _ -> failwith "not supported" 112 | | Function (t1, t2) -> Printf.sprintf "%s -> %s" (to_ocaml t1) (to_ocaml t2) 113 | | Record _ -> failwith "not supported" 114 | | Variant _ -> failwith "not supported" 115 | | Named (named, _) -> 116 | let name = Typerep.Named.typename_of_t named |> Typerep_lib.Typename.name in 117 | Named_types.ocaml_type ~name 118 | 119 | and tuple_to_ocaml strs = 120 | List.map strs ~f:(fun s -> Printf.sprintf "(%s)" s) |> String.concat ~sep:" * " 121 | ;; 122 | 123 | let check o ~name ~check = 124 | if not (check o) 125 | then Printf.failwithf "expected %s, got %s" name (Py.Type.get o |> Py.Type.name) () 126 | ;; 127 | 128 | let check_tuple pyobject ~n = 129 | check pyobject ~name:"tuple" ~check:Py.Tuple.check; 130 | let size = Py.Tuple.size pyobject in 131 | if size <> n then Printf.failwithf "expected a tuple of size %d, got %d" n size () 132 | ;; 133 | 134 | let protect ~f x = 135 | try f x with 136 | | Py.Err _ as err -> raise err 137 | | exn -> raise (Py.Err (SyntaxError, Exn.to_string exn)) 138 | ;; 139 | 140 | let rec ocaml_to_python : type a. a Typerep.t -> a -> pyobject = 141 | fun t o -> 142 | match t with 143 | | Unit -> Py.none 144 | | Int -> Py.Int.of_int o 145 | | String -> Py.String.of_string o 146 | | Float -> Py.Float.of_float o 147 | | Bool -> Py.Bool.of_bool o 148 | | Option t -> 149 | (match o with 150 | | None -> Py.none 151 | | Some o -> ocaml_to_python t o) 152 | | List t -> Py.List.of_list_map (ocaml_to_python t) o 153 | | Array t -> Py.List.of_array_map (ocaml_to_python t) o 154 | | Tuple (T2 (t1, t2)) -> 155 | let o1, o2 = o in 156 | Py.Tuple.of_tuple2 (ocaml_to_python t1 o1, ocaml_to_python t2 o2) 157 | | Tuple (T3 (t1, t2, t3)) -> 158 | let o1, o2, o3 = o in 159 | Py.Tuple.of_tuple3 160 | (ocaml_to_python t1 o1, ocaml_to_python t2 o2, ocaml_to_python t3 o3) 161 | | Tuple (T4 (t1, t2, t3, t4)) -> 162 | let o1, o2, o3, o4 = o in 163 | Py.Tuple.of_tuple4 164 | ( ocaml_to_python t1 o1 165 | , ocaml_to_python t2 o2 166 | , ocaml_to_python t3 o3 167 | , ocaml_to_python t4 o4 ) 168 | | Tuple (T5 (t1, t2, t3, t4, t5)) -> 169 | let o1, o2, o3, o4, o5 = o in 170 | Py.Tuple.of_tuple5 171 | ( ocaml_to_python t1 o1 172 | , ocaml_to_python t2 o2 173 | , ocaml_to_python t3 o3 174 | , ocaml_to_python t4 o4 175 | , ocaml_to_python t5 o5 ) 176 | | Int32 -> failwith "not supported" 177 | | Int64 -> failwith "not supported" 178 | | Nativeint -> failwith "not supported" 179 | | Char -> failwith "not supported" 180 | | Bytes -> failwith "not supported" 181 | | Lazy _ -> failwith "not supported" 182 | | Ref _ -> failwith "not supported" 183 | | Function (t1, t2) -> 184 | Py.Callable.of_function 185 | ~docstring:(to_ocaml t) 186 | (protect ~f:(fun pyobjects -> 187 | let pyobject = 188 | match pyobjects with 189 | | [||] -> Py.none 190 | | [| pyobject |] -> pyobject 191 | | array -> Py.Tuple.of_array array 192 | in 193 | python_to_ocaml t1 pyobject |> o |> ocaml_to_python t2)) 194 | | Record _ -> failwith "not supported" 195 | | Variant _ -> failwith "not supported" 196 | | Named (named, _) -> 197 | let name = Typerep.Named.typename_of_t named |> Typerep_lib.Typename.name in 198 | Named_types.ocaml_to_python t o ~name 199 | 200 | and python_to_ocaml : type a. a Typerep.t -> pyobject -> a = 201 | fun t pyobj -> 202 | match t with 203 | | Unit -> check pyobj ~name:"none" ~check:Py.is_none 204 | | Int -> 205 | (* We cannot use Py.Int.check as it actually checks for the type 206 | being Long rather than Int. *) 207 | check pyobj ~name:"int" ~check:(fun o -> 208 | match Py.Type.get o with 209 | | Int | Long -> true 210 | | _ -> false); 211 | Py.Int.to_int pyobj 212 | | String -> 213 | check pyobj ~name:"string" ~check:Py.String.check; 214 | Py.String.to_string pyobj 215 | | Float -> 216 | check pyobj ~name:"float" ~check:(fun o -> 217 | match Py.Type.get o with 218 | | Int | Long | Float -> true 219 | | _ -> false); 220 | Py.Float.to_float pyobj 221 | | Bool -> 222 | check pyobj ~name:"bool" ~check:Py.Bool.check; 223 | Py.Bool.to_bool pyobj 224 | | Option t -> 225 | (match Py.Type.get pyobj with 226 | | None | Null -> None 227 | | _ -> Some (python_to_ocaml t pyobj)) 228 | | List t -> 229 | check pyobj ~name:"list" ~check:Py.List.check; 230 | Py.List.to_list_map (python_to_ocaml t) pyobj 231 | | Array t -> 232 | check pyobj ~name:"list" ~check:Py.List.check; 233 | Py.List.to_array_map (python_to_ocaml t) pyobj 234 | | Tuple (T2 (t1, t2)) -> 235 | (* This check avoids a segfault as getting items from non-tuples return null. 236 | 237 | (The reason we check in the other case is for better error messages and possible 238 | future changes.) *) 239 | check_tuple pyobj ~n:2; 240 | let p1, p2 = Py.Tuple.to_tuple2 pyobj in 241 | python_to_ocaml t1 p1, python_to_ocaml t2 p2 242 | | Tuple (T3 (t1, t2, t3)) -> 243 | check_tuple pyobj ~n:3; 244 | let p1, p2, p3 = Py.Tuple.to_tuple3 pyobj in 245 | python_to_ocaml t1 p1, python_to_ocaml t2 p2, python_to_ocaml t3 p3 246 | | Tuple (T4 (t1, t2, t3, t4)) -> 247 | check_tuple pyobj ~n:4; 248 | let p1, p2, p3, p4 = Py.Tuple.to_tuple4 pyobj in 249 | ( python_to_ocaml t1 p1 250 | , python_to_ocaml t2 p2 251 | , python_to_ocaml t3 p3 252 | , python_to_ocaml t4 p4 ) 253 | | Tuple (T5 (t1, t2, t3, t4, t5)) -> 254 | check_tuple pyobj ~n:5; 255 | let p1, p2, p3, p4, p5 = Py.Tuple.to_tuple5 pyobj in 256 | ( python_to_ocaml t1 p1 257 | , python_to_ocaml t2 p2 258 | , python_to_ocaml t3 p3 259 | , python_to_ocaml t4 p4 260 | , python_to_ocaml t5 p5 ) 261 | | Int32 -> failwith "not supported" 262 | | Int64 -> failwith "not supported" 263 | | Nativeint -> failwith "not supported" 264 | | Char -> failwith "not supported" 265 | | Bytes -> failwith "not supported" 266 | | Lazy _ -> failwith "not supported" 267 | | Ref _ -> failwith "not supported" 268 | | Function ((Tuple _ as t1), t2) -> 269 | check pyobj ~name:"callable" ~check:Py.Callable.check; 270 | protect ~f:(fun x -> 271 | ocaml_to_python t1 x |> Py.Callable.to_function_as_tuple pyobj |> python_to_ocaml t2) 272 | | Function (t1, t2) -> 273 | check pyobj ~name:"callable" ~check:Py.Callable.check; 274 | protect ~f:(fun x -> 275 | [| ocaml_to_python t1 x |] |> Py.Callable.to_function pyobj |> python_to_ocaml t2) 276 | | Record _ -> failwith "not supported" 277 | | Variant _ -> failwith "not supported" 278 | | Named (named, _) -> 279 | let name = Typerep.Named.typename_of_t named |> Typerep_lib.Typename.name in 280 | Named_types.python_to_ocaml t pyobj ~name 281 | ;; 282 | 283 | let%expect_test "obj" = 284 | if not (Py.is_initialized ()) then Py.initialize ~version:3 (); 285 | let print_list elt_to_string l = 286 | List.map l ~f:elt_to_string |> String.concat ~sep:" " |> Stdio.printf "%s\n%!" 287 | in 288 | let roundtrip : type a. a Typerep.t -> a -> a = 289 | fun t v -> ocaml_to_python t v |> python_to_ocaml t 290 | in 291 | let () = roundtrip Unit () in 292 | print_list Int.to_string (List.map [ -1; 0; 42 ] ~f:(roundtrip Int)); 293 | [%expect {| -1 0 42 |}]; 294 | print_list Float.to_string (List.map [ -2.71828; 3.1415 ] ~f:(roundtrip Float)); 295 | [%expect {| -2.71828 3.1415 |}]; 296 | print_list Float.to_string (roundtrip (List Float) [ -2.71828; 3.1415 ]); 297 | [%expect {| -2.71828 3.1415 |}]; 298 | print_list 299 | (fun (f, i, o) -> 300 | let o = 301 | Option.value_map o ~default:"()" ~f:(fun (s, b) -> Printf.sprintf "%s %b" s b) 302 | in 303 | Printf.sprintf "(%f %i %s)" f i o) 304 | (roundtrip 305 | (List (Tuple (T3 (Float, Int, Option (Tuple (T2 (String, Bool))))))) 306 | [ 3.14, 42, None; 2.71828, 1337, Some ("test", true) ]); 307 | [%expect {| (3.140000 42 ()) (2.718280 1337 test true) |}] 308 | ;; 309 | 310 | let register_named_type ~name ~ocaml_type = 311 | match Named_types.find_ocaml_type ~name with 312 | | Some otype when String.( = ) ocaml_type otype -> 313 | (* In this case we consider the result a no-op. *) 314 | () 315 | | Some otype -> 316 | Printf.failwithf "Type %s already exists and is bound to %s." name otype () 317 | | None -> 318 | let ocaml_to_python, python_to_ocaml = 319 | Py.Capsule.make (Printf.sprintf "%s-%s" name ocaml_type) 320 | in 321 | Named_types.register_exn ~name ~ocaml_type ~python_to_ocaml ~ocaml_to_python 322 | ;; 323 | 324 | let rec of_type : Type.t -> Typerep.packed = function 325 | | Atom (_, "unit") -> T Unit 326 | | Atom (_, "int") -> T Int 327 | | Atom (_, "float") -> T Float 328 | | Atom (_, "bool") -> T Bool 329 | | Atom (_, "string") -> T String 330 | | Atom (_, str) when Named_types.mem str -> Named_types.typerep_exn str 331 | | Atom (_, str) -> Printf.failwithf "unknown type %s" str () 332 | | Tuple2 (t1, t2) -> 333 | let (T t1) = of_type t1 in 334 | let (T t2) = of_type t2 in 335 | T (Tuple (T2 (t1, t2))) 336 | | Tuple3 (t1, t2, t3) -> 337 | let (T t1) = of_type t1 in 338 | let (T t2) = of_type t2 in 339 | let (T t3) = of_type t3 in 340 | T (Tuple (T3 (t1, t2, t3))) 341 | | Tuple4 (t1, t2, t3, t4) -> 342 | let (T t1) = of_type t1 in 343 | let (T t2) = of_type t2 in 344 | let (T t3) = of_type t3 in 345 | let (T t4) = of_type t4 in 346 | T (Tuple (T4 (t1, t2, t3, t4))) 347 | | Tuple5 (t1, t2, t3, t4, t5) -> 348 | let (T t1) = of_type t1 in 349 | let (T t2) = of_type t2 in 350 | let (T t3) = of_type t3 in 351 | let (T t4) = of_type t4 in 352 | let (T t5) = of_type t5 in 353 | T (Tuple (T5 (t1, t2, t3, t4, t5))) 354 | | Arrow (_, t1, t2) -> 355 | let (T t1) = of_type t1 in 356 | let (T t2) = of_type t2 in 357 | T (Function (t1, t2)) 358 | | Apply (t, "list") -> 359 | let (T t) = of_type t in 360 | T (List t) 361 | | Apply (t, "array") -> 362 | let (T t) = of_type t in 363 | T (Array t) 364 | | Apply (t, "option") -> 365 | let (T t) = of_type t in 366 | T (Option t) 367 | | Apply (_t, str) -> Printf.failwithf "unknown type %s" str () 368 | ;; 369 | 370 | let parse str = Type_parser.type_expr Type_lexer.token (Lexing.from_string str) |> of_type 371 | 372 | let%expect_test "parse-type" = 373 | if not (Py.is_initialized ()) then Py.initialize (); 374 | List.iteri 375 | [ "unit" 376 | ; " int" 377 | ; "unit -> int" 378 | ; "string list -> float * bool option" 379 | ; "int * (string * int * bool)" 380 | ; "(int*int*int*(int*string list * int) list) option -> int * (string * int * bool)" 381 | ; "(int*int*int array*(int*string array * int) list) option -> string array" 382 | ; "int array list option array -> string array array" 383 | ; "(((int array list) option)) array -> (((string array)) array)" 384 | ] 385 | ~f:(fun index str -> 386 | let (T t) = parse str in 387 | Stdio.printf "%d %s\n%!" index (to_ocaml t)); 388 | [%expect 389 | {| 390 | 0 unit 391 | 1 int 392 | 2 unit -> int 393 | 3 (string) list -> (float) * ((bool) option) 394 | 4 (int) * ((string) * (int) * (bool)) 395 | 5 ((int) * (int) * (int) * (((int) * ((string) list) * (int)) list)) option -> (int) * ((string) * (int) * (bool)) 396 | 6 ((int) * (int) * ((int) array) * (((int) * ((string) array) * (int)) list)) option -> (string) array 397 | 7 ((((int) array) list) option) array -> ((string) array) array 398 | 8 ((((int) array) list) option) array -> ((string) array) array 399 | |}] 400 | ;; 401 | -------------------------------------------------------------------------------- /src/py_typerep.mli: -------------------------------------------------------------------------------- 1 | open Import 2 | module Typerep = Typerep_lib.Std.Typerep 3 | 4 | module Named_types : sig 5 | val register_exn 6 | : name:string 7 | -> ocaml_type:string 8 | -> python_to_ocaml:(pyobject -> 'a) 9 | -> ocaml_to_python:('a -> pyobject) 10 | -> unit 11 | end 12 | 13 | (** [to_ocaml typerep] returns an ocaml string representing the type. *) 14 | val to_ocaml : _ Typerep.t -> string 15 | 16 | (** [ocaml_to_python typerep v] converts an arbitrary ocaml object with its typerep 17 | representation to a python value. 18 | See the implementation for supported constructions. 19 | *) 20 | val ocaml_to_python : 'a Typerep.t -> 'a -> pyobject 21 | 22 | (** [python_to_ocaml typerep pybobject] converts a python object [pyobject] to an 23 | ocaml value according to some type description [typerep]. 24 | *) 25 | val python_to_ocaml : 'a Typerep.t -> pyobject -> 'a 26 | 27 | (** [parse str] parses an ocaml like string into a type representation. 28 | [str] cannot include any function. 29 | *) 30 | val parse : string -> Typerep.packed 31 | 32 | (** [register_named_type ~name ~ocaml_type] registers a named type that can be used 33 | in [parse] with name [name]. 34 | Values for this type will be type checked to match [ocaml_type] which should be 35 | a proper type annotation for the current toplevel, e.g. "t" if a type [t] is 36 | currently defined in the toplevel. 37 | A capsule is used to send and receive values to/from python. 38 | *) 39 | val register_named_type : name:string -> ocaml_type:string -> unit 40 | 41 | val of_type : Type.t -> Typerep.packed 42 | -------------------------------------------------------------------------------- /src/python_lib.ml: -------------------------------------------------------------------------------- 1 | include Import 2 | module Broadcast = Broadcast 3 | module Class_wrapper = Class_wrapper 4 | module Defunc = Defunc 5 | module Module_env = Module_env 6 | module Py_module = Py_module 7 | module Py_traceback = Py_traceback 8 | module Py_typerep = Py_typerep 9 | module Type = Type 10 | 11 | module Let_syntax = struct 12 | include Defunc.Param 13 | 14 | module Let_syntax = struct 15 | include Defunc 16 | module Open_on_rhs = Defunc.Param 17 | end 18 | end 19 | -------------------------------------------------------------------------------- /src/type.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | module Arg = struct 4 | type t = Asttypes.arg_label = 5 | | Nolabel 6 | | Labelled of string 7 | | Optional of string 8 | end 9 | 10 | type t = 11 | | Atom of Module_env.Path.t * string 12 | | Tuple2 of t * t 13 | | Tuple3 of t * t * t 14 | | Tuple4 of t * t * t * t 15 | | Tuple5 of t * t * t * t * t 16 | | Arrow of Arg.t * t * t 17 | | Apply of t * string 18 | 19 | (* Assume that the following typenames are never shadowed by something different. *) 20 | let basic_constr0 = 21 | Set.of_list (module String) [ "int"; "bool"; "string"; "float"; "unit" ] 22 | ;; 23 | 24 | let supported_constr1 = Set.of_list (module String) [ "list"; "array" ] 25 | 26 | let of_type_desc type_desc ~env = 27 | let open Or_error.Let_syntax in 28 | let rec walk (type_desc : Types.type_desc) = 29 | match type_desc with 30 | | Tvar _ -> Ok (Atom (Module_env.Path.empty, "pyobject")) 31 | | Tunivar _ -> Or_error.error_string "not handled: Tunivar" 32 | | Tvariant _ -> Or_error.error_string "not handled: Tvariant" 33 | | Tnil -> Or_error.error_string "not handled: Tnil" 34 | | Tobject (_, _) -> Or_error.error_string "not handled: Tobject" 35 | | Tfield (_, _, _, _) -> Or_error.error_string "not handled: Tfield" 36 | | Tpackage _ -> Or_error.error_string "not handled: Tpackage" 37 | | Tpoly (ty, []) -> walk (Types.get_desc ty) 38 | | Tpoly (_, _) -> Or_error.error_string "not handled: non-mono Tpoly" 39 | | Tlink e -> walk (Types.get_desc e) 40 | | Tsubst (e1, None) -> walk (Types.get_desc e1) 41 | | Tsubst (e1, Some e2) -> walk (Ttuple [ None, e1; None, e2 ]) 42 | | Ttuple es -> 43 | let%bind tuple = 44 | List.map es ~f:(fun p -> 45 | match p with 46 | | None, e -> walk (Types.get_desc e) 47 | | Some _, _ -> Or_error.error_string "labeled tuple") 48 | |> Or_error.all 49 | in 50 | (match tuple with 51 | | [] -> Or_error.error_string "empty tuple" 52 | | [ _ ] -> Or_error.error_string "tuple with a single element" 53 | | [ t1; t2 ] -> Ok (Tuple2 (t1, t2)) 54 | | [ t1; t2; t3 ] -> Ok (Tuple3 (t1, t2, t3)) 55 | | [ t1; t2; t3; t4 ] -> Ok (Tuple4 (t1, t2, t3, t4)) 56 | | [ t1; t2; t3; t4; t5 ] -> Ok (Tuple5 (t1, t2, t3, t4, t5)) 57 | | _ -> Or_error.errorf "tuple with too many elements (%d)" (List.length tuple)) 58 | | Tarrow ((kind, _, _), e1, e2, _) -> 59 | let%bind e1 = walk (Types.get_desc e1) in 60 | let%bind e2 = walk (Types.get_desc e2) in 61 | Ok (Arrow (kind, e1, e2)) 62 | | Tconstr (constr, [], _) -> 63 | let last = Path.last constr in 64 | if Set.mem basic_constr0 last 65 | then Ok (Atom (Module_env.Path.empty, last)) 66 | else ( 67 | match Path.flatten constr with 68 | | `Contains_apply -> Or_error.errorf "contains apply %s" (Path.name constr) 69 | | `Ok (type_ident, []) -> 70 | let path = 71 | Module_env.find_type env ~type_ident 72 | |> Option.value ~default:Module_env.Path.empty 73 | in 74 | Ok (Atom (path, Ident.name type_ident)) 75 | | `Ok (module_ident, name_list) -> 76 | let path = 77 | Module_env.find_module env ~module_ident 78 | |> Option.value ~default:Module_env.Path.empty 79 | in 80 | let path = Module_env.Path.append path (Ident.name module_ident) in 81 | let rec walk path = function 82 | | [] -> assert false 83 | | [ type_name ] -> path, type_name 84 | | p :: q -> walk (Module_env.Path.append path p) q 85 | in 86 | let path, type_name = walk path name_list in 87 | Ok (Atom (path, type_name))) 88 | | Tconstr (constr, [ param ], _) -> 89 | let%bind param = walk (Types.get_desc param) in 90 | let last = Path.last constr in 91 | if Set.mem supported_constr1 last 92 | then Ok (Apply (param, last)) 93 | else Or_error.errorf "not handled: type constructor %s" last 94 | | Tconstr (constr, _ :: _ :: _, _) -> 95 | Or_error.errorf 96 | "not handled: constructor with more than one parameter %s" 97 | (Path.name constr) 98 | in 99 | walk type_desc 100 | ;; 101 | 102 | let to_string t = 103 | let need_parenthesis = function 104 | | Tuple2 _ | Tuple3 _ | Tuple4 _ | Tuple5 _ | Arrow _ -> true 105 | | Atom _ | Apply _ -> false 106 | in 107 | let rec walk = function 108 | | Tuple2 (t1, t2) -> tuple [ t1; t2 ] 109 | | Tuple3 (t1, t2, t3) -> tuple [ t1; t2; t3 ] 110 | | Tuple4 (t1, t2, t3, t4) -> tuple [ t1; t2; t3; t4 ] 111 | | Tuple5 (t1, t2, t3, t4, t5) -> tuple [ t1; t2; t3; t4; t5 ] 112 | | Atom (path, name) -> 113 | (match Module_env.Path.names path with 114 | | [] -> name 115 | | _ :: _ as path -> String.concat path ~sep:"." ^ "." ^ name) 116 | | Apply (param, name) -> 117 | if need_parenthesis param 118 | then Printf.sprintf "(%s) %s" (walk param) name 119 | else Printf.sprintf "%s %s" (walk param) name 120 | | Arrow (arg, lhs, rhs) -> 121 | let maybe_label = 122 | match arg with 123 | | Nolabel -> "" 124 | | Labelled label -> label ^ ":" 125 | | Optional label -> Printf.sprintf "?%s:" label 126 | in 127 | if need_parenthesis lhs 128 | then Printf.sprintf "(%s%s) -> %s" maybe_label (walk lhs) (walk rhs) 129 | else Printf.sprintf "%s%s -> %s" maybe_label (walk lhs) (walk rhs) 130 | and tuple ts = 131 | List.map ts ~f:walk |> String.concat ~sep:", " |> Printf.sprintf "(%s)" 132 | in 133 | walk t 134 | ;; 135 | 136 | let uncurrify t = 137 | let rec walk acc t = 138 | match t with 139 | | Arrow (arg, t1, t2) -> walk ((arg, t1) :: acc) t2 140 | | Tuple2 _ | Tuple3 _ | Tuple4 _ | Tuple5 _ | Atom _ | Apply _ -> List.rev acc, t 141 | in 142 | walk [] t 143 | ;; 144 | 145 | let rec contains_arrow = function 146 | | Atom _ -> false 147 | | Tuple2 (t1, t2) -> List.exists [ t1; t2 ] ~f:contains_arrow 148 | | Tuple3 (t1, t2, t3) -> List.exists [ t1; t2; t3 ] ~f:contains_arrow 149 | | Tuple4 (t1, t2, t3, t4) -> List.exists [ t1; t2; t3; t4 ] ~f:contains_arrow 150 | | Tuple5 (t1, t2, t3, t4, t5) -> List.exists [ t1; t2; t3; t4; t5 ] ~f:contains_arrow 151 | | Arrow _ -> true 152 | | Apply (t, _) -> contains_arrow t 153 | ;; 154 | -------------------------------------------------------------------------------- /src/type.mli: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | module Arg : sig 4 | type t = Asttypes.arg_label = 5 | | Nolabel 6 | | Labelled of string 7 | | Optional of string 8 | end 9 | 10 | type t = 11 | | Atom of Module_env.Path.t * string 12 | | Tuple2 of t * t 13 | | Tuple3 of t * t * t 14 | | Tuple4 of t * t * t * t 15 | | Tuple5 of t * t * t * t * t 16 | | Arrow of Arg.t * t * t 17 | | Apply of t * string 18 | 19 | val uncurrify : t -> (Arg.t * t) list * t 20 | val of_type_desc : Types.type_desc -> env:Module_env.t -> t Or_error.t 21 | val to_string : t -> string 22 | val contains_arrow : t -> bool 23 | -------------------------------------------------------------------------------- /src/type_lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Type_parser 3 | exception Error of string 4 | 5 | let newline lexbuf = Lexing.new_line lexbuf 6 | let error fmt = 7 | Printf.ksprintf (fun msg -> raise (Error msg)) fmt 8 | } 9 | 10 | let eol = '\r'? '\n' 11 | let space = [' ' '\t'] 12 | let alpha = ['a'-'z' 'A'-'Z'] 13 | let digit = ['0'-'9'] 14 | let ichar = alpha | digit | ['_'] 15 | let ident = alpha ichar* 16 | 17 | rule token = parse 18 | | space { token lexbuf } 19 | | eol { newline lexbuf; token lexbuf } 20 | | "(" { LPAREN } 21 | | ")" { RPAREN } 22 | | "*" { STAR } 23 | | "->" { ARROW } 24 | | ident { IDENT (Lexing.lexeme lexbuf) } 25 | | eof { EOF } 26 | | _ { let token = Lexing.lexeme lexbuf in 27 | error "'%s' is not a valid token" token } 28 | -------------------------------------------------------------------------------- /src/type_parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Type 3 | %} 4 | 5 | %token STRING IDENT 6 | %token EOF 7 | %token LPAREN RPAREN 8 | %token STAR 9 | %token ARROW 10 | 11 | %nonassoc STAR 12 | %right ARROW 13 | 14 | %start type_expr 15 | %type type_expr 16 | 17 | %% 18 | 19 | type_expr: 20 | | atom { Atom(Module_env.Path.empty, $1) } 21 | | LPAREN type_expr RPAREN { $2 } 22 | | type_expr_no_star STAR type_expr_no_star { Tuple2 ($1, $3) } 23 | | type_expr_no_star STAR type_expr_no_star STAR type_expr_no_star 24 | { Tuple3 ($1, $3, $5) } 25 | | type_expr_no_star STAR type_expr_no_star STAR type_expr_no_star STAR type_expr_no_star 26 | { Tuple4 ($1, $3, $5, $7) } 27 | | type_expr_no_star STAR type_expr_no_star STAR type_expr_no_star STAR type_expr_no_star STAR type_expr_no_star 28 | { Tuple5 ($1, $3, $5, $7, $9) } 29 | | type_expr ARROW type_expr { Arrow (Nolabel, $1, $3) } 30 | | type_expr_no_star atom { Apply ($1, $2) } 31 | ; 32 | 33 | /* [type_expr_no_star] exists to disambiguate the grammar. E.g. without it 'a * b * c' is ambiguous to 34 | be parsed both [(a*b) * c] and as a triple [a * b *c]. 35 | */ 36 | type_expr_no_star: 37 | | atom { Atom(Module_env.Path.empty, $1) } 38 | | LPAREN type_expr RPAREN { $2 } 39 | | type_expr_no_star atom { Apply ($1, $2) } 40 | 41 | atom: 42 | | IDENT { $1 } 43 | ; 44 | 45 | %% 46 | --------------------------------------------------------------------------------