├── .depend ├── .gitignore ├── .merlin ├── .ocamlinit ├── Makefile ├── README.md ├── _oasis ├── _tags ├── configure ├── examples ├── .depend ├── .merlin ├── .ocamlinit ├── Makefile ├── __working.ml ├── dbserver.ml ├── example_journal1.ml ├── example_journal2.ml ├── example_journal3.ml ├── smtp.ml ├── smtp2.ml ├── travel_agency.ml └── travel_agency_.ml ├── lib ├── META ├── channel.ml ├── channel.mli ├── lsession.ml ├── lsession.mli ├── monitor.ml ├── monitor.mli ├── net.mldylib ├── net.mllib ├── schannel.ml ├── schannel.mli ├── session-ocaml.mldylib ├── session-ocaml.mllib ├── session.ml ├── session.mli ├── unixAdapter.ml └── unixAdapter.mli ├── myocamlbuild.ml ├── net ├── dsession.ml ├── dsession.mli ├── net.mldylib └── net.mllib ├── ppx ├── ppx.mldylib ├── ppx.mllib ├── ppx_lens.ml ├── ppx_lens.mldylib ├── ppx_lens.mllib ├── ppx_session.ml └── ppx_session_ex.ml ├── setup.ml └── tests └── test.ml /.depend: -------------------------------------------------------------------------------- 1 | channel.cmi : 2 | monitor.cmi : 3 | session.cmi : 4 | channel.cmo : monitor.cmi channel.cmi 5 | channel.cmx : monitor.cmx channel.cmi 6 | demo0.cmo : session.cmi 7 | demo0.cmx : session.cmx 8 | demoN.cmo : session.cmi 9 | demoN.cmx : session.cmx 10 | monitor.cmo : monitor.cmi 11 | monitor.cmx : monitor.cmi 12 | session.cmo : channel.cmi session.cmi 13 | session.cmx : channel.cmx session.cmi 14 | examples/__working.cmo : 15 | examples/__working.cmx : 16 | examples/ex_multi1.cmo : session.cmi 17 | examples/ex_multi1.cmx : session.cmx 18 | examples/ex_single1.cmo : session.cmi 19 | examples/ex_single1.cmx : session.cmx 20 | examples/ex_single2.cmo : session.cmi 21 | examples/ex_single2.cmx : session.cmx 22 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.cm[ioxat] 2 | *.cmxa 3 | *.cmti 4 | *.o 5 | *.annot 6 | test.* 7 | *.top 8 | \#* 9 | \.\#* 10 | 11 | _build 12 | **/*.mlpack 13 | **/*.odocl 14 | **/*.docdir 15 | setup.data 16 | setup.log 17 | **/*~ 18 | setup.exe 19 | setup-dev.exe 20 | *.byte 21 | *.native 22 | _tests 23 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | FLG -rectypes 2 | B +threads 3 | PKG threads unix compiler-libs.common ppx_tools ppx_tools.metaquot ppx_deriving 4 | 5 | S lib 6 | S ppx 7 | S examples 8 | 9 | B _build/lib 10 | B _build/ppx 11 | B examples 12 | -------------------------------------------------------------------------------- /.ocamlinit: -------------------------------------------------------------------------------- 1 | let () = 2 | try Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH") 3 | with Not_found -> () 4 | ;; 5 | 6 | #use "topfind";; 7 | #thread;; 8 | 9 | #require "threads";; 10 | #require "str";; 11 | #rectypes;; 12 | 13 | (* Load each lib provided by this project. *) 14 | #directory "_build/lib";; 15 | #load "session-ocaml.cma";; 16 | 17 | open Session;; 18 | -------------------------------------------------------------------------------- /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 | 21 | uninstall: setup.data 22 | $(SETUP) -uninstall $(UNINSTALLFLAGS) 23 | 24 | reinstall: setup.data 25 | $(SETUP) -reinstall $(REINSTALLFLAGS) 26 | 27 | clean: 28 | $(SETUP) -clean $(CLEANFLAGS) 29 | 30 | distclean: 31 | $(SETUP) -distclean $(DISTCLEANFLAGS) 32 | 33 | setup.data: 34 | $(SETUP) -configure $(CONFIGUREFLAGS) 35 | 36 | configure: 37 | $(SETUP) -configure $(CONFIGUREFLAGS) 38 | 39 | .PHONY: build doc test all install uninstall reinstall clean distclean configure 40 | 41 | # OASIS_STOP 42 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Session-ocaml 2 | 3 | Session-ocaml is an implementation of session types in OCaml. 4 | 5 | (__NEW__: the [project page](http://www.ct.info.gifu-u.ac.jp/~keigoi/session-ocaml/) is now open at: [http://www.ct.info.gifu-u.ac.jp/~keigoi/session-ocaml/](http://www.ct.info.gifu-u.ac.jp/~keigoi/session-ocaml/)) 6 | 7 | ## How to try it 8 | 9 | Prepare OCaml __4.05__ and install ```findlib```, ```ocamlbuild```, ```ppx_tools```. 10 | We recommend to use ```opam``` 11 | 12 | Install the compiler and prerequisite libraries. (__NOTE__: the version number has changed: 4.03 ==> __4.05__) 13 | 14 | opam switch 4.05.0 15 | eval `opam config env` 16 | opam install ocamlfind ocamlbuild ppx_tools 17 | 18 | Then clone the repository and type following at the top directory: 19 | 20 | git clone https://github.com/keigoi/session-ocaml.git 21 | cd session-ocaml 22 | ./configure --prefix=$(dirname `which ocaml`)/.. 23 | make 24 | make install 25 | 26 | Then you can play with ```session-ocaml```: 27 | 28 | cd examples 29 | make # build examples 30 | rlwrap ocaml -short-paths # play with OCaml toplevel (utop will also do). 31 | # rlwrap is a readline wrapper (recommended) 32 | 33 | Argument ```-short-paths``` is optional (it makes ```ocaml``` show the shortest path for each type). 34 | Note that [.ocamlinit](examples/.ocamlinit) file automatically pre-loads all required packages into OCaml toplevel and sets -rectypes option. 35 | It also does ```open Session```. 36 | 37 | If things seem broken, try ```git clean -fdx```then ```make``` (WARNING: this command erases all files except the original distribution). 38 | Also, you can uninstall manually by ```ocamlfind remove session-ocaml```. 39 | 40 | ## Example 41 | 42 | * [A single session 1](examples/example_journal1.ml). 43 | * [A single session 2](examples/example_journal2.ml). 44 | * [Multiple sessions 1](examples/example_journal3.ml). 45 | * [SMTP protocol](examples/smtp2.ml). 46 | 47 | # Macro for branching / selection 48 | 49 | For branching on arbitrary labels, we provide a macro ```match%branch```. 50 | 51 | ```ocaml 52 | open Session 53 | match%branch s with 54 | | `apple -> send 100 55 | | `banana -> recv () 56 | | `orange -> send "Hello!" 57 | ``` 58 | 59 | Its protocol type will be: 60 | 61 | ``` 62 | [`branch of resp * 63 | [ `apple of [`msg of req * int * 'a] 64 | | `banana of [`msg of resp * 'v * 'a] 65 | | `orange of [`msg of req * string * 'a]] 66 | ``` 67 | 68 | Similarly, we have a macro for selection, like 69 | 70 | ```ocaml 71 | [%select s `label] 72 | ``` 73 | 74 | ---- 75 | author: Keigo IMAI (@keigoi on Twitter / keigoi __AT__ gifu-u.ac.jp) 76 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | OASISFormat: 0.4 2 | Name: session-ocaml 3 | Version: 0.1 4 | Homepage: http://www.ct.info.gifu-u.ac.jp/~keigoi/session-ocaml/ 5 | Synopsis: A concurrent / distributed programming with protocol typing, 6 | based on Session Types. 7 | Authors: Keigo Imai 8 | License: LGPL-2.1 with OCaml linking exception 9 | Plugins: META (0.4), DevFiles (0.4) 10 | 11 | Library "session-ocaml" 12 | Path: lib 13 | BuildTools: ocamlbuild 14 | Modules: 15 | Session, UnixAdapter, Lsession 16 | InternalModules: 17 | Schannel, 18 | Channel, 19 | Monitor 20 | ByteOpt: -rectypes 21 | NativeOpt: -rectypes 22 | BuildDepends: threads, str 23 | 24 | Library ppx 25 | Path: ppx 26 | BuildTools: ocamlbuild 27 | Modules: Ppx_session 28 | FindlibName: ppx 29 | FindlibParent: session-ocaml 30 | XMETAType: syntax 31 | XMETARequires: session-ocaml, ppx_deriving 32 | XMETAExtraLines: ppx = "ppx_session" 33 | BuildDepends: compiler-libs, ppx_tools.metaquot, ppx_deriving.api 34 | 35 | Library "net" 36 | Path: net 37 | BuildTools: ocamlbuild 38 | FindlibName: net 39 | FindlibParent: session-ocaml 40 | Modules: 41 | Dsession 42 | ByteOpt: -I +threads 43 | NativeOpt: -I +threads 44 | BuildDepends: threads, str, ppx_implicits 45 | 46 | Executable ppx_session 47 | Path: ppx 48 | BuildTools: ocamlbuild 49 | MainIs: ppx_session_ex.ml 50 | BuildDepends: compiler-libs.common, ppx_tools.metaquot, ppx_deriving.api 51 | CompiledObject: best 52 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: ce1ea11ddbd0478b54c6b8b2e102f06c) 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 session-ocaml 18 | "lib/session-ocaml.cmxs": use_session-ocaml 19 | : oasis_library_session_ocaml_byte 20 | : oasis_library_session_ocaml_byte 21 | : oasis_library_session_ocaml_native 22 | : oasis_library_session_ocaml_native 23 | : pkg_str 24 | : pkg_threads 25 | # Library ppx 26 | "ppx/ppx.cmxs": use_ppx 27 | : pkg_compiler-libs 28 | # Library net 29 | "net/net.cmxs": use_net 30 | : oasis_library_net_byte 31 | : oasis_library_net_byte 32 | : oasis_library_net_native 33 | : oasis_library_net_native 34 | : pkg_ppx_implicits 35 | : pkg_str 36 | : pkg_threads 37 | # Executable ppx_session 38 | : pkg_compiler-libs.common 39 | : pkg_ppx_deriving.api 40 | : pkg_ppx_tools.metaquot 41 | : pkg_compiler-libs.common 42 | : pkg_ppx_deriving.api 43 | : pkg_ppx_tools.metaquot 44 | # OASIS_STOP 45 | 46 | "examples": not_hygienic 47 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # OASIS_START 4 | # DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) 5 | set -e 6 | 7 | FST=true 8 | for i in "$@"; do 9 | if $FST; then 10 | set -- 11 | FST=false 12 | fi 13 | 14 | case $i in 15 | --*=*) 16 | ARG=${i%%=*} 17 | VAL=${i##*=} 18 | set -- "$@" "$ARG" "$VAL" 19 | ;; 20 | *) 21 | set -- "$@" "$i" 22 | ;; 23 | esac 24 | done 25 | 26 | ocaml setup.ml -configure "$@" 27 | # OASIS_STOP 28 | -------------------------------------------------------------------------------- /examples/.depend: -------------------------------------------------------------------------------- 1 | __working.cmo : 2 | __working.cmx : 3 | ex_multi1.cmo : ex_single2.cmo 4 | ex_multi1.cmx : ex_single2.cmx 5 | ex_single1.cmo : 6 | ex_single1.cmx : 7 | ex_single2.cmo : ex_single1.cmo 8 | ex_single2.cmx : ex_single1.cmx 9 | test.cmo : ex_single2.cmo 10 | test.cmx : ex_single2.cmx 11 | travel_agency.cmo : 12 | travel_agency.cmx : 13 | travel_agency_.cmo : 14 | travel_agency_.cmx : 15 | -------------------------------------------------------------------------------- /examples/.merlin: -------------------------------------------------------------------------------- 1 | PKG session-ocaml session-ocaml.ppx session-ocaml.ppx_lens 2 | FLG -rectypes 3 | B +threads 4 | S . 5 | S ../lib 6 | 7 | B . 8 | -------------------------------------------------------------------------------- /examples/.ocamlinit: -------------------------------------------------------------------------------- 1 | let () = 2 | try Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH") 3 | with Not_found -> () 4 | ;; 5 | 6 | #use "topfind";; 7 | #thread;; 8 | #rectypes;; 9 | #require "session-ocaml.ppx";; 10 | #require "session-ocaml.ppx_lens";; 11 | 12 | open Session;; 13 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | OCAMLC=ocamlfind ocamlc -g -thread -package session-ocaml,session-ocaml.ppx -rectypes -short-paths 2 | OCAMLOPT=ocamlfind ocamlc -thread -package session-ocaml,session-ocaml.ppx -rectypes -short-paths 3 | OCAMLMKTOP=ocamlfind ocamlmktop -thread -package session-ocaml -rectypes 4 | OCAMLDEP=ocamlfind ocamldep -package session-ocaml 5 | 6 | EXAMPLES=ex_single1 ex_single2 ex_multi1 ex_multi2 travel_agency smtp smtp2 7 | 8 | EXAMPLES_BYTE = $(EXAMPLES:%=%.byte) 9 | 10 | 11 | all: $(EXAMPLES_BYTE) 12 | 13 | smtp2.byte: smtp2.cmo 14 | $(OCAMLC) -package session-ocaml.net -linkpkg -o $@ $^ 15 | 16 | smtp2: smtp2.cmx 17 | $(OCAMLOPT) -package session-ocaml.net -linkpkg -o $@ $^ 18 | 19 | ex_single2.byte: ex_single1.cmo ex_single2.cmo 20 | $(OCAMLC) -linkpkg -o $@ $^ 21 | 22 | ex_single2: ex_single1.cmx ex_single2.cmx 23 | $(OCAMLOPT) -linkpkg -o $@ $^ 24 | 25 | ex_multi1.byte: ex_single1.cmo ex_single2.cmo ex_multi1.cmo 26 | $(OCAMLC) -linkpkg -o $@ $^ 27 | 28 | ex_multi1: ex_single1.cmx ex_single2.cmx ex_multi1.cmx 29 | $(OCAMLOPT) -linkpkg -o $@ $^ 30 | 31 | %.byte: %.cmo 32 | $(OCAMLC) -linkpkg -o $@ $^ 33 | 34 | 35 | # Common rules 36 | .SUFFIXES: .ml .mli .cmo .cmi .cmx 37 | 38 | smtp2.cmo: smtp2.ml 39 | $(OCAMLC) -package session-ocaml.net -c $< 40 | 41 | smtp2.cmx: smtp2.ml 42 | $(OCAMLOPT) -package session-ocaml.net -c $< 43 | 44 | .ml.cmo: 45 | $(OCAMLC) -c $< 46 | 47 | .mli.cmi: 48 | $(OCAMLC) -c $< 49 | 50 | .ml.cmx: 51 | $(OCAMLOPT) -c $< 52 | 53 | # Clean up 54 | clean: 55 | rm -f *.top *.native *.byte 56 | rm -f *.cm[ioaxt] *.cmax *.cmti *.o *.annot 57 | 58 | # Dependencies 59 | depend: 60 | $(OCAMLDEP) $(INCLUDES) *.mli *.ml > .depend 61 | 62 | include .depend 63 | -------------------------------------------------------------------------------- /examples/__working.ml: -------------------------------------------------------------------------------- 1 | (* under reconstruction *) 2 | 3 | (* 4 | module type LinSession = sig 5 | type (-'a, +'b) t 6 | type 'a bang 7 | val compose : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t 8 | val fst : ('a -> 'b) t -> ('a * 't, 'b * 't) t 9 | val snd : ('a -> 'b) t -> ('t * 'a, 't * 'b) t 10 | val connect : 'p channel -> (unit, ('p, cli) sess) t 11 | val accept : 'p channel -> (unit, ('p, serv) sess) t 12 | val bindto : 'v -> (unit, 'v) t 13 | val out : ('a -> 'b) -> ('a bang, 14 | val send : (([`msg * 'r1 * 'v * 'p], 'r1 * 'r2) sess * 'v bang, ('p, 'r1 * 'r2) sess) t 15 | val recv : (([`msg * 'r2 * 'v * 'p], 'r1 * 'r2) sess, ('p, 'r1 * 'r2) sess * 'v bang) t 16 | end 17 | 18 | module type MonadAlt = sig 19 | type (-'a, +'b) t 20 | type ('a, 'b, 's, 't) lens 21 | val fst : ('a, 'b) t -> ('a * 't, 'b * 't) t 22 | val snd : ('a, 'b) t -> ('t * 'a, 't * 'b) t 23 | val send : 'v -> ([`msg of 'r1 * 'v * 'p], 'p) t 24 | val recv : ([`msg of 'r1 * 'v * 'p], 'p) t 25 | 26 | val lift : ('a,'b,'ss,'tt) lens -> ('a, 'b, 'c) t -> ('ss, 'tt, 'c) t 27 | end 28 | 29 | module type MonadAlt = sig 30 | type (-'a, +'b, +'c) t 31 | val (>>) : ('a, 'b, unit) t -> ('b, 'c, 'w) t -> ('a, 'c, 'w) t 32 | val (>>=) : ('a, 'b, 'v) t -> ('v -> ('b, 'c, 'w) t) -> ('a, 'c, 'w) t 33 | val return : 'v -> ('a, 'a, 'v) t 34 | val fst : ('a, 'b, 'c) t -> ('a * 't, 'b * 't, 'c) t 35 | val snd : ('a, 'b, 'c) t -> ('t * 'a, 't * 'b, 'c) t 36 | val send : 'v -> ([`msg of 'r1 * 'v * 'p], 'p, unit) t 37 | val recv : unit -> ([`msg of 'r1 * 'v * 'p], 'p, 'v) t 38 | end 39 | module M(X:MonadAlt) = struct 40 | open X 41 | let _0 = fst 42 | let _ = _0 (send 100) >> _1 (recv ()) >> 43 | end 44 | 45 | 46 | 47 | module type TcpSessionS = sig 48 | type 'p net = Tcp.channel -> (('p, serv) sess * all_empty, all_empty, unit) session 49 | val req : ('v -> string) -> 'p part -> [`msg of req * 'v * 'p] part 50 | val resp : (string -> 'v) -> 'p part -> [`msg of resp * 'v * 'p] part 51 | val sel : 52 | : (('v1 -> string) * 'p1 part) 53 | -> (('v2 -> string) * 'p2 part) 54 | -> [`branch of req * [`left * 'p1 | `right * 'p2]] part 55 | val bra : 56 | : ((string -> 'v1 option) * 'p1 part) 57 | -> ((string -> 'v2 option) * 'p2 part) 58 | -> [`branch of resp * [`left * [`msg of resp * 'v1 * 'p1] 59 | |`right * [`msg of resp * 'v2 * 'p2]]] part 60 | val cls : [`close] part 61 | end 62 | module TcpSession : TcpSessionS = struct 63 | type 'p net = Tcp.channel -> (('p, serv) sess * all_empty, all_empty, unit) session 64 | open Session0 65 | 66 | let req conv cont tcp = 67 | recv () >>= fun v -> 68 | Tcp.send_line tcp (conv v); 69 | cont tcp 70 | 71 | let resp conv cont tcp = 72 | let line = Tcp.recv_line tcp in 73 | send (conv line) >>= fun () -> 74 | cont tcp 75 | 76 | let sel cont1 cont2 tcp = 77 | branch2 78 | (fun () -> cont1 tcp) 79 | (fun () -> cont2 tcp) 80 | 81 | let bra (conv1,cont1) cont2 tcp = 82 | let line = Tcp.recv_line tcp in 83 | match conv1 line with 84 | | Some(v) -> select_left () >> send v >>= fun () -> cont1 tcp 85 | | None -> cont2 86 | 87 | let cls tcp = Tcp.close tcp; close () 88 | 89 | let channel f opts = 90 | let ch = new_channel () in 91 | Thread.create (fun () -> 92 | accept_ ch (fun () -> 93 | let tcp = Tcp.connect opts in 94 | f tcp)) (); 95 | ch 96 | end 97 | 98 | type ehlo = EHLO of string 99 | type mail = MAIL of string 100 | type rcpt = RCPT of string 101 | type data = DATA 102 | type quit = QUIT 103 | 104 | type r200 = R200 of string list 105 | type r500 = R500 of string list 106 | type R354 = R354 of string 107 | 108 | module SMTP = struct 109 | open TcpSession 110 | let rec rcpt_part cont x = 111 | begin 112 | select (send rcpt @@ branch (r200, rcpt_part cont) (r500, send quit close)) 113 | cont 114 | end @@ x 115 | 116 | let rec mail_loop x = 117 | begin 118 | send mail @@ recv r200 @@ 119 | rcpt_part @@ 120 | send data @@ recv r354 @@ 121 | send string_list @@ recv r200 @@ 122 | select (send quit close) 123 | mail_loop 124 | end @@ x 125 | 126 | let smtp_protcol = 127 | recv r200 (send ehlo (recv r200, mail_loop ())) 128 | end 129 | 130 | let ch = TcpSession.channel SMTP.smtp_protocol opts 131 | ;; 132 | 133 | connect_ch (fun () -> 134 | send (EHLO("keigoimai.info")) >> recv () >>= fun (R200 str) -> 135 | send (MAIL("keigo.imai@gmail.com")) >> recv () >>= fun (R200 str) -> 136 | send (RCPT("keigoi@gifu-u.ac.jp")) >> 137 | branch (fun () -> 138 | recv () >>= fun (R200 str) -> 139 | send DATA >> recv () >>= fun R354 -> 140 | send (escape mailbody) >> recv () >>= fun (R200 str) -> 141 | send QUIT >> 142 | close ()) 143 | (fun () -> 144 | recv () >>= fun (R500 str) -> 145 | List.iter print_endline str; 146 | send QUIT >> 147 | close ())) () 148 | 149 | n 150 | *) 151 | 152 | 153 | 154 | (* newtype EHLO = EHLO String; newtype MAIL = MAIL String; newtype RCPT = RCPT String *) 155 | (* data DATA = DATA; data QUIT = QUIT; *) 156 | (* -- Types for SMTP server replies (200 OK, 500 error and 354 start mail input) *) 157 | (* newtype R2yz = R2yz [String]; newtype R5yz = R5yz [String]; newtype R354 = R354 String *) 158 | 159 | (* module type SerialSession = sig *) 160 | (* type t *) 161 | (* val run : Tcp.channel -> ((t, serv) sess * all_empty, empty, unit) session *) 162 | (* end *) 163 | 164 | (* module type Printer = sig *) 165 | (* type v *) 166 | (* val print : v -> string *) 167 | (* end *) 168 | 169 | (* module type Parser = sig *) 170 | (* type v *) 171 | (* val parse : string -> v option *) 172 | (* end *) 173 | 174 | (* module Send(V:Printer, P:SerialSession) : SerialSession *) 175 | (* with type t = [`msg of req * V.t * P.t] = *) 176 | (* struct *) 177 | (* type t = [`msg of req * V.t * P.t] *) 178 | (* let run c = *) 179 | (* Session.recv () >>= fun x -> *) 180 | (* Tcp.send c (V.print x); *) 181 | (* P.run c *) 182 | (* end;; *) 183 | 184 | (* module Recv(V:Parser, P:SerialSession) : SerialSession *) 185 | (* with type t = [`msg of resp * V.t * P.t] = *) 186 | (* struct *) 187 | (* type t = [`msg of req * V.t * P.t] *) 188 | (* let run c = *) 189 | (* let str = Tcp.recv c in *) 190 | (* match V.parse str with *) 191 | (* | Some(x) -> *) 192 | (* Session.send (V.parse str) >> *) 193 | (* P.run c *) 194 | (* | None -> failwith "network parse error" *) 195 | (* end;; *) 196 | 197 | (* module Branch(V1:Parser, P1:SerialSession, V2:Parser, P2:SerialSession) : SerialSession *) 198 | (* with type t = [`branch of resp * [`left * [`msg of resp * V1.t * P1.t] *) 199 | (* | `right * [`msg of resp * V2.t * P2.t]]] = *) 200 | (* struct *) 201 | (* type t = [`branch of resp * [`left * [`msg of resp * V1.t * P1.t] *) 202 | (* | `right * [`msg of resp * V2.t * P2.t]]] *) 203 | (* let run c = *) 204 | (* let str = Tcp.recv c in *) 205 | (* match parse str with *) 206 | (* | Some(x) -> *) 207 | (* Session.select_left () >> *) 208 | (* Session.send x >> *) 209 | (* P1.run c *) 210 | (* | None -> *) 211 | 212 | 213 | 214 | 215 | (* end;; *) 216 | 217 | 218 | (* module Example4 = struct *) 219 | (* open SafeSession.Session0 *) 220 | 221 | (* let rec smtpclient ch () = *) 222 | (* _branch_start (function *) 223 | (* | `EHLO(p,server) -> *) 224 | (* end *) 225 | 226 | (* _branch_start (function *) 227 | (* | `neg(p),r -> _branch (p,r) (neg_server ()) *) 228 | (* | `bin(p),r -> _branch (p,r) (binop_server ()) *) 229 | (* | `fin(p),r -> _branch (p,r) (close ()): [`neg of 'p1 | `bin of 'p2 | `fin of 'p3] * 'a -> 'b) *) 230 | -------------------------------------------------------------------------------- /examples/dbserver.ml: -------------------------------------------------------------------------------- 1 | open Session 2 | 3 | type result = Result (*stub*) 4 | type credential = Cred (*stub*) 5 | let bad_credential Cred = false (*stub*) 6 | let do_query (query:string) : result = Result (*stub*) 7 | 8 | let db_ch = new_channel () 9 | and worker_ch = new_channel () 10 | 11 | let rec main () = 12 | accept db_ch ~bindto:_0 >> 13 | recv _0 >>= fun cred -> 14 | if bad_credential cred then 15 | select_left _0 >> 16 | close _0 17 | else 18 | select_right _0 >> 19 | connect worker_ch ~bindto:_1 >> 20 | deleg_send _1 ~release:_0 >> 21 | close _1 >>= 22 | main 23 | 24 | let rec worker () = 25 | accept worker_ch ~bindto:_0 >> 26 | deleg_recv _0 ~bindto:_1 >> 27 | close _0 >> 28 | let rec loop () = 29 | branch 30 | ~left:(_1, fun () -> close _1) 31 | ~right:(_1, fun () -> 32 | recv _1 >>= fun query -> 33 | let res = do_query query in 34 | send _1 res >>= 35 | loop) 36 | in loop () >>= worker 37 | -------------------------------------------------------------------------------- /examples/example_journal1.ml: -------------------------------------------------------------------------------- 1 | open Session 2 | let xor : bool -> bool -> bool = (<>) 3 | let print_bool = Printf.printf "%B" 4 | let xor_ch = new_channel ();; 5 | Thread.create 6 | (accept_ xor_ch (fun () -> 7 | recv s >>= fun (x,y) -> 8 | send s (xor x y) >> 9 | close s)) ();; 10 | connect_ xor_ch (fun () -> 11 | send s (false,true) >> 12 | recv s >>= fun b -> 13 | print_bool b; 14 | close s) () 15 | -------------------------------------------------------------------------------- /examples/example_journal2.ml: -------------------------------------------------------------------------------- 1 | open Session 2 | let xor : bool -> bool -> bool = (<>) 3 | let print_bool = Printf.printf "%B" 4 | type binop = And | Or | Xor | Imp 5 | let log_ch = new_channel () 6 | let eval_op = function 7 | | And -> (&&) 8 | | Or -> (||) 9 | | Xor -> xor 10 | | Imp -> (fun a b -> not a || b) 11 | let rec logic_server () = 12 | branch ~left:(s, fun () -> 13 | recv s >>= fun op -> 14 | recv s >>= fun (x,y) -> 15 | send s (eval_op op x y) >>= fun () -> 16 | logic_server ()) 17 | ~right:(s, fun () -> close s);; 18 | Thread.create 19 | (accept_ log_ch logic_server) ();; 20 | connect_ log_ch (fun () -> 21 | select_left s >> 22 | send s And >> 23 | send s (true, false) >> 24 | recv s >>= fun ans -> 25 | (print_bool ans; 26 | select_right s >> 27 | close s)) () 28 | -------------------------------------------------------------------------------- /examples/example_journal3.ml: -------------------------------------------------------------------------------- 1 | open Session 2 | open Example_journal2 3 | let worker_ch = new_channel () 4 | let rec main () = 5 | accept log_ch ~bindto:_0 >> 6 | connect worker_ch ~bindto:_1 >> 7 | deleg_send _1 ~release:_0 >> 8 | close _1 >>= fun () -> 9 | main () 10 | let rec worker () = 11 | accept worker_ch ~bindto:_1 >> 12 | deleg_recv _1 ~bindto:_0 >> 13 | close _1 >> 14 | logic_server () >>= fun () -> 15 | worker ();; 16 | for i = 0 to 5 do 17 | Thread.create (run worker) () 18 | done;; 19 | Thread.create (run main) ();; 20 | connect_ log_ch (fun () -> 21 | select_left s >> 22 | send s Or >> 23 | send s (true, false) >> 24 | recv s >>= fun ans -> 25 | print_bool ans; print_newline (); 26 | select_left s >> 27 | send s And >> 28 | send s (true, false) >> 29 | recv s >>= fun ans -> 30 | print_bool ans; print_newline (); 31 | select_left s >> 32 | send s Xor >> 33 | send s (true, false) >> 34 | recv s >>= fun ans -> 35 | print_bool ans; print_newline (); 36 | select_right s >> 37 | close s) () 38 | 39 | -------------------------------------------------------------------------------- /examples/smtp.ml: -------------------------------------------------------------------------------- 1 | (* EHLO example.com *) (* MAIL FROM: alice@example.com *) 2 | type ehlo = EHLO of string type mail = MAIL of string 3 | (* RCPT TO: bob@example.com *) (* DATA *) 4 | type rcpt = RCPT of string type data = DATA 5 | (* QUIT *) (* Success e.g. 250 Ok *) 6 | type quit = QUIT type r200 = R200 of string list 7 | (* Error e.g. 554 Relay denied *) (* 354 Start mail input *) 8 | type r500 = R500 of string list type r354 = R354 of string list 9 | 10 | module SMTP_Commands = struct 11 | 12 | let crlf = (Str.regexp "\r\n") 13 | let msgbody s = String.sub s 4 (String.length s-4) 14 | 15 | let rec parse_reply kind f orig_str : 'a Session.parse_result = 16 | let rec read acc str : 'a Session.parse_result = 17 | match Str.bounded_split_delim crlf str 2 with 18 | (* found CRLF *) 19 | | l::[ls] -> 20 | if l.[0] <> kind then 21 | `Fail(orig_str) 22 | else begin 23 | if l.[3] = '-' then 24 | read (msgbody l::acc) ls (* line continues *) 25 | else 26 | `Done(f (msgbody l::List.rev acc), ls) 27 | end 28 | (* no CRLF. starting over *) 29 | | _ -> `Partial(function Some(str) -> 30 | parse_reply kind f (orig_str^str) 31 | | None -> raise End_of_file (*FIXME*)) 32 | in 33 | read [] orig_str 34 | 35 | let r200 str = parse_reply '2' (fun x -> R200(x)) str 36 | let r500 str = parse_reply '5' (fun x -> R500(x)) str 37 | let r354 str = parse_reply '3' (fun x -> R354(x)) str 38 | let ehlo (EHLO v) = "EHLO " ^ v ^ "\r\n" 39 | let mail (MAIL v) = "MAIL FROM:" ^ v ^ "\r\n" 40 | let rcpt (RCPT v) = "RCPT TO:" ^ v ^ "\r\n" 41 | let data DATA = "DATA\r\n" 42 | let quit QUIT = "QUIT\r\n" 43 | let string_list ls = String.concat "\r\n" ls ^ "\r\n.\r\n" 44 | end 45 | 46 | 47 | open SMTP_Commands 48 | open Session 49 | open UnixAdapter 50 | 51 | type smtp = [`msg of resp * r200 * [`msg of req * ehlo * [`msg of resp * r200 * 52 | mail_loop]]] 53 | and mail_loop = [`branch of req * 54 | [`left of [`msg of req * mail * [`msg of resp * r200 * rcpt_loop]] 55 | |`right of [`msg of req * quit * [`close]]]] 56 | and rcpt_loop = [`branch of req * [`left of [`msg of req * rcpt * 57 | [`branch of resp * [`left of [`msg of resp * r200 * rcpt_loop] 58 | |`right of [`msg of resp * r500 * [`msg of req * quit * [`close]]]]]] 59 | |`right of body]] 60 | and body = [`msg of req * data * [`msg of resp * r354 * [`msg of req * string list * 61 | [`msg of resp * r200 * mail_loop]]]] 62 | 63 | 64 | let rec smtp_adapter : smtp net = fun ch -> (resp r200 @@ req ehlo @@ resp r200 @@ ml_p) ch 65 | and ml_p ch = sel ~left:(req mail @@ resp r200 @@ rp_p) ~right:(req quit @@ cls) ch 66 | and rp_p ch = sel ~left:(req rcpt @@ bra ~left:(r200, rp_p) 67 | ~right:(resp r500 @@ req quit @@ cls)) 68 | ~right:bd_p ch 69 | and bd_p ch = (req data @@ resp r354 @@ req string_list @@ resp r200 @@ ml_p) ch 70 | 71 | let escape : string -> string list = Str.split (Str.regexp "\n") (*FIXME*) 72 | 73 | open Session0 74 | let smtp_client hostport from to_ mailbody = 75 | let ch : smtp channel = TcpSession.new_channel smtp_adapter hostport in 76 | connect_ ch begin fun () -> 77 | let%s R200 s = recv () in 78 | send (EHLO("me.example.com")) >> let%s R200 _ = recv () in 79 | select_left () >> (* enter into the main loop *) 80 | send (MAIL(from)) >> let%s R200 _ = recv () in 81 | select_left () >> (* enter into recipient loop *) 82 | send (RCPT(to_)) >> 83 | branch2 (fun () -> let%s R200 _ = recv () in (* recipient Ok *) 84 | select_right () >> (* proceed to sending the mail body *) 85 | send DATA >> let%s R354 _ = recv () in 86 | send (escape mailbody) >> let%s R200 _ = recv () in 87 | select_right () >> send QUIT >> close ()) 88 | (fun () -> let%s R500 msg = recv () in (* a recipient is rejected *) 89 | (print_endline "ERROR:"; List.iter print_endline msg; send QUIT) >> close ()) end () 90 | 91 | 92 | let () = 93 | if Array.length Sys.argv <> 5 then begin 94 | print_endline ("Usage: " ^ Sys.argv.(0) ^ " host:port from to body"); 95 | exit 1 96 | end; 97 | smtp_client Sys.argv.(1) Sys.argv.(2) Sys.argv.(3) Sys.argv.(4) 98 | -------------------------------------------------------------------------------- /examples/smtp2.ml: -------------------------------------------------------------------------------- 1 | (* ocamlfind ocamlc -o smtp -linkpkg -short-paths -thread -package linocaml.ppx,linocaml.ppx_lens,session_ocaml smtp.ml *) 2 | open Dsession 3 | open Dsession.Tcp 4 | 5 | let bufsize = 4096 6 | 7 | (* EHLO example.com *) (* MAIL FROM: alice@example.com *) 8 | type ehlo = EHLO of string type mail = MAIL of string 9 | (* RCPT TO: bob@example.com *) (* DATA *) 10 | type rcpt = RCPT of string type data_ = DATA 11 | (* QUIT *) (* Success e.g. 250 Ok *) 12 | type quit = QUIT type r200 = R200 of string list 13 | (* Error e.g. 554 Relay denied *) (* 354 Start mail input *) 14 | type r500 = R500 of string list type r354 = R354 of string list 15 | (* mail body *) 16 | type mailbody = MailBody of string 17 | 18 | (* Instance declaration for SMTP reply deserialisers *) 19 | module Receivers = struct 20 | 21 | 22 | let rec parse_reply table tcp = 23 | let read_chunk () = 24 | let rec read_chunk_aux lines = 25 | let line = input_line tcp.in_ in 26 | (* remove trailing \r *) 27 | let line = 28 | let len = String.length line in 29 | if len > 0 && line.[len-1] = '\r' 30 | then String.sub line 0 (len-1) 31 | else line 32 | in 33 | if line.[3] = '-' then 34 | (* chunk continues. get the next line *) 35 | read_chunk_aux (line::lines) 36 | else 37 | (* chunk terminated *) 38 | List.rev (line::lines) 39 | in 40 | read_chunk_aux [] 41 | in 42 | let lines = read_chunk () in 43 | match lines with 44 | | [] -> assert false 45 | | first::_ -> 46 | if String.length first = 0 then 47 | failwith ("Parse error :" ^ String.concat "\r\n" lines) 48 | else 49 | (* get message constructor from the table*) 50 | let f = 51 | try 52 | List.assoc first.[0] table 53 | with 54 | | Not_found -> 55 | failwith ("Parse error : expected " 56 | ^ String.concat " or " (List.map Char.escaped (fst (List.split table))) 57 | ^ " but got:\r\n" ^ String.concat "\r\n" lines) 58 | in 59 | let msgbody s = String.sub s 4 (String.length s-4) 60 | in 61 | f tcp (List.map msgbody lines) 62 | 63 | let r200 = ('2', (fun tcp msg -> `_200(W msg, _mksess tcp))) 64 | let r354 = ('3', (fun tcp msg -> `_354(W msg, _mksess tcp))) 65 | let r500 = ('5', (fun tcp msg -> `_500(W msg, _mksess tcp))) 66 | 67 | let _200 68 | : stream -> [`_200 of _ * _] 69 | = fun c -> parse_reply [r200] c 70 | let _200_or_500 71 | : stream -> [`_200 of _ * _ | `_500 of _ * _] 72 | = fun c -> parse_reply [r200; r500] c 73 | let _354 74 | : stream -> [`_354 of _ * _] 75 | = fun c -> parse_reply [r354] c 76 | 77 | end 78 | 79 | (* Instance declaration for SMTP command serialisers *) 80 | module Senders = struct 81 | let write {out} str = 82 | output_string out str; 83 | flush out 84 | 85 | let _ehlo c (`EHLO (v,_) : [`EHLO of _]) = write c @@ "EHLO " ^ v ^ "\r\n" 86 | let _mailbody c (MailBody s) = write c @@ s ^ "\r\n.\r\n" 87 | 88 | let _mail c : [`MAIL of _] -> unit = function 89 | | `MAIL(v,_) -> write c @@ "MAIL FROM:" ^ v ^ "\r\n" 90 | 91 | let _quit c : [`QUIT of _] -> unit = function 92 | | `QUIT(_) -> write c "QUIT\r\n" 93 | 94 | let _rcpt_or_data c = (function 95 | | `RCPT(v,_) -> write c @@ "RCPT TO:" ^ v ^ "\r\n" 96 | | `DATA(_) -> write c "DATA\r\n" 97 | : [`RCPT of _ | `DATA of _] -> unit) 98 | 99 | let _mail_or_quit c = (function 100 | | `MAIL(_) as m -> _mail c m 101 | | `QUIT(_) as m -> _quit c m 102 | : [`MAIL of _ | `QUIT of _] -> unit) 103 | 104 | end 105 | 106 | 107 | type 'p cont = ('p,cli,stream) dsess 108 | type 'p contR = ('p,serv,stream) dsess 109 | 110 | type smtp = 111 | [`branch of resp * [`_200 of string list data * 112 | [`branch of req * [`EHLO of string * 113 | [`branch of resp * [`_200 of string list data * 114 | mailloop cont]] contR]] cont]] 115 | and mailloop = 116 | [`branch of req * 117 | [`MAIL of string * 118 | [`branch of resp * [`_200 of string list data * rcptloop cont]] contR 119 | |`QUIT of 120 | [`close] contR]] 121 | and rcptloop = 122 | [`branch of req * 123 | [`RCPT of string * 124 | [`branch of resp * 125 | [`_200 of string list data * 126 | rcptloop cont 127 | |`_500 of string list data * 128 | [`branch of req * [`QUIT of 129 | [`close] contR]] cont]] contR 130 | |`DATA of 131 | [`branch of resp * [`_354 of string list data * 132 | [`msg of req * mailbody * 133 | [`branch of resp * [`_200 of string list data * 134 | mailloop cont]]] cont]] contR]] 135 | 136 | open Tcp 137 | 138 | let s = _0 139 | 140 | let sendmail host port from to_ mailbody () : ((smtp,cli,stream) dsess * empty_three, empty_four, unit) lmonad = 141 | let%lin `_200(msg,#s) = branch s in 142 | List.iter print_endline msg; 143 | let%lin #s = select (fun x -> `EHLO("me.example.com",x)) s in 144 | let%lin `_200(_,#s) = branch s in 145 | let%lin #s = select (fun x -> `MAIL(from,x)) s in 146 | let%lin `_200(_,#s) = branch s in 147 | let%lin #s = select (fun x -> `RCPT(to_,x)) s in 148 | begin match%lin branch s with 149 | | `_200(_,#s) -> 150 | let%lin #s = select (fun x -> `DATA(x)) s in 151 | let%lin `_354(_, #s) = branch s in 152 | let%lin #s = send (MailBody mailbody) s in 153 | let%lin `_200(msg, #s) = branch s in 154 | print_string "Email sent: "; 155 | List.iter print_endline msg; 156 | let%lin #s = select (fun x -> `QUIT(x)) s in 157 | return () 158 | | `_500 (msg,#s) -> 159 | print_endline "Email sending failed. Detail:"; 160 | List.iter print_endline msg; 161 | let%lin #s = select (fun x -> `QUIT(x)) s in 162 | return () 163 | end >> 164 | close s 165 | 166 | let smtp_client host port from to_ mailbody () = 167 | let smtp : (smtp,stream) connector = connector ~host ~port in 168 | let%lin #s = connect smtp in 169 | sendmail host port from to_ mailbody () 170 | 171 | let () = 172 | if Array.length Sys.argv <> 6 then begin 173 | print_endline ("Usage: " ^ Sys.argv.(0) ^ " host port from to body"); 174 | exit 1 175 | end; 176 | run (smtp_client Sys.argv.(1) (int_of_string Sys.argv.(2)) Sys.argv.(3) Sys.argv.(4) Sys.argv.(5)) 177 | -------------------------------------------------------------------------------- /examples/travel_agency.ml: -------------------------------------------------------------------------------- 1 | open Session 2 | open SessionN 3 | 4 | type address = Address of string 5 | type date = Date of int 6 | 7 | let customer ch = 8 | connect ch ~bindto:_0 >> 9 | let rec loop () = 10 | [%select _0 `quote] >> 11 | send _0 "London to Paris, Eurostar" >> 12 | let%s cost = recv _0 in 13 | if cost < 100. then 14 | [%select _0 `accept] >> 15 | return cost 16 | else 17 | loop () 18 | in 19 | let%s cost = loop () in 20 | send _0 (Address("Kensington, London SW7 2AZ, UK")) >> 21 | let%s Date(date) = recv _0 in 22 | close _0 >> 23 | (Printf.printf "customer done. cost: %f\n" cost; return ()) 24 | 25 | (* 26 | val customer : 27 | ([ `branch of 28 | Session.req * 29 | [> `accept of 30 | [ `msg of 31 | Session.req * address * 32 | [ `msg of Session.resp * date * [ `close ] ] ] 33 | | `quote of 34 | [ `msg of 35 | Session.req * string * [ `msg of Session.resp * float * 'a ] ] ] ] 36 | as 'a) 37 | Session.channel -> 38 | (Session.empty * 'b, Session.empty * 'b, unit) Session.monad = 39 | *) 40 | 41 | let agency ctm_ch svc_ch = 42 | accept ctm_ch ~bindto:_0 >> 43 | let rec loop () = 44 | match%branch _0 with 45 | | `accept -> return () 46 | | `quote -> begin 47 | let%s dest = recv _0 in 48 | send _0 80.00 >> 49 | loop () 50 | end 51 | in 52 | loop () >> 53 | connect svc_ch ~bindto:_1 >> 54 | deleg_send _1 ~release:_0 >> 55 | close _1 56 | 57 | 58 | (* 59 | val agency : 60 | ([ `branch of 61 | Session.req * 62 | [< `accept of 'b 63 | | `quote of 64 | [ `msg of 65 | Session.req * 'c * [ `msg of Session.resp * float * 'a ] ] ] ] 66 | as 'a) 67 | Session.channel -> 68 | [ `deleg of 69 | Session.req * ('b, Session.resp * Session.req) Session.sess * 70 | [ `close ] ] 71 | Session.channel -> 72 | (Session.empty * (Session.empty * 'd), 73 | Session.empty * (Session.empty * 'd), unit) 74 | Session.monad = 75 | *) 76 | 77 | let service svc_ch = 78 | accept svc_ch ~bindto:_0 >> 79 | deleg_recv _0 ~bindto:_1 >> 80 | let%s Address(address) = recv _1 in 81 | send _1 (Date(0)) >> 82 | close _1 >> 83 | close _0 84 | 85 | (* 86 | val service : 87 | [ `deleg of 88 | Session.req * 89 | ([ `msg of 'a * address * [ `msg of 'b * date * [ `close ] ] ], 90 | 'b * 'a) 91 | Session.sess * [ `close ] ] 92 | Session.channel -> 93 | (Session.empty * (Session.empty * 'c), 94 | Session.empty * (Session.empty * 'c), unit) 95 | Session.monad = 96 | *) 97 | 98 | let ctm_ch = new_channel () 99 | let svc_ch = new_channel () 100 | 101 | let _ = 102 | ignore @@ Thread.create (run service) svc_ch; 103 | ignore @@ Thread.create (run (agency ctm_ch)) svc_ch; 104 | run customer ctm_ch 105 | 106 | 107 | -------------------------------------------------------------------------------- /examples/travel_agency_.ml: -------------------------------------------------------------------------------- 1 | open Session 2 | open SessionN 3 | 4 | type address = Address of string 5 | type date = Date of int 6 | 7 | let customer ch = 8 | connect ch ~bindto:_0 >> 9 | let rec loop () = 10 | [%select _0 `quote] >> 11 | send _0 "London to Paris, Eurostar" >> 12 | let%s cost = recv _0 in 13 | if cost < 100. then 14 | [%select _0 `accept] >> 15 | return cost 16 | else 17 | loop () 18 | in 19 | let%s cost = loop () in 20 | send _0 (Address("Kensington, London SW7 2AZ, UK")) >> 21 | let (Date(date)) = recv _0 in 22 | close _0 >> 23 | (Printf.printf "customer done. cost: %f\n" cost; return ()) 24 | 25 | (* 26 | val customer : 27 | ([ `branch of 28 | Session.req * 29 | [> `accept of 30 | [ `msg of 31 | Session.req * address * 32 | [ `msg of Session.resp * date * [ `close ] ] ] 33 | | `quote of 34 | [ `msg of 35 | Session.req * string * [ `msg of Session.resp * float * 'a ] ] ] ] 36 | as 'a) 37 | Session.channel -> 38 | (Session.empty * 'b, Session.empty * 'b, unit) Session.monad = 39 | *) 40 | 41 | let agency ctm_ch svc_ch = 42 | accept ctm_ch ~bindto:_0 >> 43 | let rec loop () = 44 | match%branch _0 with 45 | | `accept(p),q -> return () 46 | | `quote(p),q -> begin 47 | let%s dest = recv _0 in 48 | send _0 80.00 >> 49 | loop () 50 | end 51 | in 52 | loop () >> 53 | connect svc_ch ~bindto:_1 >> 54 | deleg_send _1 ~release:_0 >> 55 | close _1 56 | 57 | (* 58 | val agency : 59 | ([ `branch of 60 | Session.req * 61 | [< `accept of 'b 62 | | `quote of 63 | [ `msg of 64 | Session.req * 'c * [ `msg of Session.resp * float * 'a ] ] ] ] 65 | as 'a) 66 | Session.channel -> 67 | [ `deleg of 68 | Session.req * ('b, Session.resp * Session.req) Session.sess * 69 | [ `close ] ] 70 | Session.channel -> 71 | (Session.empty * (Session.empty * 'd), 72 | Session.empty * (Session.empty * 'd), unit) 73 | Session.monad = 74 | *) 75 | 76 | let service svc_ch = 77 | accept svc_ch ~bindto:_0 >> 78 | deleg_recv _0 ~bindto:_1 >> 79 | let%s (Address(address)) = recv _1 in 80 | send _1 (Date(0)) >> 81 | close _1 >> 82 | close _0 83 | 84 | (* 85 | val service : 86 | [ `deleg of 87 | Session.req * 88 | ([ `msg of 'a * address * [ `msg of 'b * date * [ `close ] ] ], 89 | 'b * 'a) 90 | Session.sess * [ `close ] ] 91 | Session.channel -> 92 | (Session.empty * (Session.empty * 'c), 93 | Session.empty * (Session.empty * 'c), unit) 94 | Session.monad = 95 | *) 96 | 97 | let ctm_ch = new_channel () 98 | let svc_ch = new_channel () 99 | 100 | let _ = 101 | Thread.create (run service) svc_ch; 102 | Thread.create (run (agency ctm_ch)) svc_ch; 103 | run customer ctm_ch 104 | 105 | 106 | -------------------------------------------------------------------------------- /lib/META: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 1d623cb73d79c863e1d78379570b701c) 3 | version = "0.1" 4 | description = 5 | "A concurrent / distributed programming with protocol typing, based on Session Types." 6 | requires = "threads str" 7 | archive(byte) = "session-ocaml.cma" 8 | archive(byte, plugin) = "session-ocaml.cma" 9 | archive(native) = "session-ocaml.cmxa" 10 | archive(native, plugin) = "session-ocaml.cmxs" 11 | exists_if = "session-ocaml.cma" 12 | package "ppx" ( 13 | version = "0.1" 14 | description = 15 | "A concurrent / distributed programming with protocol typing, based on Session Types." 16 | requires = "session-ocaml ppx_deriving" 17 | archive(syntax, preprocessor) = "ppx.cma" 18 | archive(syntax, toploop) = "ppx.cma" 19 | archive(syntax, preprocessor, native) = "ppx.cmxa" 20 | archive(syntax, preprocessor, native, plugin) = "ppx.cmxs" 21 | ppx = "ppx_session" 22 | exists_if = "ppx.cma" 23 | ) 24 | 25 | package "net" ( 26 | version = "0.1" 27 | description = 28 | "A concurrent / distributed programming with protocol typing, based on Session Types." 29 | requires = "threads str ppx_implicits" 30 | archive(byte) = "net.cma" 31 | archive(byte, plugin) = "net.cma" 32 | archive(native) = "net.cmxa" 33 | archive(native, plugin) = "net.cmxs" 34 | exists_if = "net.cma" 35 | ) 36 | # OASIS_STOP 37 | 38 | -------------------------------------------------------------------------------- /lib/channel.ml: -------------------------------------------------------------------------------- 1 | module Q = Queue 2 | 3 | module M = Monitor 4 | 5 | type 'a t = ('a Q.t ref) M.t 6 | 7 | let create () : 'a t = M.create (ref (Q.create ())) 8 | 9 | let send (t : 'a t) (v:'a) : unit = 10 | M.lock t (fun q -> Q.add v !q; M.signal t) 11 | 12 | let send_all (t : 'a t) (xs:'a list) : unit = 13 | M.lock t (fun q -> List.iter (fun x -> Q.add x !q) xs; M.signal t) 14 | 15 | let try_receive (t:'a t) : 'a option = 16 | M.lock t (fun q -> if Q.is_empty !q then None else Some (Q.take !q)) 17 | 18 | let receive (t:'a t) : 'a = 19 | M.wait t (fun q -> 20 | if Q.is_empty !q then 21 | M.WaitMore 22 | else 23 | M.Return (Q.take !q)) 24 | 25 | let clear_queue_ t = 26 | M.lock t (fun q -> 27 | let old = !q in 28 | q := Q.create (); 29 | old) 30 | 31 | let receive_all (t:'a t) (func:'b -> 'a -> 'b) (init:'b) : 'b = 32 | Q.fold func init (clear_queue_ t) 33 | 34 | let receive_all_ (t:'a t) (func:'a -> unit) : unit = 35 | receive_all t (fun _ x -> func x) () 36 | 37 | let peek (t:'a t) : 'a = 38 | M.wait t (fun q -> 39 | if Q.is_empty !q then 40 | M.WaitMore 41 | else 42 | M.Return (Q.peek !q)) 43 | 44 | let clear (t:'a t) : unit = 45 | ignore (clear_queue_ t) 46 | 47 | let is_empty (t:'a t) : bool = 48 | M.lock t (fun q -> Q.is_empty !q) 49 | 50 | let length (t:'a t) : int = 51 | M.lock t (fun q -> Q.length !q) 52 | -------------------------------------------------------------------------------- /lib/channel.mli: -------------------------------------------------------------------------------- 1 | (** Concurrent, buffered channel *) 2 | 3 | type 'a t 4 | val create : unit -> 'a t 5 | val send : 'a t -> 'a -> unit 6 | val receive : 'a t -> 'a 7 | val receive_all : 'a t -> ('b -> 'a -> 'b) -> 'b -> 'b 8 | val receive_all_ : 'a t -> ('a -> unit) -> unit 9 | val peek : 'a t -> 'a 10 | val clear : 'a t -> unit 11 | val is_empty : 'a t -> bool 12 | val length : 'a t -> int 13 | -------------------------------------------------------------------------------- /lib/lsession.ml: -------------------------------------------------------------------------------- 1 | type 'a data = W of 'a 2 | type ('pre, 'post, 'a) lmonad = 'pre -> 'post * 'a 3 | type 'f lbind = 'f 4 | 5 | type ('a,'b,'ss,'tt) slot = ('ss -> 'a) * ('ss -> 'b -> 'tt) 6 | 7 | let _0 = (fun (a,_) -> a), (fun (_,ss) b -> (b,ss)) 8 | let _1 = (fun (_,(a,_)) -> a), (fun (s0,(_,ss)) b -> (s0,(b,ss))) 9 | let _2 = (fun (_,(_,(a,_))) -> a), (fun (s0,(s1,(_,ss))) b -> (s0,(s1,(b,ss)))) 10 | let _3 = (fun (_,(_,(_,(a,_)))) -> a), (fun (s0,(s1,(s2,(_,ss)))) b -> (s0,(s1,(s2,(b,ss))))) 11 | 12 | type empty = Empty 13 | type all_empty = empty * 'a as 'a 14 | 15 | let return a pre = pre, a 16 | let (>>=) f g pre = let mid, la = f pre in g la mid 17 | let (>>) f g pre = let mid, _ = f pre in g mid 18 | 19 | module type UnsafeChannel = sig 20 | type t 21 | val create : unit -> t 22 | val send : t -> 'a -> unit 23 | val receive : t -> 'a 24 | val reverse : t -> t 25 | end 26 | 27 | type req and resp 28 | type cli = req * resp and serv = resp * req 29 | 30 | module type S = sig 31 | type 'p channel 32 | val new_channel : unit -> 'p channel 33 | 34 | type ('p,'q) sess 35 | 36 | val accept : 'p channel -> ('pre, 'pre, ('p, serv) sess) lmonad 37 | 38 | val connect : 'p channel -> ('pre, 'pre, ('p, cli) sess) lmonad 39 | 40 | val close : (([`close], 'r1*'r2) sess, empty, 'pre, 'post) slot 41 | -> ('pre, 'post, unit) lmonad 42 | 43 | val send : 'v -> (([`msg of 'r1 * 'v * 'p], 'r1*'r2) sess, empty, 'pre, 'post) slot 44 | -> ('pre, 'post, ('p, 'r1*'r2) sess) lmonad 45 | 46 | val receive : (([`msg of 'r2 * 'v * 'p], 'r1*'r2) sess, empty, 'pre, 'post) slot 47 | -> ('pre, 'post, 'v data * ('p, 'r1*'r2) sess) lmonad 48 | 49 | val select : (('p,'r2*'r1) sess -> ([>] as 'br)) 50 | -> (([`branch of 'r1 * 'br],'r1*'r2) sess, empty, 'pre, 'post) slot 51 | -> ('pre, 'post, ('p,'r1*'r2) sess) lmonad 52 | 53 | val branch : (([`branch of 'r2 * [>] as 'br], 'r1*'r2) sess, empty, 'pre, 'post) slot 54 | -> ('pre, 'post, 'br) lmonad 55 | 56 | val deleg_send : (('pp, 'qq) sess, empty, 'mid, 'post) slot 57 | -> (([`deleg of 'r1 * ('pp, 'qq) sess * 'p], 'r1*'r2) sess, empty, 'pre, 'mid) slot 58 | -> ('pre, 'post, ('p, 'r1*'r2) sess) lmonad 59 | 60 | val deleg_recv : 61 | (([`deleg of 'r2 * ('pp, 'qq) sess * 'p], 'r1*'r2) sess, empty, 'pre, 'post) slot 62 | -> ('pre, 'post, ('pp,'qq) sess * ('p,'r1*'r2) sess) lmonad 63 | 64 | end 65 | 66 | module Make(U : UnsafeChannel) : S = struct 67 | type ('p,'q) sess = U.t 68 | type 'p channel = U.t Schannel.t 69 | 70 | let new_channel = Schannel.create 71 | 72 | let accept : 'p 'pre. 'p channel -> ('pre, 'pre, ('p, serv) sess) lmonad = 73 | fun ch pre -> 74 | let s = Schannel.receive ch in 75 | pre, s 76 | 77 | let connect : 'p 'pre. 'p channel -> ('pre, 'pre, ('p, cli) sess) lmonad = 78 | fun ch pre -> 79 | let s = U.create () in 80 | Schannel.send ch (U.reverse s); 81 | pre, s 82 | 83 | let close : 'pre 'r1 'r2 'post. 84 | (([`close], 'r1*'r2) sess, empty, 'pre, 'post) slot 85 | -> ('pre, 'post, unit) lmonad = 86 | fun (_,set) pre -> 87 | set pre Empty, () 88 | 89 | let send : 'v 'r1 'p 'r2 'pre 'post. 90 | 'v -> (([`msg of 'r1 * 'v * 'p], 'r1*'r2) sess, empty, 'pre, 'post) slot 91 | -> ('pre, 'post, ('p, 'r1*'r2) sess) lmonad = 92 | fun v (get,set) pre -> 93 | let s = get pre in 94 | U.send s v; 95 | set pre Empty, s 96 | 97 | let receive : 'r2 'v 'p 'r1 'pre 'post. 98 | (([`msg of 'r2 * 'v * 'p], 'r1*'r2) sess, empty, 'pre, 'post) slot 99 | -> ('pre, 'post, 'v data * ('p, 'r1*'r2) sess) lmonad = 100 | fun (get,set) pre -> 101 | let s = get pre in 102 | set pre Empty, (W (U.receive s), s) 103 | 104 | let select : 'p 'r2 'r1 'pre 'post. 105 | (('p,'r2*'r1) sess -> ([>] as 'br)) 106 | -> (([`branch of 'r1 * 'br],'r1*'r2) sess, empty, 'pre, 'post) slot 107 | -> ('pre, 'post, ('p,'r1*'r2) sess) lmonad = 108 | fun f (get,set) pre -> 109 | let s = get pre in 110 | U.send s (f (U.reverse s)); 111 | set pre Empty, s 112 | 113 | let branch : 'r2 'r1 'pre 'post. 114 | (([`branch of 'r2 * [>] as 'br], 'r1*'r2) sess, empty, 'pre, 'post) slot 115 | -> ('pre, 'post, 'br) lmonad = 116 | fun (get,set) pre -> 117 | let s = get pre in 118 | set pre Empty, (U.receive s) 119 | 120 | let deleg_send : 'pp 'qq 'mid 'post 'r1 'r2 'pre. 121 | (('pp, 'qq) sess, empty, 'mid, 'post) slot 122 | -> (([`deleg of 'r1 * ('pp, 'qq) sess * 'p], 'r1*'r2) sess, empty, 'pre, 'mid) slot 123 | -> ('pre, 'post, ('p, 'r1*'r2) sess) lmonad = 124 | fun (get1,set1) (get2,set2) pre -> 125 | let s = get2 pre in 126 | let mid = set2 pre Empty in 127 | let t = get1 mid in 128 | U.send s t; 129 | set1 mid Empty, s 130 | 131 | let deleg_recv : 'r2 'p 'r1 'pre 'post 'pp 'qq. 132 | (([`deleg of 'r2 * ('pp, 'qq) sess * 'p], 'r1*'r2) sess, empty, 'pre, 'post) slot 133 | -> ('pre, 'post, ('pp,'qq) sess * ('p,'r1*'r2) sess) lmonad = 134 | fun (get,set) pre -> 135 | let s = get pre in 136 | let t = U.receive s in 137 | set pre Empty, (t, s) 138 | 139 | end 140 | 141 | include Make(struct 142 | type t = unit Event.channel 143 | let create = Event.new_channel 144 | let send ch x = Event.sync (Event.send ch (Obj.magic x)) 145 | let receive ch = Obj.magic (Event.sync (Event.receive ch)) 146 | let reverse ch = ch 147 | end) 148 | 149 | module Syntax = struct 150 | let bind = (>>=) 151 | 152 | module Internal = struct 153 | let __return_raw v pre = pre, v 154 | let __bind_raw = fun m f pre -> match m pre with (mid,x) -> f x mid 155 | 156 | let __putval_raw = fun (_,set) v pre -> 157 | set pre v, () 158 | 159 | let __takeval_raw (get,set) pre = 160 | set pre Empty, get pre 161 | 162 | let __mkbindfun f = f 163 | let __dispose_env m pre = 164 | (>>=) (m pre) (fun (_,a) -> return (Empty, a)) 165 | end 166 | end 167 | -------------------------------------------------------------------------------- /lib/lsession.mli: -------------------------------------------------------------------------------- 1 | type 'a data = W of 'a 2 | type ('pre, 'post, 'a) lmonad 3 | type 'f lbind 4 | 5 | type ('a,'b,'ss,'tt) slot = ('ss -> 'a) * ('ss -> 'b -> 'tt) 6 | val _0 : ('a, 'b, ('a * 'ss), ('b * 'ss)) slot 7 | val _1 : ('a, 'b, ('s0 * ('a * 'ss)), ('s0 * ('b * 'ss))) slot 8 | val _2 : ('a, 'b, ('s0 * ('s1 * ('a * 'ss))), ('s0 * ('s1 * ('b * 'ss)))) slot 9 | val _3 : ('a, 'b, ('s0 * ('s1 * ('s2 * ('a * 'ss)))), ('s0 * ('s1 * ('s2 * ('b * 'ss))))) slot 10 | 11 | type empty 12 | type all_empty = empty * 'a as 'a 13 | 14 | val return : 'a -> ('pre, 'pre, 'a) lmonad 15 | val (>>=) : ('pre, 'mid, 'a) lmonad 16 | -> ('a -> ('mid, 'post, 'b) lmonad) lbind 17 | -> ('pre, 'post, 'b) lmonad 18 | val (>>) : ('pre, 'mid, unit) lmonad 19 | -> ('mid, 'post, 'b) lmonad 20 | -> ('pre, 'post, 'b) lmonad 21 | 22 | module type UnsafeChannel = sig 23 | type t 24 | val create : unit -> t 25 | val send : t -> 'a -> unit 26 | val receive : t -> 'a 27 | val reverse : t -> t 28 | end 29 | 30 | type req and resp 31 | type cli = req * resp and serv = resp * req 32 | 33 | module type S = sig 34 | type 'p channel 35 | val new_channel : unit -> 'p channel 36 | 37 | type ('p,'q) sess 38 | 39 | val accept : 'p channel -> ('pre, 'pre, ('p, serv) sess) lmonad 40 | 41 | val connect : 'p channel -> ('pre, 'pre, ('p, cli) sess) lmonad 42 | 43 | val close : (([`close], 'r1*'r2) sess, empty, 'pre, 'post) slot 44 | -> ('pre, 'post, unit) lmonad 45 | 46 | val send : 'v -> (([`msg of 'r1 * 'v * 'p], 'r1*'r2) sess, empty, 'pre, 'post) slot 47 | -> ('pre, 'post, ('p, 'r1*'r2) sess) lmonad 48 | 49 | val receive : (([`msg of 'r2 * 'v * 'p], 'r1*'r2) sess, empty, 'pre, 'post) slot 50 | -> ('pre, 'post, 'v data * ('p, 'r1*'r2) sess) lmonad 51 | 52 | val select : (('p,'r2*'r1) sess -> ([>] as 'br)) 53 | -> (([`branch of 'r1 * 'br],'r1*'r2) sess, empty, 'pre, 'post) slot 54 | -> ('pre, 'post, ('p,'r1*'r2) sess) lmonad 55 | 56 | val branch : (([`branch of 'r2 * [>] as 'br], 'r1*'r2) sess, empty, 'pre, 'post) slot 57 | -> ('pre, 'post, 'br) lmonad 58 | 59 | val deleg_send : (('pp, 'qq) sess, empty, 'mid, 'post) slot 60 | -> (([`deleg of 'r1 * ('pp, 'qq) sess * 'p], 'r1*'r2) sess, empty, 'pre, 'mid) slot 61 | -> ('pre, 'post, ('p, 'r1*'r2) sess) lmonad 62 | 63 | val deleg_recv : 64 | (([`deleg of 'r2 * ('pp, 'qq) sess * 'p], 'r1*'r2) sess, empty, 'pre, 'post) slot 65 | -> ('pre, 'post, ('pp,'qq) sess * ('p,'r1*'r2) sess) lmonad 66 | 67 | end 68 | 69 | module Make(U : UnsafeChannel) : S 70 | 71 | include S 72 | 73 | module Syntax : sig 74 | val bind : ('pre, 'mid, 'a) lmonad 75 | -> ('a -> ('mid, 'post, 'b) lmonad) lbind 76 | -> ('pre, 'post, 'b) lmonad 77 | 78 | module Internal : sig 79 | val __bind_raw : ('pre,'mid,'a) lmonad -> ('a -> ('mid,'post,'b) lmonad) -> ('pre,'post,'b) lmonad 80 | val __return_raw : 'a -> ('p,'p,'a) lmonad 81 | 82 | val __mkbindfun : ('a -> ('pre,'post,'b) lmonad) -> ('a -> ('pre, 'post, 'b) lmonad) lbind 83 | 84 | val __putval_raw : (empty,'a,'pre,'post) slot -> 'a -> ('pre,'post,unit) lmonad 85 | val __takeval_raw : ('a,empty,'pre,'post) slot -> ('pre,'post,'a) lmonad 86 | end 87 | end 88 | -------------------------------------------------------------------------------- /lib/monitor.ml: -------------------------------------------------------------------------------- 1 | module M = Mutex 2 | module C = Condition 3 | 4 | type 'a t = ('a * M.t * C.t) 5 | 6 | type 'a wait = WaitMore | Return of 'a 7 | 8 | let create v = (v, M.create (), C.create ()) 9 | 10 | let wait (cell,m,c) (func: 'a -> 'b wait) : 'b = 11 | Mutex.lock m; 12 | let rec loop () = 13 | begin try 14 | match func cell with 15 | | Return v -> v 16 | | WaitMore -> begin 17 | Condition.wait c m; 18 | loop () 19 | end 20 | with e -> 21 | Mutex.unlock m; 22 | raise e 23 | end 24 | in 25 | let v = loop () in 26 | Mutex.unlock m; 27 | v 28 | 29 | let signal (_,_,c) = Condition.signal c 30 | 31 | let lock (cell,m,_) (func: 'a -> 'b) : 'b = 32 | Mutex.lock m; 33 | begin try 34 | let v = func cell in 35 | Mutex.unlock m; 36 | v 37 | with e -> 38 | Mutex.unlock m; 39 | raise e 40 | end 41 | 42 | let try_lock (cell,m,_) (func: 'a -> 'b) (iffail:'b) : 'b = 43 | if Mutex.try_lock m then begin 44 | begin try 45 | let v = func cell in 46 | Mutex.unlock m; 47 | v 48 | with e -> 49 | Mutex.unlock m; 50 | raise e 51 | end 52 | end else iffail 53 | 54 | let get (cell,_,_) = cell 55 | -------------------------------------------------------------------------------- /lib/monitor.mli: -------------------------------------------------------------------------------- 1 | (** Monitor *) 2 | type 'a t 3 | type 'b wait = WaitMore | Return of 'b 4 | val create : 'a -> 'a t 5 | val signal : 'a t -> unit 6 | val wait : 'a t -> ('a -> 'b wait) -> 'b 7 | val lock : 'a t -> ('a -> 'b) -> 'b 8 | val try_lock : 'a t -> ('a -> 'b) -> 'b -> 'b 9 | val get : 'a t -> 'a 10 | -------------------------------------------------------------------------------- /lib/net.mldylib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 69d8d7ebdc07a1c95cb8d87d2ab59184) 3 | Dsession 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /lib/net.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 69d8d7ebdc07a1c95cb8d87d2ab59184) 3 | Dsession 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /lib/schannel.ml: -------------------------------------------------------------------------------- 1 | type 'a t = 'a Event.channel 2 | let create = Event.new_channel 3 | let send ch x = Event.sync (Event.send ch x) 4 | let receive ch = Event.sync (Event.receive ch) 5 | -------------------------------------------------------------------------------- /lib/schannel.mli: -------------------------------------------------------------------------------- 1 | type 'a t 2 | val create : unit -> 'a t 3 | val send : 'a t -> 'a -> unit 4 | val receive : 'a t -> 'a 5 | -------------------------------------------------------------------------------- /lib/session-ocaml.mldylib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: ea3e3c213e7806636db684613d022fa6) 3 | Session 4 | UnixAdapter 5 | Lsession 6 | Schannel 7 | Channel 8 | Monitor 9 | # OASIS_STOP 10 | -------------------------------------------------------------------------------- /lib/session-ocaml.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: ea3e3c213e7806636db684613d022fa6) 3 | Session 4 | UnixAdapter 5 | Lsession 6 | Schannel 7 | Channel 8 | Monitor 9 | # OASIS_STOP 10 | -------------------------------------------------------------------------------- /lib/session.ml: -------------------------------------------------------------------------------- 1 | (* slots and lenses *) 2 | type empty = Empty 3 | type all_empty = empty * 'a as 'a 4 | let rec all_empty = Empty, all_empty 5 | 6 | type ('a,'b,'pre,'post) slot = ('pre -> 'a) * ('pre -> 'b -> 'post) 7 | 8 | let s = (fun (a,_) -> a), (fun (_,ss) b -> (b,ss)) 9 | let _0 = (fun (a,_) -> a), (fun (_,ss) b -> (b,ss)) 10 | let _1 = (fun (_,(a,_)) -> a), (fun (s0,(_,ss)) b -> (s0,(b,ss))) 11 | let _2 = (fun (_,(_,(a,_))) -> a), (fun (s0,(s1,(_,ss))) b -> (s0,(s1,(b,ss)))) 12 | let _3 = (fun (_,(_,(_,(a,_)))) -> a), (fun (s0,(s1,(s2,(_,ss)))) b -> (s0,(s1,(s2,(b,ss))))) 13 | let _4 = (fun (_,(_,(_,(_,(a,_))))) -> a), (fun (s0,(s1,(s2,(s3,(_,ss))))) b -> (s0,(s1,(s2,(s3,(b,ss)))))) 14 | 15 | let _run_internal a f x = snd (f x a) 16 | let run f x = snd (f x all_empty) 17 | let run_ m = snd (m all_empty) 18 | 19 | (* sessions *) 20 | type ('pre,'post,'a) session = 'pre -> 'post * 'a 21 | 22 | let return x = fun pre -> pre, x 23 | let (>>=) m f = fun pre -> let mid,a = m pre in f a mid 24 | let (>>) m n = fun pre -> let mid,_ = m pre in n mid 25 | 26 | (* polarized session types *) 27 | type req = Req 28 | type resp = Resp 29 | 30 | type cli = req * resp 31 | type serv = resp * req 32 | 33 | type 'p wrap = 34 | Msg : ('v * 'p wrap Channel.t) -> [`msg of 'r * 'v * 'p] wrap 35 | | Branch : 'br -> [`branch of 'r * 'br] wrap 36 | | Chan : (('pp, 'rr) sess * 'p wrap Channel.t) -> [`deleg of 'r * ('pp, 'rr) sess * 'p] wrap 37 | and ('p, 'q) sess = 'p wrap Channel.t * 'q 38 | 39 | (* service channels *) 40 | type 'p channel = 'p wrap Channel.t Channel.t 41 | let new_channel = Channel.create 42 | 43 | let accept_ ch f x = 44 | let ch' = Channel.receive ch in 45 | let ch' = (ch',(Resp,Req)) in 46 | _run_internal (ch',all_empty) f x 47 | 48 | let connect_ ch f x = 49 | let ch' = Channel.create () in 50 | Channel.send ch ch'; 51 | let ch' = (ch',(Req,Resp)) in 52 | _run_internal (ch',all_empty) f x 53 | 54 | let close (get,set) = fun pre -> 55 | set pre Empty, () 56 | 57 | let send (get,set) v = fun pre -> 58 | let ch,q = get pre 59 | and ch' = Channel.create () in 60 | Channel.send ch (Msg(v,ch')); 61 | set pre (ch',q), () 62 | 63 | let recv (get,set) = fun pre -> 64 | let (ch,q) = get pre in 65 | let Msg(v,ch') = Channel.receive ch in 66 | set pre (ch',q), v 67 | 68 | let deleg_send (get0,set0) ~release:(get1,set1) = fun pre -> 69 | let ch0,q1 = get0 pre 70 | and ch0' = Channel.create () in 71 | let mid = set0 pre (ch0',q1) in 72 | let ch1,q2 = get1 mid in 73 | Channel.send ch0 (Chan((ch1,q2),ch0')); 74 | set1 mid Empty, () 75 | 76 | let deleg_recv (get0,set0) ~bindto:(get1,set1) = fun pre -> 77 | let ch0,q0 = get0 pre in 78 | let Chan((ch1',q1),ch0') = Channel.receive ch0 in 79 | let mid = set0 pre (ch0',q0) in 80 | set1 mid (ch1',q1), () 81 | 82 | let accept ch ~bindto:(_,set) = fun pre -> 83 | let ch' = Channel.receive ch in 84 | set pre (ch',(Resp,Req)), () 85 | 86 | let connect ch ~bindto:(_,set) = fun pre -> 87 | let ch' = Channel.create () in 88 | Channel.send ch ch'; 89 | set pre (ch',(Req,Resp)), () 90 | 91 | 92 | let inp : 'p 'r. 'p -> 'p wrap Channel.t = Obj.magic 93 | let out : 'p 'r. 'p wrap Channel.t -> 'p = Obj.magic 94 | 95 | let _branch : type br. 96 | (([`branch of 'r2 * br], 'r1*'r2) sess, empty, 'pre, 'mid) slot 97 | -> (br * ('r1*'r2) -> ('mid, 'post,'v) session) 98 | -> ('pre, 'post, 'v) session 99 | = fun (get0,set0) f pre -> 100 | let (ch,p) = get0 pre in 101 | let mid = set0 pre Empty in 102 | match Channel.receive ch with 103 | | Branch(br) -> f (br,p) mid 104 | 105 | let _set_sess : 106 | (empty, ('p,'r1*'r2) sess, 'pre, 'mid) slot 107 | -> 'p * ('r1*'r2) 108 | -> ('mid,'post,'v) session 109 | -> ('pre, 'post, 'v) session 110 | = fun (_,set1) (c,p) m ss -> 111 | let tt1 = set1 ss ((inp c), p) 112 | in m tt1 113 | 114 | 115 | let _select : type br p. 116 | (([`branch of 'r1 * br],'r1*'r2) sess, (p,'r1*'r2) sess, 'ss, 'tt) slot 117 | -> (p -> br) 118 | -> ('ss, 'tt, 'v) session = fun (get0,set0) f ss -> 119 | let ch,p = get0 ss in 120 | let k = Channel.create () in 121 | Channel.send ch (Branch(f (out k))); 122 | set0 ss (k,p), () 123 | 124 | let branch ~left:((get1,set1),f1) ~right:((get2,set2),f2) = fun pre -> 125 | let (ch,p) = get1 pre in 126 | match Channel.receive ch with 127 | | Branch(`left(ch')) -> f1 () (set1 pre (inp ch', p)) 128 | | Branch(`right(ch')) -> f2 () (set2 pre (inp ch', p)) 129 | 130 | let select_left s = _select s (fun x -> `left(x)) 131 | 132 | let select_right s = _select s (fun x -> `right(x)) 133 | 134 | type 'a parse_result = 135 | [`Partial of (string option -> 'a parse_result) 136 | |`Done of 'a * string 137 | |`Fail of string] 138 | 139 | module type Adapter = sig 140 | type raw_chan 141 | type 'p net = raw_chan -> (('p, serv) sess * all_empty, all_empty, unit) session 142 | val req : ('v -> string) -> 'p net -> [`msg of req * 'v * 'p] net 143 | val resp : (string -> 'v parse_result) -> 'p net -> [`msg of resp * 'v * 'p] net 144 | val sel : left:'p1 net -> right:'p2 net -> 145 | [`branch of req * [`left of 'p1|`right of 'p2]] net 146 | val bra : left:((string -> 'v1 parse_result) * 'p1 net) -> right:'p2 net -> 147 | [`branch of resp * [`left of [`msg of resp * 'v1 * 'p1] |`right of 'p2]] net 148 | val cls : [`close] net 149 | end 150 | 151 | module Syntax = struct 152 | let bind = (>>=) 153 | let _select = _select 154 | let _branch = _branch 155 | let _set_sess = _set_sess 156 | end 157 | -------------------------------------------------------------------------------- /lib/session.mli: -------------------------------------------------------------------------------- 1 | (* empty slots *) 2 | type empty 3 | type all_empty = empty * 'a as 'a 4 | 5 | (* lenses on slots *) 6 | type ('a,'b,'pre,'post) slot = ('pre -> 'a) * ('pre -> 'b -> 'post) 7 | 8 | val s : ('a, 'b, ('a * 'pre), ('b * 'pre)) slot 9 | val _0 : ('a, 'b, ('a * 'pre), ('b * 'pre)) slot 10 | val _1 : ('a, 'b, ('s0 * ('a * 'pre)), ('s0 * ('b * 'pre))) slot 11 | val _2 : ('a, 'b, ('s0 * ('s1 * ('a * 'pre))), ('s0 * ('s1 * ('b * 'pre)))) slot 12 | val _3 : ('a, 'b, ('s0 * ('s1 * ('s2 * ('a * 'pre)))), ('s0 * ('s1 * ('s2 * ('b * 'pre))))) slot 13 | 14 | (* parameterized sessions *) 15 | type ('x,'y,'a) session 16 | 17 | val return : 'a -> ('pre,'pre,'a) session 18 | val (>>=) : ('pre,'mid,'a) session -> ('a -> ('mid,'post,'b) session) -> ('pre,'post,'b) session 19 | val (>>) : ('pre,'mid,'a) session -> ('mid,'post,'b) session -> ('pre,'post,'b) session 20 | 21 | val run_ : (all_empty,all_empty,unit) session -> unit 22 | val run : ('a -> (all_empty,all_empty,'b) session) -> 'a -> 'b 23 | val _run_internal : 'a -> ('b -> ('a, 'a, 'c) session) -> 'b -> 'c 24 | 25 | (* channels *) 26 | type 'p channel 27 | 28 | val new_channel : unit -> 'p channel 29 | 30 | (* polarized session types *) 31 | type req and resp 32 | 33 | type cli = req * resp 34 | type serv = resp * req 35 | 36 | type ('p, 'q) sess 37 | 38 | 39 | val accept_ : 'p channel -> ('a -> (('p,serv) sess * all_empty, all_empty, 'b) session) -> 'a -> 'b 40 | val connect_ : 'p channel -> ('a -> (('p,cli) sess * all_empty, all_empty, 'b) session) -> 'a -> 'b 41 | 42 | val accept : 'p channel -> bindto:(empty, ('p,serv) sess, 'pre, 'post) slot -> ('pre, 'post, unit) session 43 | val connect : 'p channel -> bindto:(empty, ('p,cli) sess, 'pre, 'post) slot -> ('pre, 'post, unit) session 44 | 45 | val close : (([`close], 'r1*'r2) sess, empty, 'pre, 'post) slot -> ('pre, 'post, unit) session 46 | val send : (([`msg of 'r1 * 'v * 'p], 'r1*'r2) sess, ('p, 'r1*'r2) sess, 'pre, 'post) slot -> 'v -> ('pre, 'post, unit) session 47 | val recv : (([`msg of 'r2 * 'v * 'p], 'r1*'r2) sess, ('p, 'r1*'r2) sess, 'pre, 'post) slot -> ('pre, 'post, 'v) session 48 | 49 | val branch 50 | : left:(([`branch of 'r2 * [`left of 'p1 | `right of 'p2]], 'r1*'r2) sess, ('p1, 'r1*'r2) sess, 'pre, 'mid1) slot * (unit -> ('mid1, 'post, 'a) session) 51 | -> right:(([`branch of 'r2 * [`left of 'p1 | `right of 'p2]], 'r1*'r2) sess, ('p2, 'r1*'r2) sess, 'pre, 'mid2) slot * (unit -> ('mid2, 'post, 'a) session) 52 | -> ('pre, 'post, 'a) session 53 | 54 | val select_left 55 | : (([`branch of 'r1 * [>`left of 'p1]], 'r1*'r2) sess, 56 | ('p1, 'r1*'r2) sess, 'pre, 'post) slot 57 | -> ('pre, 'post, unit) session 58 | 59 | val select_right 60 | : (([`branch of 'r1 * [>`right of 'p2]], 'r1*'r2) sess, 61 | ('p2, 'r1*'r2) sess, 'pre, 'post) slot 62 | -> ('pre, 'post, unit) session 63 | 64 | val _select 65 | : (([`branch of 'r1 * 'br],'r1*'r2) sess, ('p,'r1*'r2) sess, 'pre, 'post) slot 66 | -> ('p -> ([>] as 'br)) 67 | -> ('pre, 'post, unit) session 68 | 69 | val _branch 70 | : (([`branch of 'r2 * 'br], 'r1*'r2) sess, empty, 'pre, 'mid) slot 71 | -> ('br * ('r1*'r2) -> ('mid, 'post,'v) session) 72 | -> ('pre, 'post, 'v) session 73 | 74 | val _set_sess 75 | : (empty, ('p,'r1*'r2) sess, 'pre, 'mid) slot 76 | -> 'p * ('r1*'r2) 77 | -> ('mid, 'post, 'v) session 78 | -> ('pre, 'post, 'v) session 79 | 80 | val deleg_send 81 | : (([`deleg of 'r1 * ('pp, 'qq) sess * 'p], 'r1*'r2) sess, ('p, 'r1*'r2) sess, 'pre, 'mid) slot 82 | -> release:(('pp, 'qq) sess, empty, 'mid, 'post) slot 83 | -> ('pre, 'post, unit) session 84 | 85 | val deleg_recv 86 | : (([`deleg of 'r2 * ('pp, 'qq) sess * 'p], 'r1*'r2) sess, ('p, 'r1*'r2) sess, 'pre, 'mid) slot 87 | -> bindto:(empty, ('pp, 'qq) sess, 'mid, 'post) slot 88 | -> ('pre, 'post, unit) session 89 | 90 | type 'a parse_result = 91 | [`Partial of (string option -> 'a parse_result) (* `Partial f. invariant: (f None) may not return Partial *) 92 | |`Done of 'a * string 93 | |`Fail of string] 94 | 95 | module type Adapter = sig 96 | type raw_chan 97 | type 'p net = raw_chan -> (('p, serv) sess * all_empty, all_empty, unit) session 98 | val req : ('v -> string) -> 'p net -> [`msg of req * 'v * 'p] net 99 | val resp : (string -> 'v parse_result) -> 'p net -> [`msg of resp * 'v * 'p] net 100 | val sel : left:'p1 net -> right:'p2 net -> 101 | [`branch of req * [`left of 'p1|`right of 'p2]] net 102 | val bra : left:((string -> 'v1 parse_result) * 'p1 net) -> right:'p2 net -> 103 | [`branch of resp * [`left of [`msg of resp * 'v1 * 'p1] |`right of 'p2]] net 104 | val cls : [`close] net 105 | end 106 | 107 | module Syntax : sig 108 | val bind : ('x,'y,'a) session -> ('a -> ('y, 'z, 'b) session) -> ('x,'z,'b) session 109 | val _select 110 | : (([`branch of 'r1 * 'br],'r1*'r2) sess, ('p,'r1*'r2) sess, 'pre, 'post) slot 111 | -> ('p -> ([>] as 'br)) 112 | -> ('pre, 'post, unit) session 113 | 114 | val _branch 115 | : (([`branch of 'r2 * 'br], 'r1*'r2) sess, empty, 'pre, 'mid) slot 116 | -> ('br * ('r1*'r2) -> ('mid, 'post,'v) session) 117 | -> ('pre, 'post, 'v) session 118 | 119 | val _set_sess 120 | : (empty, ('p,'r1*'r2) sess, 'pre, 'mid) slot 121 | -> 'p * ('r1*'r2) 122 | -> ('mid, 'post, 'v) session 123 | -> ('pre, 'post, 'v) session 124 | end 125 | -------------------------------------------------------------------------------- /lib/unixAdapter.ml: -------------------------------------------------------------------------------- 1 | open Session 2 | 3 | let bufsize = 4096 4 | 5 | type raw_chan = {in_ch:in_channel; in_buf:string; out_ch:out_channel} 6 | type 'p net = raw_chan -> (('p, serv) sess * all_empty, all_empty, unit) session 7 | 8 | let consume (read:string->'v parse_result) {in_ch;in_buf} = 9 | let consume_buf : string -> 'v parse_result = function 10 | | "" -> `Partial(function Some(x) -> read x | None -> assert false (*FIXME: EOF*)) 11 | | buf -> read buf 12 | in 13 | let buf = Bytes.create bufsize in 14 | let rec read_loop : 'v parse_result -> 'v option * string = function 15 | | `Done(v,rest) -> Some(v),rest 16 | | `Fail(rest) -> None,rest 17 | | `Partial read -> 18 | let len_read = input in_ch buf 0 bufsize in 19 | if len_read = 0 then 20 | read_loop (read None) 21 | else 22 | read_loop (read @@ Some(Bytes.sub_string buf 0 len_read)) 23 | in 24 | read_loop (consume_buf in_buf) 25 | 26 | let req : 'v 'p . ('v -> string) -> 'p net -> [`msg of req * 'v * 'p] net 27 | = fun print cont ({out_ch} as ch) -> 28 | recv _0 >>= fun v -> 29 | (output_string out_ch (print v); flush out_ch; cont ch) 30 | 31 | let resp 32 | = fun read cont ({in_buf} as ch) -> 33 | let v, in_buf = consume read ch in 34 | let ch = {ch with in_buf} in 35 | match v with 36 | | None -> assert false (*FIXME:EOF*) 37 | | Some(v) -> 38 | send _0 v >> 39 | cont ch 40 | 41 | let sel : 'p1 'p2. left:'p1 net -> right:'p2 net -> 42 | [`branch of req * [`left of 'p1|`right of 'p2]] net 43 | = fun ~left ~right ch -> 44 | branch (_0, fun () -> left ch) 45 | (_0, fun () -> right ch) 46 | 47 | let bra 48 | = fun ~left:(read,left) ~right ({in_ch;in_buf} as ch) -> 49 | let v, in_buf = consume read ch in 50 | let ch = {ch with in_buf} in 51 | match v with 52 | | Some v -> select_left _0 >> send _0 v >> left ch 53 | | None -> select_right _0 >> right ch 54 | 55 | let cls : [`close] net 56 | = fun {in_ch;out_ch;in_buf} -> 57 | close_in_noerr in_ch; 58 | close_out_noerr out_ch; 59 | (* assert in_buf="" *) 60 | close _0 61 | 62 | module TcpSession = struct 63 | let new_channel adapter hostport = 64 | let connect () = 65 | let host,port = 66 | match Str.split (Str.regexp ":") hostport with 67 | | [host] -> host, "25" 68 | | host::port::_ -> host, port 69 | 70 | | [] -> assert false 71 | in 72 | match Unix.getaddrinfo host port [] with 73 | | [] -> failwith ("Host not found " ^ host) 74 | | h::t -> Unix.open_connection h.Unix.ai_addr 75 | in 76 | let in_ch,out_ch = connect () in 77 | let ch = Session.new_channel () in 78 | ignore @@ Thread.create (fun () -> run_ (accept ch ~bindto:_0 >> adapter {in_ch;out_ch;in_buf=""})) (); 79 | ch 80 | end 81 | -------------------------------------------------------------------------------- /lib/unixAdapter.mli: -------------------------------------------------------------------------------- 1 | type raw_chan = {in_ch:in_channel; in_buf:string; out_ch:out_channel} 2 | include Session.Adapter with type raw_chan := raw_chan 3 | 4 | module TcpSession : sig 5 | val new_channel : 'p net -> string -> 'p Session.channel 6 | end 7 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: 8f0c958ed55f8e58c9f7529d4666c5d5) *) 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 = 883 | [ 884 | ("session-ocaml", ["lib"], []); 885 | ("ppx", ["ppx"], []); 886 | ("net", ["net"], []) 887 | ]; 888 | lib_c = []; 889 | flags = 890 | [ 891 | (["oasis_library_session_ocaml_byte"; "ocaml"; "link"; "byte"], 892 | [(OASISExpr.EBool true, S [A "-rectypes"])]); 893 | (["oasis_library_session_ocaml_native"; "ocaml"; "link"; "native"], 894 | [(OASISExpr.EBool true, S [A "-rectypes"])]); 895 | (["oasis_library_session_ocaml_byte"; "ocaml"; "ocamldep"; "byte"], 896 | [(OASISExpr.EBool true, S [A "-rectypes"])]); 897 | ([ 898 | "oasis_library_session_ocaml_native"; 899 | "ocaml"; 900 | "ocamldep"; 901 | "native" 902 | ], 903 | [(OASISExpr.EBool true, S [A "-rectypes"])]); 904 | (["oasis_library_session_ocaml_byte"; "ocaml"; "compile"; "byte"], 905 | [(OASISExpr.EBool true, S [A "-rectypes"])]); 906 | ([ 907 | "oasis_library_session_ocaml_native"; 908 | "ocaml"; 909 | "compile"; 910 | "native" 911 | ], 912 | [(OASISExpr.EBool true, S [A "-rectypes"])]); 913 | (["oasis_library_net_byte"; "ocaml"; "link"; "byte"], 914 | [(OASISExpr.EBool true, S [A "-I"; A "+threads"])]); 915 | (["oasis_library_net_native"; "ocaml"; "link"; "native"], 916 | [(OASISExpr.EBool true, S [A "-I"; A "+threads"])]); 917 | (["oasis_library_net_byte"; "ocaml"; "ocamldep"; "byte"], 918 | [(OASISExpr.EBool true, S [A "-I"; A "+threads"])]); 919 | (["oasis_library_net_native"; "ocaml"; "ocamldep"; "native"], 920 | [(OASISExpr.EBool true, S [A "-I"; A "+threads"])]); 921 | (["oasis_library_net_byte"; "ocaml"; "compile"; "byte"], 922 | [(OASISExpr.EBool true, S [A "-I"; A "+threads"])]); 923 | (["oasis_library_net_native"; "ocaml"; "compile"; "native"], 924 | [(OASISExpr.EBool true, S [A "-I"; A "+threads"])]) 925 | ]; 926 | includes = [] 927 | } 928 | ;; 929 | 930 | let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} 931 | 932 | let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; 933 | 934 | # 935 "myocamlbuild.ml" 935 | (* OASIS_STOP *) 936 | Ocamlbuild_plugin.dispatch dispatch_default;; 937 | -------------------------------------------------------------------------------- /net/dsession.ml: -------------------------------------------------------------------------------- 1 | type 'a lin = L of 'a 2 | type 'a data = W of 'a 3 | type ('pre, 'post, 'a) lmonad = 'pre -> 'post * 'a 4 | type 'f lbind = 'f 5 | 6 | let unlin (L v) = v 7 | 8 | type ('a,'b,'ss,'tt) slot = ('ss -> 'a) * ('ss -> 'b -> 'tt) 9 | 10 | let _0 = (fun (a,_) -> a), (fun (_,ss) b -> (b,ss)) 11 | let _1 = (fun (_,(a,_)) -> a), (fun (s0,(_,ss)) b -> (s0,(b,ss))) 12 | let _2 = (fun (_,(_,(a,_))) -> a), (fun (s0,(s1,(_,ss))) b -> (s0,(s1,(b,ss)))) 13 | let _3 = (fun (_,(_,(_,(a,_)))) -> a), (fun (s0,(s1,(s2,(_,ss)))) b -> (s0,(s1,(s2,(b,ss))))) 14 | 15 | type empty = Empty 16 | type empty_three = empty * (empty * (empty * empty)) 17 | type empty_four = empty * empty_three 18 | 19 | let return a pre = pre, a 20 | let (>>=) f g pre = let mid, la = f pre in g la mid 21 | let (>>) f g pre = let mid, _ = f pre in g mid 22 | 23 | let run f = snd @@ f () (Empty, (Empty, (Empty, (Empty, Empty)))) 24 | 25 | type req and resp 26 | type cli = req * resp and serv = resp * req 27 | 28 | module type S = sig 29 | type ('p, 'q, 'c) sess 30 | type ('p, 'q, 'c) dsess = ('p, 'q, 'c) sess lin 31 | type shmem 32 | 33 | val _mksess : 'c -> ('p, 'q, 'c) dsess 34 | 35 | (* connectors *) 36 | type ('p,'c) connector 37 | type ('p,'c) acceptor 38 | 39 | val create_connector : (unit -> 'c) -> ('p,'c) connector 40 | val create_acceptor : (unit -> 'c) -> ('p,'c) acceptor 41 | 42 | module Sender : sig 43 | type ('c,'v) t = ('c -> 'v -> unit, [%imp Senders]) Ppx_implicits.t 44 | end 45 | module Receiver : sig 46 | type ('c,'v) t = ('c -> 'v, [%imp Receivers]) Ppx_implicits.t 47 | end 48 | module Closer : sig 49 | type 'c t = ('c -> unit, [%imp Closers]) Ppx_implicits.t 50 | end 51 | 52 | (* connections on shared memory *) 53 | val new_shmem_channel : unit -> ('p,shmem) connector * ('p,shmem) acceptor 54 | module Senders : sig 55 | val _f : shmem -> 'v -> unit 56 | end 57 | module Receivers : sig 58 | val _f : shmem -> 'v 59 | end 60 | module Closers : sig 61 | val _f : shmem -> unit 62 | end 63 | 64 | val accept : ('p,'c) acceptor -> ('pre, 'pre, ('p, serv, 'c) dsess) lmonad 65 | 66 | val connect : ('p,'c) connector -> ('pre, 'pre, ('p, cli, 'c) dsess) lmonad 67 | 68 | val close : 69 | ?_closer:'c Closer.t -> 70 | (([`close], 'r1*'r2, 'c) dsess, empty, 'pre, 'post) slot 71 | -> ('pre, 'post, unit) lmonad 72 | 73 | val send : 74 | ?_sender:('c, 'v) Sender.t 75 | -> 'v -> (([`msg of 'r1 * 'v * 'p], 'r1*'r2, 'c) dsess, empty, 'pre, 'post) slot 76 | -> ('pre, 'post, ('p, 'r1*'r2, 'c) dsess) lmonad 77 | 78 | val receive : 79 | ?_receiver:('c, 'v) Receiver.t 80 | -> (([`msg of 'r2 * 'v * 'p], 'r1*'r2, 'c) dsess, empty, 'pre, 'post) slot 81 | -> ('pre, 'post, 'v data * ('p, 'r1*'r2, 'c) dsess) lmonad 82 | 83 | val select : 84 | ?_sender:('c, [>] as 'br) Sender.t 85 | -> (('p,'r2*'r1, 'c) dsess -> 'br) 86 | -> (([`branch of 'r1 * 'br],'r1*'r2, 'c) dsess, empty, 'pre, 'post) slot 87 | -> ('pre, 'post, ('p,'r1*'r2, 'c) dsess) lmonad 88 | 89 | val branch : 90 | ?_receiver:('c, [>] as 'br) Receiver.t 91 | -> (([`branch of 'r2 * 'br], 'r1*'r2, 'c) dsess, empty, 'pre, 'post) slot 92 | -> ('pre, 'post, 'br) lmonad 93 | 94 | val deleg_send : 95 | ?_sender:('c , ('pp,'qq,'cc) sess) Sender.t 96 | -> (('pp, 'qq, 'cc) dsess, empty, 'mid, 'post) slot 97 | -> (([`deleg of 'r1 * ('pp, 'qq, 'cc) dsess * 'p], 'r1*'r2, 'c) dsess, empty, 'pre, 'mid) slot 98 | -> ('pre, 'post, ('p, 'r1*'r2, 'c) dsess) lmonad 99 | 100 | val deleg_recv : 101 | ?_receiver:('c, ('pp, 'qq, 'cc) sess) Receiver.t 102 | -> (([`deleg of 'r2 * ('pp, 'qq, 'cc) dsess * 'p], 'r1*'r2, 'c) dsess, empty, 'pre, 'post) slot 103 | -> ('pre, 'post, ('pp,'qq,'cc) dsess * ('p,'r1*'r2,'c) dsess) lmonad 104 | 105 | end 106 | 107 | module Schannel = struct 108 | type 'a t = 'a Event.channel 109 | let create = Event.new_channel 110 | let send ch x = Event.sync (Event.send ch x) 111 | let receive ch = Event.sync (Event.receive ch) 112 | end 113 | 114 | module Make(U : sig 115 | type t 116 | val create : unit -> t 117 | val send : t -> 'a -> unit 118 | val receive : t -> 'a 119 | val reverse : t -> t 120 | end) : S = struct 121 | type ('p, 'q, 'c) sess = 'c 122 | type 'p channel = U.t Schannel.t 123 | type ('p, 'q, 'c) dsess = ('p, 'q, 'c) sess lin 124 | type shmem = U.t 125 | 126 | let _mksess c = L c 127 | 128 | let new_shmem_channel () = 129 | let ch = Schannel.create () in 130 | (fun () -> let raw = U.create () in 131 | Schannel.send ch (U.reverse raw); 132 | raw), 133 | (fun () -> Schannel.receive ch) 134 | 135 | type ('p,'c) connector = unit -> 'c 136 | type ('p,'c) acceptor = unit -> 'c 137 | 138 | let create_connector f = f 139 | let create_acceptor f = f 140 | 141 | module Sender = struct 142 | type ('c,'v) t = ('c -> 'v -> unit, [%imp Senders]) Ppx_implicits.t 143 | let unpack : ('c,'v) t -> 'c -> 'v -> unit = fun d -> Ppx_implicits.imp ~d 144 | end 145 | module Receiver = struct 146 | type ('c,'v) t = ('c -> 'v, [%imp Receivers]) Ppx_implicits.t 147 | let unpack : ('c,'v) t -> 'c -> 'v = fun d -> Ppx_implicits.imp ~d 148 | end 149 | module Closer = struct 150 | type 'c t = ('c -> unit, [%imp Closers]) Ppx_implicits.t 151 | let unpack : 'c t -> 'c -> unit = fun d -> Ppx_implicits.imp ~d 152 | end 153 | module Senders = struct 154 | let _f = U.send 155 | end 156 | module Receivers = struct 157 | let _f = U.receive 158 | end 159 | module Closers = struct 160 | let _f _ = () 161 | end 162 | 163 | let new_channel = Schannel.create 164 | 165 | let accept : 'p 'c 'pre. ('p,'c) acceptor -> ('pre, 'pre, ('p, serv, 'c) dsess) lmonad = 166 | fun acc pre -> 167 | let s = acc () in 168 | pre, L s 169 | 170 | let connect : 'p 'c 'pre. ('p,'c) connector -> ('pre, 'pre, ('p, cli, 'c) dsess) lmonad = 171 | fun conn pre -> 172 | let s = conn () in 173 | pre, L s 174 | 175 | let instance = function 176 | Some i -> i 177 | | None -> failwith "impossible: no instance" 178 | 179 | let close : 'pre 'r1 'r2 'c 'post. 180 | ?_closer:'c Closer.t 181 | -> (([`close], 'r1*'r2, 'c) dsess, empty, 'pre, 'post) slot 182 | -> ('pre, 'post, unit) lmonad = 183 | fun ?_closer (get,set) pre -> 184 | Closer.unpack (instance _closer) (unlin @@ get pre); 185 | set pre Empty, () 186 | 187 | let send : 'v 'r1 'p 'r2 'c 'pre 'post. 188 | ?_sender:('c,'v) Sender.t 189 | -> 'v -> (([`msg of 'r1 * 'v * 'p], 'r1*'r2, 'c) dsess, empty, 'pre, 'post) slot 190 | -> ('pre, 'post, ('p, 'r1*'r2, 'c) dsess) lmonad = 191 | fun ?_sender v (get,set) pre -> 192 | let s = unlin @@ get pre in 193 | Sender.unpack (instance _sender) s v; 194 | set pre Empty, L s 195 | 196 | let receive : 'r2 'v 'p 'r1 'c 'pre 'post. 197 | ?_receiver:('c,'v) Receiver.t 198 | -> (([`msg of 'r2 * 'v * 'p], 'r1*'r2, 'c) dsess, empty, 'pre, 'post) slot 199 | -> ('pre, 'post, 'v data * ('p, 'r1*'r2, 'c) dsess) lmonad = 200 | fun ?_receiver (get,set) pre -> 201 | let s = unlin @@ get pre in 202 | set pre Empty, (W (Receiver.unpack (instance _receiver) s), L s) 203 | 204 | let select : 'p 'r2 'r1 'c 'pre 'post. 205 | ?_sender:('c, [>] as 'br) Sender.t 206 | -> (('p,'r2*'r1,'c) dsess -> 'br) 207 | -> (([`branch of 'r1 * 'br],'r1*'r2,'c) dsess, empty, 'pre, 'post) slot 208 | -> ('pre, 'post, ('p,'r1*'r2,'c) dsess) lmonad = 209 | fun ?_sender f (get,set) pre -> 210 | let s = unlin @@ get pre in 211 | Sender.unpack (instance _sender) s (f (L (Obj.magic ()))); 212 | set pre Empty, L s 213 | 214 | let branch : 'r2 'r1 'c 'pre 'post. 215 | ?_receiver:('c,[>] as 'br) Receiver.t 216 | -> (([`branch of 'r2 * 'br], 'r1*'r2, 'c) dsess, empty, 'pre, 'post) slot 217 | -> ('pre, 'post, 'br) lmonad = 218 | fun ?_receiver (get,set) pre -> 219 | let s = unlin @@ get pre in 220 | set pre Empty, (Receiver.unpack (instance _receiver) s) 221 | 222 | let deleg_send : 'pp 'qq 'cc 'mid 'post 'r1 'r2 'c 'pre. 223 | ?_sender:('c, ('pp, 'qq, 'cc) sess) Sender.t 224 | -> (('pp, 'qq, 'cc) dsess, empty, 'mid, 'post) slot 225 | -> (([`deleg of 'r1 * ('pp, 'qq, 'cc) dsess * 'p], 'r1*'r2, 'c) dsess, empty, 'pre, 'mid) slot 226 | -> ('pre, 'post, ('p, 'r1*'r2, 'c) dsess) lmonad = 227 | fun ?_sender (get1,set1) (get2,set2) pre -> 228 | let s = unlin @@ get2 pre in 229 | let mid = set2 pre Empty in 230 | let t = unlin @@ get1 mid in 231 | Sender.unpack (instance _sender) s t; 232 | set1 mid Empty, L s 233 | 234 | let deleg_recv : 'r2 'p 'r1 'c 'pre 'post 'pp 'qq 'cc. 235 | ?_receiver:('c, ('pp, 'qq, 'cc) sess) Receiver.t 236 | -> (([`deleg of 'r2 * ('pp, 'qq, 'cc) dsess * 'p], 'r1*'r2, 'c) dsess, empty, 'pre, 'post) slot 237 | -> ('pre, 'post, ('pp,'qq,'cc) dsess * ('p,'r1*'r2,'c) dsess) lmonad = 238 | fun ?_receiver (get,set) pre -> 239 | let s = unlin @@ get pre in 240 | let t = Receiver.unpack (instance _receiver) s in 241 | set pre Empty, (L t, L s) 242 | 243 | end 244 | 245 | include Make(struct 246 | type t = unit Event.channel 247 | let create = Event.new_channel 248 | let send ch x = Event.sync (Event.send ch (Obj.magic x)) 249 | let receive ch = Obj.magic (Event.sync (Event.receive ch)) 250 | let reverse ch = ch 251 | end) 252 | 253 | module Syntax = struct 254 | let bind = (>>=) 255 | 256 | module Internal = struct 257 | let __return_raw v pre = pre, v 258 | let __bind_raw = fun m f pre -> match m pre with (mid,x) -> f x mid 259 | 260 | let __putval_raw = fun (_,set) v pre -> 261 | set pre (L v), () 262 | 263 | let __takeval_raw (get,set) pre = 264 | set pre Empty, get pre 265 | 266 | let __mkbindfun f = f 267 | let __run m pre = (>>=) (m pre) (fun (_,L a) -> a) 268 | let __dispose_env m pre = 269 | (>>=) (m pre) (fun (_,a) -> return (Empty, a)) 270 | end 271 | end 272 | 273 | 274 | module Tcp = struct 275 | type stream = {in_:in_channel; out:out_channel} 276 | 277 | let make (fi, fo) = {in_=Unix.in_channel_of_descr fi; out=Unix.out_channel_of_descr fo} 278 | 279 | let connector ~host ~port : ('p, stream) connector = 280 | create_connector @@ 281 | fun () -> 282 | match Unix.getaddrinfo host (string_of_int port) [] with 283 | | [] -> failwith ("Host not found " ^ host) 284 | | h::_ -> 285 | let ic,oc = Unix.open_connection h.Unix.ai_addr in 286 | {in_=ic; out=oc} 287 | 288 | let new_domain_channel () = 289 | let path = Filename.temp_file "sock" "sock" in 290 | Unix.unlink path; 291 | let sock_listen = Unix.(socket PF_UNIX SOCK_STREAM 0) in 292 | Unix.(bind sock_listen (ADDR_UNIX path)); 293 | Unix.listen sock_listen 0; 294 | create_connector (fun () -> 295 | let sock_cli = Unix.(socket PF_UNIX SOCK_STREAM 0) in 296 | Unix.(connect sock_cli (ADDR_UNIX path)); 297 | make (sock_cli, sock_cli)), 298 | create_acceptor (fun () -> 299 | let sock_serv, _ = Unix.(accept sock_listen) in 300 | make (sock_serv, sock_serv)) 301 | 302 | let fork : 'p 'v. (('p, serv, stream) dsess * (empty * (empty * (empty * empty))), empty_four, unit lin) lmonad 303 | -> (('p, cli, stream) dsess * (empty * (empty * (empty * empty))), empty, 'v lin) lmonad 304 | -> 'v = fun ms mc -> 305 | let c_in, s_out = Unix.pipe () in 306 | let s_in, c_out = Unix.pipe () in 307 | if Unix.fork () = 0 then begin 308 | let ch = _mksess @@ make (c_in, c_out) in 309 | unlin @@ snd @@ mc (ch,(Empty,(Empty,(Empty,Empty)))) 310 | end 311 | else begin 312 | let ch = _mksess @@ make (s_in, s_out) in 313 | ignore (ms (ch,(Empty,(Empty,(Empty,Empty))))); 314 | exit 0 315 | end 316 | 317 | module Closers = struct 318 | let _f {in_;out} = close_in in_ 319 | end 320 | end 321 | -------------------------------------------------------------------------------- /net/dsession.mli: -------------------------------------------------------------------------------- 1 | type 'a lin = L of 'a 2 | type 'a data = W of 'a 3 | type ('pre, 'post, 'a) lmonad 4 | type 'f lbind 5 | 6 | type ('a,'b,'ss,'tt) slot = ('ss -> 'a) * ('ss -> 'b -> 'tt) 7 | val _0 : ('a, 'b, ('a * 'ss), ('b * 'ss)) slot 8 | val _1 : ('a, 'b, ('s0 * ('a * 'ss)), ('s0 * ('b * 'ss))) slot 9 | val _2 : ('a, 'b, ('s0 * ('s1 * ('a * 'ss))), ('s0 * ('s1 * ('b * 'ss)))) slot 10 | val _3 : ('a, 'b, ('s0 * ('s1 * ('s2 * ('a * 'ss)))), ('s0 * ('s1 * ('s2 * ('b * 'ss))))) slot 11 | 12 | type empty 13 | type empty_three = empty * (empty * (empty * empty)) 14 | type empty_four = empty * empty_three 15 | 16 | val return : 'a -> ('pre, 'pre, 'a) lmonad 17 | val (>>=) : ('pre, 'mid, 'a) lmonad 18 | -> ('a -> ('mid, 'post, 'b) lmonad) lbind 19 | -> ('pre, 'post, 'b) lmonad 20 | val (>>) : ('pre, 'mid, unit) lmonad 21 | -> ('mid, 'post, 'b) lmonad 22 | -> ('pre, 'post, 'b) lmonad 23 | 24 | val run : (unit -> (empty_four, empty_four, unit) lmonad) -> unit 25 | 26 | type req and resp 27 | type cli = req * resp and serv = resp * req 28 | 29 | module type S = sig 30 | type ('p, 'q, 'c) sess 31 | type ('p, 'q, 'c) dsess = ('p, 'q, 'c) sess lin 32 | type shmem 33 | 34 | val _mksess : 'c -> ('p, 'q, 'c) dsess 35 | 36 | (* connectors *) 37 | type ('p,'c) connector 38 | type ('p,'c) acceptor 39 | 40 | val create_connector : (unit -> 'c) -> ('p,'c) connector 41 | val create_acceptor : (unit -> 'c) -> ('p,'c) acceptor 42 | 43 | module Sender : sig 44 | type ('c,'v) t = ('c -> 'v -> unit, [%imp Senders]) Ppx_implicits.t 45 | end 46 | module Receiver : sig 47 | type ('c,'v) t = ('c -> 'v, [%imp Receivers]) Ppx_implicits.t 48 | end 49 | module Closer : sig 50 | type 'c t = ('c -> unit, [%imp Closers]) Ppx_implicits.t 51 | end 52 | 53 | (* connections on shared memory *) 54 | val new_shmem_channel : unit -> ('p,shmem) connector * ('p,shmem) acceptor 55 | module Senders : sig 56 | val _f : shmem -> 'v -> unit 57 | end 58 | module Receivers : sig 59 | val _f : shmem -> 'v 60 | end 61 | module Closers : sig 62 | val _f : shmem -> unit 63 | end 64 | 65 | val accept : ('p,'c) acceptor -> ('pre, 'pre, ('p, serv, 'c) dsess) lmonad 66 | 67 | val connect : ('p,'c) connector -> ('pre, 'pre, ('p, cli, 'c) dsess) lmonad 68 | 69 | val close : 70 | ?_closer:'c Closer.t -> 71 | (([`close], 'r1*'r2, 'c) dsess, empty, 'pre, 'post) slot 72 | -> ('pre, 'post, unit) lmonad 73 | 74 | val send : 75 | ?_sender:('c, 'v) Sender.t 76 | -> 'v -> (([`msg of 'r1 * 'v * 'p], 'r1*'r2, 'c) dsess, empty, 'pre, 'post) slot 77 | -> ('pre, 'post, ('p, 'r1*'r2, 'c) dsess) lmonad 78 | 79 | val receive : 80 | ?_receiver:('c, 'v) Receiver.t 81 | -> (([`msg of 'r2 * 'v * 'p], 'r1*'r2, 'c) dsess, empty, 'pre, 'post) slot 82 | -> ('pre, 'post, 'v data * ('p, 'r1*'r2, 'c) dsess) lmonad 83 | 84 | val select : 85 | ?_sender:('c, [>] as 'br) Sender.t 86 | -> (('p,'r2*'r1, 'c) dsess -> 'br) 87 | -> (([`branch of 'r1 * 'br],'r1*'r2, 'c) dsess, empty, 'pre, 'post) slot 88 | -> ('pre, 'post, ('p,'r1*'r2, 'c) dsess) lmonad 89 | 90 | val branch : 91 | ?_receiver:('c, [>] as 'br) Receiver.t 92 | -> (([`branch of 'r2 * 'br], 'r1*'r2, 'c) dsess, empty, 'pre, 'post) slot 93 | -> ('pre, 'post, 'br) lmonad 94 | 95 | val deleg_send : 96 | ?_sender:('c , ('pp,'qq,'cc) sess) Sender.t 97 | -> (('pp, 'qq, 'cc) dsess, empty, 'mid, 'post) slot 98 | -> (([`deleg of 'r1 * ('pp, 'qq, 'cc) dsess * 'p], 'r1*'r2, 'c) dsess, empty, 'pre, 'mid) slot 99 | -> ('pre, 'post, ('p, 'r1*'r2, 'c) dsess) lmonad 100 | 101 | val deleg_recv : 102 | ?_receiver:('c, ('pp, 'qq, 'cc) sess) Receiver.t 103 | -> (([`deleg of 'r2 * ('pp, 'qq, 'cc) dsess * 'p], 'r1*'r2, 'c) dsess, empty, 'pre, 'post) slot 104 | -> ('pre, 'post, ('pp,'qq,'cc) dsess * ('p,'r1*'r2,'c) dsess) lmonad 105 | 106 | end 107 | 108 | module Make(U : sig 109 | type t 110 | val create : unit -> t 111 | val send : t -> 'a -> unit 112 | val receive : t -> 'a 113 | val reverse : t -> t 114 | end 115 | ) : S 116 | include S 117 | 118 | module Syntax : sig 119 | val bind : ('pre, 'mid, 'a) lmonad 120 | -> ('a -> ('mid, 'post, 'b) lmonad) lbind 121 | -> ('pre, 'post, 'b) lmonad 122 | 123 | module Internal : sig 124 | val __bind_raw : ('pre,'mid,'a) lmonad -> ('a -> ('mid,'post,'b) lmonad) -> ('pre,'post,'b) lmonad 125 | val __return_raw : 'a -> ('p,'p,'a) lmonad 126 | 127 | val __mkbindfun : ('a -> ('pre,'post,'b) lmonad) -> ('a -> ('pre, 'post, 'b) lmonad) lbind 128 | 129 | val __putval_raw : (empty,'a lin,'pre,'post) slot -> 'a -> ('pre,'post,unit) lmonad 130 | val __takeval_raw : ('a,empty,'pre,'post) slot -> ('pre,'post,'a) lmonad 131 | end 132 | end 133 | 134 | module Tcp : sig 135 | type stream = {in_:in_channel; out:out_channel} 136 | val connector : host:string -> port:int -> ('p, stream) connector 137 | val new_domain_channel : unit -> ('p, stream) connector * ('p, stream) acceptor 138 | val fork : (('p, serv, stream) dsess * (empty * (empty * (empty * empty))), empty_four, unit lin) lmonad 139 | -> (('p, cli, stream) dsess * (empty * (empty * (empty * empty))), empty, 'v lin) lmonad 140 | -> 'v 141 | 142 | module Closers : sig 143 | val _f : stream -> unit 144 | end 145 | end 146 | -------------------------------------------------------------------------------- /net/net.mldylib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 69d8d7ebdc07a1c95cb8d87d2ab59184) 3 | Dsession 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /net/net.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 69d8d7ebdc07a1c95cb8d87d2ab59184) 3 | Dsession 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /ppx/ppx.mldylib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 15bcee367d95d0652fdb9133bcacd682) 3 | Ppx_session 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /ppx/ppx.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 15bcee367d95d0652fdb9133bcacd682) 3 | Ppx_session 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /ppx/ppx_lens.ml: -------------------------------------------------------------------------------- 1 | open Longident 2 | open Location 3 | open Asttypes 4 | open Parsetree 5 | open Ast_helper 6 | open Ast_convenience 7 | 8 | let deriver = "lens" 9 | let raise_errorf = Ppx_deriving.raise_errorf 10 | 11 | let parse_options options = 12 | options |> List.iter (fun (name, expr) -> 13 | match name with 14 | | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name) 15 | 16 | let rec traverse f ({ptyp_desc; ptyp_loc = loc} as typ) = 17 | let f ptyp_desc = 18 | match ptyp_desc with 19 | | Ptyp_var var -> Ptyp_var (f var) 20 | | Ptyp_alias(t, var) -> Ptyp_alias(traverse f t, f var) 21 | | Ptyp_any -> Ptyp_any 22 | | Ptyp_arrow(lab,t1,t2) -> Ptyp_arrow(lab, traverse f t1, traverse f t2) 23 | | Ptyp_tuple ts -> Ptyp_tuple (List.map (traverse f) ts) 24 | | Ptyp_constr(lab,ts) -> Ptyp_constr(lab, List.map (traverse f) ts) 25 | | Ptyp_object(flds,flg) -> Ptyp_object(List.map (fun (str,attr,t) -> (str,attr,traverse f t)) flds, flg) 26 | | Ptyp_class(name,ts) -> Ptyp_class(name, List.map (traverse f) ts) 27 | | Ptyp_poly(_, _) | Ptyp_variant(_,_,_) 28 | | Ptyp_package _ | Ptyp_extension _ -> 29 | raise_errorf ~loc "%s cannot handle a type in a field" deriver 30 | in 31 | {typ with ptyp_desc = f ptyp_desc} 32 | 33 | let free_tvars typ = 34 | let rvars = ref [] in 35 | let f var = rvars := var::!rvars; var in 36 | ignore @@ traverse f typ; 37 | !rvars 38 | 39 | let rename_tvars mapping typ = 40 | let f var = 41 | try List.assoc var mapping with Not_found -> var 42 | in 43 | traverse f typ 44 | 45 | (* replace tvars in typ with fresh name *) 46 | let change_tvars tvars typ = 47 | let mapping = ref [] in 48 | let rec fresh var = 49 | if List.exists (fun v->v=var) tvars then 50 | fresh (var^var) 51 | else 52 | var 53 | in 54 | let rename var = 55 | if List.exists (fun v->v=var) tvars then 56 | try 57 | List.assoc var !mapping 58 | with Not_found -> 59 | begin 60 | let newvar = fresh var in 61 | mapping := (var,newvar)::!mapping; 62 | newvar 63 | end 64 | else begin 65 | mapping := (var,var)::!mapping; 66 | var 67 | end 68 | in 69 | !mapping, traverse rename typ 70 | 71 | let lens_typ rtyp ftyp = 72 | let getter_typ = Typ.arrow Label.nolabel rtyp ftyp 73 | in 74 | let vars = free_tvars getter_typ in 75 | let mapping, setter_2ndarg = change_tvars vars ftyp in 76 | let setter_result = rename_tvars mapping rtyp in 77 | let setter_typ = Typ.arrow Label.nolabel rtyp (Typ.arrow Label.nolabel setter_2ndarg setter_result) in 78 | Typ.tuple [getter_typ; setter_typ] 79 | 80 | let object_update obj labels fields = 81 | let meth (fname,_,_) = 82 | let expr = 83 | try 84 | List.assoc fname fields 85 | with Not_found -> 86 | Exp.send obj fname 87 | in 88 | {pcf_desc = 89 | Pcf_method ({txt=fname;loc=Location.none}, 90 | Public, 91 | Cfk_concrete(Fresh,expr)); 92 | pcf_loc = Location.none; 93 | pcf_attributes = []} 94 | in 95 | Exp.object_ {pcstr_self = Pat.any (); pcstr_fields = List.map meth labels} 96 | 97 | let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = 98 | parse_options options; 99 | let quoter = Ppx_deriving.create_quoter () in 100 | match type_decl with 101 | | {ptype_kind = Ptype_record labels} -> 102 | let mkfun = Exp.fun_ Label.nolabel None in 103 | let varname = Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl in 104 | let getter field = 105 | mkfun (pvar varname) (Exp.field (evar varname) (lid field)) 106 | and setter field = 107 | mkfun (pvar varname) (mkfun (pvar field) (record ~over:(evar varname) [(field, (evar field))])) 108 | in 109 | let typ = Ppx_deriving.core_type_of_type_decl type_decl in 110 | let lens { pld_name = { txt = name }; pld_type } = 111 | Vb.mk (Pat.constraint_ (pvar name) (lens_typ typ pld_type)) 112 | (Ppx_deriving.sanitize ~quoter (tuple [getter name; setter name])) 113 | in 114 | List.map lens labels 115 | | {ptype_manifest = Some ({ptyp_desc = Ptyp_object (labels, Closed)} as typ)} -> 116 | let typename = Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl in 117 | let fn = Exp.fun_ Label.nolabel None in 118 | let getter field = 119 | fn (pvar typename) (Exp.send (evar typename) field) 120 | and setter field = 121 | fn (pvar typename) (fn (pvar field) (object_update (evar typename) labels [(field, (evar field))])) 122 | in 123 | let lens (field,_,ftyp) = 124 | Vb.mk (Pat.constraint_ (pvar field) (lens_typ typ ftyp)) 125 | (Ppx_deriving.sanitize ~quoter (tuple [getter field; setter field])) 126 | in 127 | List.map lens labels 128 | | _ -> raise_errorf ~loc "%s can be derived only for record or closed object types" deriver 129 | 130 | let sig_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = 131 | parse_options options; 132 | match type_decl with 133 | | {ptype_kind = Ptype_record labels} -> 134 | let typ = Ppx_deriving.core_type_of_type_decl type_decl in 135 | let lens { pld_name = { txt = name }; pld_type } = 136 | Sig.value (Val.mk (mknoloc name) (lens_typ typ pld_type)) 137 | in 138 | List.map lens labels 139 | | {ptype_manifest = Some ({ptyp_desc = Ptyp_object (labels, Closed)} as typ)} -> 140 | let lens (field,_,ftyp) = 141 | Sig.value (Val.mk (mknoloc field) (lens_typ typ ftyp)) 142 | in 143 | List.map lens labels 144 | | _ -> raise_errorf ~loc "%s can only be derived for record types" deriver 145 | 146 | 147 | let () = 148 | Ppx_deriving.(register (create deriver 149 | ~type_decl_str: (fun ~options ~path type_decls -> 150 | [Str.value Nonrecursive (List.concat (List.map (str_of_type ~options ~path) type_decls))]) 151 | ~type_decl_sig: (fun ~options ~path type_decls -> 152 | List.concat (List.map (sig_of_type ~options ~path) type_decls)) 153 | () 154 | )) 155 | -------------------------------------------------------------------------------- /ppx/ppx_lens.mldylib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: ce018ff259f6b484e2e9572107631f84) 3 | Ppx_lens 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /ppx/ppx_lens.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: ce018ff259f6b484e2e9572107631f84) 3 | Ppx_lens 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /ppx/ppx_session.ml: -------------------------------------------------------------------------------- 1 | (* TODO: replace "failwith" with proper error-handling *) 2 | 3 | open Asttypes 4 | open Parsetree 5 | open Longident 6 | open Ast_helper 7 | open Ast_convenience 8 | 9 | let newname = 10 | let r = ref 0 in 11 | fun prefix -> 12 | let i = !r in 13 | r := i + 1; 14 | Printf.sprintf "__ppx_linocaml_%s_%d" prefix i 15 | 16 | let root_module = ref "Syntax" 17 | 18 | let longident ?loc str = evar ?loc str 19 | 20 | let monad_bind () = 21 | longident (!root_module ^ ".bind") 22 | 23 | let emptyslot () = 24 | longident (!root_module ^ ".empty") 25 | 26 | let mkbindfun () = 27 | longident (!root_module ^ ".Internal.__mkbindfun") 28 | 29 | let monad_bind_raw () = 30 | longident (!root_module ^ ".Internal.__bind_raw") 31 | 32 | let monad_return_raw () = 33 | longident (!root_module ^ ".Internal.__return_raw") 34 | 35 | let setfunc_raw () = 36 | longident (!root_module ^ ".Internal.__putval_raw") 37 | 38 | let getfunc () = 39 | longident (!root_module ^ ".Internal.__takeval_raw") 40 | 41 | let error loc (s:string) = 42 | Location.raise_errorf ~loc "%s" s 43 | 44 | let rec traverse f(*var wrapper*) g(*#tconst wrapper*) ({ppat_desc} as patouter) = 45 | match ppat_desc with 46 | | Ppat_any -> f patouter 47 | (* _ *) 48 | | Ppat_var _ -> f patouter 49 | (* x *) 50 | | Ppat_alias (pat,tvarloc) -> 51 | error tvarloc.loc "as-pattern is forbidden at %lin match" (* TODO relax this *) 52 | (* {patouter with ppat_desc=Ppat_alias(traverse f g pat,tvarloc)} *) 53 | (* P as 'a *) 54 | | Ppat_constant _ -> patouter 55 | (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) 56 | | Ppat_interval (_,_) -> patouter 57 | (* 'a'..'z' 58 | 59 | Other forms of interval are recognized by the parser 60 | but rejected by the type-checker. *) 61 | | Ppat_tuple pats -> {patouter with ppat_desc=Ppat_tuple(List.map (traverse f g) pats)} 62 | (* (P1, ..., Pn) 63 | 64 | Invariant: n >= 2 65 | *) 66 | | Ppat_construct (lidloc,Some(pat)) -> {patouter with ppat_desc=Ppat_construct(lidloc,Some(traverse f g pat))} 67 | | Ppat_construct (_,None) -> patouter 68 | (* C None 69 | C P Some P 70 | C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) 71 | *) 72 | | Ppat_variant (lab,Some(pat)) -> {patouter with ppat_desc=Ppat_variant(lab,Some(traverse f g pat))} 73 | | Ppat_variant (lab,None) -> patouter 74 | (* `A (None) 75 | `A P (Some P) 76 | *) 77 | | Ppat_record (recpats, Closed) -> 78 | {patouter with 79 | ppat_desc=Ppat_record(List.map (fun (field,pat) -> (field,traverse f g pat)) recpats, Closed) 80 | } 81 | (* { l1=P1; ...; ln=Pn } (flag = Closed) 82 | { l1=P1; ...; ln=Pn; _} (flag = Open) 83 | 84 | Invariant: n > 0 85 | *) 86 | | Ppat_array pats -> {patouter with ppat_desc=Ppat_array (List.map (traverse f g) pats)} 87 | (* [| P1; ...; Pn |] *) 88 | | Ppat_constraint (pat,typ) -> {patouter with ppat_desc=Ppat_constraint(traverse f g pat,typ)} 89 | (* (P : T) *) 90 | | Ppat_type lidloc -> g lidloc 91 | (* #tconst *) 92 | | Ppat_lazy pat -> {patouter with ppat_desc=Ppat_lazy(traverse f g pat)} 93 | 94 | | Ppat_record (_, Open) 95 | | Ppat_or (_,_) | Ppat_unpack _ 96 | | Ppat_exception _ | Ppat_extension _ | Ppat_open _ -> 97 | error patouter.ppat_loc "%lin cannot handle this pattern" 98 | 99 | let rec is_linpat {ppat_desc;ppat_loc} = 100 | match ppat_desc with 101 | | Ppat_type _ -> true 102 | | Ppat_alias (pat,_) -> is_linpat pat 103 | | Ppat_constraint (pat,_) -> is_linpat pat 104 | | Ppat_any | Ppat_var _ 105 | | Ppat_constant _ | Ppat_interval (_,_) 106 | | Ppat_tuple _ | Ppat_construct (_,_) 107 | | Ppat_variant (_,_) | Ppat_record (_, _) 108 | | Ppat_array _ | Ppat_lazy _ -> false 109 | | Ppat_or (_,_) | Ppat_unpack _ 110 | | Ppat_exception _ | Ppat_extension _ | Ppat_open _ -> 111 | error ppat_loc "%lin cannot handle this pattern" 112 | 113 | let lin_pattern oldpat = 114 | let wrap ({ppat_loc} as oldpat) = 115 | let lin_vars = ref [] 116 | in 117 | let replace_linpat ({loc} as linvar) = 118 | let newvar = newname "match" in 119 | lin_vars := (linvar,newvar) :: !lin_vars; 120 | pconstr ~loc "L" [pvar ~loc newvar] 121 | 122 | and wrap_datapat ({ppat_loc} as pat) = 123 | pconstr ~loc:ppat_loc "W" [pat] 124 | in 125 | let newpat = traverse wrap_datapat replace_linpat oldpat in 126 | newpat, List.rev !lin_vars 127 | in 128 | let newpat,lin_vars = wrap oldpat in 129 | newpat, lin_vars 130 | 131 | let add_setslots es expr = 132 | let insert_expr (linvar, newvar) = 133 | app (* ~loc:oldpat.ppat_loc *) (setfunc_raw ()) [Exp.ident ~loc:linvar.loc linvar; evar ~loc:linvar.loc newvar] 134 | in 135 | List.fold_right (fun e expr -> 136 | app 137 | (monad_bind_raw ()) 138 | [insert_expr e; lam (punit ()) expr]) es expr 139 | 140 | let add_getslots es expr = 141 | List.fold_right (fun (v,slot) expr -> 142 | app 143 | (monad_bind_raw ()) 144 | [app (getfunc ()) [slot]; 145 | lam (pvar v) expr]) es expr 146 | 147 | let rec linval ({pexp_desc;pexp_loc;pexp_attributes} as outer) = 148 | match pexp_desc with 149 | | Pexp_ident _ | Pexp_constant _ 150 | | Pexp_construct (_,None) 151 | | Pexp_variant (_,None) -> 152 | outer, [] 153 | 154 | | Pexp_apply ({pexp_desc=Pexp_ident {txt=Lident"!!"}} , [(Nolabel,exp)]) -> 155 | let newvar = newname "linval" in 156 | constr ~loc:pexp_loc "L" [longident ~loc:pexp_loc newvar], [(newvar,exp)] 157 | 158 | | Pexp_tuple (exprs) -> 159 | let exprs, bindings = List.split (List.map linval exprs) in 160 | {pexp_desc=Pexp_tuple(exprs);pexp_loc;pexp_attributes}, List.concat bindings 161 | 162 | | Pexp_construct ({txt=Lident "Data"},Some(expr)) -> 163 | constr ~loc:pexp_loc ~attrs:pexp_attributes "L" [expr], [] 164 | 165 | | Pexp_construct (lid,Some(expr)) -> 166 | let expr, binding = linval expr in 167 | {pexp_desc=Pexp_construct(lid,Some(expr));pexp_loc;pexp_attributes}, binding 168 | | Pexp_variant (lab,Some(expr)) -> 169 | let expr, binding = linval expr in 170 | {pexp_desc=Pexp_variant(lab,Some(expr));pexp_loc;pexp_attributes}, binding 171 | | Pexp_record (fields,expropt) -> 172 | let fields, bindings = 173 | List.split (List.map (fun (lid,expr) -> let e,b = linval expr in (lid,e),b) fields) 174 | in 175 | let bindings = List.concat bindings in 176 | let expropt, bindings = 177 | match expropt with 178 | | Some expr -> 179 | let expr, binding = linval expr in 180 | Some expr, binding @ bindings 181 | | None -> None, bindings 182 | in 183 | {pexp_desc=Pexp_record(fields,expropt);pexp_loc;pexp_attributes}, bindings 184 | | Pexp_array (exprs) -> 185 | let exprs, bindings = 186 | List.split (List.map linval exprs) 187 | in 188 | {pexp_desc=Pexp_array(exprs);pexp_loc;pexp_attributes}, List.concat bindings 189 | | Pexp_constraint (expr,typ) -> 190 | let expr, binding = linval expr 191 | in 192 | {pexp_desc=Pexp_constraint(expr,typ);pexp_loc;pexp_attributes}, binding 193 | | Pexp_coerce (expr,typopt,typ) -> 194 | let expr, binding = linval expr 195 | in 196 | {pexp_desc=Pexp_coerce(expr,typopt,typ);pexp_loc;pexp_attributes}, binding 197 | | Pexp_lazy expr -> 198 | let expr, binding = linval expr 199 | in 200 | {pexp_desc=Pexp_lazy(expr);pexp_loc;pexp_attributes}, binding 201 | | Pexp_open (oflag,lid,expr) -> 202 | let expr, binding = linval expr 203 | in 204 | {pexp_desc=Pexp_open(oflag,lid,expr);pexp_loc;pexp_attributes}, binding 205 | | Pexp_apply (expr,exprs) -> 206 | let expr, binding = linval expr in 207 | let exprs, bindings = 208 | List.split @@ 209 | List.map 210 | (fun (lab,expr) -> let expr,binding = linval expr in (lab,expr),binding) 211 | exprs 212 | in 213 | begin match binding @ List.concat bindings with 214 | | [] -> {pexp_desc=Pexp_apply(expr,exprs);pexp_loc;pexp_attributes}, [] 215 | | _ -> 216 | error pexp_loc "function call inside %linval cannot contain slot references (!! slotname)" 217 | end 218 | | Pexp_object ({pcstr_self={ppat_desc=Ppat_any}; pcstr_fields=fields} as o) -> 219 | let new_fields, bindings = 220 | List.split @@ List.map 221 | (function 222 | | ({pcf_desc=Pcf_method (name,Public,Cfk_concrete(fl,expr))} as f) -> 223 | let new_expr, binding = linval expr in 224 | {f with pcf_desc=Pcf_method(name,Public,Cfk_concrete(fl,new_expr))}, binding 225 | | _ -> 226 | error pexp_loc "object can only contain public method") 227 | fields 228 | in 229 | {pexp_desc=Pexp_object({o with pcstr_fields=new_fields});pexp_loc;pexp_attributes}, 230 | List.concat bindings 231 | | Pexp_object _ -> 232 | failwith "object in linval can't refer to itself" 233 | | Pexp_poly (expr,None) -> 234 | let expr, binding = linval expr in 235 | {pexp_desc=Pexp_poly(expr,None);pexp_loc;pexp_attributes}, binding 236 | | Pexp_poly (expr,_) -> 237 | failwith "object method can not have type ascription" 238 | | Pexp_let (_,_,_) | Pexp_function _ 239 | | Pexp_fun (_,_,_,_) | Pexp_match (_,_) | Pexp_try (_,_) 240 | | Pexp_field (_,_) | Pexp_setfield (_,_,_) | Pexp_ifthenelse (_,_,_) 241 | | Pexp_sequence (_,_) | Pexp_while (_,_) | Pexp_for (_,_,_,_,_) 242 | | Pexp_send (_,_) | Pexp_new _ | Pexp_setinstvar (_,_) | Pexp_override _ 243 | | Pexp_letmodule (_,_,_) | Pexp_assert _ | Pexp_newtype (_,_) 244 | | Pexp_pack _ | Pexp_extension _ 245 | | Pexp_unreachable | Pexp_letexception _ 246 | -> failwith "%linval can only contain values" 247 | 248 | let bindings_of_let bindings = 249 | List.mapi (fun i binding -> 250 | let var = newname "let" in 251 | {binding with pvb_pat = pvar var}, (var, binding.pvb_pat) 252 | ) bindings 253 | 254 | (* [p0 = ??] and [p1 = ??] and .. and e ==> [bind dum$0 (fun p0 -> bind dum$1 (fun p1 -> .. -> e))] *) 255 | let bindbody_of_let exploc bindings exp = 256 | let rec make i bindings = 257 | match bindings with 258 | | [] -> exp 259 | | (binding,(var,origpat)) :: t -> 260 | let name = evar var [@metaloc binding.pvb_expr.pexp_loc] in 261 | let f = [%expr (fun [%p origpat] -> [%e make (i+1) t])] [@metaloc binding.pvb_loc] in 262 | let new_exp = [%expr [%e monad_bind ()] [%e name] [%e f]] [@metaloc exploc] in 263 | { new_exp with pexp_attributes = binding.pvb_attributes } 264 | in 265 | make 0 bindings 266 | 267 | (* (\* [{lab1} = e1] and [{lab2} = e2 and .. and e ==> e1 ~bindto:lab1 >>= (fun () -> e2 ~bindto:lab2 ] *\) *) 268 | (* let slot_bind bindings expr = *) 269 | (* let f binding expr = *) 270 | (* match binding with *) 271 | (* | {pvb_pat = {ppat_desc = Ppat_record ([({txt},_)],Closed)}; pvb_expr = rhs} *) 272 | (* | {pvb_pat = {ppat_desc = Ppat_type {txt}}; pvb_expr = rhs} -> *) 273 | (* let lensname = String.concat "." (Longident.flatten txt) in *) 274 | (* let f = Exp.fun_ Label.nolabel None (punit ()) expr in *) 275 | (* [%expr [%e monad_bind ()] ([%e rhs] ~bindto:[%e evar lensname]) [%e f]] *) 276 | (* | _ -> raise Not_found *) 277 | (* in List.fold_right f bindings expr *) 278 | (* Generates session selection. [%select `labl] ==> _select0 (fun x -> `labl(x)) *) 279 | let session_select which labl = 280 | let selectfunc = 281 | match which with 282 | | `Session0 -> longident (!root_module ^ ".Session0._select") 283 | | `SessionN e -> [%expr [%e longident (!root_module ^ ".SessionN._select")] [%e e]] 284 | in 285 | let new_exp = 286 | [%expr [%e selectfunc ] 287 | (fun [%p pvar "x"] -> 288 | [%e Exp.variant labl (Some(evar "x"))]) ] 289 | in new_exp 290 | 291 | (* Converts match clauses to handle branching. 292 | | `lab1 -> e1 293 | | .. 294 | | `labN -> eN 295 | ==> 296 | | `lab1(p),r -> _branch e0? (p,r) e1 297 | | .. 298 | | `fin(p),r -> _branch e0? (p,r) eN) 299 | : [`lab1 of 'p1 | .. | `labN of 'pN] * 'a -> 'b) 300 | *) 301 | let session_branch_clauses which cases = 302 | let branch_exp = 303 | match which with 304 | | `Session0 -> longident (!root_module ^ ".Session0._branch") 305 | | `SessionN e -> [%expr [%e longident (!root_module ^ ".SessionN._branch")] [%e e]] 306 | in 307 | let conv = function 308 | | {pc_lhs={ppat_desc=Ppat_variant(labl,pat);ppat_loc;ppat_attributes};pc_guard;pc_rhs=rhs_orig} -> 309 | if pat=None then 310 | let open Ast_convenience in 311 | let open Ast_helper in 312 | let open Ast_helper in 313 | let protocol_var = newname "match_p" in 314 | let polarity_var = newname "match_q" in 315 | let pat = [%pat? ( [%p Pat.variant labl (Some(pvar protocol_var)) ], [%p pvar polarity_var])] in 316 | let pair = [%expr [%e evar protocol_var],[%e evar polarity_var]] in 317 | let expr = [%expr [%e branch_exp] [%e pair] [%e rhs_orig]] in 318 | {pc_lhs={ppat_desc=pat.ppat_desc;ppat_loc;ppat_attributes};pc_guard;pc_rhs=expr}, labl 319 | else 320 | error ppat_loc "Invalid variant pattern" 321 | | {pc_lhs={ppat_loc=loc}} -> error loc "Invalid pattern" 322 | in 323 | List.split (List.map conv cases) 324 | 325 | let branch_func_name = function 326 | | `Session0 -> longident (!root_module ^ ".Session0._branch_start") 327 | | `SessionN -> longident (!root_module ^ ".SessionN._branch_start") 328 | 329 | let make_branch_func_types labls = 330 | let open Typ in 331 | let rows = 332 | List.mapi (fun i labl -> Rtag(labl,[],false,[var ("p"^string_of_int i)])) labls 333 | in 334 | [%type: [%t (variant rows Closed None)] * [%t any () ] -> [%t any () ] ] 335 | 336 | 337 | let expression_mapper id mapper exp attrs = 338 | let pexp_attributes = exp.pexp_attributes @ attrs in 339 | let pexp_loc=exp.pexp_loc in 340 | let process_inner expr = mapper.Ast_mapper.expr mapper expr 341 | in 342 | match id, exp.pexp_desc with 343 | 344 | | "lin", Pexp_let (Nonrecursive, vbls, expr) -> 345 | let lin_binding ({pvb_pat;pvb_expr} as vb) = 346 | let newpat, inserts = lin_pattern pvb_pat in 347 | {vb with pvb_pat=newpat}, inserts 348 | in 349 | let new_vbls, inserts = List.split (List.map lin_binding vbls) in 350 | let new_expr = add_setslots (List.concat inserts) expr in 351 | let make_bind {pvb_pat;pvb_expr;pvb_loc;pvb_attributes} expr = 352 | app ~loc:pexp_loc (monad_bind ()) [pvb_expr; app ~loc:pvb_loc (mkbindfun ()) [lam ~loc:pvb_loc pvb_pat expr]] 353 | in 354 | let expression = List.fold_right make_bind new_vbls new_expr 355 | in 356 | Some (process_inner expression) 357 | 358 | | "lin", Pexp_match(matched, cases) -> 359 | let lin_match ({pc_lhs=pat;pc_rhs=expr} as case) = 360 | let newpat, inserts = lin_pattern pat in 361 | let newexpr = add_setslots inserts expr in 362 | {case with pc_lhs=newpat;pc_rhs=newexpr} 363 | in 364 | let cases = List.map lin_match cases in 365 | let new_exp = 366 | app ~loc:pexp_loc ~attrs:pexp_attributes 367 | (monad_bind_raw ()) 368 | [matched; 369 | Exp.function_ ~loc:pexp_loc cases] 370 | in 371 | Some (process_inner new_exp) 372 | 373 | | "lin", Pexp_function(cases) -> 374 | let lin_match ({pc_lhs=pat;pc_rhs=expr} as case) = 375 | let newpat, inserts = lin_pattern pat in 376 | let newexpr = add_setslots inserts expr in 377 | {case with pc_lhs=newpat;pc_rhs=newexpr} 378 | in 379 | let cases = List.map lin_match cases in 380 | Some (app (mkbindfun ()) [process_inner {pexp_desc=Pexp_function(cases); pexp_loc; pexp_attributes}]) 381 | 382 | | "lin", Pexp_fun(Nolabel,None,pat,expr) -> 383 | let newpat, inserts = lin_pattern pat in 384 | let newexpr = add_setslots inserts expr in 385 | Some (app (mkbindfun ()) [process_inner {pexp_desc=Pexp_fun(Nolabel,None,newpat,newexpr); pexp_loc; pexp_attributes}]) 386 | 387 | | "lin", _ -> 388 | error pexp_loc "Invalid content for extension %lin; it must be \"let%lin slotname = ..\" OR \"match%lin slotname with ..\"" 389 | 390 | | "linret", expr -> 391 | let new_exp,bindings = linval {pexp_desc=expr;pexp_loc;pexp_attributes} in 392 | let new_exp = constr ~loc:pexp_loc "L" [new_exp] in 393 | let new_exp = app (monad_return_raw ()) [new_exp] in 394 | let new_exp = add_getslots bindings new_exp in 395 | Some(new_exp) 396 | 397 | (* monadic bind *) 398 | (* let%s p = e1 in e2 ==> let dum$0 = e1 in Session.(>>=) dum$0 e2 *) 399 | | ("s"|"w"), Pexp_let (Nonrecursive, vbl, expression) -> 400 | let new_exp = 401 | let vbl = bindings_of_let vbl in 402 | Exp.let_ 403 | Nonrecursive 404 | (fst @@ List.split vbl) 405 | (bindbody_of_let exp.pexp_loc vbl expression) 406 | in 407 | Some (mapper.Ast_mapper.expr mapper { new_exp with pexp_attributes }) 408 | | ("s"|"w"), _ -> error pexp_loc "Invalid content for extension %s|%w" 409 | 410 | (* session selection *) 411 | (* [%select0 `labl] ==> _select (fun x -> `labl(x)) *) 412 | | "select0", Pexp_variant (labl, None) -> 413 | let new_exp = session_select `Session0 labl in 414 | Some (mapper.Ast_mapper.expr mapper {new_exp with pexp_attributes}) 415 | | "select0", _ -> error pexp_loc "Invalid content for extension %select0" 416 | 417 | (* [%select _n `labl] ==> _select _n (fun x -> `labl(x)) *) 418 | | "select", Pexp_apply(e1, [(_,{pexp_desc=Pexp_variant (labl, None)})]) -> 419 | let new_exp = session_select (`SessionN e1) labl in 420 | Some (mapper.Ast_mapper.expr mapper {new_exp with pexp_attributes}) 421 | | "select", Pexp_variant(labl1, Some {pexp_desc=Pexp_variant (labl2, None)}) -> 422 | let new_exp = session_select (`SessionN (Exp.variant labl1 None)) labl2 in 423 | Some (mapper.Ast_mapper.expr mapper {new_exp with pexp_attributes}) 424 | | "select", _ -> error pexp_loc "Invalid content for extension %select" 425 | 426 | (* session branching 427 | match%branch0 () with | `lab1 -> e1 | .. | `labN -> eN 428 | ==> 429 | _branch_start ((function 430 | | `lab1(p),r -> _branch (p,r) e1 | .. 431 | | `labN(p),r -> _branch (p,r) eN) 432 | : [`lab1 of 'p1 | .. | `labN of 'pN] * 'a -> 'b) 433 | *) 434 | | "branch0", Pexp_match ({pexp_desc=Pexp_construct({txt=Longident.Lident("()")},None)}, cases) -> 435 | let cases, labls = session_branch_clauses `Session0 cases in 436 | let new_typ = make_branch_func_types labls in 437 | let new_exp = 438 | [%expr [%e branch_func_name `Session0] ([%e Exp.function_ cases] : [%t new_typ ])] 439 | in 440 | Some (mapper.Ast_mapper.expr mapper {new_exp with pexp_attributes}) 441 | | "branch0", _ -> error pexp_loc "Invalid content for extension %branch0" 442 | 443 | (* 444 | match%branch e0 with | `lab1 -> e1 | .. | `labN -> eN 445 | ==> 446 | _branch_start e0 ((function 447 | | `lab1(p),r -> _branch e0 (p,r) e1 | .. 448 | | `labN(p),r -> _branch e0 (p,r) eN) 449 | : [`lab1 of 'p1 | .. | `labN of 'pN] * 'a -> 'b) 450 | *) 451 | | "branch", Pexp_match (e0, cases) -> 452 | let open Typ in 453 | let cases, labls = session_branch_clauses (`SessionN e0) cases in 454 | let new_typ = make_branch_func_types labls in 455 | let new_exp = 456 | [%expr [%e branch_func_name `SessionN] [%e e0] 457 | ([%e Exp.function_ cases] : [%t new_typ ])] 458 | in 459 | Some (mapper.Ast_mapper.expr mapper {new_exp with pexp_attributes}) 460 | | "branch", _ -> error pexp_loc "Invalid content for extension %branch" 461 | 462 | | _ -> None 463 | 464 | let mapper_fun _ = 465 | let open Ast_mapper in 466 | let rec expr mapper outer = 467 | match outer with 468 | | {pexp_desc=Pexp_extension ({ txt = id }, PStr([{pstr_desc=Pstr_eval(inner,inner_attrs)}])); pexp_attributes=outer_attrs} -> 469 | begin match expression_mapper id mapper inner (inner_attrs @ outer_attrs) with 470 | | Some exp -> exp 471 | | None -> default_mapper.expr mapper outer 472 | end 473 | | _ -> default_mapper.expr mapper outer 474 | in 475 | {default_mapper with expr} 476 | 477 | 478 | (* let expression_mapper id mapper exp attrs = *) 479 | (* let pexp_attributes = attrs @ exp.pexp_attributes in *) 480 | (* let pexp_loc=exp.pexp_loc in *) 481 | (* match id, exp.pexp_desc with *) 482 | 483 | (* (\* slot bind *\) *) 484 | (* (\* let%lin {lab} = e1 in e2 ==> Session.(>>=) (e1 ~bindto:lab) (fun () -> e2) *\) *) 485 | (* | "lin", Pexp_let (Nonrecursive, vbl, expression) -> *) 486 | (* let new_exp = slot_bind vbl expression in *) 487 | (* Some (mapper.Ast_mapper.expr mapper { new_exp with pexp_attributes }) *) 488 | (* | "lin", _ -> error pexp_loc "Invalid content for extension %lin" *) 489 | 490 | (* | _ -> None *) 491 | 492 | (* let rebind_module modexpr = *) 493 | (* match modexpr.pmod_desc with *) 494 | (* | Pmod_ident {txt = id} -> root_module := String.concat "." (Longident.flatten id) *) 495 | (* | _ -> error modexpr.pmod_loc "Use (module M) here." *) 496 | 497 | (* let runner ({ ptype_loc = loc } as type_decl) = *) 498 | (* match type_decl with *) 499 | (* (\* | {ptype_kind = Ptype_record labels} -> *\) *) 500 | (* | {ptype_name = {txt = name}; ptype_manifest = Some ({ptyp_desc = Ptyp_object (labels, Closed)})} -> *) 501 | (* let obj = *) 502 | (* let meth (fname,_,_) = *) 503 | (* {pcf_desc = *) 504 | (* Pcf_method ({txt=fname;loc=Location.none}, *) 505 | (* Public, *) 506 | (* Cfk_concrete(Fresh, [%expr Session.Empty])); *) 507 | (* pcf_loc = Location.none; *) 508 | (* pcf_attributes = []} *) 509 | (* in *) 510 | (* Exp.object_ {pcstr_self = Pat.any (); pcstr_fields = List.map meth labels} *) 511 | (* in *) 512 | (* let mkfun = Exp.fun_ Label.nolabel None in *) 513 | (* let runner = mkfun (pvar "x") (app [%expr Session._run_internal] [obj; evar "x"]) in *) 514 | (* let quoter = Ppx_deriving.create_quoter () in *) 515 | (* let varname = "run_" ^ name in *) 516 | (* [{pstr_desc = Pstr_value (Nonrecursive, [Vb.mk (pvar varname) (Ppx_deriving.sanitize ~quoter runner)]); pstr_loc = Location.none}] *) 517 | (* | _ -> error loc "run_* can be derived only for record or closed object types" *) 518 | 519 | (* let has_runner attrs = *) 520 | (* List.exists (fun ({txt = name},_) -> name = "runner") attrs *) 521 | 522 | (* let mapper_fun _ = *) 523 | (* let open Ast_mapper in *) 524 | (* let expr mapper outer = *) 525 | (* match outer.pexp_desc with *) 526 | (* | Pexp_extension ({ txt = id }, PStr [{ pstr_desc = Pstr_eval (inner, attrs) }]) -> *) 527 | (* begin match expression_mapper id mapper inner attrs with *) 528 | (* | Some exp -> exp *) 529 | (* | None -> default_mapper.expr mapper outer *) 530 | (* end *) 531 | (* | _ -> default_mapper.expr mapper outer *) 532 | (* and stritem mapper outer = *) 533 | (* match outer with *) 534 | (* | {pstr_desc = Pstr_extension (({ txt = "s_syntax_rebind" }, PStr [{ pstr_desc = Pstr_eval ({pexp_desc=Pexp_pack modexpr}, _) }]),_) }-> *) 535 | (* rebind_module modexpr; *) 536 | (* [{outer with pstr_desc = Pstr_eval ([%expr ()],[])}] (\* replace with () *\) *) 537 | (* | {pstr_desc = Pstr_type (_, type_decls)} -> *) 538 | (* let runners = *) 539 | (* List.map (fun type_decl -> *) 540 | (* if has_runner type_decl.ptype_attributes then *) 541 | (* [runner type_decl] *) 542 | (* else []) type_decls *) 543 | (* in [outer] @ List.flatten (List.flatten runners) *) 544 | (* | _ -> [default_mapper.structure_item mapper outer] *) 545 | (* in *) 546 | (* let structure mapper str = *) 547 | (* List.flatten (List.map (stritem mapper) str) *) 548 | (* in *) 549 | (* {default_mapper with expr; structure} *) 550 | -------------------------------------------------------------------------------- /ppx/ppx_session_ex.ml: -------------------------------------------------------------------------------- 1 | let () = Ast_mapper.register "ppx_session" Ppx_session.mapper_fun 2 | -------------------------------------------------------------------------------- /tests/test.ml: -------------------------------------------------------------------------------- 1 | 2 | let race_check = 3 | let mutex = Mutex.create () in 4 | fun () -> 5 | if not (Mutex.try_lock mutex) then begin 6 | failwith "race detected!" 7 | end; 8 | Thread.delay 0.001; 9 | Mutex.unlock mutex 10 | 11 | 12 | 13 | (* Test for channels *) 14 | module C = Channel;; 15 | 16 | (* send n to 1 of type int on channel c *) 17 | let sender c put_ n = 18 | let put_ = put_ () in 19 | let ok = ref false in 20 | ignore (Thread.create (fun _ -> 21 | Thread.delay 0.001; 22 | print_string "s "; flush stderr; 23 | for i=n downto 1 do 24 | Thread.yield (); 25 | put_ c i 26 | done; 27 | ok := true) ()); 28 | ok 29 | 30 | (* receive and sum all ints until finish () = true *) 31 | let receiver c finish get_ () = 32 | let get_ = get_ () in 33 | let ok = ref None in 34 | ignore (Thread.create (fun _ -> 35 | Thread.delay 0.001; 36 | print_string "r "; flush stderr; 37 | let sum = ref 0 in 38 | let rec loop () = 39 | Thread.yield (); (* explicit yield is needed since OCaml's thread lacks fairness on this case *) 40 | sum := get_ c + !sum; 41 | if not (finish ()) || not (C.is_empty c) then 42 | loop () 43 | else 44 | ok := Some (!sum) 45 | in loop ()) ()); 46 | ok 47 | 48 | let rec loop n f x = 49 | match n with 50 | | 0 -> [] 51 | | n -> f x :: loop (n-1) f x 52 | 53 | let test_chan put_ get_ = 54 | let c = C.create () in 55 | let amount = 1000 and threads = 100 56 | in 57 | (* start sender threads *) 58 | let senders = loop threads (sender c put_) amount in 59 | let senders_finished () = List.for_all (fun c -> !c) senders 60 | in 61 | (* start receiver threads *) 62 | let receivers = loop threads (receiver c senders_finished get_) () in 63 | let receivers_finished () = List.for_all (fun c -> !c<>None) receivers 64 | in 65 | (* wait until all receives finishes *) 66 | while not (receivers_finished ()) do 67 | Thread.delay 0.; 68 | done; 69 | let get x = 70 | match !x with 71 | | None -> failwith "impossible" 72 | | Some v -> print_string (string_of_int v^" "); v 73 | in 74 | (* sum all received values *) 75 | let sum = List.fold_left (fun x r -> x + (get r)) 0 receivers in 76 | (* check it *) 77 | print_endline (string_of_int sum); 78 | assert ((amount*(amount+1))/2 * threads = sum) 79 | 80 | 81 | let _ = 82 | let cnt = 100000 in 83 | let c = C.create () in 84 | for i=0 to cnt-1 do 85 | ignore (Thread.create (fun _ -> Thread.delay 0.001; C.send c (Random.bits ())) ()); 86 | let v = C.peek c and w = C.receive c in 87 | assert (v = w) 88 | done; 89 | print_endline "Channel.peek/receive OK."; 90 | for i=0 to cnt-1 do 91 | let len = Random.bits () mod 100 + 1 in 92 | for n=0 to len-1 do 93 | C.send c n; 94 | done; 95 | assert (C.length c = len); 96 | assert (not (C.is_empty c)); 97 | C.clear c; 98 | assert (C.is_empty c); 99 | done; 100 | print_endline "Channel.length/is_empty OK."; 101 | () 102 | 103 | let _ = 104 | let receive_all () c = C.receive_all c (+) 0 105 | and receive_all_ () = 106 | let buf = ref 0 in 107 | fun c -> 108 | C.receive_all_ c (fun n -> buf := n + !buf); 109 | let v = !buf in 110 | buf := 0; 111 | v 112 | and send () c n = C.send c n 113 | in 114 | test_chan send receive_all; 115 | print_endline "Channel.send/receive_all OK."; 116 | test_chan send receive_all_; 117 | print_endline "Channel.send/receive_all_ OK."; 118 | 119 | () 120 | --------------------------------------------------------------------------------