├── tests
├── srcs
├── mod
│ ├── __init__.py
│ └── test.py
├── modul.py
├── test4.ml
├── fetch.py
├── test5.ml
├── test8.ml
├── test1.ml
├── test7.ml
├── test6.ml
├── test3.ml
└── test2.ml
├── benchmark
├── srcs
├── modul.py
└── benchmark.ml
├── examples
├── srcs
├── simple.py
├── phantom.py
├── simple.ml
├── phantom.ml
└── reference.ml
├── srcs
├── lymp.mldylib
├── lymp.mllib
├── META
├── LICENSE.bson.txt
├── lymp.mli
├── bson.mli
├── lymp.py
├── lymp.ml
└── bson.ml
├── _oasis
├── _tags
├── Makefile
├── LICENSE
├── README.md
└── myocamlbuild.ml
/tests/srcs:
--------------------------------------------------------------------------------
1 | ../srcs
--------------------------------------------------------------------------------
/benchmark/srcs:
--------------------------------------------------------------------------------
1 | ../srcs
--------------------------------------------------------------------------------
/examples/srcs:
--------------------------------------------------------------------------------
1 | ../srcs
--------------------------------------------------------------------------------
/tests/mod/__init__.py:
--------------------------------------------------------------------------------
1 |
--------------------------------------------------------------------------------
/benchmark/modul.py:
--------------------------------------------------------------------------------
1 |
2 |
3 | def get_int():
4 | return 42
--------------------------------------------------------------------------------
/tests/mod/test.py:
--------------------------------------------------------------------------------
1 |
2 |
3 | def get_msg():
4 | return "hi there"
5 |
--------------------------------------------------------------------------------
/srcs/lymp.mldylib:
--------------------------------------------------------------------------------
1 | # OASIS_START
2 | # DO NOT EDIT (digest: 4edada10b77f0a99cbffc29e8b34715f)
3 | Lymp
4 | Bson
5 | # OASIS_STOP
6 |
--------------------------------------------------------------------------------
/srcs/lymp.mllib:
--------------------------------------------------------------------------------
1 | # OASIS_START
2 | # DO NOT EDIT (digest: 4edada10b77f0a99cbffc29e8b34715f)
3 | Lymp
4 | Bson
5 | # OASIS_STOP
6 |
--------------------------------------------------------------------------------
/examples/simple.py:
--------------------------------------------------------------------------------
1 |
2 |
3 | def get_message():
4 | return u"hi there"
5 |
6 | def get_integer():
7 | return 42
8 |
9 | def sum(a, b):
10 | return a + b
11 |
--------------------------------------------------------------------------------
/tests/modul.py:
--------------------------------------------------------------------------------
1 | # coding: utf-8
2 | import bson
3 |
4 | def rand_str():
5 | print("alright, inside python")
6 | return "salut les gars"
7 |
8 | def get_tuple():
9 | return (1,2)
10 |
11 | def print_tuple(arg):
12 | print(arg)
13 |
14 | def first_of_tuple(arg):
15 | return arg[0]
16 |
17 | def print_arg(arg):
18 | print(arg)
19 |
20 | def ret_unicode():
21 | return u'saluté'
--------------------------------------------------------------------------------
/_oasis:
--------------------------------------------------------------------------------
1 | OASISFormat: 0.3
2 | Name: lymp
3 | Version: 0.2.2
4 | Synopsis: Use Python functions and objects from OCaml
5 | Authors: Dominik Bousquet
6 | License: MIT
7 | Plugins: META (0.3)
8 |
9 | Library lymp
10 | Path: srcs
11 | BuildTools: ocamlbuild
12 | BuildDepends: unix, threads
13 | Modules: Lymp
14 | InternalModules: Bson
15 |
--------------------------------------------------------------------------------
/srcs/META:
--------------------------------------------------------------------------------
1 | # OASIS_START
2 | # DO NOT EDIT (digest: d86d9a8ff71868e64aaf64d1811c3216)
3 | version = "0.2.2"
4 | description = "Use Python functions and objects from OCaml"
5 | requires = "unix threads"
6 | archive(byte) = "lymp.cma"
7 | archive(byte, plugin) = "lymp.cma"
8 | archive(native) = "lymp.cmxa"
9 | archive(native, plugin) = "lymp.cmxs"
10 | exists_if = "lymp.cma"
11 | # OASIS_STOP
12 |
13 |
--------------------------------------------------------------------------------
/examples/phantom.py:
--------------------------------------------------------------------------------
1 |
2 |
3 | import lxml.html as lx
4 | from selenium import webdriver
5 |
6 | driver = webdriver.PhantomJS()
7 | driver.set_window_size(1024, 768)
8 |
9 | def download(url):
10 | driver.get(url)
11 | driver.save_screenshot('screen.png')
12 | return driver.page_source
13 |
14 | def select(html, css_selector):
15 | doc = lx.fromstring(html)
16 | return doc.cssselect(css_selector)
--------------------------------------------------------------------------------
/tests/test4.ml:
--------------------------------------------------------------------------------
1 |
2 |
3 | open Lymp
4 |
5 | let ocamlfind_ok = (try (Sys.getenv "OCAMLFIND_OK" ; true) with | _ -> false)
6 | let py = if ocamlfind_ok then Lymp.init "." else Lymp.init ~exec:"python3" ~ocamlfind:false ~lymppy_dirpath:"srcs" "."
7 | let test = Lymp.get_module py "mod.test"
8 |
9 | let () =
10 | if (get_string test "get_msg" [] <> "hi there") then raise (Failure "failed") ;
11 |
12 | close py
13 |
--------------------------------------------------------------------------------
/tests/fetch.py:
--------------------------------------------------------------------------------
1 |
2 |
3 | class Fetch:
4 | def __init__(self, url, mode):
5 | self.url = url
6 | self.mode = mode
7 |
8 | def download(self):
9 | if self.mode == "phantom":
10 | return "Hi from phantom
"
11 | return "Hi
"
12 |
13 | def ret_self(self):
14 | return self
15 |
16 | def ret_list(self):
17 | return [1,2,self, ["salut", 3], 4]
18 |
19 | def ret_list2(self):
20 | return [1, 2]
--------------------------------------------------------------------------------
/tests/test5.ml:
--------------------------------------------------------------------------------
1 |
2 |
3 | let ocamlfind_ok = (try (Sys.getenv "OCAMLFIND_OK" ; true) with | _ -> false)
4 | let py = if ocamlfind_ok then Lymp.init "." else Lymp.init ~exec:"python3" ~ocamlfind:false ~lymppy_dirpath:"srcs" "."
5 | let sys = Lymp.get_module py "sys"
6 |
7 | let () =
8 | Lymp.set_attr sys "stdin" (Lymp.Pyint 42) ;
9 | let py_stdin = Lymp.attr_int sys "stdin" in
10 | if py_stdin = 42 then () else raise (Failure "failed") ;
11 |
12 | Lymp.close py
--------------------------------------------------------------------------------
/tests/test8.ml:
--------------------------------------------------------------------------------
1 |
2 |
3 | let ocamlfind_ok = (try (Sys.getenv "OCAMLFIND_OK" ; true) with | _ -> false)
4 | let py = if ocamlfind_ok then Lymp.init "." else Lymp.init ~exec:"python3" ~ocamlfind:false ~lymppy_dirpath:"srcs" "."
5 | let builtin = Lymp.builtins py
6 |
7 | let make_stuff () =
8 | let file = Lymp.get_ref builtin "open" [Lymp.Pystr "test8.ml"] in
9 | ()
10 |
11 | let () =
12 | print_endline "should show \"ok\" : " ;
13 | make_stuff () ;
14 | Lymp.close py ;
15 | Gc.full_major () ;
16 | print_endline "ok"
--------------------------------------------------------------------------------
/examples/simple.ml:
--------------------------------------------------------------------------------
1 |
2 |
3 | open Lymp
4 |
5 | (* change "python3" to the name of your interpreter *)
6 | let interpreter = "python3"
7 | let py = init ~exec:interpreter "."
8 | let simple = get_module py "simple"
9 |
10 | let () =
11 | (* msg = simple.get_message() *)
12 | let msg = get_string simple "get_message" [] in
13 | let integer = get_int simple "get_integer" [] in
14 | let addition = get_int simple "sum" [Pyint 12 ; Pyint 10] in
15 | let strconcat = get_string simple "sum" [Pystr "first " ; Pystr "second"] in
16 | Printf.printf "%s\n%d\n%d\n%s\n" msg integer addition strconcat ;
17 |
18 | close py
19 |
--------------------------------------------------------------------------------
/tests/test1.ml:
--------------------------------------------------------------------------------
1 |
2 |
3 | (* TESTING BASIC FUNCTION CALL *)
4 |
5 | let ocamlfind_ok = (try (Sys.getenv "OCAMLFIND_OK" ; true) with | _ -> false)
6 | let py = if ocamlfind_ok then Lymp.init "." else Lymp.init ~ocamlfind:false ~lymppy_dirpath:"srcs" "."
7 | let modul = Lymp.get_module py "modul"
8 |
9 | let rand_str () =
10 | Lymp.get_string modul "rand_str" []
11 |
12 | let () =
13 | let str = Lymp.get_string modul "rand_str" [] in
14 | if str <> "salut les gars" then raise (Failure "failed") ;
15 | print_endline str ;
16 |
17 | let str = rand_str () in
18 | if str <> "salut les gars" then raise (Failure "failed") ;
19 | print_endline str ;
20 |
21 | Lymp.close py
--------------------------------------------------------------------------------
/_tags:
--------------------------------------------------------------------------------
1 | # OASIS_START
2 | # DO NOT EDIT (digest: c4ed2b26dcfb6d5a5b888077fd80e49f)
3 | # Ignore VCS directories, you can use the same kind of rule outside
4 | # OASIS_START/STOP if you want to exclude directories that contains
5 | # useless stuff for the build process
6 | true: annot, bin_annot
7 | <**/.svn>: -traverse
8 | <**/.svn>: not_hygienic
9 | ".bzr": -traverse
10 | ".bzr": not_hygienic
11 | ".hg": -traverse
12 | ".hg": not_hygienic
13 | ".git": -traverse
14 | ".git": not_hygienic
15 | "_darcs": -traverse
16 | "_darcs": not_hygienic
17 | # Library lymp
18 | "srcs/lymp.cmxs": use_lymp
19 | : pkg_threads
20 | : pkg_unix
21 | # OASIS_STOP
22 |
--------------------------------------------------------------------------------
/tests/test7.ml:
--------------------------------------------------------------------------------
1 |
2 |
3 | let ocamlfind_ok = (try (Sys.getenv "OCAMLFIND_OK" ; true) with | _ -> false)
4 | let py = if ocamlfind_ok then Lymp.init "." else Lymp.init ~exec:"python3" ~ocamlfind:false ~lymppy_dirpath:"srcs" "."
5 | let builtin = Lymp.builtins py
6 |
7 | let get_ints i =
8 | let string_repr1 = Lymp.get_string builtin "str" [Lymp.Pyint i] in
9 | let string_repr2 = Lymp.get_string builtin "str" [Lymp.Pyint (i + 100)] in
10 | let string_repr3 = Lymp.get_string builtin "str" [Lymp.Pyint (i + 200)] in
11 | Printf.printf "%s %s %s\n" string_repr1 string_repr2 string_repr3
12 |
13 | let () =
14 | let threads = ref [] in
15 | for i = 0 to 50 do
16 | threads := (Thread.create get_ints i)::(!threads)
17 | done ;
18 | List.iter Thread.join !threads ;
19 | Lymp.close py
--------------------------------------------------------------------------------
/tests/test6.ml:
--------------------------------------------------------------------------------
1 |
2 |
3 | let ocamlfind_ok = (try (Sys.getenv "OCAMLFIND_OK" ; true) with | _ -> false)
4 | let py = if ocamlfind_ok then Lymp.init "." else Lymp.init ~exec:"python3" ~ocamlfind:false ~lymppy_dirpath:"srcs" "."
5 | let builtin = Lymp.builtins py
6 |
7 | let () =
8 | let file1 = Lymp.get_ref builtin "open" [Lymp.Pystr "test5.ml" ; Lymp.Namedarg ("encoding", Lymp.Pystr "utf-8")] in
9 | let encoding = Lymp.attr_string file1 "encoding" in
10 | if encoding = "utf-8" then () else raise (Failure "failed") ;
11 | let file2 = Lymp.get_ref builtin "open" [Lymp.Pystr "test5.ml" ; Lymp.Namedarg ("encoding", Lymp.Pystr "ascii")] in
12 | let encoding = Lymp.attr_string file2 "encoding" in
13 | if encoding = "ascii" then () else raise (Failure "failed") ;
14 |
15 | Lymp.close py
--------------------------------------------------------------------------------
/examples/phantom.ml:
--------------------------------------------------------------------------------
1 |
2 |
3 | (* downloads a webpage using phantomjs, saves a screenshot of it to screen.png,
4 | selects links out of page, and prints the links' titles *)
5 |
6 | open Lymp
7 |
8 | let py = init "."
9 | let phantom = get_module py "phantom"
10 |
11 | let download_with_phantom url =
12 | get_string phantom "download" [Pystr url]
13 |
14 | let select html css_selector =
15 | get_list phantom "select" [Pystr html ; Pystr css_selector]
16 |
17 | let get_lxml_text (Pyref lxml_elt) =
18 | (* calling method text_content() of lxml element *)
19 | let text = get lxml_elt "text_content" [] in
20 | (* text is a custom lxml type, we convert it to str *)
21 | get_string (builtins py) "str" [text]
22 |
23 | let () =
24 | let url = "https://github.com/dbousque/lymp" in
25 | let page_content = download_with_phantom url in
26 | let links = select page_content "a" in
27 | let titles = List.map get_lxml_text links in
28 | List.iter print_endline titles ;
29 |
30 | close py
31 |
--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
1 | # OASIS_START
2 | # DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954)
3 |
4 | SETUP = ocaml setup.ml
5 |
6 | build: setup.data
7 | $(SETUP) -build $(BUILDFLAGS)
8 |
9 | doc: setup.data build
10 | $(SETUP) -doc $(DOCFLAGS)
11 |
12 | test: setup.data build
13 | $(SETUP) -test $(TESTFLAGS)
14 |
15 | all:
16 | $(SETUP) -all $(ALLFLAGS)
17 |
18 | install: setup.data
19 | $(SETUP) -install $(INSTALLFLAGS)
20 | cp srcs/lymp.py `ocamlfind query lymp`/
21 | pip install pymongo || echo ""
22 | pip3 install pymongo || echo ""
23 |
24 | uninstall: setup.data
25 | $(SETUP) -uninstall $(UNINSTALLFLAGS)
26 |
27 | reinstall: setup.data
28 | $(SETUP) -reinstall $(REINSTALLFLAGS)
29 |
30 | clean:
31 | $(SETUP) -clean $(CLEANFLAGS)
32 |
33 | distclean:
34 | $(SETUP) -distclean $(DISTCLEANFLAGS)
35 |
36 | setup.data:
37 | $(SETUP) -configure $(CONFIGUREFLAGS)
38 |
39 | configure:
40 | $(SETUP) -configure $(CONFIGUREFLAGS)
41 |
42 | .PHONY: build doc test all install uninstall reinstall clean distclean configure
43 |
44 | # OASIS_STOP
45 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2016 Dominik Bousquet
2 |
3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
4 |
5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
6 |
7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
--------------------------------------------------------------------------------
/benchmark/benchmark.ml:
--------------------------------------------------------------------------------
1 |
2 |
3 | let ocamlfind_ok = (try (Sys.getenv "OCAMLFIND_OK" ; true) with | _ -> false)
4 | let py = if ocamlfind_ok then Lymp.init "." else Lymp.init ~exec:"python3" ~ocamlfind:false ~lymppy_dirpath:"srcs" "."
5 | let modul = Lymp.get_module py "modul"
6 |
7 | let speed_test () =
8 | let nb = ref 0 in
9 | let start = Unix.gettimeofday () in
10 | while Unix.gettimeofday () -. start < 1.0 do
11 | ignore (Lymp.get_int modul "get_int" []) ;
12 | ignore (Lymp.get_int modul "get_int" []) ;
13 | ignore (Lymp.get_int modul "get_int" []) ;
14 | ignore (Lymp.get_int modul "get_int" []) ;
15 | ignore (Lymp.get_int modul "get_int" []) ;
16 | ignore (Lymp.get_int modul "get_int" []) ;
17 | ignore (Lymp.get_int modul "get_int" []) ;
18 | ignore (Lymp.get_int modul "get_int" []) ;
19 | ignore (Lymp.get_int modul "get_int" []) ;
20 | ignore (Lymp.get_int modul "get_int" []) ;
21 | nb := !nb + 10
22 | done ;
23 | print_endline ("Function call overhead : " ^ (string_of_int (1000000 / !nb)) ^ " μs")
24 |
25 | let () =
26 | speed_test () ;
27 | Lymp.close py
--------------------------------------------------------------------------------
/srcs/LICENSE.bson.txt:
--------------------------------------------------------------------------------
1 | The MIT License (MIT)
2 | Copyright © 2013
3 | Marc Simon, marc.simon42@gmail.com, twitter.com/marcsimon42
4 | Dr. Xinuo Chen, iamindcs@gmail.com
5 |
6 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
7 |
8 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
9 |
10 | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
11 |
--------------------------------------------------------------------------------
/examples/reference.ml:
--------------------------------------------------------------------------------
1 |
2 |
3 | (* example usage of an object through a reference (here a dict object) *)
4 |
5 | open Lymp
6 |
7 | let py = init "."
8 | let builtin = builtins py
9 |
10 | let () =
11 | (* create a dict *)
12 | let dict = get_ref builtin "dict" [] in
13 | (* dict["field1"] = "value1" *)
14 | call dict "__setitem__" [Pystr "field1" ; Pystr "value1"] ;
15 | call dict "__setitem__" [Pystr "field2" ; Pyint 2] ;
16 | call dict "__setitem__" [Pystr "field3" ; Pyfloat 3.3] ;
17 | (* getting fields, for example 'val1' is the string "value1" *)
18 | let val1 = get_string dict "get" [Pystr "field1"] in
19 | let val2 = get_int dict "get" [Pystr "field2"] in
20 | let val3 = get_float dict "get" [Pystr "field3"] in
21 | (* 'values' will be : [Pystr "value1" ; Pyint 2 ; Pyfloat 3.3] *)
22 | let values_ref = get dict "values" [] in
23 | (* my_dict.values() returns a 'dict_values' and not a 'list' in python 3,
24 | so we make a conversion with list(values_ref) *)
25 | let values = get_list builtin "list" [values_ref] in
26 |
27 | print_endline val1 ;
28 | print_endline (string_of_int val2) ;
29 | print_endline (string_of_float val3) ;
30 |
31 | print_endline (string_of_int (List.length values)) ;
32 |
33 | (* ouput will be :
34 | value1
35 | 2
36 | 3.3
37 | 3
38 | *)
39 |
40 | close py
--------------------------------------------------------------------------------
/tests/test3.ml:
--------------------------------------------------------------------------------
1 |
2 |
3 | let ocamlfind_ok = (try (Sys.getenv "OCAMLFIND_OK" ; true) with | _ -> false)
4 | let py = if ocamlfind_ok then Lymp.init "." else Lymp.init ~exec:"python3" ~ocamlfind:false ~lymppy_dirpath:"srcs" "."
5 | let fetch = Lymp.get_module py "fetch"
6 | let builtin = Lymp.builtins py
7 |
8 | let () =
9 | let fetch_obj = Lymp.get_ref fetch "Fetch" [Lymp.Pystr "https://google.com" ; Lymp.Pystr "std"] in
10 | Lymp.call builtin "print" [Lymp.Pyref fetch_obj] ;
11 | let content = Lymp.get_string fetch_obj "download" [] in
12 | if content <> "Hi
" then raise (Failure "failed") ;
13 | let obj_ref_again = Lymp.get_ref fetch_obj "ret_self" [] in
14 | let url = Lymp.attr_string fetch_obj "url" in
15 | if url <> "https://google.com" then raise (Failure "failed") ;
16 | let mode = Lymp.attr_string obj_ref_again "mode" in
17 | if mode <> "std" then raise (Failure "failed") ;
18 |
19 | let int_ref = Lymp.get_ref builtin "int" [Lymp.Pystr "42"] in
20 | let int_val = Lymp.dereference int_ref in
21 | (match int_val with
22 | | Lymp.Pyint v -> if v <> 42 then raise (Failure "failed")
23 | | _ -> raise (Failure "failed") );
24 | let lst = Lymp.get_list fetch_obj "ret_list" [] in
25 | ( match lst with
26 | | [Lymp.Pyint i1 ; Lymp.Pyint i2 ; Lymp.Pyref obj ; Lymp.Pylist [Lymp.Pystr str ; Lymp.Pyint i3] ; Lymp.Pyint i4] -> if i1 <> 1 || i2 <> 2 || i3 <> 3 || i4 <> 4 || str <> "salut" then raise (Failure "failed")
27 | | _ -> raise (Failure "failed") ) ;
28 |
29 | Lymp.close py
--------------------------------------------------------------------------------
/tests/test2.ml:
--------------------------------------------------------------------------------
1 |
2 |
3 | (* TESTING PYREF AND WRONGTYPE EXCEPTION *)
4 |
5 | let ocamlfind_ok = (try (Sys.getenv "OCAMLFIND_OK" ; true) with | _ -> false)
6 | let py = if ocamlfind_ok then Lymp.init "." else Lymp.init ~exec:"python3" ~ocamlfind:false ~lymppy_dirpath:"srcs" "."
7 | let modul = Lymp.get_module py "modul"
8 |
9 | let file_lines filename =
10 | let lines = ref [] in
11 | let chan = open_in filename in
12 | try
13 | while true; do
14 | lines := input_line chan :: !lines
15 | done ;
16 | !lines
17 | with End_of_file ->
18 | close_in chan ;
19 | List.rev !lines
20 |
21 | let rec check_lines lines expected_lines =
22 | match expected_lines with
23 | | [] -> ()
24 | | e::rest_e -> match lines with
25 | | [] -> raise (Failure "failed")
26 | | l::rest_l -> if l <> e then raise (Failure "failed") else check_lines rest_l rest_e
27 |
28 | let () =
29 | ignore (try (Lymp.get_string modul "get_tuple" [])
30 | with Lymp.Wrong_Pytype _ -> "") ;
31 | (* tuples are converted to lists *)
32 | let tuple = Lymp.get modul "get_tuple" [] in
33 | ( match tuple with
34 | | Lymp.Pytuple l -> ()
35 | | _ -> raise (Failure "failed")) ;
36 |
37 | (* ASSERTING THAT PASSING PYREF AS ARGUMENT PASSES ACTUAL OBJECT *)
38 | Lymp.call modul "print_tuple" [tuple] ;
39 |
40 | (* ASSERTING THAT GENERIC FUNCTIONS ACCEPTS ALL KINDS OF ARGUMENTS *)
41 | Lymp.call modul "print_arg" [Lymp.Pystr "salut"] ;
42 | Lymp.call modul "print_arg" [Lymp.Pyint 42] ;
43 | Lymp.call modul "print_arg" [Lymp.Pyfloat 42.42] ;
44 | Lymp.call modul "print_arg" [Lymp.Pybool true] ;
45 | Lymp.call modul "print_arg" [Lymp.Pybytes (Bytes.of_string "some bytes")] ;
46 | Lymp.call modul "print_arg" [Lymp.get modul "ret_unicode" []] ;
47 | Lymp.call modul "print_arg" [Lymp.get modul "rand_str" []] ;
48 | (* equivalent of modul.print_arg(modul.first_of_tuple(tuple)) : *)
49 | Lymp.call modul "print_arg" [Lymp.get modul "first_of_tuple" [tuple]] ;
50 |
51 | Lymp.close py ;
52 |
53 | (* python_log should now be :
54 | (1, 2)
55 | salut
56 | 42
57 | 42.42
58 | True
59 | b'some bytes'
60 | saluté
61 | alright, inside python
62 | salut les gars
63 | 1
64 | *)
65 |
66 | let lines = file_lines "python_log" in
67 | let expected_lines = [
68 | "(1, 2)" ;
69 | "salut" ;
70 | "42" ;
71 | "42.42" ;
72 | "True" ;
73 | "b'some bytes'" ;
74 | "saluté" ;
75 | "alright, inside python" ;
76 | "salut les gars" ;
77 | "1"
78 | ] in
79 | check_lines lines expected_lines
80 |
--------------------------------------------------------------------------------
/srcs/lymp.mli:
--------------------------------------------------------------------------------
1 |
2 |
3 | exception Unknown_return_type of string
4 | exception Wrong_Pytype of string
5 | exception Expected_reference_not_module
6 | exception Could_not_create_pipe
7 | exception Pyexception of string
8 |
9 | (* information enabling communication with the python process *)
10 | type pycommunication
11 |
12 | (* pycallable can be a module or a reference *)
13 | type pycallable
14 |
15 | (* arguments passed to python functions must be of type pyobj *)
16 | type pyobj =
17 | Pystr of string
18 | | Pyint of int
19 | | Pyfloat of float
20 | | Pybool of bool
21 | | Pybytes of bytes
22 | | Pyref of pycallable
23 | | Pytuple of pyobj list
24 | | Pylist of pyobj list
25 | | Pynone
26 | | Namedarg of (string * pyobj)
27 |
28 | val get_module : pycommunication -> string -> pycallable
29 |
30 | (* module givin access to builtins attributes and functions, such as 'print' *)
31 | val builtins : pycommunication -> pycallable
32 |
33 | (* call functions and methods of modules and objects *)
34 | val call : pycallable -> string -> pyobj list -> unit
35 | val get : pycallable -> string -> pyobj list -> pyobj
36 | val get_string : pycallable -> string -> pyobj list -> string
37 | val get_int : pycallable -> string -> pyobj list -> int
38 | val get_float : pycallable -> string -> pyobj list -> float
39 | val get_bool : pycallable -> string -> pyobj list -> bool
40 | val get_bytes : pycallable -> string -> pyobj list -> bytes
41 | val get_ref : pycallable -> string -> pyobj list -> pycallable
42 | val get_tuple : pycallable -> string -> pyobj list -> pyobj list
43 | val get_list : pycallable -> string -> pyobj list -> pyobj list
44 |
45 | (* get attributes of modules and objects *)
46 | val attr : pycallable -> string -> pyobj
47 | val attr_string : pycallable -> string -> string
48 | val attr_int : pycallable -> string -> int
49 | val attr_float : pycallable -> string -> float
50 | val attr_bool : pycallable -> string -> bool
51 | val attr_bytes : pycallable -> string -> bytes
52 | val attr_ref : pycallable -> string -> pycallable
53 | val attr_tuple : pycallable -> string -> pyobj list
54 | val attr_list : pycallable -> string -> pyobj list
55 |
56 | val set_attr : pycallable -> string -> pyobj -> unit
57 |
58 | (* get what is being referenced,
59 | will return a Pyref if the python type is not supported *)
60 | val dereference : pycallable -> pyobj
61 |
62 | val close : pycommunication -> unit
63 | val init : ?exec:string -> ?ocamlfind:bool -> ?lymppy_dirpath:string -> string -> pycommunication
64 |
--------------------------------------------------------------------------------
/srcs/bson.mli:
--------------------------------------------------------------------------------
1 | (**
2 | This module includes a Bson document data structure, together with its encoding (to bytes) and decoding (from bytes).
3 |
4 | The logic of {b usage} is like this
5 | - Create an empty Bson document
6 | - Create the elements you want
7 | - Add elements to the document with names
8 | - Or remove elements from the document via the names
9 | - Get elements from the document via the names
10 | - After obtaining an element, get the raw value from the element
11 |
12 | The functions inside this module seem to be many, however, most of them are just for creating elements. These functions are to {e hide the implementation details of the type elements}. Also, in this way, the Bson document can be used more safely.
13 |
14 | Please refer to the {{: http://bsonspec.org/#/specification } Official Bson specification } for more information.
15 |
16 | {e Version 0.89.1}
17 | *)
18 |
19 | (** Raised when an objectId's length is not 12. see http://bsonspec.org/#/specification *)
20 | exception Invalid_objectId;;
21 |
22 | (** Raised when an unkown bson type is met while encoding the bson doc *)
23 | exception Wrong_bson_type;;
24 |
25 | (** Raised only when trying to decode the bytes to string. *)
26 | exception Wrong_string;;
27 |
28 | (** Raised when bad things happen while decoding the bytes to bson doc *)
29 | exception Malformed_bson;;
30 |
31 | (** The type for the Bson document. This is the main data structure *)
32 | type t;;
33 |
34 | (** The type for representing the special fields in Bson *)
35 | type special =
36 | | NULL
37 | | MINKEY
38 | | MAXKEY;;
39 |
40 | (** The type for the fields for the Bson document *)
41 | type element;;
42 |
43 |
44 | (** {6 Basic operations on Bson document} *)
45 |
46 | (** The empty Bson document *)
47 | val empty : t;;
48 |
49 | (** Check whether this Bson document empty or not *)
50 | val is_empty: t -> bool;;
51 |
52 | (** Add an element to a Bson document *)
53 | val add_element : string -> element -> t -> t;;
54 |
55 | (** Get an element from a Bson document via its name *)
56 | val get_element : string -> t -> element;;
57 |
58 | (** Check whether this Bson document has a specific element *)
59 | val has_element : string -> t -> bool;;
60 |
61 | (** Remove an element from a Bson document *)
62 | val remove_element : string -> t -> t;;
63 |
64 | (** Encode a Bson document to bytes (using type string as a carrier) *)
65 | val encode : t -> string;;
66 |
67 | (** Decode bytes (assuming type string as a carrier) to a Bson document *)
68 | val decode : string -> t;;
69 |
70 |
71 | (** {6 Creating elements} *)
72 |
73 |
74 | val create_double : float -> element;;
75 | val create_string : string -> element;;
76 | val create_doc_element : t -> element;;
77 | val create_list : element list -> element;;
78 | val create_doc_element_list : t list -> element;;
79 | val create_user_binary : string -> element;;
80 | val create_objectId : string -> element;;
81 | val create_boolean : bool -> element;;
82 | val create_utc : int64 -> element;;
83 | val create_null : unit -> element;;
84 | val create_regex : string -> string -> element;;
85 | val create_jscode : string -> element;;
86 | val create_jscode_w_s : string -> t -> element;;
87 | val create_int32 : int32 -> element;;
88 | val create_int64 : int64 -> element;;
89 | val create_minkey : unit -> element;;
90 | val create_maxkey : unit -> element;;
91 |
92 |
93 | (** {6 Getting raw values from elements} *)
94 |
95 |
96 | val get_double : element -> float;;
97 | val get_string : element -> string;;
98 | val get_doc_element : element -> t;;
99 | val get_list : element -> element list;;
100 | val get_generic_binary : element -> string;;
101 | val get_function_binary : element -> string;;
102 | val get_uuid_binary : element -> string;;
103 | val get_md5_binary : element -> string;;
104 | val get_user_binary : element -> string;;
105 | val get_objectId : element -> string;;
106 | val get_boolean : element -> bool;;
107 | val get_utc : element -> int64;;
108 | val get_null : element -> special;;
109 | val get_regex : element -> (string * string);;
110 | val get_jscode : element -> string;;
111 | val get_jscode_w_s : element -> (string * t);;
112 | val get_int32 : element -> int32;;
113 | val get_int64 : element -> int64;;
114 | val get_timestamp : element -> int64;;
115 | val get_minkey : element -> special;;
116 | val get_maxkey : element -> special;;
117 |
118 | val all_elements : t -> (string * element) list
119 |
120 | (** {6 Experimental. Convert a Bson document to Json.} *)
121 |
122 |
123 | val to_simple_json : t -> string;;
124 |
125 | (*val create_generic_binary : string -> element;;
126 | val create_function_binary : string -> element;;
127 | val create_uuid_binary : string -> element;;
128 | val create_md5_binary : string -> element;;
129 | val create_timestamp : int64 -> element;;*)
130 |
--------------------------------------------------------------------------------
/srcs/lymp.py:
--------------------------------------------------------------------------------
1 |
2 |
3 | from time import time
4 | from struct import pack, unpack
5 | import bson, sys, os, codecs
6 | from random import randint
7 | from traceback import print_exc
8 |
9 | def int_to_int64_bytes(i):
10 | return pack('>q', i)
11 |
12 | def py_to_bson(val):
13 | if type(val) is int:
14 | return bson.int64.Int64(val)
15 | if sys.version_info.major == 2 and type(val) is str:
16 | return bson.binary.Binary(val)
17 | return val
18 |
19 | def exit_lymp():
20 | # closing 'python_log'
21 | sys.stdout.close()
22 | exit(0)
23 |
24 | # A communication class, could be implemented using other ipc methods,
25 | # it only needs the methods 'send_bytes' and 'get_bytes'
26 | class PipeReaderWriter:
27 |
28 | def __init__(self, read_pipe_name, write_pipe_name):
29 | self.get_pipes(read_pipe_name, write_pipe_name)
30 |
31 | def get_pipes(self, read_pipe_name, write_pipe_name):
32 | # Order of open matters, since it is blocking, should match OCaml order
33 | # 0 to be unbuffered, so we don't have to flush (better performance ?)
34 | self.write_pipe = open(write_pipe_name, 'wb', 0)
35 | self.read_pipe = open(read_pipe_name, 'rb', 0)
36 |
37 | def send_bytes(self, byts):
38 | # '>q' to force signed 8 bytes integer
39 | self.write_pipe.write(pack('>q', len(byts)))
40 | #self.write_pipe.flush()
41 | self.write_pipe.write(byts)
42 | #self.write_pipe.flush()
43 |
44 | def get_bytes(self):
45 | # '>q' to force signed 8 bytes integer
46 | try:
47 | nb_bytes = unpack('>q', self.read_pipe.read(8))[0]
48 | except:
49 | # ocaml process has been terminated
50 | exit_lymp()
51 | byts = b'' if sys.version_info.major == 3 else ""
52 | while len(byts) < nb_bytes:
53 | byts += self.read_pipe.read(nb_bytes)
54 | return byts
55 |
56 | class ExecutionHandler:
57 |
58 | to_ret_types = {
59 | int: "i",
60 | tuple: "t",
61 | list: "l",
62 | str: "s",
63 | float: "f",
64 | type(None): "n",
65 | bool: "b",
66 | bytes: "B"
67 | }
68 | # for python 2, unicode is str and str is bytes
69 | if sys.version_info.major == 2:
70 | to_ret_types[unicode] = "s"
71 | to_ret_types[str] = "B"
72 |
73 | def __init__(self, reader_writer):
74 | self.reader_writer = reader_writer
75 | self.modules = {}
76 | self.objs = {}
77 | self.ref_nb = 0
78 |
79 | def loop(self):
80 | # don't recursively call .loop, to avoid stack overflow
81 | while True:
82 | command_bytes = self.reader_writer.get_bytes()
83 | if command_bytes == b'done':
84 | exit_lymp()
85 | instruction = bson.BSON.decode(bson.BSON(command_bytes))
86 | try:
87 | ret = self.execute_instruction(instruction)
88 | # data may still be in the buffer
89 | sys.stdout.flush()
90 | self.send_ret(ret, ret_ref=("R" in instruction))
91 | except BaseException as e:
92 | # exception whilst executing, inform ocaml side
93 | print_exc()
94 | # data may still be in the buffer
95 | sys.stdout.flush()
96 | self.send_ret("", exception=True)
97 |
98 | def ret_to_msg(self, ret, ret_ref):
99 | msg = {}
100 | # reference (type not supported or explicitely asked to)
101 | if ret_ref or (type(ret) not in self.to_ret_types):
102 | self.ref_nb += 1
103 | self.objs[self.ref_nb] = ret
104 | msg["t"] = "r"
105 | msg["v"] = bson.code.Code(str(self.ref_nb))
106 | else:
107 | msg["t"] = self.to_ret_types[type(ret)]
108 | # tuples are just like lists, but their type "t" is "t" instead of "l"
109 | if type(ret) is tuple:
110 | ret = list(ret)
111 | # if type is list, further resolve
112 | if type(ret) is list:
113 | msg["v"] = []
114 | for elt in ret:
115 | # ret_ref is false here (would not be in the else otherwise)
116 | msg["v"].append(self.ret_to_msg(elt, False))
117 | else:
118 | msg["v"] = py_to_bson(ret)
119 | return msg
120 |
121 | def send_ret(self, ret, exception=False, ret_ref=False):
122 | if exception:
123 | msg = {}
124 | msg["t"] = "e"
125 | msg["v"] = ""
126 | else:
127 | msg = self.ret_to_msg(ret, ret_ref)
128 | msg = bytes(bson.BSON.encode(msg))
129 | self.reader_writer.send_bytes(msg)
130 |
131 | def resolve_args(self, args):
132 | named = {}
133 | i = 0
134 | for arg in args:
135 | # resolve named args (list of size 2, first one being a bson.code.Code starting with "!")
136 | if type(arg) is list and len(arg) == 2 and type(arg[0]) is bson.code.Code and str(arg[0])[0] == "!":
137 | named[str(arg[0])[1:]] = self.resolve_args([arg[1]])[0][0]
138 | del args[i]
139 | continue
140 | # if bytes
141 | if type(arg) is bson.binary.Binary:
142 | args[i] = bytes(arg)
143 | # resolve reference args (using bson jscode)
144 | if type(arg) is bson.code.Code:
145 | args[i] = self.objs[int(arg)]
146 | if type(arg) is bson.int64.Int64:
147 | args[i] = int(arg)
148 | # for python 2, if arg is str, convert to unicode
149 | if sys.version_info.major == 2 and type(arg) is str:
150 | args[i] = args[i].decode('utf-8')
151 | # for python 2, if arg is bytes, convert to str
152 | if sys.version_info.major == 2 and type(arg) is bson.binary.Binary:
153 | args[i] = str(arg)
154 | # if we have a list, we must recursively resolve
155 | if type(arg) is list:
156 | args[i] = self.resolve_args(arg)[0]
157 | # if we have a dict, it is a tuple inside "v"
158 | if type(arg) is dict:
159 | args[i] = tuple(self.resolve_args(arg["v"])[0])
160 | i += 1
161 | return args, named
162 |
163 | def execute_instruction(self, instruction):
164 | if "r" in instruction:
165 | # if we are asked to realease an inexisting of already released reference
166 | if "d" in instruction and instruction["r"] not in self.objs:
167 | return None
168 | # module is the object referenced, later we call getattr to get the method called
169 | module = self.objs[instruction["r"]]
170 | # if we were asked to 'detach' (release) the reference
171 | if "d" in instruction:
172 | del self.objs[instruction["r"]]
173 | return None
174 | # if we were asked to return the reference
175 | if "g" in instruction:
176 | return module
177 | else:
178 | # python 2 builtin module has a different name
179 | if sys.version_info.major == 2 and instruction["m"] == "builtins":
180 | instruction["m"] = "__builtin__"
181 | if instruction["m"] not in self.modules:
182 | __import__(instruction["m"])
183 | self.modules[instruction["m"]] = sys.modules[instruction["m"]]
184 | module = self.modules[instruction["m"]]
185 | # set attribute
186 | if "s" in instruction:
187 | args, named = self.resolve_args(instruction["a"])
188 | arg = args[0]
189 | setattr(module, instruction["f"], arg)
190 | return None
191 | func_or_attr = getattr(module, instruction["f"])
192 | # get attribute
193 | if "t" in instruction:
194 | return func_or_attr
195 | args = instruction["a"]
196 | args, named = self.resolve_args(args)
197 | ret = func_or_attr(*args, **named)
198 | return ret
199 |
200 | working_directory = sys.argv[1]
201 | write_pipe_path = sys.argv[2]
202 | read_pipe_path = sys.argv[3]
203 | # changing dir
204 | os.chdir(working_directory)
205 | sys.path.insert(0, working_directory)
206 | # redirect stdout to 'python_log'
207 | sys.stdout = codecs.open('python_log', 'w', encoding='utf-8')
208 | sys.stderr = sys.stdout
209 | communication = PipeReaderWriter(read_pipe_path, write_pipe_path)
210 | handler = ExecutionHandler(communication)
211 | handler.loop()
212 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | Lymp
2 |
3 | `lymp` is a library allowing you to use Python functions and objects from OCaml. It gives access to the rich ecosystem of libraries in Python. You might want to use `selenium`, `scipy`, `lxml`, `requests`, `tensorflow` or `matplotlib`.
4 |
5 | You can also very easily write OCaml wrappers for Python libraries or your own modules.
6 |
7 | Python 2 and 3 compatible. Thread safe.
8 |
9 | Installation and compilation
10 |
11 | `opam install lymp`
12 |
13 | Python's `pymongo` package is required (for it's bson subpackage), `opam` and the Makefile try to install it using `pip` and `pip3`, so you should not have to install it manually. If `$ python3 -c "import pymongo"` fails, you need to install `pymongo`, maybe using sudo on `pip` or `pip3`.
14 |
15 | To make sure everything is fine, you may want to compile the simple example, like so for example : `ocamlbuild -use-ocamlfind -pkgs lymp -tag thread simple.native && ./simple.native`
16 |
17 | When compiling a project using `lymp`, you need to link the `thread` library. For example, when using ocamlbuild, set a tag : `-tag thread`.
18 |
19 | If you have trouble building the package, please contact me.
20 |
21 | Simple example
22 |
23 | ```
24 | $ ls
25 | simple.ml
26 | simple.py
27 | ```
28 | simple.py
29 |
30 | ```python
31 | def get_message():
32 | return u"hi there"
33 |
34 | def get_integer():
35 | return 42
36 |
37 | def sum(a, b):
38 | return a + b
39 | ```
40 |
41 | simple.ml
42 |
43 | ```ocaml
44 | open Lymp
45 |
46 | (* change "python3" to the name of your interpreter *)
47 | let interpreter = "python3"
48 | let py = init ~exec:interpreter "."
49 | let simple = get_module py "simple"
50 |
51 | let () =
52 | (* msg = simple.get_message() *)
53 | let msg = get_string simple "get_message" [] in
54 | let integer = get_int simple "get_integer" [] in
55 | let addition = get_int simple "sum" [Pyint 12 ; Pyint 10] in
56 | let strconcat = get_string simple "sum" [Pystr "first " ; Pystr "second"] in
57 | Printf.printf "%s\n%d\n%d\n%s\n" msg integer addition strconcat ;
58 |
59 | close py
60 | ```
61 |
62 | ```
63 | $ ./simple.native
64 | hi there
65 | 42
66 | 22
67 | first second
68 | ```
69 |
70 | Useful example
71 |
72 | This example shows how you can use `selenium` and `lxml` to download a webpage (with content loaded via Javascript thanks to PhantomJS), and then parse it and manipulate the DOM. You would need `lxml`, `cssselect`, `selenium`, nodeJS and phantomJS (through `npm` for example) to run this example.
73 |
74 | phantom.py
75 |
76 | ```python
77 | import lxml.html as lx
78 | from selenium import webdriver
79 |
80 | driver = webdriver.PhantomJS()
81 | driver.set_window_size(1024, 768)
82 |
83 | def download(url):
84 | driver.get(url)
85 | driver.save_screenshot('screen.png')
86 | return driver.page_source
87 |
88 | def select(html, css_selector):
89 | doc = lx.fromstring(html)
90 | return doc.cssselect(css_selector)
91 | ```
92 |
93 | phantom.ml
94 |
95 | ```ocaml
96 | (* downloads a webpage using phantomjs, saves a screenshot of it to screen.png,
97 | selects links out of the page, and prints the links' titles *)
98 |
99 | open Lymp
100 |
101 | let py = init "."
102 | let phantom = get_module py "phantom"
103 |
104 | let download_with_phantom url =
105 | get_string phantom "download" [Pystr url]
106 |
107 | let select html css_selector =
108 | get_list phantom "select" [Pystr html ; Pystr css_selector]
109 |
110 | let get_lxml_text (Pyref lxml_elt) =
111 | (* calling method text_content() of lxml element *)
112 | let text = get lxml_elt "text_content" [] in
113 | (* text is a custom lxml type, we convert it to str *)
114 | get_string (builtins py) "str" [text]
115 |
116 | let () =
117 | let url = "https://github.com/dbousque/lymp" in
118 | let page_content = download_with_phantom url in
119 | let links = select page_content "a" in
120 | let titles = List.map get_lxml_text links in
121 | List.iter print_endline titles ;
122 |
123 | close py
124 | ```
125 | You don't really need the python script to do that, you could write it completely in OCaml using `lymp`, getting and manipulating the `driver` object directly using a reference.
126 |
127 | pyobj
128 |
129 | ```ocaml
130 | type pyobj =
131 | Pystr of string
132 | | Pyint of int
133 | | Pyfloat of float
134 | | Pybool of bool
135 | | Pybytes of bytes
136 | | Pyref of pycallable
137 | | Pytuple of pyobj list
138 | | Pylist of pyobj list
139 | | Pynone
140 | | Namedarg of (string * pyobj)
141 | ```
142 |
143 | Main type representing python values, which are passed as arguments of functions and returned from functions. `Pyref` allows us to use python objects, we explain that later on.
144 |
145 | `Namedarg` represents a named argument, which you can use like so :
146 | ```ocaml
147 | get builtin "open" [Pystr "input.txt" ; Namedarg ("encoding", Pystr "utf-8")]
148 | ```
149 |
150 | API
151 |
152 | `init` spawns a Python process and gets it ready. A `pycommunication` is returned, which you can then use to make modules. `get_module` can be thought of as an `import` statement in Python.
153 | You can then call the functions or get the attributes of the module, using the get* and attr* functions.
154 |
155 |
156 |
157 | ```ocaml
158 | val init : ?exec:string -> ?ocamlfind:bool -> ?lymppy_dirpath:string -> string -> pycommunication
159 | ```
160 | - 1. `exec` : name of the python interpreter, or path to it. Default is `python3` (python 2 and 3 are both supported)
161 | - 2. `ocamlfind` : `lymp` uses a python script, `lymp.py`, which is in `ocamlfind query lymp` if you installed through opam or the Makefile. If you didn't install that way, set `ocamlfind` to `false`. Default is `true`
162 | - 3. `lymppy_dirpath` : if `ocamlfind` is set to `false`, `lymp.py` will be assumed to be in `lymppy_dirpath`. Default is `"."`
163 | - 4. path from which python will be launched, which influences what modules are accessible. Example value : `"../py_utils"`
164 |
165 |
166 |
167 | ```ocaml
168 | val get_module : pycommunication -> string -> pycallable
169 | ```
170 | - 1. a value returned by `init`
171 | - 2. name of the module you wish to use (can be something like `"app.crypto.utils"`)
172 |
173 |
174 |
175 | ```ocaml
176 | val builtins : pycommunication -> pycallable
177 | ```
178 | - 1. a value returned by `init`
179 |
180 | Returns the module giving access to built-in functions and attributes, such as `print()`, `str()`, `dir()` etc.
181 |
182 |
183 |
184 | ```ocaml
185 | val get : pycallable -> string -> pyobj list -> pyobj
186 | ```
187 | - 1. a module or a reference, from which you wish to call a function
188 | - 2. name of the function
189 | - 3. arguments of the function
190 |
191 | Example : `get time "sleep" [Pyint 2]` (equivalent in python : `time.sleep(2)`)
192 |
193 | Sister functions : `get_string`, `get_int`, `get_float`, `get_bool`, `get_bytes`, `get_tuple` and `get_list`. They call `get` and try to do pattern matching over the result to return the desired type, they fail with a `Wrong_Pytype` if the result was not from the expected type. For example, `get_string` doesn't return a `pyobj`, but a `string`.
194 |
195 |
196 |
197 | ```ocaml
198 | val call : pycallable -> string -> pyobj list -> unit
199 | ```
200 |
201 | Calls `get` and dismisses the value returned
202 |
203 |
204 |
205 | ```ocaml
206 | val attr : pycallable -> string -> pyobj
207 | ```
208 | - 1. a module or a reference, from which you wish to get an attribute
209 | - 2. name of the attribute
210 |
211 | Example : `attr sys "argv"` (equivalent in python : `sys.argv`)
212 |
213 | Sister functions : `attr_string`, `attr_int`, `attr_float`, `attr_bool`, `attr_bytes`, `attr_tuple` and `attr_list`. They call `attr` and try to do pattern matching over the result to return the desired type, they fail with a `Wrong_Pytype` if the result was not from the expected type.
214 |
215 |
216 |
217 | ```ocaml
218 | val set_attr : pycallable -> string -> pyobj -> unit
219 | ```
220 | - 1. a module or a reference, to which you wish to set an attribute
221 | - 2. name of the attribute
222 | - 3. value to set the attribute to
223 |
224 | Example : `set_attr sys "stdout" (Pyint 42)` (equivalent in python : `sys.stdout = 42`)
225 |
226 |
227 |
228 | ```ocaml
229 | val close : pycommunication -> unit
230 | ```
231 | - 1. a value returned by `init`
232 |
233 | Exit properly, it's important to call it.
234 |
235 |
236 | References
237 | To be able to use python objects of non supported-types (anything outside of int, str etc.), we have references.
238 |
239 | A `Pyreference` is of type `pycallable`, which allows us to call `get` and `attr` on it. When passed as arguments or returned from functions, they are passed as `Pyref`, of type `pyobj`.
240 |
241 | References passed as arguments are resolved on the python side, which means that if you call a function with a reference as argument, on the python side the actual object will be passed.
242 |
243 | Another use case for references (other than unsupported types) is for very big strings, bytes or lists, which you may not wish to send back and forth between OCaml and Python if you need to further process them in python. Passing is relatively cheap, but you may want to avoid it.
244 |
245 | Objects referenced are garbage collected when you no longer need them.
246 |
247 |
248 |
249 | ```ocaml
250 | val get_ref : pycallable -> string -> pyobj list -> pycallable
251 | ```
252 | Calls `get` and forces the result to be a reference, so the actual data is not sent back to OCaml, but remains on the Python side. To be used for unsupported types and big strings, bytes and lists if you need to further process them in python. What we call "big string" is a whole webpage for example (but as shown in the "Useful example", it's perfectly fine to pass the string directly back and forth).
253 |
254 |
255 |
256 | ```ocaml
257 | val attr_ref : pycallable -> string -> pycallable
258 | ```
259 | Calls `attr` and forces the result to be a reference.
260 |
261 |
262 |
263 | ```ocaml
264 | val dereference : pycallable -> pyobj
265 | ```
266 | If the value's type is supported, it will be returned, otherwise a reference to it is returned.
267 |
268 |
269 |
270 | Example usage of a reference :
271 | ```ocaml
272 | let file = get_ref builtin "open" [Pystr "input_file.txt"] in
273 | call builtin "print" [Pyref file] ;
274 | let content = get_string file "read" [] in
275 | print_endline content
276 | ```
277 | You can find a more in-depth example in `examples/reference.ml`
278 |
279 | Notes
280 |
281 | - In Python 2, Pystr are converted to `unicode`, assuming that the string is utf-8 encoded, and Pybytes to `str`
282 | - If there is a fatal exception, the python process continues as normal, but a Pyexception is raised on the OCaml side.
283 | - Python's stdout is a file named `python_log`, you will find the output and uncatched exceptions' traceback there.
284 | - Python's `int`s are converted to OCaml `int`s, overflow and underflow are therefore possible. Same goes for `float`.
285 |
286 | Implementation
287 |
288 | `lymp` currently uses named pipes to make OCaml and Python processes communicate. BSON is used to serialize data passed.
289 | Performance is very good for almost all use cases. On my setup (virtual machine and relatively low specs), the overhead associated with a function call is roughly 25 μs. You can launch the benchmark to see what the overhead is on yours.
290 | Performance could be improved by using other IPC methods, such as shared memory.
291 |
292 | "lymp" ?
293 | "pyml" was already taken, and so were "ocpy" and "pyoc", so I figured I would just mix letters.
294 |
295 | TODO
296 |
297 | If it matters to you, better support for Python exceptions could be implemented (currently, a Pyexception is raised). Also, better performance would be pretty easy to get. Support for dicts could be added. We could also add the option to log Python's stdout to OCaml's stdout (there would be some drawbacks but it might be worth it). You are welcome to make pull requests and suggestions.
298 |
--------------------------------------------------------------------------------
/srcs/lymp.ml:
--------------------------------------------------------------------------------
1 |
2 |
3 | exception Unknown_return_type of string
4 | exception Wrong_Pytype of string
5 | exception Expected_reference_not_module
6 | exception Could_not_create_pipe
7 | exception Pyexception of string
8 |
9 |
10 | (* TYPES *)
11 |
12 | type pipe = {
13 | path: string ;
14 | fd: Unix.file_descr
15 | }
16 |
17 | type pycommunication = {
18 | read_pipe: pipe ;
19 | write_pipe: pipe ;
20 | process_in: in_channel ;
21 | process_out: out_channel ;
22 | mutex: Mutex.t ;
23 | mutable closed: bool
24 | }
25 |
26 | type reference = {
27 | mutable py: pycommunication ;
28 | ref_nb: int ;
29 | mutable released: bool
30 | }
31 |
32 | type pycallable =
33 | Pymodule of pycommunication * string
34 | | Pyreference of reference
35 |
36 | type pyobj =
37 | Pystr of string
38 | | Pyint of int
39 | | Pyfloat of float
40 | | Pybool of bool
41 | | Pybytes of bytes
42 | | Pyref of pycallable
43 | | Pytuple of pyobj list
44 | | Pylist of pyobj list
45 | | Pynone
46 | | Namedarg of (string * pyobj)
47 |
48 | let ret_wrongtype mod_name func_name expected_type returned_type =
49 | let str = mod_name ^ "." ^ func_name ^ " : " in
50 | Wrong_Pytype (str ^ "expected " ^ expected_type ^ " but python returned " ^ returned_type)
51 |
52 | let make_wrongtype callable func_name expected_type ret_obj =
53 | let type_ret = ( match ret_obj with
54 | | Pystr _ -> "str"
55 | | Pyint _ -> "int"
56 | | Pyfloat _ -> "float"
57 | | Pybool _ -> "bool"
58 | | Pybytes _ -> "bytes"
59 | | Pyref _ -> "Pyref"
60 | | Pytuple _ -> "tuple"
61 | | Pylist _ -> "list"
62 | | Pynone -> "Nonetype"
63 | | Namedarg _ -> "Namedarg"
64 | ) in
65 | let mod_name = (match callable with
66 | | Pymodule (_,mod_name) -> mod_name
67 | | _ -> "method "
68 | ) in
69 | ret_wrongtype mod_name func_name expected_type type_ret
70 |
71 |
72 | (* COMMUNICATION UTILS *)
73 |
74 | let get_random_characters () =
75 | String.init 10 (fun i -> Char.chr (Random.int 26 + Char.code 'a'))
76 |
77 | let rec create_pipe path name =
78 | let rand_name = get_random_characters () in
79 | let rand_path = (path ^ rand_name) in
80 | if Sys.file_exists rand_path then create_pipe path name
81 | else (
82 | (try Unix.mkfifo rand_path 0o600 with
83 | | Unix.Unix_error _ -> raise Could_not_create_pipe) ;
84 | name ^ rand_name
85 | )
86 |
87 | let get_pipes path_read path_write =
88 | (* set O_SYNC to have synchronous (unbuffered) communication,
89 | so we don't have to flush, maybe O_DSYNC instead ? *)
90 | let fd_read = Unix.openfile path_read [Unix.O_RDONLY; Unix.O_SYNC] 0o600 in
91 | let fd_write = Unix.openfile path_write [Unix.O_WRONLY; Unix.O_SYNC] 0o600 in
92 | ({path = path_read ; fd = fd_read}, {path = path_write ; fd = fd_write})
93 |
94 | let create_process exec pyroot ocamlfind_ready lymppy_dirpath read_pipe_name write_pipe_name =
95 | let path = (
96 | if ocamlfind_ready then
97 | "`ocamlfind query lymp`" ^ Filename.dir_sep
98 | else
99 | lymppy_dirpath ^ Filename.dir_sep
100 | ) in
101 | let command = exec ^ " " ^ path ^ "lymp.py " in
102 | let command = command ^ "$(cd " ^ pyroot ^ " ; pwd) " in
103 | let command = command ^ "$(cd " ^ pyroot ^ " ; pwd)" ^ Filename.dir_sep ^ read_pipe_name ^ " " in
104 | let command = command ^ "$(cd " ^ pyroot ^ " ; pwd)" ^ Filename.dir_sep ^ write_pipe_name in
105 | Unix.open_process (command)
106 |
107 |
108 | (* SERIALIZATION / DESERIALIZATION *)
109 |
110 | let int64_mod i n =
111 | Int64.sub i (Int64.mul (Int64.div i (Int64.of_int n)) (Int64.of_int n))
112 |
113 | let int64_to_bytes i =
114 | let bytes = Bytes.make 8 (Char.chr 0) in
115 | let rec _to_bytes bytes i ind =
116 | Bytes.set bytes ind (Char.chr (Int64.to_int (int64_mod i 256))) ;
117 | match ind with
118 | | 0 -> ()
119 | | n -> _to_bytes bytes (Int64.div i (Int64.of_int 256)) (n - 1)
120 | in
121 | _to_bytes bytes i 7 ;
122 | bytes
123 |
124 | let bytes_to_int bytes nb =
125 | let rec _to_int bytes ind nb ret =
126 | let tmp = Char.code (Bytes.get bytes ind) in
127 | match nb - ind - 1 with
128 | | 0 -> ret * 256 + tmp
129 | | _ -> _to_int bytes (ind + 1) nb (ret * 256 + tmp)
130 | in
131 | _to_int bytes 0 nb 0
132 |
133 | let send_raw_bytes py bytes =
134 | let len = Int64.of_int (Bytes.length bytes) in
135 | ignore (Unix.write py.write_pipe.fd (int64_to_bytes len) 0 8) ;
136 | ignore (Unix.write py.write_pipe.fd bytes 0 (Bytes.length bytes))
137 |
138 | let get_raw_bytes py =
139 | let len = Bytes.make 8 (Char.chr 0) in
140 | ignore (Unix.read py.read_pipe.fd len 0 8) ;
141 | let to_read = bytes_to_int len 8 in
142 | let ret_bytes = Bytes.make to_read (Char.chr 0) in
143 | let nb_read = ref 0 in
144 | while !nb_read < to_read do
145 | nb_read := !nb_read + Unix.read py.read_pipe.fd ret_bytes !nb_read (to_read - !nb_read)
146 | done ;
147 | ret_bytes
148 |
149 | let compose f g x = f (g x)
150 |
151 | (* Bson.encode reverses lists, so use rev_map *)
152 | let rec serialize_list lst =
153 | Bson.create_list (List.rev_map serialize lst)
154 |
155 | and serialize = function
156 | | Pystr str -> Bson.create_string str
157 | | Pyint i -> Bson.create_int64 (Int64.of_int i)
158 | | Pytuple lst -> Bson.empty |> Bson.add_element "v" (serialize_list lst) |> Bson.create_doc_element
159 | | Pylist lst -> serialize_list lst
160 | | Pyfloat f -> Bson.create_double f
161 | | Pybool b -> Bson.create_boolean b
162 | | Pybytes b -> Bson.create_user_binary (Bytes.to_string b)
163 | | Pyref (Pyreference {py ; ref_nb ; released}) -> Bson.create_jscode (string_of_int ref_nb)
164 | | Pyref (Pymodule _) -> raise Expected_reference_not_module
165 | | Pynone -> Bson.create_null ()
166 | | Namedarg (name, value) -> Bson.create_list [serialize value ; Bson.create_jscode ("!" ^ name)]
167 |
168 | (* Bson.decode reverses lists, so use rev_map *)
169 | let rec deserialize_list py lst =
170 | List.rev_map (compose (deserialize py) Bson.get_doc_element) lst
171 |
172 | and deserialize py doc =
173 | let element = Bson.get_element "v" doc in
174 | match Bson.get_string (Bson.get_element "t" doc) with
175 | | "s" -> Pystr (Bson.get_string element)
176 | | "i" -> Pyint (Int64.to_int (Bson.get_int64 element))
177 | | "t" -> Pytuple (deserialize_list py (Bson.get_list element))
178 | | "l" -> Pylist (deserialize_list py (Bson.get_list element))
179 | | "f" -> Pyfloat (Bson.get_double element)
180 | | "b" -> Pybool (Bson.get_boolean element)
181 | | "B" -> Pybytes ((Bson.get_generic_binary element) |> Bytes.of_string)
182 | | "r" -> let r = {py = py ; ref_nb = int_of_string (Bson.get_jscode element) ; released = false} in
183 | Gc.finalise release_reference r ;
184 | Pyref (Pyreference r)
185 | | "n" -> Pynone
186 | | "e" -> raise (Pyexception "check the file python_log for traceback")
187 | | n -> raise (Unknown_return_type n)
188 |
189 | and py_call_raw py arg_to_not_finalize_ref release_ref set_attr modul dereference get_attr ret_ref mod_or_ref_bytes func_name args =
190 | let mod_or_ref_bytes = if dereference = false then mod_or_ref_bytes else (
191 | match arg_to_not_finalize_ref with
192 | | Pymodule (py, name) -> raise Expected_reference_not_module
193 | | Pyreference {py ; ref_nb ; released} -> Bson.create_int64 (Int64.of_int ref_nb)
194 | ) in
195 | let doc = Bson.empty in
196 | let lst = serialize_list args in
197 | let doc = Bson.add_element "a" lst doc in
198 | let doc = Bson.add_element (if dereference then "g" else "f") (Bson.create_string func_name) doc in
199 | let doc = if get_attr then (Bson.add_element "t" (Bson.create_string "") doc) else doc in
200 | let doc = if set_attr then (Bson.add_element "s" (Bson.create_string "") doc) else doc in
201 | let doc = if ret_ref then (Bson.add_element "R" (Bson.create_string "") doc) else doc in
202 | let doc = if release_ref then (Bson.add_element "d" (Bson.create_string "") doc) else doc in
203 | (* mutex lock before making bytes, to prevent release of current reference *)
204 | let continue = ( if release_ref
205 | then
206 | Mutex.try_lock py.mutex
207 | else
208 | ( Mutex.lock py.mutex ; true )
209 | ) in
210 | if continue = false then Pynone else (
211 | let mod_or_ref_bytes = if dereference = false then mod_or_ref_bytes else (
212 | match arg_to_not_finalize_ref with
213 | | Pymodule (py, name) -> raise Expected_reference_not_module
214 | | Pyreference {py ; ref_nb ; released} -> Bson.create_int64 (Int64.of_int ref_nb)
215 | ) in
216 | let doc = Bson.add_element (if modul then "m" else "r") mod_or_ref_bytes doc in
217 | let bytes = Bson.encode doc |> Bytes.of_string in
218 | send_raw_bytes py bytes ;
219 | let ret_bytes = get_raw_bytes py in
220 | Mutex.unlock py.mutex ;
221 | let ret_doc = Bson.decode (Bytes.to_string ret_bytes) in
222 | let ret_obj = deserialize py ret_doc in
223 | ret_obj
224 | )
225 |
226 | and release_reference reference =
227 | match reference with
228 | | {py ; ref_nb ; released} ->
229 | ( if py.closed = false && released = false then
230 | ( reference.released <- true ;
231 | try ignore (py_call_raw py (Pymodule (py, "")) true false false false false false (Bson.create_int64 (Int64.of_int ref_nb)) "" []) with
232 | | _ -> ()
233 | )
234 | else
235 | ()
236 | )
237 |
238 |
239 | (* INTERFACE *)
240 |
241 | let get_module py mod_name =
242 | Pymodule (py, mod_name)
243 |
244 | let builtins py =
245 | Pymodule (py, "builtins")
246 |
247 | let get callable func args =
248 | match callable with
249 | | Pymodule (py, name) -> py_call_raw py callable false false true false false false (Bson.create_string name) func args
250 | | Pyreference {py ; ref_nb} -> py_call_raw py callable false false false false false false (Bson.create_int64 (Int64.of_int ref_nb)) func args
251 |
252 | let call callable func args =
253 | ignore (get callable func args)
254 |
255 | let get_string callable func args =
256 | match get callable func args with
257 | | Pystr s -> s
258 | | ret -> raise (make_wrongtype callable func "str" ret)
259 |
260 | let get_int callable func args =
261 | match get callable func args with
262 | | Pyint i -> i
263 | | ret -> raise (make_wrongtype callable func "int" ret)
264 |
265 | let get_float callable func args =
266 | match get callable func args with
267 | | Pyfloat f -> f
268 | | ret -> raise (make_wrongtype callable func "float" ret)
269 |
270 | let get_bool callable func args =
271 | match get callable func args with
272 | | Pybool b -> b
273 | | ret -> raise (make_wrongtype callable func "bool" ret)
274 |
275 | let get_bytes callable func args =
276 | match get callable func args with
277 | | Pybytes b -> b
278 | | ret -> raise (make_wrongtype callable func "bytes" ret)
279 |
280 | let get_ref callable func args =
281 | let ret = (
282 | match callable with
283 | | Pymodule (py, name) -> py_call_raw py callable false false true false false true (Bson.create_string name) func args
284 | | Pyreference {py ; ref_nb ; released} -> py_call_raw py callable false false false false false true (Bson.create_int64 (Int64.of_int ref_nb)) func args
285 | ) in
286 | match ret with
287 | | Pyref r -> r
288 | | ret -> raise (make_wrongtype callable func "Pyref" ret)
289 |
290 | let get_tuple callable func args =
291 | match get callable func args with
292 | | Pytuple t -> t
293 | | ret -> raise (make_wrongtype callable func "tuple" ret)
294 |
295 | let get_list callable func args =
296 | match get callable func args with
297 | | Pylist l -> l
298 | | ret -> raise (make_wrongtype callable func "list" ret)
299 |
300 | let attr callable name =
301 | match callable with
302 | | Pymodule (py, name) -> py_call_raw py callable false false true false true false (Bson.create_string name) name []
303 | | Pyreference {py ; ref_nb ; released} -> py_call_raw py callable false false false false true false (Bson.create_int64 (Int64.of_int ref_nb)) name []
304 |
305 | let attr_string callable name =
306 | match attr callable name with
307 | | Pystr s -> s
308 | | ret -> raise (make_wrongtype callable name "str" ret)
309 |
310 | let attr_int callable name =
311 | match attr callable name with
312 | | Pyint i -> i
313 | | ret -> raise (make_wrongtype callable name "int" ret)
314 |
315 | let attr_float callable name =
316 | match attr callable name with
317 | | Pyfloat f -> f
318 | | ret -> raise (make_wrongtype callable name "float" ret)
319 |
320 | let attr_bool callable name =
321 | match attr callable name with
322 | | Pybool b -> b
323 | | ret -> raise (make_wrongtype callable name "bool" ret)
324 |
325 | let attr_bytes callable name =
326 | match attr callable name with
327 | | Pybytes b -> b
328 | | ret -> raise (make_wrongtype callable name "bytes" ret)
329 |
330 | let attr_ref callable name =
331 | let ret = (
332 | match callable with
333 | | Pymodule (py, name) -> py_call_raw py callable false false true false true true (Bson.create_string name) name []
334 | | Pyreference {py ; ref_nb ; released} -> py_call_raw py callable false false false false true true (Bson.create_int64 (Int64.of_int ref_nb)) name []
335 | ) in
336 | match ret with
337 | | Pyref r -> r
338 | | ret -> raise (make_wrongtype callable name "Pyref" ret)
339 |
340 | let attr_tuple callable name =
341 | match attr callable name with
342 | | Pytuple t -> t
343 | | ret -> raise (make_wrongtype callable name "tuple" ret)
344 |
345 | let attr_list callable name =
346 | match attr callable name with
347 | | Pylist l -> l
348 | | ret -> raise (make_wrongtype callable name "list" ret)
349 |
350 | let set_attr callable name value =
351 | ignore ( match callable with
352 | | Pymodule (py, name) -> py_call_raw py callable false true true false false false (Bson.create_string name) name [value]
353 | | Pyreference {py ; ref_nb ; released} -> py_call_raw py callable false true false false false false (Bson.create_int64 (Int64.of_int ref_nb)) name [value] ) ;
354 | ()
355 |
356 | let dereference r =
357 | match r with
358 | | Pymodule (py, name) -> raise Expected_reference_not_module
359 | | Pyreference {py ; ref_nb ; released} -> py_call_raw py r false false false true false false (Bson.create_string "") "" []
360 |
361 | let close py =
362 | py.closed <- true ;
363 | Mutex.lock py.mutex ;
364 | send_raw_bytes py (Bytes.of_string "done") ;
365 | Mutex.unlock py.mutex ;
366 | ignore (Unix.close_process (py.process_in, py.process_out)) ;
367 | Sys.remove py.read_pipe.path ;
368 | Sys.remove py.write_pipe.path
369 |
370 | (* set ocamlfind to false if your ocamlfind is unable to find the package,
371 | lymp.py will be assumed to be in lymppy_dirpath *)
372 | let init ?(exec="python3") ?(ocamlfind=true) ?(lymppy_dirpath=".") pyroot =
373 | Random.self_init () ;
374 | let read_pipe_name = ".lymp_to_ocaml" in
375 | let write_pipe_name = ".lymp_to_python" in
376 | let read_pipe_path = pyroot ^ Filename.dir_sep ^ read_pipe_name in
377 | let write_pipe_path = pyroot ^ Filename.dir_sep ^ write_pipe_name in
378 | let read_pipe_randname = create_pipe read_pipe_path read_pipe_name in
379 | let write_pipe_randname = create_pipe write_pipe_path write_pipe_name in
380 | let process_in, process_out = create_process exec pyroot ocamlfind lymppy_dirpath read_pipe_randname write_pipe_randname in
381 | let read_pipe, write_pipe = get_pipes (pyroot ^ Filename.dir_sep ^ read_pipe_randname) (pyroot ^ Filename.dir_sep ^ write_pipe_randname) in
382 | {
383 | read_pipe = read_pipe ;
384 | write_pipe = write_pipe ;
385 | process_in = process_in ;
386 | process_out = process_out ;
387 | mutex = Mutex.create () ;
388 | closed = false
389 | }
390 |
--------------------------------------------------------------------------------
/srcs/bson.ml:
--------------------------------------------------------------------------------
1 | exception Invalid_objectId;;
2 | exception Wrong_bson_type;;
3 | exception Wrong_string;;
4 | exception Malformed_bson;;
5 |
6 | type document = (string * element) list
7 | and t = document
8 | and special =
9 | | NULL
10 | | MINKEY
11 | | MAXKEY
12 | and element =
13 | | Double of float
14 | | String of string
15 | | Document of document
16 | | Array of element list
17 | | Binary of binary
18 | | ObjectId of string (* only 12 bytes *)
19 | | Boolean of bool
20 | | UTC of int64
21 | | Null of special
22 | | Regex of (string * string)
23 | | JSCode of string
24 | | JSCodeWS of (string * document)
25 | | Int32 of int32
26 | | Int64 of int64
27 | | Timestamp of int64
28 | | MinKey of special
29 | | MaxKey of special
30 | and binary =
31 | | Generic of string
32 | | Function of string
33 | | UUID of string
34 | | MD5 of string
35 | | UserDefined of string;;
36 |
37 |
38 | let empty = [];;
39 |
40 | let is_empty = function
41 | | [] -> true
42 | | _ -> false;;
43 |
44 | let has_element = List.mem_assoc
45 |
46 | (*
47 | The remove operations.
48 | *)
49 | let remove_element = List.remove_assoc
50 |
51 | (*
52 | for constructing a document
53 | 1. we make a empty document
54 | 2. we create element as we want
55 | 3. we add the element to the document, with a element name
56 | *)
57 | let add_element ename element doc =
58 | (* Emulating StringMap add operation *)
59 | let doc =
60 | if has_element ename doc then remove_element ename doc
61 | else doc
62 | in
63 | (ename,element)::doc;;
64 |
65 | (*
66 | for using a document
67 | 1. we get an element from document, if existing
68 | 2. we get the value of the element
69 | *)
70 | let get_element = List.assoc
71 |
72 |
73 |
74 | let create_double v = Double v;;
75 | let create_string v = String v;;
76 | let create_doc_element v = Document v;;
77 | let create_list l = Array l;;
78 | let create_doc_element_list l = create_list (List.map create_doc_element l);;
79 | let create_generic_binary v = Binary (Generic v);;
80 | let create_function_binary v = Binary (Function v);;
81 | let create_uuid_binary v = Binary (UUID v);;
82 | let create_md5_binary v = Binary (MD5 v);;
83 | let create_user_binary v = Binary (UserDefined v);;
84 | let is_valid_objectId objectId = if String.length objectId = 12 || String.length objectId = 24 then true else false;;
85 | let hex_to_string s =
86 | let n = String.length s in
87 | let buf = Buffer.create 12 in
88 | let rec convert i =
89 | if i > n-1 then Buffer.contents buf
90 | else begin
91 | Buffer.add_char buf (char_of_int (int_of_string ("0x" ^ (String.sub s i 2))));
92 | convert (i+2)
93 | end
94 | in
95 | convert 0
96 | let create_objectId v =
97 | if String.length v = 12 then ObjectId v
98 | else if String.length v = 24 then
99 | try (ObjectId (hex_to_string v)) with (Failure "int_of_string") -> raise Invalid_objectId
100 | else raise Invalid_objectId;;
101 | let create_boolean v = Boolean v;;
102 | let create_utc v = UTC v;;
103 | let create_null () = Null NULL;;
104 | let create_regex s1 s2 = Regex (s1, s2);;
105 | let create_jscode v = JSCode v;;
106 | let create_jscode_w_s s doc = JSCodeWS (s, doc);;
107 | let create_int32 v = Int32 v;;
108 | let create_int64 v = Int64 v;;
109 | let create_timestamp v = Timestamp v;;
110 | let create_minkey () = MinKey MINKEY;;
111 | let create_maxkey () = MaxKey MAXKEY;;
112 |
113 | let get_double = function | Double v -> v | _ -> raise Wrong_bson_type;;
114 | let get_string = function | String v -> v | _ -> raise Wrong_bson_type;;
115 | let get_doc_element = function | Document v -> v | _ -> raise Wrong_bson_type;;
116 | let get_list = function | Array v -> v | _ -> raise Wrong_bson_type;;
117 | let get_generic_binary = function | Binary (Generic v) -> v | _ -> raise Wrong_bson_type;;
118 | let get_function_binary = function | Binary (Function v) -> v | _ -> raise Wrong_bson_type;;
119 | let get_uuid_binary = function | Binary (UUID v) -> v | _ -> raise Wrong_bson_type;;
120 | let get_md5_binary = function | Binary (MD5 v) -> v | _ -> raise Wrong_bson_type;;
121 | let get_user_binary = function | Binary (UserDefined v) -> v | _ -> raise Wrong_bson_type;;
122 | let get_objectId = function | ObjectId v -> v | _ -> raise Wrong_bson_type;;
123 | let get_boolean = function | Boolean v -> v | _ -> raise Wrong_bson_type;;
124 | let get_utc = function | UTC v -> v | _ -> raise Wrong_bson_type;;
125 | let get_null = function | Null NULL -> NULL | _ -> raise Wrong_bson_type;;
126 | let get_regex = function | Regex v -> v | _ -> raise Wrong_bson_type;;
127 | let get_jscode = function | JSCode v -> v | _ -> raise Wrong_bson_type;;
128 | let get_jscode_w_s = function | JSCodeWS v -> v | _ -> raise Wrong_bson_type;;
129 | let get_int32 = function | Int32 v -> v | _ -> raise Wrong_bson_type;;
130 | let get_int64 = function | Int64 v -> v | _ -> raise Wrong_bson_type;;
131 | let get_timestamp = function | Timestamp v -> v | _ -> raise Wrong_bson_type;;
132 | let get_minkey = function | MinKey MINKEY -> MINKEY | _ -> raise Wrong_bson_type;;
133 | let get_maxkey = function | MaxKey MAXKEY -> MAXKEY | _ -> raise Wrong_bson_type;;
134 |
135 | let all_elements d = d
136 |
137 | (*
138 | encode int64, int32 and float.
139 | note that encoding float is the same as int64, just need to transfer all the bits into an int64.
140 |
141 | The logic is that (e.g., for int32):
142 | 1) we get an int32
143 | 2) we shift right 1 byte one by one
144 | 3) After each shift, we logic and 0000 0000 ... 0000 1111 1111 (255l) with the shifted int32 to get the lower 1 byte
145 | 4) we convert the int32 to int, so Char.chr can pick it up and convert it to char (byte)
146 | 5) we put the byte to the buffer (starting from index of 0, since it is little-endian format)
147 | *)
148 |
149 | let encode_int64 buf v =
150 | for i = 0 to 7 do
151 | let b = Int64.logand 255L (Int64.shift_right v (i*8)) in
152 | Buffer.add_char buf (Char.chr (Int64.to_int b))
153 | done;;
154 |
155 | let encode_float buf v = encode_int64 buf (Int64.bits_of_float v);;
156 |
157 | let encode_int32 buf v =
158 | for i = 0 to 3 do
159 | let b = Int32.logand 255l (Int32.shift_right v (i*8)) in
160 | Buffer.add_char buf (Char.chr (Int32.to_int b))
161 | done;;
162 |
163 | let encode_ename buf c ename =
164 | Buffer.add_char buf c;
165 | Buffer.add_string buf ename;
166 | Buffer.add_char buf '\x00';;
167 |
168 | let encode_string buf s =
169 | let len = String.length s in
170 | if len > 0 && s.[len-1] = '\x00' then raise Wrong_string
171 | else begin
172 | encode_int32 buf (Int32.of_int (len+1));
173 | Buffer.add_string buf s;
174 | Buffer.add_char buf '\x00'
175 | end;;
176 |
177 | let encode_objectId buf s =
178 | if String.length s <> 12 then raise Invalid_objectId
179 | else Buffer.add_string buf s;;
180 |
181 | let encode_binary buf c b =
182 | encode_int32 buf (Int32.of_int (String.length b));
183 | Buffer.add_char buf c;
184 | Buffer.add_string buf b;;
185 |
186 | let encode_cstring buf cs =
187 | Buffer.add_string buf cs;
188 | Buffer.add_char buf '\x00';;
189 |
190 | let list_to_doc l = (* we need to transform the list to a doc with key as incrementing from '0' *)
191 | let rec to_doc i acc = function
192 | | [] -> acc
193 | | hd::tl -> to_doc (i+1) (add_element (string_of_int i) hd acc) tl
194 | in
195 | to_doc 0 empty l;;
196 |
197 |
198 | let encode doc =
199 | let all_buf = Buffer.create 64 in
200 | let rec encode_element buf ename element =
201 | match element with
202 | | Double v ->
203 | encode_ename buf '\x01' ename;
204 | encode_float buf v
205 | | String v ->
206 | encode_ename buf '\x02' ename;
207 | encode_string buf v
208 | | Document v ->
209 | encode_ename buf '\x03' ename;
210 | encode_doc buf v
211 | | Array v ->
212 | encode_ename buf '\x04' ename;
213 | encode_doc buf (list_to_doc v)
214 | | Binary v ->
215 | encode_ename buf '\x05' ename;
216 | begin match v with
217 | | Generic v -> encode_binary buf '\x00' v
218 | | Function v -> encode_binary buf '\x01' v
219 | | UUID v -> encode_binary buf '\x04' v
220 | | MD5 v -> encode_binary buf '\x05' v
221 | | UserDefined v -> encode_binary buf '\x80' v
222 | end
223 | | ObjectId v ->
224 | encode_ename buf '\x07' ename;
225 | encode_objectId buf v
226 | | Boolean v ->
227 | encode_ename buf '\x08' ename;
228 | Buffer.add_char buf (if v then '\x01' else '\x00')
229 | | UTC v ->
230 | encode_ename buf '\x09' ename;
231 | encode_int64 buf v
232 | | Null NULL->
233 | encode_ename buf '\x0A' ename;
234 | | Regex (v1,v2) ->
235 | encode_ename buf '\x0B' ename;
236 | encode_cstring buf v1;
237 | encode_cstring buf v2
238 | | JSCode v ->
239 | encode_ename buf '\x0D' ename;
240 | encode_string buf v
241 | | JSCodeWS (v, d) ->
242 | encode_ename buf '\x0F' ename;
243 | let tmp_str_buf = Buffer.create 16 and tmp_doc_buf = Buffer.create 16 in
244 | encode_string tmp_str_buf v;
245 | encode_doc tmp_doc_buf d;
246 | encode_int32 buf (Int32.of_int (4 + (Buffer.length tmp_str_buf) + (Buffer.length tmp_doc_buf)));
247 | Buffer.add_buffer buf tmp_str_buf;
248 | Buffer.add_buffer buf tmp_doc_buf
249 | | Int32 v ->
250 | encode_ename buf '\x10' ename;
251 | encode_int32 buf v
252 | | Timestamp v ->
253 | encode_ename buf '\x11' ename;
254 | encode_int64 buf v
255 | | Int64 v ->
256 | encode_ename buf '\x12' ename;
257 | encode_int64 buf v
258 | | MinKey MINKEY ->
259 | encode_ename buf '\xFF' ename
260 | | MaxKey MAXKEY ->
261 | encode_ename buf '\x7F' ename
262 | | _ -> raise Malformed_bson
263 | and
264 | encode_doc buf doc =
265 | let process_element buf (ename, element) = encode_element buf ename element; buf in
266 | let e_buf = List.fold_left process_element (Buffer.create 64) doc in
267 | encode_int32 buf (Int32.of_int (5+(Buffer.length e_buf)));
268 | Buffer.add_buffer buf e_buf;
269 | Buffer.add_char buf '\x00';
270 | in
271 | encode_doc all_buf doc;
272 | Buffer.contents all_buf;;
273 |
274 |
275 | let decode_int64 str cur =
276 | let rec decode i acc =
277 | if i < cur then acc
278 | else
279 | let high_byte = Char.code str.[i] in
280 | let high_int64 = Int64.of_int high_byte in
281 | let shift_acc = Int64.shift_left acc 8 in
282 | let new_acc = Int64.logor high_int64 shift_acc in
283 | decode (i-1) new_acc
284 | in (decode (cur+7) 0L, cur+8)
285 |
286 | let decode_float str cur =
287 | let (i, new_cur) = decode_int64 str cur in
288 | (Int64.float_of_bits i, new_cur);;
289 |
290 | let decode_int32 str cur =
291 | let rec decode i acc =
292 | if i < cur then acc
293 | else
294 | let high_byte = Char.code str.[i] in
295 | (*print_int high_byte;print_endline "";*)
296 | let high_int32 = Int32.of_int high_byte in
297 | let shift_acc = Int32.shift_left acc 8 in
298 | let new_acc = Int32.logor high_int32 shift_acc in
299 | decode (i-1) new_acc
300 | in (decode (cur+3) 0l, cur+4);;
301 |
302 | let rec next_x00 str cur = String.index_from str cur '\x00';;
303 |
304 | let decode_ename str cur =
305 | let x00 = next_x00 str cur in
306 | if x00 = -1 then raise Malformed_bson
307 | else (String.sub str cur (x00-cur), x00+1);;
308 |
309 | let decode_cstring = decode_ename;;
310 |
311 | let decode_len str cur =
312 | let (len32, next_cur) = decode_int32 str cur in
313 | (Int32.to_int len32, next_cur)
314 |
315 | let decode_double str cur =
316 | let (f, new_cur) = decode_float str cur in
317 | (Double f, new_cur);;
318 |
319 | let decode_string str cur =
320 | let (len, next_cur) = decode_len str cur in
321 | (*print_string "cur=";print_int cur;print_string ";";
322 | print_string "len=";print_int len;
323 | print_endline "";*)
324 | (*let x00 = next_x00 str next_cur in
325 | Printf.printf "len=%d, next_cur=%d, x00=%d, s[x00]=%c\n" len next_cur x00 str.[x00-1];
326 | print_endline (String.sub str next_cur (len-1));*)
327 | (*if len - 1 <> x00-next_cur then raise Wrong_string
328 | else (String.sub str next_cur (len-1), x00+1);;*)
329 | (String.sub str next_cur (len-1), next_cur+len);;
330 |
331 | let doc_to_list doc = (* we need to transform a doc with key as incrementing from '0' to a list *)
332 | List.map (
333 | fun (k,v) -> v
334 | ) doc
335 |
336 |
337 | let decode_binary str cur =
338 | let (len, next_cur) = decode_len str cur in
339 | let c = str.[next_cur] in
340 | let b = String.sub str (next_cur+1) len in
341 | let new_cur = next_cur+1+len in
342 | match c with
343 | | '\x00' -> (Binary (Generic b), new_cur)
344 | | '\x01' -> (Binary (Function b), new_cur)
345 | | '\x04' -> (Binary (UUID b), new_cur)
346 | | '\x05' -> (Binary (MD5 b), new_cur)
347 | | '\x80' -> (Binary (UserDefined b), new_cur)
348 | | _ -> raise Malformed_bson;;
349 |
350 | let decode_objectId str cur = (ObjectId (String.sub str cur 12), cur+12);;
351 |
352 | let decode_boolean str cur = (Boolean (if str.[cur] = '\x00' then false else true), cur+1);;
353 |
354 | let decode_utc str cur =
355 | let (i, new_cur) = decode_int64 str cur in
356 | (UTC i, new_cur);;
357 |
358 | let decode_regex str cur =
359 | let (s1, x00) = decode_cstring str cur in
360 | let (s2, new_cur) = decode_cstring str (x00+1) in
361 | (Regex (s1, s2), new_cur);;
362 |
363 | let decode_jscode str cur =
364 | let (s, next_cur) = decode_string str cur in
365 | (JSCode s, next_cur);;
366 |
367 | let decode str =
368 | let rec decode_element str cur =
369 | let c = str.[cur] in
370 | let next_cur = cur+1 in
371 | let (ename, next_cur) = decode_ename str next_cur in
372 | (*print_endline ename;*)
373 | let (element, next_cur) =
374 | match c with
375 | | '\x01' -> decode_double str next_cur
376 | | '\x02' ->
377 | (*print_endline "decoding string...";*)
378 | let (s, next_cur) = decode_string str next_cur in
379 | (String s, next_cur)
380 | | '\x03' ->
381 | let (doc, next_cur) = decode_doc str next_cur in
382 | (Document doc, next_cur)
383 | | '\x04' ->
384 | let (doc, next_cur) = decode_doc str next_cur in
385 | (Array (doc_to_list doc), next_cur)
386 | | '\x05' -> decode_binary str next_cur
387 | | '\x07' -> decode_objectId str next_cur
388 | | '\x08' -> decode_boolean str next_cur
389 | | '\x09' -> decode_utc str next_cur
390 | | '\x0A' -> (Null NULL, next_cur)
391 | | '\x0B' -> decode_regex str next_cur
392 | | '\x0D' -> decode_jscode str next_cur
393 | | '\x0F' -> (* decode jscode_w_s *)
394 | let (len, next_cur) = decode_len str next_cur in
395 | let (s, next_cur) = decode_string str next_cur in
396 | let (doc, next_cur) = decode_doc str next_cur in
397 | (JSCodeWS (s, doc), next_cur)
398 | | '\x10' ->
399 | let (i, next_cur) = decode_int32 str next_cur in
400 | (Int32 i, next_cur)
401 | | '\x11' ->
402 | let (i, next_cur) = decode_int64 str next_cur in
403 | (Timestamp i, next_cur)
404 | | '\x12' ->
405 | let (i, next_cur) = decode_int64 str next_cur in
406 | (Int64 i, next_cur)
407 | | '\xFF' -> (MinKey MINKEY, next_cur)
408 | | '\x7F' -> (MaxKey MAXKEY, next_cur)
409 | | _ -> raise Malformed_bson
410 | in
411 | (ename, element, next_cur)
412 | and decode_doc str cur =
413 | let acc = empty in
414 | let (len, next_cur) = decode_len str cur in
415 | let rec decode_elements cur acc =
416 | if str.[cur] = '\x00' then (acc, cur+1)
417 | else
418 | let (ename, element, next_cur) = decode_element str cur in
419 | decode_elements next_cur (add_element ename element acc)
420 | in
421 | let (doc, des) = decode_elements next_cur acc in
422 | if des - cur <> len then raise Malformed_bson
423 | else (doc, des)
424 | in let (doc, _) = decode_doc str 0 in doc;;
425 |
426 | (*
427 | Not that this bson to json conversion is far from completion.
428 | It is used to help the test verification and can handle only simple objects.
429 | *)
430 | let to_simple_json doc =
431 | let rec el_to_sl el =
432 | List.rev (List.fold_left (fun acc e -> (e_to_s e)::acc) [] el)
433 | and e_to_s = function
434 | | Double v -> string_of_float v
435 | | String v -> "\"" ^ v ^ "\""
436 | | Document v -> d_to_s v
437 | | Array v -> let sl = el_to_sl v in "[" ^ (String.concat ", " sl) ^ "]"
438 | | Binary v ->
439 | begin match v with
440 | | Generic v | Function v | UUID v | MD5 v | UserDefined v -> "\"" ^ v ^ "\""
441 | end
442 | | ObjectId v -> "\"" ^ v ^ "\""
443 | | Boolean v -> if v then "\"true\"" else "\"false\""
444 | | UTC v -> Int64.to_string v
445 | | Null NULL-> "\"null\""
446 | | Regex (v1,v2) -> "(\"" ^ v1 ^ ", \"" ^ v2 ^ "\")"
447 | | JSCode v -> "\"" ^ v ^ "\""
448 | | JSCodeWS (v, d) -> "(\"" ^ v ^ ", \"" ^ (d_to_s d) ^ "\")"
449 | | Int32 v -> Int32.to_string v
450 | | Timestamp v -> Int64.to_string v
451 | | Int64 v -> Int64.to_string v
452 | | MinKey MINKEY -> "\"minkey\""
453 | | MaxKey MAXKEY -> "\"maxkey\""
454 | | _ -> raise Malformed_bson
455 | and d_to_s d =
456 | let buf = Buffer.create 16 in
457 | Buffer.add_string buf "{";
458 | (* let bindings = all_elements d in *)
459 | let process acc (ename, element) =
460 | ("\"" ^ ename ^ "\" : " ^ (e_to_s element)) :: acc;
461 | in
462 | Buffer.add_string buf (String.concat ", " (List.rev (List.fold_left process [] d)));
463 | Buffer.add_string buf "}";
464 | Buffer.contents buf
465 | in
466 | d_to_s doc;;
467 |
--------------------------------------------------------------------------------
/myocamlbuild.ml:
--------------------------------------------------------------------------------
1 | (* OASIS_START *)
2 | (* DO NOT EDIT (digest: 7c79194eb16194bf2a2a530cc49aff34) *)
3 | module OASISGettext = struct
4 | (* # 22 "src/oasis/OASISGettext.ml" *)
5 |
6 |
7 | let ns_ str = str
8 | let s_ str = str
9 | let f_ (str: ('a, 'b, 'c, 'd) format4) = str
10 |
11 |
12 | let fn_ fmt1 fmt2 n =
13 | if n = 1 then
14 | fmt1^^""
15 | else
16 | fmt2^^""
17 |
18 |
19 | let init = []
20 | end
21 |
22 | module OASISString = struct
23 | (* # 22 "src/oasis/OASISString.ml" *)
24 |
25 |
26 | (** Various string utilities.
27 |
28 | Mostly inspired by extlib and batteries ExtString and BatString libraries.
29 |
30 | @author Sylvain Le Gall
31 | *)
32 |
33 |
34 | let nsplitf str f =
35 | if str = "" then
36 | []
37 | else
38 | let buf = Buffer.create 13 in
39 | let lst = ref [] in
40 | let push () =
41 | lst := Buffer.contents buf :: !lst;
42 | Buffer.clear buf
43 | in
44 | let str_len = String.length str in
45 | for i = 0 to str_len - 1 do
46 | if f str.[i] then
47 | push ()
48 | else
49 | Buffer.add_char buf str.[i]
50 | done;
51 | push ();
52 | List.rev !lst
53 |
54 |
55 | (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the
56 | separator.
57 | *)
58 | let nsplit str c =
59 | nsplitf str ((=) c)
60 |
61 |
62 | let find ~what ?(offset=0) str =
63 | let what_idx = ref 0 in
64 | let str_idx = ref offset in
65 | while !str_idx < String.length str &&
66 | !what_idx < String.length what do
67 | if str.[!str_idx] = what.[!what_idx] then
68 | incr what_idx
69 | else
70 | what_idx := 0;
71 | incr str_idx
72 | done;
73 | if !what_idx <> String.length what then
74 | raise Not_found
75 | else
76 | !str_idx - !what_idx
77 |
78 |
79 | let sub_start str len =
80 | let str_len = String.length str in
81 | if len >= str_len then
82 | ""
83 | else
84 | String.sub str len (str_len - len)
85 |
86 |
87 | let sub_end ?(offset=0) str len =
88 | let str_len = String.length str in
89 | if len >= str_len then
90 | ""
91 | else
92 | String.sub str 0 (str_len - len)
93 |
94 |
95 | let starts_with ~what ?(offset=0) str =
96 | let what_idx = ref 0 in
97 | let str_idx = ref offset in
98 | let ok = ref true in
99 | while !ok &&
100 | !str_idx < String.length str &&
101 | !what_idx < String.length what do
102 | if str.[!str_idx] = what.[!what_idx] then
103 | incr what_idx
104 | else
105 | ok := false;
106 | incr str_idx
107 | done;
108 | !what_idx = String.length what
109 |
110 |
111 | let strip_starts_with ~what str =
112 | if starts_with ~what str then
113 | sub_start str (String.length what)
114 | else
115 | raise Not_found
116 |
117 |
118 | let ends_with ~what ?(offset=0) str =
119 | let what_idx = ref ((String.length what) - 1) in
120 | let str_idx = ref ((String.length str) - 1) in
121 | let ok = ref true in
122 | while !ok &&
123 | offset <= !str_idx &&
124 | 0 <= !what_idx do
125 | if str.[!str_idx] = what.[!what_idx] then
126 | decr what_idx
127 | else
128 | ok := false;
129 | decr str_idx
130 | done;
131 | !what_idx = -1
132 |
133 |
134 | let strip_ends_with ~what str =
135 | if ends_with ~what str then
136 | sub_end str (String.length what)
137 | else
138 | raise Not_found
139 |
140 |
141 | let replace_chars f s =
142 | let buf = Buffer.create (String.length s) in
143 | String.iter (fun c -> Buffer.add_char buf (f c)) s;
144 | Buffer.contents buf
145 |
146 | let lowercase_ascii =
147 | replace_chars
148 | (fun c ->
149 | if (c >= 'A' && c <= 'Z') then
150 | Char.chr (Char.code c + 32)
151 | else
152 | c)
153 |
154 | let uncapitalize_ascii s =
155 | if s <> "" then
156 | (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1))
157 | else
158 | s
159 |
160 | let uppercase_ascii =
161 | replace_chars
162 | (fun c ->
163 | if (c >= 'a' && c <= 'z') then
164 | Char.chr (Char.code c - 32)
165 | else
166 | c)
167 |
168 | let capitalize_ascii s =
169 | if s <> "" then
170 | (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1))
171 | else
172 | s
173 |
174 | end
175 |
176 | module OASISUtils = struct
177 | (* # 22 "src/oasis/OASISUtils.ml" *)
178 |
179 |
180 | open OASISGettext
181 |
182 |
183 | module MapExt =
184 | struct
185 | module type S =
186 | sig
187 | include Map.S
188 | val add_list: 'a t -> (key * 'a) list -> 'a t
189 | val of_list: (key * 'a) list -> 'a t
190 | val to_list: 'a t -> (key * 'a) list
191 | end
192 |
193 | module Make (Ord: Map.OrderedType) =
194 | struct
195 | include Map.Make(Ord)
196 |
197 | let rec add_list t =
198 | function
199 | | (k, v) :: tl -> add_list (add k v t) tl
200 | | [] -> t
201 |
202 | let of_list lst = add_list empty lst
203 |
204 | let to_list t = fold (fun k v acc -> (k, v) :: acc) t []
205 | end
206 | end
207 |
208 |
209 | module MapString = MapExt.Make(String)
210 |
211 |
212 | module SetExt =
213 | struct
214 | module type S =
215 | sig
216 | include Set.S
217 | val add_list: t -> elt list -> t
218 | val of_list: elt list -> t
219 | val to_list: t -> elt list
220 | end
221 |
222 | module Make (Ord: Set.OrderedType) =
223 | struct
224 | include Set.Make(Ord)
225 |
226 | let rec add_list t =
227 | function
228 | | e :: tl -> add_list (add e t) tl
229 | | [] -> t
230 |
231 | let of_list lst = add_list empty lst
232 |
233 | let to_list = elements
234 | end
235 | end
236 |
237 |
238 | module SetString = SetExt.Make(String)
239 |
240 |
241 | let compare_csl s1 s2 =
242 | String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2)
243 |
244 |
245 | module HashStringCsl =
246 | Hashtbl.Make
247 | (struct
248 | type t = string
249 | let equal s1 s2 = (compare_csl s1 s2) = 0
250 | let hash s = Hashtbl.hash (OASISString.lowercase_ascii s)
251 | end)
252 |
253 | module SetStringCsl =
254 | SetExt.Make
255 | (struct
256 | type t = string
257 | let compare = compare_csl
258 | end)
259 |
260 |
261 | let varname_of_string ?(hyphen='_') s =
262 | if String.length s = 0 then
263 | begin
264 | invalid_arg "varname_of_string"
265 | end
266 | else
267 | begin
268 | let buf =
269 | OASISString.replace_chars
270 | (fun c ->
271 | if ('a' <= c && c <= 'z')
272 | ||
273 | ('A' <= c && c <= 'Z')
274 | ||
275 | ('0' <= c && c <= '9') then
276 | c
277 | else
278 | hyphen)
279 | s;
280 | in
281 | let buf =
282 | (* Start with a _ if digit *)
283 | if '0' <= s.[0] && s.[0] <= '9' then
284 | "_"^buf
285 | else
286 | buf
287 | in
288 | OASISString.lowercase_ascii buf
289 | end
290 |
291 |
292 | let varname_concat ?(hyphen='_') p s =
293 | let what = String.make 1 hyphen in
294 | let p =
295 | try
296 | OASISString.strip_ends_with ~what p
297 | with Not_found ->
298 | p
299 | in
300 | let s =
301 | try
302 | OASISString.strip_starts_with ~what s
303 | with Not_found ->
304 | s
305 | in
306 | p^what^s
307 |
308 |
309 | let is_varname str =
310 | str = varname_of_string str
311 |
312 |
313 | let failwithf fmt = Printf.ksprintf failwith fmt
314 |
315 |
316 | let rec file_location ?pos1 ?pos2 ?lexbuf () =
317 | match pos1, pos2, lexbuf with
318 | | Some p, None, _ | None, Some p, _ ->
319 | file_location ~pos1:p ~pos2:p ?lexbuf ()
320 | | Some p1, Some p2, _ ->
321 | let open Lexing in
322 | let fn, lineno = p1.pos_fname, p1.pos_lnum in
323 | let c1 = p1.pos_cnum - p1.pos_bol in
324 | let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in
325 | Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2
326 | | _, _, Some lexbuf ->
327 | file_location
328 | ~pos1:(Lexing.lexeme_start_p lexbuf)
329 | ~pos2:(Lexing.lexeme_end_p lexbuf)
330 | ()
331 | | None, None, None ->
332 | s_ ""
333 |
334 |
335 | let failwithpf ?pos1 ?pos2 ?lexbuf fmt =
336 | let loc = file_location ?pos1 ?pos2 ?lexbuf () in
337 | Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt
338 |
339 |
340 | end
341 |
342 | module OASISExpr = struct
343 | (* # 22 "src/oasis/OASISExpr.ml" *)
344 |
345 |
346 | open OASISGettext
347 | open OASISUtils
348 |
349 |
350 | type test = string
351 | type flag = string
352 |
353 |
354 | type t =
355 | | EBool of bool
356 | | ENot of t
357 | | EAnd of t * t
358 | | EOr of t * t
359 | | EFlag of flag
360 | | ETest of test * string
361 |
362 |
363 | type 'a choices = (t * 'a) list
364 |
365 |
366 | let eval var_get t =
367 | let rec eval' =
368 | function
369 | | EBool b ->
370 | b
371 |
372 | | ENot e ->
373 | not (eval' e)
374 |
375 | | EAnd (e1, e2) ->
376 | (eval' e1) && (eval' e2)
377 |
378 | | EOr (e1, e2) ->
379 | (eval' e1) || (eval' e2)
380 |
381 | | EFlag nm ->
382 | let v =
383 | var_get nm
384 | in
385 | assert(v = "true" || v = "false");
386 | (v = "true")
387 |
388 | | ETest (nm, vl) ->
389 | let v =
390 | var_get nm
391 | in
392 | (v = vl)
393 | in
394 | eval' t
395 |
396 |
397 | let choose ?printer ?name var_get lst =
398 | let rec choose_aux =
399 | function
400 | | (cond, vl) :: tl ->
401 | if eval var_get cond then
402 | vl
403 | else
404 | choose_aux tl
405 | | [] ->
406 | let str_lst =
407 | if lst = [] then
408 | s_ ""
409 | else
410 | String.concat
411 | (s_ ", ")
412 | (List.map
413 | (fun (cond, vl) ->
414 | match printer with
415 | | Some p -> p vl
416 | | None -> s_ "")
417 | lst)
418 | in
419 | match name with
420 | | Some nm ->
421 | failwith
422 | (Printf.sprintf
423 | (f_ "No result for the choice list '%s': %s")
424 | nm str_lst)
425 | | None ->
426 | failwith
427 | (Printf.sprintf
428 | (f_ "No result for a choice list: %s")
429 | str_lst)
430 | in
431 | choose_aux (List.rev lst)
432 |
433 |
434 | end
435 |
436 |
437 | # 437 "myocamlbuild.ml"
438 | module BaseEnvLight = struct
439 | (* # 22 "src/base/BaseEnvLight.ml" *)
440 |
441 |
442 | module MapString = Map.Make(String)
443 |
444 |
445 | type t = string MapString.t
446 |
447 |
448 | let default_filename = Filename.concat (Sys.getcwd ()) "setup.data"
449 |
450 |
451 | let load ?(allow_empty=false) ?(filename=default_filename) ?stream () =
452 | let line = ref 1 in
453 | let lexer st =
454 | let st_line =
455 | Stream.from
456 | (fun _ ->
457 | try
458 | match Stream.next st with
459 | | '\n' -> incr line; Some '\n'
460 | | c -> Some c
461 | with Stream.Failure -> None)
462 | in
463 | Genlex.make_lexer ["="] st_line
464 | in
465 | let rec read_file lxr mp =
466 | match Stream.npeek 3 lxr with
467 | | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] ->
468 | Stream.junk lxr; Stream.junk lxr; Stream.junk lxr;
469 | read_file lxr (MapString.add nm value mp)
470 | | [] -> mp
471 | | _ ->
472 | failwith
473 | (Printf.sprintf "Malformed data file '%s' line %d" filename !line)
474 | in
475 | match stream with
476 | | Some st -> read_file (lexer st) MapString.empty
477 | | None ->
478 | if Sys.file_exists filename then begin
479 | let chn = open_in_bin filename in
480 | let st = Stream.of_channel chn in
481 | try
482 | let mp = read_file (lexer st) MapString.empty in
483 | close_in chn; mp
484 | with e ->
485 | close_in chn; raise e
486 | end else if allow_empty then begin
487 | MapString.empty
488 | end else begin
489 | failwith
490 | (Printf.sprintf
491 | "Unable to load environment, the file '%s' doesn't exist."
492 | filename)
493 | end
494 |
495 | let rec var_expand str env =
496 | let buff = Buffer.create ((String.length str) * 2) in
497 | Buffer.add_substitute
498 | buff
499 | (fun var ->
500 | try
501 | var_expand (MapString.find var env) env
502 | with Not_found ->
503 | failwith
504 | (Printf.sprintf
505 | "No variable %s defined when trying to expand %S."
506 | var
507 | str))
508 | str;
509 | Buffer.contents buff
510 |
511 |
512 | let var_get name env = var_expand (MapString.find name env) env
513 | let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst
514 | end
515 |
516 |
517 | # 517 "myocamlbuild.ml"
518 | module MyOCamlbuildFindlib = struct
519 | (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *)
520 |
521 |
522 | (** OCamlbuild extension, copied from
523 | * https://ocaml.org/learn/tutorials/ocamlbuild/Using_ocamlfind_with_ocamlbuild.html
524 | * by N. Pouillard and others
525 | *
526 | * Updated on 2016-06-02
527 | *
528 | * Modified by Sylvain Le Gall
529 | *)
530 | open Ocamlbuild_plugin
531 |
532 |
533 | type conf = {no_automatic_syntax: bool}
534 |
535 |
536 | let run_and_read = Ocamlbuild_pack.My_unix.run_and_read
537 |
538 |
539 | let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings
540 |
541 |
542 | let exec_from_conf exec =
543 | let exec =
544 | let env = BaseEnvLight.load ~allow_empty:true () in
545 | try
546 | BaseEnvLight.var_get exec env
547 | with Not_found ->
548 | Printf.eprintf "W: Cannot get variable %s\n" exec;
549 | exec
550 | in
551 | let fix_win32 str =
552 | if Sys.os_type = "Win32" then begin
553 | let buff = Buffer.create (String.length str) in
554 | (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'.
555 | *)
556 | String.iter
557 | (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c))
558 | str;
559 | Buffer.contents buff
560 | end else begin
561 | str
562 | end
563 | in
564 | fix_win32 exec
565 |
566 |
567 | let split s ch =
568 | let buf = Buffer.create 13 in
569 | let x = ref [] in
570 | let flush () =
571 | x := (Buffer.contents buf) :: !x;
572 | Buffer.clear buf
573 | in
574 | String.iter
575 | (fun c ->
576 | if c = ch then
577 | flush ()
578 | else
579 | Buffer.add_char buf c)
580 | s;
581 | flush ();
582 | List.rev !x
583 |
584 |
585 | let split_nl s = split s '\n'
586 |
587 |
588 | let before_space s =
589 | try
590 | String.before s (String.index s ' ')
591 | with Not_found -> s
592 |
593 | (* ocamlfind command *)
594 | let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x]
595 |
596 | (* This lists all supported packages. *)
597 | let find_packages () =
598 | List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list"))
599 |
600 |
601 | (* Mock to list available syntaxes. *)
602 | let find_syntaxes () = ["camlp4o"; "camlp4r"]
603 |
604 |
605 | let well_known_syntax = [
606 | "camlp4.quotations.o";
607 | "camlp4.quotations.r";
608 | "camlp4.exceptiontracer";
609 | "camlp4.extend";
610 | "camlp4.foldgenerator";
611 | "camlp4.listcomprehension";
612 | "camlp4.locationstripper";
613 | "camlp4.macro";
614 | "camlp4.mapgenerator";
615 | "camlp4.metagenerator";
616 | "camlp4.profiler";
617 | "camlp4.tracer"
618 | ]
619 |
620 |
621 | let dispatch conf =
622 | function
623 | | After_options ->
624 | (* By using Before_options one let command line options have an higher
625 | * priority on the contrary using After_options will guarantee to have
626 | * the higher priority override default commands by ocamlfind ones *)
627 | Options.ocamlc := ocamlfind & A"ocamlc";
628 | Options.ocamlopt := ocamlfind & A"ocamlopt";
629 | Options.ocamldep := ocamlfind & A"ocamldep";
630 | Options.ocamldoc := ocamlfind & A"ocamldoc";
631 | Options.ocamlmktop := ocamlfind & A"ocamlmktop";
632 | Options.ocamlmklib := ocamlfind & A"ocamlmklib"
633 |
634 | | After_rules ->
635 |
636 | (* Avoid warnings for unused tag *)
637 | flag ["tests"] N;
638 |
639 | (* When one link an OCaml library/binary/package, one should use
640 | * -linkpkg *)
641 | flag ["ocaml"; "link"; "program"] & A"-linkpkg";
642 |
643 | (* For each ocamlfind package one inject the -package option when
644 | * compiling, computing dependencies, generating documentation and
645 | * linking. *)
646 | List.iter
647 | begin fun pkg ->
648 | let base_args = [A"-package"; A pkg] in
649 | (* TODO: consider how to really choose camlp4o or camlp4r. *)
650 | let syn_args = [A"-syntax"; A "camlp4o"] in
651 | let (args, pargs) =
652 | (* Heuristic to identify syntax extensions: whether they end in
653 | ".syntax"; some might not.
654 | *)
655 | if not (conf.no_automatic_syntax) &&
656 | (Filename.check_suffix pkg "syntax" ||
657 | List.mem pkg well_known_syntax) then
658 | (syn_args @ base_args, syn_args)
659 | else
660 | (base_args, [])
661 | in
662 | flag ["ocaml"; "compile"; "pkg_"^pkg] & S args;
663 | flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args;
664 | flag ["ocaml"; "doc"; "pkg_"^pkg] & S args;
665 | flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args;
666 | flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args;
667 |
668 | (* TODO: Check if this is allowed for OCaml < 3.12.1 *)
669 | flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs;
670 | flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs;
671 | flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs;
672 | flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs;
673 | end
674 | (find_packages ());
675 |
676 | (* Like -package but for extensions syntax. Morover -syntax is useless
677 | * when linking. *)
678 | List.iter begin fun syntax ->
679 | flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
680 | flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
681 | flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
682 | flag ["ocaml"; "infer_interface"; "syntax_"^syntax] &
683 | S[A"-syntax"; A syntax];
684 | end (find_syntaxes ());
685 |
686 | (* The default "thread" tag is not compatible with ocamlfind.
687 | * Indeed, the default rules add the "threads.cma" or "threads.cmxa"
688 | * options when using this tag. When using the "-linkpkg" option with
689 | * ocamlfind, this module will then be added twice on the command line.
690 | *
691 | * To solve this, one approach is to add the "-thread" option when using
692 | * the "threads" package using the previous plugin.
693 | *)
694 | flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]);
695 | flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]);
696 | flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]);
697 | flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]);
698 | flag ["c"; "pkg_threads"; "compile"] (S[A "-thread"]);
699 | flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]);
700 | flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]);
701 | flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]);
702 | flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]);
703 | flag ["c"; "package(threads)"; "compile"] (S[A "-thread"]);
704 |
705 | | _ ->
706 | ()
707 | end
708 |
709 | module MyOCamlbuildBase = struct
710 | (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *)
711 |
712 |
713 | (** Base functions for writing myocamlbuild.ml
714 | @author Sylvain Le Gall
715 | *)
716 |
717 |
718 | open Ocamlbuild_plugin
719 | module OC = Ocamlbuild_pack.Ocaml_compiler
720 |
721 |
722 | type dir = string
723 | type file = string
724 | type name = string
725 | type tag = string
726 |
727 |
728 | type t =
729 | {
730 | lib_ocaml: (name * dir list * string list) list;
731 | lib_c: (name * dir * file list) list;
732 | flags: (tag list * (spec OASISExpr.choices)) list;
733 | (* Replace the 'dir: include' from _tags by a precise interdepends in
734 | * directory.
735 | *)
736 | includes: (dir * dir list) list;
737 | }
738 |
739 |
740 | (* # 110 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *)
741 |
742 |
743 | let env_filename = Pathname.basename BaseEnvLight.default_filename
744 |
745 |
746 | let dispatch_combine lst =
747 | fun e ->
748 | List.iter
749 | (fun dispatch -> dispatch e)
750 | lst
751 |
752 |
753 | let tag_libstubs nm =
754 | "use_lib"^nm^"_stubs"
755 |
756 |
757 | let nm_libstubs nm =
758 | nm^"_stubs"
759 |
760 |
761 | let dispatch t e =
762 | let env = BaseEnvLight.load ~allow_empty:true () in
763 | match e with
764 | | Before_options ->
765 | let no_trailing_dot s =
766 | if String.length s >= 1 && s.[0] = '.' then
767 | String.sub s 1 ((String.length s) - 1)
768 | else
769 | s
770 | in
771 | List.iter
772 | (fun (opt, var) ->
773 | try
774 | opt := no_trailing_dot (BaseEnvLight.var_get var env)
775 | with Not_found ->
776 | Printf.eprintf "W: Cannot get variable %s\n" var)
777 | [
778 | Options.ext_obj, "ext_obj";
779 | Options.ext_lib, "ext_lib";
780 | Options.ext_dll, "ext_dll";
781 | ]
782 |
783 | | After_rules ->
784 | (* Declare OCaml libraries *)
785 | List.iter
786 | (function
787 | | nm, [], intf_modules ->
788 | ocaml_lib nm;
789 | let cmis =
790 | List.map (fun m -> (OASISString.uncapitalize_ascii m) ^ ".cmi")
791 | intf_modules in
792 | dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis
793 | | nm, dir :: tl, intf_modules ->
794 | ocaml_lib ~dir:dir (dir^"/"^nm);
795 | List.iter
796 | (fun dir ->
797 | List.iter
798 | (fun str ->
799 | flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir]))
800 | ["compile"; "infer_interface"; "doc"])
801 | tl;
802 | let cmis =
803 | List.map (fun m -> dir^"/"^(OASISString.uncapitalize_ascii m)^".cmi")
804 | intf_modules in
805 | dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"]
806 | cmis)
807 | t.lib_ocaml;
808 |
809 | (* Declare directories dependencies, replace "include" in _tags. *)
810 | List.iter
811 | (fun (dir, include_dirs) ->
812 | Pathname.define_context dir include_dirs)
813 | t.includes;
814 |
815 | (* Declare C libraries *)
816 | List.iter
817 | (fun (lib, dir, headers) ->
818 | (* Handle C part of library *)
819 | flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib]
820 | (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib";
821 | A("-l"^(nm_libstubs lib))]);
822 |
823 | flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib]
824 | (S[A"-cclib"; A("-l"^(nm_libstubs lib))]);
825 |
826 | if bool_of_string (BaseEnvLight.var_get "native_dynlink" env) then
827 | flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib]
828 | (S[A"-dllib"; A("dll"^(nm_libstubs lib))]);
829 |
830 | (* When ocaml link something that use the C library, then one
831 | need that file to be up to date.
832 | This holds both for programs and for libraries.
833 | *)
834 | dep ["link"; "ocaml"; tag_libstubs lib]
835 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
836 |
837 | dep ["compile"; "ocaml"; tag_libstubs lib]
838 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
839 |
840 | (* TODO: be more specific about what depends on headers *)
841 | (* Depends on .h files *)
842 | dep ["compile"; "c"]
843 | headers;
844 |
845 | (* Setup search path for lib *)
846 | flag ["link"; "ocaml"; "use_"^lib]
847 | (S[A"-I"; P(dir)]);
848 | )
849 | t.lib_c;
850 |
851 | (* Add flags *)
852 | List.iter
853 | (fun (tags, cond_specs) ->
854 | let spec = BaseEnvLight.var_choose cond_specs env in
855 | let rec eval_specs =
856 | function
857 | | S lst -> S (List.map eval_specs lst)
858 | | A str -> A (BaseEnvLight.var_expand str env)
859 | | spec -> spec
860 | in
861 | flag tags & (eval_specs spec))
862 | t.flags
863 | | _ ->
864 | ()
865 |
866 |
867 | let dispatch_default conf t =
868 | dispatch_combine
869 | [
870 | dispatch t;
871 | MyOCamlbuildFindlib.dispatch conf;
872 | ]
873 |
874 |
875 | end
876 |
877 |
878 | # 878 "myocamlbuild.ml"
879 | open Ocamlbuild_plugin;;
880 | let package_default =
881 | {
882 | MyOCamlbuildBase.lib_ocaml = [("lymp", ["srcs"], [])];
883 | lib_c = [];
884 | flags = [];
885 | includes = []
886 | }
887 | ;;
888 |
889 | let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false}
890 |
891 | let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;;
892 |
893 | # 894 "myocamlbuild.ml"
894 | (* OASIS_STOP *)
895 | Ocamlbuild_plugin.dispatch dispatch_default;;
896 |
--------------------------------------------------------------------------------