├── opam ├── findlib ├── descr └── opam ├── docs ├── html.stamp ├── index_classes.html ├── index_exceptions.html ├── index_extensions.html ├── index_class_types.html ├── index_methods.html ├── index_attributes.html ├── index_module_types.html ├── index.html ├── Binary_session_lwt.html ├── index_modules.html ├── style.css ├── index_types.html ├── type_Binary_session.IO.html ├── Binary_session.IO.html ├── index_values.html ├── type_Binary_session_lwt.Make.html ├── Binary_session.Binary_process.html ├── Binary_session_lwt.Make.html ├── type_Binary_session.Make.html ├── type_Binary_session_lwt.html ├── Binary_session.Make.html ├── Binary_session.html └── type_Binary_session.Binary_process.html ├── .merlin ├── src ├── sessions.mllib ├── sessions.mldylib ├── sessions-lwt.mldylib ├── sessions-lwt.mllib ├── binary_session_lwt.mli ├── META ├── binary_session_lwt.ml ├── binary_session.ml └── binary_session.mli ├── .gitignore ├── .travis.yml ├── configure ├── Makefile ├── LICENSE ├── _tags ├── _oasis ├── README.md ├── examples └── vending_machine.ml └── myocamlbuild.ml /opam/findlib: -------------------------------------------------------------------------------- 1 | sessions 2 | -------------------------------------------------------------------------------- /docs/html.stamp: -------------------------------------------------------------------------------- 1 | 9ceada939da5212ca8d2531060005127 -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | S src 2 | B _build/src 3 | PKG lwt lwt.ppx 4 | FLG -w +a-4-40..42-44-45-48 5 | -------------------------------------------------------------------------------- /src/sessions.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: f02efc608e5c7ff7493b42ce97dac649) 3 | Binary_session 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /src/sessions.mldylib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: f02efc608e5c7ff7493b42ce97dac649) 3 | Binary_session 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /src/sessions-lwt.mldylib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 74dc9bfc9cdc62782981d011318461b1) 3 | Binary_session_lwt 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /src/sessions-lwt.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 74dc9bfc9cdc62782981d011318461b1) 3 | Binary_session_lwt 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | *.odocl 11 | 12 | # ocamlbuild working directory 13 | _build/ 14 | 15 | # ocamlbuild targets 16 | *.byte 17 | *.native 18 | 19 | # oasis generated files 20 | setup.data 21 | setup.log 22 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: required 3 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh 4 | script: bash -ex .travis-opam.sh 5 | env: 6 | - OCAML_VERSION=4.02 PACKAGE=sessions 7 | - OCAML_VERSION=4.03 PACKAGE=sessions 8 | - OCAML_VERSION=4.04 PACKAGE=sessions 9 | os: 10 | - linux 11 | - osx 12 | -------------------------------------------------------------------------------- /opam/descr: -------------------------------------------------------------------------------- 1 | Library to provide session types to allow for static verification of protocols between concurrent computations. 2 | 3 | Provides sessions types (currently binary session type) for statically verifying protocols between concurrent computations. 4 | A pair of processes which are parametrized by binary session types can only be run if they have compatible (dual) session types. 5 | This library is based on the paper "Haskell Session Types with (Almost) No Class". -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /src/binary_session_lwt.mli: -------------------------------------------------------------------------------- 1 | (** A lwt based implementation of {!module:Binary_session.Binary_process} 2 | that uses a pipe for the communication channel between two processes. 3 | 4 | @author essdotteedot [] 5 | @version 0.1.0 6 | *) 7 | 8 | module Make : (Binary_session.Binary_process with type 'a io = 'a Lwt.t and type chan_endpoint = (Lwt_io.input_channel * Lwt_io.output_channel)) 9 | (** Functor to create a module of type {!module:Binary_session.Binary_process}. *) -------------------------------------------------------------------------------- /docs/index_classes.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | Index of classes 12 | 13 | 14 |
 Up 15 |  
16 |

Index of classes

17 | 18 |
19 | 20 | -------------------------------------------------------------------------------- /docs/index_exceptions.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | Index of exceptions 12 | 13 | 14 |
 Up 15 |  
16 |

Index of exceptions

17 | 18 |
19 | 20 | -------------------------------------------------------------------------------- /docs/index_extensions.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | Index of extensions 12 | 13 | 14 |
 Up 15 |  
16 |

Index of extensions

17 | 18 |
19 | 20 | -------------------------------------------------------------------------------- /docs/index_class_types.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | Index of class types 12 | 13 | 14 |
 Up 15 |  
16 |

Index of class types

17 | 18 |
19 | 20 | -------------------------------------------------------------------------------- /docs/index_methods.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | Index of class methods 12 | 13 | 14 |
 Up 15 |  
16 |

Index of class methods

17 | 18 |
19 | 20 | -------------------------------------------------------------------------------- /src/META: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 2a1685dc8e6501585f8946393537df57) 3 | version = "0.1.0" 4 | description = 5 | "Library to provide session types to allow for static verification of protocols between concurrent computations." 6 | archive(byte) = "sessions.cma" 7 | archive(byte, plugin) = "sessions.cma" 8 | archive(native) = "sessions.cmxa" 9 | archive(native, plugin) = "sessions.cmxs" 10 | exists_if = "sessions.cmxa" 11 | package "lwt" ( 12 | version = "0.1.0" 13 | description = 14 | "Library to provide session types to allow for static verification of protocols between concurrent computations." 15 | requires = "sessions unix lwt lwt.unix threads" 16 | archive(byte) = "sessions-lwt.cma" 17 | archive(byte, plugin) = "sessions-lwt.cma" 18 | archive(native) = "sessions-lwt.cmxa" 19 | archive(native, plugin) = "sessions-lwt.cmxs" 20 | exists_if = "sessions-lwt.cmxa" 21 | ) 22 | # OASIS_STOP 23 | 24 | -------------------------------------------------------------------------------- /docs/index_attributes.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | Index of class attributes 12 | 13 | 14 |
 Up 15 |  
16 |

Index of class attributes

17 | 18 |
19 | 20 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /opam/opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "sessions" 3 | version: "0.1.0" 4 | maintainer: "essdotteedot " 5 | authors: [ "essdotteedot " ] 6 | license: "MIT" 7 | homepage: "https://github.com/essdotteedot/sessions" 8 | dev-repo: "https://github.com/essdotteedot/sessions.git" 9 | bug-reports: "https://github.com/essdotteedot/sessions/issues" 10 | build: [ 11 | ["ocaml" "setup.ml" "-configure" "--prefix" prefix "--%{lwt:enable}%-lwt"] 12 | ["ocaml" "setup.ml" "-build"] 13 | ] 14 | install: ["ocaml" "setup.ml" "-install"] 15 | remove: [ 16 | ["ocamlfind" "remove" "sessions"] 17 | ] 18 | build-test: [ 19 | ["ocaml" "setup.ml" "-configure" "--enable-tests" "--%{lwt:enable}%-lwt"] 20 | ["ocaml" "setup.ml" "-build"] 21 | ["ocaml" "setup.ml" "-test"] 22 | ] 23 | build-doc: [ "ocaml" "setup.ml" "-doc" ] 24 | depends: [ 25 | "base-threads" 26 | "base-unix" 27 | "lwt" 28 | "ocamlfind" {build} 29 | ] 30 | available: [ ocaml-version >= "4.02.3" ] 31 | -------------------------------------------------------------------------------- /src/binary_session_lwt.ml: -------------------------------------------------------------------------------- 1 | module Nonblock_io = struct 2 | type 'a t = 'a Lwt.t 3 | 4 | type chan_endpoint = Lwt_io.input_channel * Lwt_io.output_channel 5 | 6 | type chan = Chan : chan_endpoint * chan_endpoint -> chan 7 | 8 | let make_channel () : chan = 9 | let (in_ch,out_ch) = Lwt_io.pipe () in 10 | Chan ((in_ch,out_ch),(in_ch,out_ch)) 11 | 12 | let read_channel ((in_ch,_) : chan_endpoint) : 'a t = 13 | Lwt_io.read_value in_ch 14 | 15 | let write_channel (v : 'a) ~(flags:Marshal.extern_flags list) ((_,out_ch) : chan_endpoint) : unit t = 16 | Lwt_io.write_value out_ch ~flags v 17 | 18 | let close_channel (Chan ((ch_in,ch_out),_) : chan) : unit t = 19 | Lwt.(Lwt_io.close ch_in >>= fun () -> Lwt_io.close ch_out) 20 | 21 | let return = Lwt.return 22 | 23 | let (>>=) = Lwt.(>>=) 24 | end 25 | 26 | module Make : (Binary_session.Binary_process with type 'a io = 'a Lwt.t and type chan_endpoint = (Lwt_io.input_channel * Lwt_io.output_channel)) = 27 | Binary_session.Make (Nonblock_io) -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2016 essdotteedot 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /docs/index_module_types.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | Index of module types 12 | 13 | 14 |
 Up 15 |  
16 |

Index of module types

17 | 18 | 19 | 20 | 24 | 25 | 26 | 30 |

B
Binary_process [Binary_session]
21 | A process which is parametrized by a binary session type. 22 |
23 |

I
IO [Binary_session]
27 | Abstract type which can perform monadic concurrent IO. 28 |
29 |
31 | 32 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: f30c2228080509953ff39601a2584b21) 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 sessions 18 | "src/sessions.cmxs": use_sessions 19 | # Library sessions-lwt 20 | "src/sessions-lwt.cmxs": use_sessions-lwt 21 | : package(lwt) 22 | : package(lwt.unix) 23 | : package(threads) 24 | : package(unix) 25 | : use_sessions 26 | # Executable vending_machine 27 | "examples/vending_machine.native": package(lwt) 28 | "examples/vending_machine.native": package(lwt.unix) 29 | "examples/vending_machine.native": package(threads) 30 | "examples/vending_machine.native": package(unix) 31 | "examples/vending_machine.native": use_sessions 32 | "examples/vending_machine.native": use_sessions-lwt 33 | : package(lwt) 34 | : package(lwt.unix) 35 | : package(threads) 36 | : package(unix) 37 | : use_sessions 38 | : use_sessions-lwt 39 | # OASIS_STOP 40 | -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 |

16 | 22 |

23 | 24 | 29 | 34 |
Binary_session
25 | This module provides modules to create binary sessions types for statically verifying protocols between 26 | a pair of concurrent processes. 27 |
28 |
Binary_session_lwt
30 | A lwt based implementation of Binary_session.Binary_process 31 | that uses a pipe for the communication channel between two processes. 32 |
33 |
35 | 36 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | Name: sessions 2 | Version: 0.1.0 3 | Synopsis: Library to provide session types to allow for static verification of protocols between concurrent computations. 4 | Description: 5 | Provides sessions types (currently binary session type) for statically verifying protocols between concurrent computations. 6 | A pair of processes which are parametrized by binary session types can only be run if they have compatible (dual) session types. 7 | This library is based on the paper "Haskell Session Types with (Almost) No Class". 8 | Authors: essdotteedot 9 | Maintainers: essdotteedot 10 | License: MIT 11 | 12 | Description: Library to provide session types to allow for static verification of protocols between concurrent processes. 13 | Homepage: https://github.com/essdotteedot/sessions 14 | 15 | OASISFormat: 0.4 16 | BuildTools: ocamlbuild 17 | Plugins: META (0.4), DevFiles (0.4) 18 | OCamlVersion: >= 4.02.3 19 | 20 | Flag lwt 21 | Description: Build the Lwt wrapper 22 | Default: true 23 | 24 | Library "sessions" 25 | Path: src 26 | CompiledObject: native 27 | Modules: Binary_session 28 | 29 | Library "sessions-lwt" 30 | Build$: flag(lwt) 31 | Install$: flag(lwt) 32 | FindLibName: lwt 33 | FindLibParent: sessions 34 | CompiledObject: native 35 | Path: src 36 | Modules: Binary_session_lwt 37 | BuildDepends: sessions, unix, lwt, lwt.unix, threads 38 | 39 | Flag examples 40 | Description: Build the examples 41 | Default: false 42 | 43 | Executable "vending_machine" 44 | Path: examples 45 | MainIs: vending_machine.ml 46 | Build$: flag(examples) && flag(lwt) 47 | CompiledObject: native 48 | BuildDepends: sessions.lwt 49 | 50 | AlphaFeatures: ocamlbuild_more_args 51 | Document "sessions-api" 52 | Type: ocamlbuild (0.4) 53 | BuildTools: ocamldoc 54 | 55 | Title: API reference for sessions 56 | XOCamlbuildPath: . 57 | XOCamlbuildExtraArgs: "-docflags '-colorize-code -short-functors -charset utf-8'" 58 | XOCamlbuildLibraries: sessions, sessions.lwt 59 | 60 | SourceRepository master 61 | Type: git 62 | Location: https://github.com/essdotteedot/sessions.git 63 | Branch: master 64 | Browser: https://github.com/essdotteedot/sessions 65 | 66 | -------------------------------------------------------------------------------- /docs/Binary_session_lwt.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | Binary_session_lwt 15 | 16 | 17 |
Previous 18 |  Up 19 |  
20 |

Module Binary_session_lwt

21 | 22 | 
module Binary_session_lwt: sig .. end
23 | A lwt based implementation of Binary_session.Binary_process 24 | that uses a pipe for the communication channel between two processes.
25 | Author(s): essdotteedot [<essdotteedot[at]gmail[dot]com>]
26 | Version: 0.1.0
27 |
28 |
29 | 30 | 
module Make: Binary_session.Binary_process  with type 'a io = 'a Lwt.t and type chan_endpoint = (Lwt_io.input_channel * Lwt_io.output_channel)
31 | Functor to create a module of type Binary_session.Binary_process. 32 |
33 | -------------------------------------------------------------------------------- /docs/index_modules.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | Index of modules 12 | 13 | 14 |
 Up 15 |  
16 |

Index of modules

17 | 18 | 19 | 20 | 25 | 26 | 31 | 32 | 33 | 37 | 38 | 42 |

B
Binary_session
21 | This module provides modules to create binary sessions types for statically verifying protocols between 22 | a pair of concurrent processes. 23 |
24 |
Binary_session_lwt
27 | A lwt based implementation of Binary_session.Binary_process 28 | that uses a pipe for the communication channel between two processes. 29 |
30 |

M
Make [Binary_session_lwt]
34 | Functor to create a module of type Binary_session.Binary_process. 35 |
36 |
Make [Binary_session]
39 | Functor to create a module of type Binary_session.Binary_process given a message module I of type Binary_session.IO. 40 |
41 |
43 | 44 | -------------------------------------------------------------------------------- /docs/style.css: -------------------------------------------------------------------------------- 1 | .keyword { font-weight : bold ; color : Red } 2 | .keywordsign { color : #C04600 } 3 | .superscript { font-size : 4 } 4 | .subscript { font-size : 4 } 5 | .comment { color : Green } 6 | .constructor { color : Blue } 7 | .type { color : #5C6585 } 8 | .string { color : Maroon } 9 | .warning { color : Red ; font-weight : bold } 10 | .info { margin-left : 3em; margin-right: 3em } 11 | .param_info { margin-top: 4px; margin-left : 3em; margin-right : 3em } 12 | .code { color : #465F91 ; } 13 | .typetable { border-style : hidden } 14 | .paramstable { border-style : hidden ; padding: 5pt 5pt} 15 | tr { background-color : White } 16 | td.typefieldcomment { background-color : #FFFFFF ; font-size: smaller ;} 17 | div.sig_block {margin-left: 2em} 18 | *:target { background: yellow; } 19 | body {font: 13px sans-serif; color: black; text-align: left; padding: 5px; margin: 0} 20 | h1 { font-size : 20pt ; text-align: center; } 21 | h2 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90BDFF ;padding: 2px; } 22 | h3 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90DDFF ;padding: 2px; } 23 | h4 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90EDFF ;padding: 2px; } 24 | h5 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90FDFF ;padding: 2px; } 25 | h6 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90BDFF ; padding: 2px; } 26 | div.h7 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #E0FFFF ; padding: 2px; } 27 | div.h8 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #F0FFFF ; padding: 2px; } 28 | div.h9 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #FFFFFF ; padding: 2px; } 29 | a {color: #416DFF; text-decoration: none} 30 | a:hover {background-color: #ddd; text-decoration: underline} 31 | pre { margin-bottom: 4px; font-family: monospace; } 32 | pre.verbatim, pre.codepre { } 33 | .indextable {border: 1px #ddd solid; border-collapse: collapse} 34 | .indextable td, .indextable th {border: 1px #ddd solid; min-width: 80px} 35 | .indextable td.module {background-color: #eee ; padding-left: 2px; padding-right: 2px} 36 | .indextable td.module a {color: 4E6272; text-decoration: none; display: block; width: 100%} 37 | .indextable td.module a:hover {text-decoration: underline; background-color: transparent} 38 | .deprecated {color: #888; font-style: italic} 39 | .indextable tr td div.info { margin-left: 2px; margin-right: 2px } 40 | ul.indexlist { margin-left: 0; padding-left: 0;} 41 | ul.indexlist li { list-style-type: none ; margin-left: 0; padding-left: 0; } -------------------------------------------------------------------------------- /docs/index_types.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | Index of types 12 | 13 | 14 |
 Up 15 |  
16 |

Index of types

17 | 18 | 19 | 20 | 24 | 25 | 29 | 30 | 34 | 35 | 36 | 40 | 41 | 42 | 46 | 47 | 48 | 52 | 53 | 54 | 58 |

C
chan [Binary_session.IO]
21 | The abstract type representing a communication channel between two processes. 22 |
23 |
chan_endpoint [Binary_session.IO]
26 | The abstract type representing one end of a communication channel. 27 |
28 |
chan_endpoint [Binary_session.Binary_process]
31 | The abstract type representing one end of a communication channel. 32 |
33 |

I
io [Binary_session.Binary_process]
37 | The abstract monadic type representing a computation returning 'a. 38 |
39 |

P
process [Binary_session.Binary_process]
43 | The type representing a process returning a value of type 'a. 44 |
45 |

S
session [Binary_session.Binary_process]
49 | The type representing a communication protocol made up of a sequence of operations between two processes. 50 |
51 |

T
t [Binary_session.IO]
55 | The monadic light weight thread type returning value 'a. 56 |
57 |
59 | 60 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # sessions [![Build Status](https://travis-ci.org/essdotteedot/sessions.svg?branch=master)](https://travis-ci.org/essdotteedot/sessions) 2 | Library to provide session types to allow for static verification of protocols between concurrent computations. 3 | 4 | Provides sessions types (currently binary session type) for statically verifying protocols between concurrent computations. 5 | This library is based on the paper "Haskell Session Types with (Almost) No Class". 6 | 7 | A session type `('a,'b) session` represents a protocol that a particular process carries out. Here `'a` and `'b` are duals of each other. 8 | 9 | A process `('a,'b,'c) process` is parameterized by a starting session type `'b`, `'a` is it's return value and `'c` is it's final 10 | session type. Two processes can be run only if they have dual initial session types a final session type of `unit`. 11 | 12 | The following operations are duals of each other : 13 | - `Stop, Stop` 14 | - `Send of 'a * 'b, Recv of 'a * 'b`, where `'b` is a session type 15 | - `Offer of ('a, 'b) session * ('c, 'd) session, Choice of ('b, 'a) session * ('d, 'c) session`, where `'a`, `'b`, `'c`, `'d` are session types 16 | 17 | Here are some examples of processes which are duals : 18 | 19 | ```Ocaml 20 | module BP = Binary_session_lwt.Make 21 | 22 | let send_str_recv_int_stop = BP.(send "hello" >>= fun () -> recv () >>= fun (i : int) -> stop ()) 23 | let recv_str_send_int_stop = BP.(recv () >>= fun (s : string) -> send 1 >>= fun () -> stop ()) 24 | 25 | let _ = BP.run_processes send_str_recv_int_stop recv_str_send_int_stop 26 | ``` 27 | 28 | Note that the session type associated with the process `send_str_recv_int_stop` was inferred as 29 | 30 | ```Ocaml 31 | ([ `Send of string * [ `Recv of int * [ `Stop ] ] ],[ `Recv of string * [ `Send of int * [ `Stop ] ] ]) BP.session 32 | ``` 33 | 34 | as you can see it provides it's own session type 35 | 36 | ```Ocaml 37 | [ `Send of string * [ `Recv of int * [ `Stop ] ] ]] 38 | ``` 39 | as well as it's dual 40 | 41 | ```Ocaml 42 | [ `Recv of string * [ `Send of int * [ `Stop ] ] ] 43 | ``` 44 | 45 | The session type associated with the process `recv_str_send_int_stop` is 46 | 47 | ```Ocaml 48 | ([ `Recv of string * [ `Send of int * [ `Stop ] ] ], [ `Send of string * [ `Recv of int * [ `Stop ] ] ]) BP.session 49 | ``` 50 | we see that it indeed has the dual of `send_str_recv_int_stop` which means that `BP.run_processes send_str_recv_int_stop recv_str_send_int_stop` will type check. 51 | 52 | If these two processes were to differ in such a way that they were not duals then `BP.run_processes send_str_recv_int_stop recv_str_send_int_stop` would not type check. 53 | 54 | Here is another example using offer and choice as well as recursion. 55 | 56 | ```Ocaml 57 | module BP = Binary_session_lwt.Make 58 | 59 | let rec print_server () = BP.( 60 | offer 61 | (stop ()) 62 | ( 63 | recv () >>= fun (s : string) -> 64 | lift_io (Lwt_io.printlf "print server : %s" s) >>= 65 | print_server 66 | ) 67 | ) 68 | 69 | let rec print_client (i : int) = BP.( 70 | lift_io (Lwt_io.read_line Lwt_io.stdin) >>= fun (s : string) -> 71 | if s = "q" 72 | then choose_right (send (Printf.sprintf "Total lines printed : %d" (i+1)) >>= fun () -> choose_left (stop ())) 73 | else choose_right (send s >>= fun () -> print_client (i+1)) 74 | ) 75 | 76 | let () = Lwt_main.run ( 77 | Lwt.( 78 | BP.run_processes print_server (print_client 1) >>= fun (server_fn,client_fn) -> 79 | async server_fn ; 80 | client_fn () >>= fun _ -> 81 | return () 82 | ) 83 | ) 84 | ``` 85 | Documentation 86 | ------------- 87 | 88 | The API documentation is available [here](https://essdotteedot.github.io/sessions/). 89 | Example programs can be found in the [examples] (examples) directory. 90 | 91 | License 92 | ------- 93 | 94 | [MIT License](LICENSE) 95 | -------------------------------------------------------------------------------- /docs/type_Binary_session.IO.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | Binary_session.IO 11 | 12 | 13 | sig
14 |   type 'a t
15 |   type chan_endpoint
16 |   type chan =
17 |       Chan : Binary_session.IO.chan_endpoint *
18 |         Binary_session.IO.chan_endpoint -> Binary_session.IO.chan
19 |   val make_channel : unit -> Binary_session.IO.chan
20 |   val read_channel :
21 |     Binary_session.IO.chan_endpoint -> 'a Binary_session.IO.t
22 |   val write_channel :
23 |     'a ->
24 |     flags:Marshal.extern_flags list ->
25 |     Binary_session.IO.chan_endpoint -> unit Binary_session.IO.t
26 |   val close_channel : Binary_session.IO.chan -> unit Binary_session.IO.t
27 |   val return : 'a -> 'a Binary_session.IO.t
28 |   val ( >>= ) :
29 |     'a Binary_session.IO.t ->
30 |     ('a -> 'b Binary_session.IO.t) -> 'b Binary_session.IO.t
31 | end -------------------------------------------------------------------------------- /src/binary_session.ml: -------------------------------------------------------------------------------- 1 | module type IO = sig 2 | 3 | type 'a t 4 | 5 | type chan_endpoint 6 | 7 | type chan = Chan : chan_endpoint * chan_endpoint -> chan 8 | 9 | val make_channel : unit -> chan 10 | 11 | val read_channel : chan_endpoint -> 'a t 12 | 13 | val write_channel : 'a -> flags:Marshal.extern_flags list -> chan_endpoint -> unit t 14 | 15 | val close_channel : chan -> unit t 16 | 17 | val return : 'a -> 'a t 18 | 19 | val (>>=) : 'a t -> ('a -> 'b t) -> 'b t 20 | 21 | end 22 | 23 | module type Binary_process = sig 24 | 25 | type 'a io 26 | 27 | type chan_endpoint 28 | 29 | type ('a,'b) session constraint 'a = [>] constraint 'b = [>] 30 | 31 | type ('a,'b,'c) process 32 | 33 | val send : 'a -> (unit,([`Send of 'a * 'b], [`Recv of 'a * 'c]) session, ('b,'c) session) process 34 | 35 | val recv : unit -> ('a,([`Recv of 'a * 'b], [`Send of 'a * 'c]) session, ('b,'c) session) process 36 | 37 | val offer : ('e,('a, 'b) session,'f) process -> ('e,('c, 'd) session,'f) process -> 38 | ('e,([`Offer of (('a, 'b) session * ('c, 'd) session)], [`Choice of (('b, 'a) session * ('d, 'c) session)]) session,'f) process 39 | 40 | val choose_left : ('e,('a, 'b) session,'f) process -> 41 | ('e,([`Choice of (('a, 'b) session * ('c, 'd) session)], [`Offer of (('b, 'a) session * ('d, 'c) session)]) session,'f) process 42 | 43 | val choose_right : ('e,('c, 'd) session,'f) process -> 44 | ('e,([`Choice of (('a, 'b) session * ('c, 'd) session)], [`Offer of (('b, 'a) session * ('d, 'c) session)]) session,'f) process 45 | 46 | val stop : 'a -> ('a,([`Stop], [`Stop]) session, unit) process 47 | 48 | val lift_io : 'a io -> ('a, 'b, 'b) process 49 | 50 | val return : 'a -> ('a,'b,'b) process 51 | 52 | val (>>=) : ('a,'b,'c) process -> ('a -> ('d,'c,'e) process) -> ('d,'b,'e) process 53 | 54 | val run_processes : ('a, ('b,'c) session, unit) process -> ('d, ('c,'b) session, unit) process -> ((unit -> 'a io) * (unit -> 'd io)) io 55 | 56 | end 57 | 58 | module Make (I : IO) : (Binary_process with type 'a io = 'a I.t and type chan_endpoint = I.chan_endpoint) = struct 59 | type 'a io = 'a I.t 60 | 61 | type chan_endpoint = I.chan_endpoint 62 | 63 | type ('a,'b) session constraint 'a = [>] constraint 'b = [>] 64 | 65 | type ('a,'b,'c) process = P : (chan_endpoint -> ('a * chan_endpoint) io) -> ('a,'b,'c) process 66 | 67 | type which_choice = Left_choice | Right_choice 68 | 69 | let send (i : 'a) : (unit,([`Send of 'a * 'b], [`Recv of 'a * 'c]) session, ('b,'c) session) process = 70 | P (fun ch -> I.(write_channel i ~flags:[Marshal.Closures] ch >>= fun () -> return ((),ch))) 71 | 72 | let recv () : ('a,([`Recv of 'a * 'b], [`Send of 'a * 'c]) session, ('b,'c) session) process = 73 | P (fun ch -> I.(read_channel ch >>= fun (v : 'a) -> return (v,ch))) 74 | 75 | let offer (left : ('e,('a, 'b) session,'f) process) (right : ('e,('c, 'd) session,'f) process) : 76 | ('e,([`Offer of (('a, 'b) session * ('c, 'd) session)], [`Choice of (('b, 'a) session * ('d, 'c) session)]) session,'f) process = 77 | P (fun ch -> I.( 78 | read_channel ch >>= function 79 | Left_choice -> let P left' = left in left' ch 80 | | Right_choice -> let P right' = right in right' ch 81 | )) 82 | 83 | let choose_left (left : ('e,('a, 'b) session,'f) process) : 84 | ('e,([`Choice of (('a, 'b) session * ('c, 'd) session)], [`Offer of (('b, 'a) session * ('d, 'c) session)]) session,'f) process = 85 | P (fun ch -> I.(write_channel ~flags:[] Left_choice ch >>= fun () -> let P left' = left in left' ch)) 86 | 87 | let choose_right (right : ('e,('c, 'd) session,'f) process) : 88 | ('e,([`Choice of (('a, 'b) session * ('c, 'd) session)], [`Offer of (('b, 'a) session * ('d, 'c) session)]) session,'f) process = 89 | P (fun ch -> I.(write_channel ~flags:[] Right_choice ch >>= fun () -> let P right' = right in right' ch)) 90 | 91 | let stop (v : 'a) : ('a,([`Stop], [`Stop]) session, unit) process = 92 | P (fun ch -> I.return (v,ch)) 93 | 94 | let lift_io (v : 'a io) : ('a, 'b, 'b) process = 95 | P (fun ch -> I.(v >>= fun v' -> return (v',ch))) 96 | 97 | let return (v : 'a) : ('a,'b,'b) process = 98 | P (fun ch -> I.return (v,ch)) 99 | 100 | let (>>=) (p : ('a,'b,'c) process) (f : ('a -> ('d,'c,'e) process)) : ('d,'b,'e) process = 101 | P (fun ch -> I.(let P p' = p in p' ch >>= fun (v,ch') -> let P p'' = f v in p'' ch' >>= fun (v'',ch'') -> return (v'',ch''))) 102 | 103 | let run_processes (p : ('a, ('b,'c) session, unit) process) (p1 : ('d, ('c,'b) session, unit) process) : ((unit -> 'a io) * (unit -> 'd io)) io = 104 | I.( 105 | let P p' = p in 106 | let P p1' = p1 in 107 | let Chan (ep1,ep2) = I.make_channel () in 108 | let r1 = fun () -> (p' ep1) >>= fun (v,_) -> return v in 109 | let r2 = fun () -> (p1' ep2) >>= fun (v,_) -> return v in 110 | return (r1, r2) 111 | ) 112 | end -------------------------------------------------------------------------------- /examples/vending_machine.ml: -------------------------------------------------------------------------------- 1 | module BP = Binary_session_lwt.Make 2 | 3 | type coffee = Coffee 4 | type tea = Tea 5 | 6 | (* The vending machine : 7 | 1) waits for change 8 | 2) makes an internal choice 9 | - if the change is not enough then it stops 10 | - if there is enough change then it offers a choice 11 | between coffee or tea, upon receiving the decision 12 | from the client it dispenses the drink then stops 13 | *) 14 | let vending_machine () = BP.( 15 | lift_io (Lwt_io.printl "vending machine: waiting for funds") >>= fun () -> 16 | recv () >>= fun (amount : float) -> 17 | if amount < 2.0 18 | then lift_io (Lwt_io.printl "vending machine: received insufficient funds") >>= fun () -> choose_left (stop amount) 19 | else lift_io (Lwt_io.printl "vending machine: waiting for drink choice") >>= fun () -> choose_right ( 20 | offer 21 | ( 22 | recv () >>= fun (c : coffee) -> 23 | send "coffee" >>= fun () -> 24 | lift_io (Lwt_io.printl "vending machine: dispensing coffee") >>= fun () -> 25 | stop 0.0 26 | ) 27 | ( 28 | recv () >>= fun (t : tea) -> 29 | send "tea" >>= fun () -> 30 | lift_io (Lwt_io.printl "vending machine: dispensing tea") >>= fun () -> 31 | stop 0.0 32 | ) 33 | ) 34 | ) 35 | 36 | (* The coffee client : 37 | 1) puts in change 38 | 2) if vending machine informs it that the funds are not enough it stops 39 | 3) otherwise it chooses left (i.e., coffee) and receives the drink then stops 40 | *) 41 | let vending_client_coffee (amount : float) = BP.( 42 | lift_io (Lwt_io.printlf "vending machine user : putting in %f into vending machine" amount) >>= fun () -> 43 | send amount >>= fun () -> 44 | offer 45 | (stop ()) 46 | (choose_left ( 47 | send Coffee >>= fun () -> 48 | lift_io (Lwt_io.printl "vending machine user : picked coffee") >>= fun () -> 49 | recv () >>= fun (d : string) -> 50 | lift_io (Lwt_io.printlf "vending machine user : received %s" d) >>= fun () -> 51 | stop () 52 | ) 53 | ) 54 | ) 55 | 56 | (* The tea client : 57 | 1) puts in change 58 | 2) if vending machine informs it that the funds are not enough it stops 59 | 3) otherwise it chooses right (i.e., tea) and receives the drink then stops 60 | *) 61 | let vending_client_tea (amount : float) = BP.( 62 | lift_io (Lwt_io.printlf "vending machine user : putting in %f into vending machine" amount) >>= fun () -> 63 | send amount >>= fun () -> 64 | offer 65 | (stop ()) 66 | ( 67 | choose_right ( 68 | send Tea >>= fun () -> 69 | lift_io (Lwt_io.printl "vending machine user : picked tea") >>= fun () -> 70 | recv () >>= fun (d : string) -> 71 | lift_io (Lwt_io.printlf "vending machine user : received %s" d) >>= fun () -> 72 | stop () 73 | ) 74 | ) 75 | ) 76 | 77 | (* Print server 78 | offer a choice between 79 | - stopping 80 | - receiving text to be printed then looping 81 | *) 82 | let rec print_server () = BP.( 83 | offer 84 | (stop ()) 85 | ( 86 | recv () >>= fun (s : string) -> 87 | lift_io (Lwt_io.printlf "print server : %s" s) >>= 88 | print_server 89 | ) 90 | ) 91 | 92 | (* Print client 93 | makes an internal choice between 94 | - stopping 95 | - receiving text to be printed then looping 96 | *) 97 | let rec print_client (i : int) = BP.( 98 | lift_io (Lwt_io.read_line Lwt_io.stdin) >>= fun (s : string) -> 99 | if s = "q" 100 | then choose_right (send (Printf.sprintf "Total lines printed : %d" (i+1)) >>= fun () -> choose_left (stop ())) 101 | else choose_right (send s >>= fun () -> print_client (i+1)) 102 | ) 103 | 104 | let () = Lwt_main.run ( 105 | Lwt.( 106 | BP.run_processes (vending_machine ()) (vending_client_coffee 1.0) >>= fun (vm_fn,client_fn) -> 107 | async vm_fn ; 108 | client_fn () >>= fun _ -> 109 | 110 | Lwt_io.printl "" >>= fun () -> 111 | 112 | BP.run_processes (vending_client_coffee 3.0) (vending_machine ()) >>= fun (vm_fn,client_fn) -> 113 | async client_fn ; 114 | vm_fn () >>= fun _ -> 115 | 116 | Lwt_io.printl "" >>= fun () -> 117 | 118 | BP.run_processes (vending_machine ()) (vending_client_tea 1.0) >>= fun (vm_fn,client_fn) -> 119 | async vm_fn ; 120 | client_fn () >>= fun _ -> 121 | 122 | Lwt_io.printl "" >>= fun () -> 123 | 124 | BP.run_processes (vending_machine ()) (vending_client_tea 3.0) >>= fun (vm_fn,client_fn) -> 125 | async vm_fn ; 126 | client_fn () >>= fun _ -> 127 | 128 | Lwt_io.printl "" >>= fun () -> 129 | 130 | BP.run_processes (print_server ()) (print_client 1) >>= fun (vm_fn,client_fn) -> 131 | async vm_fn ; 132 | client_fn () >>= fun _ -> 133 | 134 | 135 | return () 136 | ) 137 | ) -------------------------------------------------------------------------------- /docs/Binary_session.IO.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | Binary_session.IO 15 | 16 | 17 |
 Up 18 |  Next 19 |
20 |

Module type Binary_session.IO

21 | 22 | 
module type IO = sig .. end
23 | Abstract type which can perform monadic concurrent IO.
24 |
25 |
26 | 27 | 
type 'a t
28 |
29 | The monadic light weight thread type returning value 'a.
30 |
31 | 32 | 33 | 
type chan_endpoint
34 |
35 | The abstract type representing one end of a communication channel.
36 |
37 | 38 | 39 | 
type chan =
40 | 41 | 43 | 45 | 49 |
42 | | 44 | Chan : chan_endpoint * chan_endpoint -> chan(*
46 | A channel consists of two Binary_session.IO.chan_endpoint.
47 |
48 | 		*)
50 | 51 |
52 | The abstract type representing a communication channel between two processes.
53 |
54 | 55 | 56 | 
val make_channel : unit -> chan
57 | make_channel () will return a new communication channel Binary_session.IO.chan.
58 |
59 | 60 | 
val read_channel : chan_endpoint -> 'a t
61 | read_channel end_point reads a marshalled value from end_point and returns it.
62 |
63 | 64 | 
val write_channel : 'a ->
       flags:Marshal.extern_flags list ->
       chan_endpoint -> unit t
65 | write_channel v flags end_point marshals the value v according to flags and writes it to end_point.
66 |
67 | 68 | 
val close_channel : chan -> unit t
69 | close_channel c will close the given channel c.
70 |
71 | 72 | 
val return : 'a -> 'a t
73 | return v creates a light weight thread returning v.
74 |
75 | 76 | 
val (>>=) : 'a t ->
       ('a -> 'b t) -> 'b t
77 | bind t f is a thread which first waits for the thread t to terminate and then, behaves as the application of 78 | function f to the return value of t.
79 |
80 | -------------------------------------------------------------------------------- /docs/index_values.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | Index of values 12 | 13 | 14 |
 Up 15 |  
16 |

Index of values

17 | 18 | 19 | 20 | 25 | 26 | 30 | 31 | 32 | 37 | 38 | 43 | 44 | 48 | 49 | 50 | 54 | 55 | 56 | 60 | 61 | 62 | 67 | 68 | 69 | 73 | 74 | 78 | 79 | 83 | 84 | 88 | 89 | 94 | 95 | 96 | 100 | 101 | 106 | 107 | 108 | 112 |

(>>=) [Binary_session.IO]
21 | bind t f is a thread which first waits for the thread t to terminate and then, behaves as the application of 22 | function f to the return value of t. 23 |
24 |
(>>=) [Binary_session.Binary_process]
27 | p1 >>= f creates a process which is the composition of running p1 then applying. 28 |
29 |

C
choose_left [Binary_session.Binary_process]
33 | choose_left left_choice creates a process which internally chooses left_choice and communicates this choice 34 | to the other process. 35 |
36 |
choose_right [Binary_session.Binary_process]
39 | choose_right right_choice creates a process which internally chooses rigth_choice and communicates this choice 40 | to the other process. 41 |
42 |
close_channel [Binary_session.IO]
45 | close_channel c will close the given channel c. 46 |
47 |

L
lift_io [Binary_session.Binary_process]
51 | lift_io io lifts the io computation into the process. 52 |
53 |

M
make_channel [Binary_session.IO]
57 | make_channel () will return a new communication channel Binary_session.IO.chan. 58 |
59 |

O
offer [Binary_session.Binary_process]
63 | offer left_choice right_choice creates a process which allows the other process to make a choice between 64 | two choices left_choice and right_choice. 65 |
66 |

R
read_channel [Binary_session.IO]
70 | read_channel end_point reads a marshalled value from end_point and returns it. 71 |
72 |
recv [Binary_session.Binary_process]
75 | recv () creates a process which is capable of receiving a value of type 'a to the other process. 76 |
77 |
return [Binary_session.IO]
80 | return v creates a light weight thread returning v. 81 |
82 |
return [Binary_session.Binary_process]
85 | return v creates a process which returns v its capabilities are not altered. 86 |
87 |
run_processes [Binary_session.Binary_process]
90 | run_process p1 p2 will run two processes p1 and p2 which have dual session types and which have 91 | unit as their end state capabilities (i.e., are complete processes). 92 |
93 |

S
send [Binary_session.Binary_process]
97 | send v creates a process which is capable of sending a value of type 'a (v) to the other process. 98 |
99 |
stop [Binary_session.Binary_process]
102 | stop v creates a process which stops (is not capable of performing any further operations) and returns a 103 | value v. 104 |
105 |

W
write_channel [Binary_session.IO]
109 | write_channel v flags end_point marshals the value v according to flags and writes it to end_point. 110 |
111 |
113 | 114 | -------------------------------------------------------------------------------- /src/binary_session.mli: -------------------------------------------------------------------------------- 1 | (** This module provides modules to create binary sessions types for statically verifying protocols between 2 | a pair of concurrent processes. 3 | 4 | Binary processes which are parametrized by binary session types can be created using {!modtype:Binary_process}. 5 | A pair of processes can only be run if they have compatible (dual) session types. 6 | 7 | @author essdotteedot [] 8 | @version 0.1.0 9 | *) 10 | 11 | (** A session type [('a,'b) session] represents a protocol that a particular process carries out. Here 12 | ['a] and ['b] are duals of each other. 13 | 14 | A process [('a,'b,'c) process] is parameterized by a starting session type ['b], ['a] is it's return value and ['c] is it's final 15 | session type. Two processes can be run only if they have dual initial session types a final session type of [unit]. 16 | 17 | The following operations are duals of each other : 18 | - [[`Stop]], [[`Stop]] 19 | - [[`Send of 'a * 'b]], [[`Recv of 'a * 'b]], where ['b] is a session type 20 | - [[`Offer of ('a, 'b) session * ('c, 'd) session ], [ `Choice of ('b, 'a) session * ('d, 'c) session ]], 21 | where ['a], ['b], ['c], ['d] are session types 22 | 23 | Here are some examples of processes which are duals (assume we have an implementation of {!modtype:IO} called ExIO) : 24 | 25 | {[ 26 | module BP = Binary_session.Make (ExIO) 27 | let send_str_recv_int_stop = BP.(send "hello" >>= fun () -> recv () >>= fun (i : int) -> stop ()) 28 | let recv_str_send_int_stop = BP.(recv () >>= fun (s : string) -> send 1 >>= fun () -> stop ()) 29 | let _ = BP.run_processes send_str_recv_int_stop recv_str_send_int_stop 30 | ]} 31 | 32 | Note that the session type associated with the process [send_str_recv_int_stop] was inferred as 33 | 34 | [([ `Send of string * [ `Recv of int * [ `Stop ] ] ],[ `Recv of string * [ `Send of int * [ `Stop ] ] ]) BP.session] 35 | 36 | as you can see it provides it's own session type [[ `Send of string * [ `Recv of int * [ `Stop ] ] ]] as well as it's 37 | dual [[ `Recv of string * [ `Send of int * [ `Stop ] ] ]]. 38 | 39 | The session type associated with the process [recv_str_send_int_stop] is 40 | [([ `Recv of string * [ `Send of int * [ `Stop ] ] ], [ `Send of string * [ `Recv of int * [ `Stop ] ] ]) BP.session] 41 | 42 | we see that it indeed has the dual of [send_str_recv_int_stop] which means that 43 | [BP.run_processes send_str_recv_int_stop recv_str_send_int_stop] can type check. 44 | 45 | If these two processes were to differ in such a way that they were not duals then 46 | [BP.run_processes send_str_recv_int_stop recv_str_send_int_stop] would not type check. 47 | 48 | Here is another example using [`Offer] and [`Choice] as well as recursion. 49 | 50 | {[ 51 | module BP = Binary_session.Make (ExIO) 52 | let rec print_server () = BP.( 53 | offer 54 | (stop ()) 55 | (recv () >>= fun (s : string) -> 56 | lift_io (Lwt_io.printlf "print server : %s" s) >>= 57 | print_server) 58 | ) 59 | let rec print_client (i : int) = BP.( 60 | lift_io (Lwt_io.read_line Lwt_io.stdin) >>= fun (s : string) -> 61 | if s = "q" 62 | then choose_right (send (Printf.sprintf "Total lines printed : %d" (i+1)) >>= fun () -> choose_left (stop ())) 63 | else choose_right (send s >>= fun () -> print_client (i+1)) 64 | ) 65 | let _ = BP.run_processes print_server (print_client 0) 66 | ]} 67 | *) 68 | 69 | (** Abstract type which can perform monadic concurrent IO. *) 70 | module type IO = sig 71 | 72 | type 'a t 73 | (** The monadic light weight thread type returning value ['a]. *) 74 | 75 | type chan_endpoint 76 | (** The abstract type representing one end of a communication channel. *) 77 | 78 | type chan = Chan : chan_endpoint * chan_endpoint -> chan (** A channel consists of two {!type:Binary_session.IO.chan_endpoint}. *) 79 | (** The abstract type representing a communication channel between two processes. *) 80 | 81 | val make_channel : unit -> chan 82 | (** [make_channel ()] will return a new communication channel {!type:Binary_session.IO.chan}. *) 83 | 84 | val read_channel : chan_endpoint -> 'a t 85 | (** [read_channel end_point] reads a marshalled value from [end_point] and returns it. *) 86 | 87 | val write_channel : 'a -> flags:Marshal.extern_flags list -> chan_endpoint -> unit t 88 | (** [write_channel v flags end_point] marshals the value [v] according to [flags] and writes it to [end_point]. *) 89 | 90 | val close_channel : chan -> unit t 91 | (** [close_channel c] will close the given channel [c]. *) 92 | 93 | val return : 'a -> 'a t 94 | (** [return v] creates a light weight thread returning [v]. *) 95 | 96 | val (>>=) : 'a t -> ('a -> 'b t) -> 'b t 97 | (** [bind t f] is a thread which first waits for the thread [t] to terminate and then, behaves as the application of 98 | function [f] to the return value of [t]. 99 | *) 100 | 101 | end 102 | 103 | (** A process which is parametrized by a binary session type. *) 104 | module type Binary_process = sig 105 | 106 | type 'a io 107 | (** The abstract monadic type representing a computation returning ['a]. *) 108 | 109 | type chan_endpoint 110 | (** The abstract type representing one end of a communication channel. *) 111 | 112 | type ('a,'b) session constraint 'a = [>] constraint 'b = [>] 113 | (** The type representing a communication protocol made up of a sequence of operations between two processes. 114 | The type ['a] is the sequence of operations from the point of view from the first process and ['b] 115 | its dual is the sequence of operations from the point of view of the second process. 116 | *) 117 | 118 | type ('a,'b,'c) process 119 | (** The type representing a process returning a value of type ['a]. The type ['b] represents the next allowed 120 | sequnce of operations and ['c] represents the sequence of operations after performing the first operation 121 | in ['b]. 122 | *) 123 | 124 | val send : 'a -> (unit,([`Send of 'a * 'b], [`Recv of 'a * 'c]) session, ('b,'c) session) process 125 | (** [send v] creates a process which is capable of sending a value of type ['a] ([v]) to the other process. *) 126 | 127 | val recv : unit -> ('a,([`Recv of 'a * 'b], [`Send of 'a * 'c]) session, ('b,'c) session) process 128 | (** [recv ()] creates a process which is capable of receiving a value of type ['a] to the other process. *) 129 | 130 | val offer : ('e,('a, 'b) session,'f) process -> ('e,('c, 'd) session,'f) process -> 131 | ('e,([`Offer of (('a, 'b) session * ('c, 'd) session)], [`Choice of (('b, 'a) session * ('d, 'c) session)]) session,'f) process 132 | (** [offer left_choice right_choice] creates a process which allows the other process to make a choice between 133 | two choices [left_choice] and [right_choice]. 134 | *) 135 | 136 | val choose_left : ('e,('a, 'b) session,'f) process -> 137 | ('e,([`Choice of (('a, 'b) session * ('c, 'd) session)], [`Offer of (('b, 'a) session * ('d, 'c) session)]) session,'f) process 138 | (** [choose_left left_choice] creates a process which internally chooses [left_choice] and communicates this choice 139 | to the other process. 140 | *) 141 | 142 | val choose_right : ('e,('c, 'd) session,'f) process -> 143 | ('e,([`Choice of (('a, 'b) session * ('c, 'd) session)], [`Offer of (('b, 'a) session * ('d, 'c) session)]) session,'f) process 144 | (** [choose_right right_choice] creates a process which internally chooses [rigth_choice] and communicates this choice 145 | to the other process. 146 | *) 147 | 148 | val stop : 'a -> ('a,([`Stop], [`Stop]) session, unit) process 149 | (** [stop v] creates a process which stops (is not capable of performing any further operations) and returns a 150 | value v. 151 | *) 152 | 153 | val lift_io : 'a io -> ('a, 'b, 'b) process 154 | (** [lift_io io] lifts the [io] computation into the process. The processes' capabilities are not altered. *) 155 | 156 | val return : 'a -> ('a,'b,'b) process 157 | (** [return v] creates a process which returns [v] its capabilities are not altered. *) 158 | 159 | val (>>=) : ('a,'b,'c) process -> ('a -> ('d,'c,'e) process) -> ('d,'b,'e) process 160 | (** [p1 >>= f] creates a process which is the composition of running [p1] then applying. *) 161 | 162 | val run_processes : ('a, ('b,'c) session, unit) process -> ('d, ('c,'b) session, unit) process -> ((unit -> 'a io) * (unit -> 'd io)) io 163 | (** [run_process p1 p2] will run two processes [p1] and [p2] which have dual session types and which have 164 | [unit] as their end state capabilities (i.e., are complete processes). The result is a 165 | {!type:Binary_session.IO.t} returning a pair of functions which may be invoked to run each process. 166 | 167 | Note, the channel that is opened between the two processes is closed when the processes have completed. 168 | *) 169 | 170 | end 171 | 172 | module Make (I : IO) : (Binary_process with type 'a io = 'a I.t and type chan_endpoint = I.chan_endpoint) 173 | (** Functor to create a module of type {!modtype:Binary_process} given a message module [I] of type {!modtype:IO}. *) -------------------------------------------------------------------------------- /docs/type_Binary_session_lwt.Make.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | Binary_session_lwt.Make 11 | 12 | 13 | sig
14 |   type 'a io = 'a Lwt.t
15 |   type chan_endpoint = Lwt_io.input_channel * Lwt_io.output_channel
16 |   type ('a, 'b) session constraint 'a = [>  ] constraint 'b = [>  ]
17 |   type ('a, 'b, 'c) process
18 |   val send :
19 |     'a ->
20 |     (unit,
21 |      ([ `Send of 'a * ([>  ] as 'b) ], [ `Recv of 'a * ([>  ] as 'c) ])
22 |      session, ('b, 'c) session)
23 |     process
24 |   val recv :
25 |     unit ->
26 |     ('a,
27 |      ([ `Recv of 'a * ([>  ] as 'b) ], [ `Send of 'a * ([>  ] as 'c) ])
28 |      session, ('b, 'c) session)
29 |     process
30 |   val offer :
31 |     ('e, ([>  ] as 'a, [>  ] as 'b) session, 'f) process ->
32 |     ('e, ([>  ] as 'c, [>  ] as 'd) session, 'f) process ->
33 |     ('e,
34 |      ([ `Offer of ('a, 'b) session * ('c, 'd) session ],
35 |       [ `Choice of ('b, 'a) session * ('d, 'c) session ])
36 |      session, 'f)
37 |     process
38 |   val choose_left :
39 |     ('e, ([>  ] as 'a, [>  ] as 'b) session, 'f) process ->
40 |     ('e,
41 |      ([ `Choice of ('a, 'b) session * ([>  ] as 'c, [>  ] as 'd) session ],
42 |       [ `Offer of ('b, 'a) session * ('d, 'c) session ])
43 |      session, 'f)
44 |     process
45 |   val choose_right :
46 |     ('e, ([>  ] as 'a, [>  ] as 'b) session, 'f) process ->
47 |     ('e,
48 |      ([ `Choice of ([>  ] as 'c, [>  ] as 'd) session * ('a, 'b) session ],
49 |       [ `Offer of ('d, 'c) session * ('b, 'a) session ])
50 |      session, 'f)
51 |     process
52 |   val stop : 'a -> ('a, ([ `Stop ], [ `Stop ]) session, unit) process
53 |   val lift_io : 'a io -> ('a, 'b, 'b) process
54 |   val return : 'a -> ('a, 'b, 'b) process
55 |   val ( >>= ) :
56 |     ('a, 'b, 'c) process ->
57 |     ('a -> ('d, 'c, 'e) process) -> ('d, 'b, 'e) process
58 |   val run_processes :
59 |     ('a, ([>  ] as 'b, [>  ] as 'c) session, unit) process ->
60 |     ('d, ('c, 'b) session, unit) process ->
61 |     ((unit -> 'a io) * (unit -> 'd io)) io
62 | end -------------------------------------------------------------------------------- /docs/Binary_session.Binary_process.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | Binary_session.Binary_process 15 | 16 | 17 |
Previous 18 |  Up 19 |  
20 |

Module type Binary_session.Binary_process

21 | 22 | 
module type Binary_process = sig .. end
23 | A process which is parametrized by a binary session type.
24 |
25 |
26 | 27 | 
type 'a io
28 |
29 | The abstract monadic type representing a computation returning 'a.
30 |
31 | 32 | 33 | 
type chan_endpoint
34 |
35 | The abstract type representing one end of a communication channel.
36 |
37 | 38 | 39 | 
type ([>  ], [>  ]) session
40 |
41 | The type representing a communication protocol made up of a sequence of operations between two processes. 42 | The type 'a is the sequence of operations from the point of view from the first process and 'b 43 | its dual is the sequence of operations from the point of view of the second process.
44 |
45 | 46 | 47 | 
type ('a, 'b, 'c) process
48 |
49 | The type representing a process returning a value of type 'a. The type 'b represents the next allowed 50 | sequnce of operations and 'c represents the sequence of operations after performing the first operation 51 | in 'b.
52 |
53 | 54 | 55 | 
val send : 'a ->
       (unit,
        ([ `Send of 'a * ([>  ] as 'b) ], [ `Recv of 'a * ([>  ] as 'c) ])
        session,
        ('b, 'c) session)
       process
56 | send v creates a process which is capable of sending a value of type 'a (v) to the other process.
57 |
58 | 59 | 
val recv : unit ->
       ('a,
        ([ `Recv of 'a * ([>  ] as 'b) ], [ `Send of 'a * ([>  ] as 'c) ])
        session,
        ('b, 'c) session)
       process
60 | recv () creates a process which is capable of receiving a value of type 'a to the other process.
61 |
62 | 63 | 
val offer : ('e, ([>  ] as 'a, [>  ] as 'b) session, 'f)
       process ->
       ('e, ([>  ] as 'c, [>  ] as 'd) session, 'f)
       process ->
       ('e,
        ([ `Offer of
             ('a, 'b) session *
             ('c, 'd) session ],
         [ `Choice of
             ('b, 'a) session *
             ('d, 'c) session ])
        session, 'f)
       process
64 | offer left_choice right_choice creates a process which allows the other process to make a choice between 65 | two choices left_choice and right_choice.
66 |
67 | 68 | 
val choose_left : ('e, ([>  ] as 'a, [>  ] as 'b) session, 'f)
       process ->
       ('e,
        ([ `Choice of
             ('a, 'b) session *
             ([>  ] as 'c, [>  ] as 'd) session ],
         [ `Offer of
             ('b, 'a) session *
             ('d, 'c) session ])
        session, 'f)
       process
69 | choose_left left_choice creates a process which internally chooses left_choice and communicates this choice 70 | to the other process.
71 |
72 | 73 | 
val choose_right : ('e, ([>  ] as 'a, [>  ] as 'b) session, 'f)
       process ->
       ('e,
        ([ `Choice of
             ([>  ] as 'c, [>  ] as 'd) session *
             ('a, 'b) session ],
         [ `Offer of
             ('d, 'c) session *
             ('b, 'a) session ])
        session, 'f)
       process
74 | choose_right right_choice creates a process which internally chooses rigth_choice and communicates this choice 75 | to the other process.
76 |
77 | 78 | 
val stop : 'a ->
       ('a, ([ `Stop ], [ `Stop ]) session, unit)
       process
79 | stop v creates a process which stops (is not capable of performing any further operations) and returns a 80 | value v.
81 |
82 | 83 | 
val lift_io : 'a io ->
       ('a, 'b, 'b) process
84 | lift_io io lifts the io computation into the process. The processes' capabilities are not altered.
85 |
86 | 87 | 
val return : 'a -> ('a, 'b, 'b) process
88 | return v creates a process which returns v its capabilities are not altered.
89 |
90 | 91 | 
val (>>=) : ('a, 'b, 'c) process ->
       ('a -> ('d, 'c, 'e) process) ->
       ('d, 'b, 'e) process
92 | p1 >>= f creates a process which is the composition of running p1 then applying.
93 |
94 | 95 | 
val run_processes : ('a, ([>  ] as 'b, [>  ] as 'c) session, unit)
       process ->
       ('d, ('c, 'b) session, unit)
       process ->
       ((unit -> 'a io) *
        (unit -> 'd io))
       io
96 | run_process p1 p2 will run two processes p1 and p2 which have dual session types and which have 97 | unit as their end state capabilities (i.e., are complete processes). The result is a 98 | Binary_session.IO.t returning a pair of functions which may be invoked to run each process. 99 |

100 | 101 | Note, the channel that is opened between the two processes is closed when the processes have completed.
102 |

103 | -------------------------------------------------------------------------------- /docs/Binary_session_lwt.Make.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | Binary_session_lwt.Make 14 | 15 | 16 |
 Up 17 |  
18 |

Module Binary_session_lwt.Make

19 | 20 | 
module Make: Binary_session.Binary_process  with type 'a io = 'a Lwt.t and type chan_endpoint = (Lwt_io.input_channel * Lwt_io.output_channel)
21 | Functor to create a module of type Binary_session.Binary_process.
22 |
23 |
24 | 25 | 
type 'a io
26 |
27 | The abstract monadic type representing a computation returning 'a.
28 |
29 | 30 | 31 | 
type chan_endpoint
32 |
33 | The abstract type representing one end of a communication channel.
34 |
35 | 36 | 37 | 
type ([>  ], [>  ]) session
38 |
39 | The type representing a communication protocol made up of a sequence of operations between two processes. 40 | The type 'a is the sequence of operations from the point of view from the first process and 'b 41 | its dual is the sequence of operations from the point of view of the second process.
42 |
43 | 44 | 45 | 
type ('a, 'b, 'c) process
46 |
47 | The type representing a process returning a value of type 'a. The type 'b represents the next allowed 48 | sequnce of operations and 'c represents the sequence of operations after performing the first operation 49 | in 'b.
50 |
51 | 52 | 53 | 
val send : 'a ->
       (unit,
        ([ `Send of 'a * ([>  ] as 'b) ], [ `Recv of 'a * ([>  ] as 'c) ])
        session,
        ('b, 'c) session)
       process
54 | send v creates a process which is capable of sending a value of type 'a (v) to the other process.
55 |
56 | 57 | 
val recv : unit ->
       ('a,
        ([ `Recv of 'a * ([>  ] as 'b) ], [ `Send of 'a * ([>  ] as 'c) ])
        session,
        ('b, 'c) session)
       process
58 | recv () creates a process which is capable of receiving a value of type 'a to the other process.
59 |
60 | 61 | 
val offer : ('e, ([>  ] as 'a, [>  ] as 'b) session, 'f)
       process ->
       ('e, ([>  ] as 'c, [>  ] as 'd) session, 'f)
       process ->
       ('e,
        ([ `Offer of
             ('a, 'b) session *
             ('c, 'd) session ],
         [ `Choice of
             ('b, 'a) session *
             ('d, 'c) session ])
        session, 'f)
       process
62 | offer left_choice right_choice creates a process which allows the other process to make a choice between 63 | two choices left_choice and right_choice.
64 |
65 | 66 | 
val choose_left : ('e, ([>  ] as 'a, [>  ] as 'b) session, 'f)
       process ->
       ('e,
        ([ `Choice of
             ('a, 'b) session *
             ([>  ] as 'c, [>  ] as 'd) session ],
         [ `Offer of
             ('b, 'a) session *
             ('d, 'c) session ])
        session, 'f)
       process
67 | choose_left left_choice creates a process which internally chooses left_choice and communicates this choice 68 | to the other process.
69 |
70 | 71 | 
val choose_right : ('e, ([>  ] as 'a, [>  ] as 'b) session, 'f)
       process ->
       ('e,
        ([ `Choice of
             ([>  ] as 'c, [>  ] as 'd) session *
             ('a, 'b) session ],
         [ `Offer of
             ('d, 'c) session *
             ('b, 'a) session ])
        session, 'f)
       process
72 | choose_right right_choice creates a process which internally chooses rigth_choice and communicates this choice 73 | to the other process.
74 |
75 | 76 | 
val stop : 'a ->
       ('a, ([ `Stop ], [ `Stop ]) session, unit)
       process
77 | stop v creates a process which stops (is not capable of performing any further operations) and returns a 78 | value v.
79 |
80 | 81 | 
val lift_io : 'a io ->
       ('a, 'b, 'b) process
82 | lift_io io lifts the io computation into the process. The processes' capabilities are not altered.
83 |
84 | 85 | 
val return : 'a -> ('a, 'b, 'b) process
86 | return v creates a process which returns v its capabilities are not altered.
87 |
88 | 89 | 
val (>>=) : ('a, 'b, 'c) process ->
       ('a -> ('d, 'c, 'e) process) ->
       ('d, 'b, 'e) process
90 | p1 >>= f creates a process which is the composition of running p1 then applying.
91 |
92 | 93 | 
val run_processes : ('a, ([>  ] as 'b, [>  ] as 'c) session, unit)
       process ->
       ('d, ('c, 'b) session, unit)
       process ->
       ((unit -> 'a io) *
        (unit -> 'd io))
       io
94 | run_process p1 p2 will run two processes p1 and p2 which have dual session types and which have 95 | unit as their end state capabilities (i.e., are complete processes). The result is a 96 | Binary_session.IO.t returning a pair of functions which may be invoked to run each process. 97 |

98 | 99 | Note, the channel that is opened between the two processes is closed when the processes have completed.
100 |

101 | -------------------------------------------------------------------------------- /docs/type_Binary_session.Make.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | Binary_session.Make 11 | 12 | 13 | functor (I : IO) ->
14 |   sig
15 |     type 'a io = 'a I.t
16 |     type chan_endpoint = I.chan_endpoint
17 |     type ('a, 'b) session constraint 'a = [>  ] constraint 'b = [>  ]
18 |     type ('a, 'b, 'c) process
19 |     val send :
20 |       'a ->
21 |       (unit,
22 |        ([ `Send of 'a * ([>  ] as 'b) ], [ `Recv of 'a * ([>  ] as 'c) ])
23 |        session, ('b, 'c) session)
24 |       process
25 |     val recv :
26 |       unit ->
27 |       ('a,
28 |        ([ `Recv of 'a * ([>  ] as 'b) ], [ `Send of 'a * ([>  ] as 'c) ])
29 |        session, ('b, 'c) session)
30 |       process
31 |     val offer :
32 |       ('e, ([>  ] as 'a, [>  ] as 'b) session, 'f) process ->
33 |       ('e, ([>  ] as 'c, [>  ] as 'd) session, 'f) process ->
34 |       ('e,
35 |        ([ `Offer of ('a, 'b) session * ('c, 'd) session ],
36 |         [ `Choice of ('b, 'a) session * ('d, 'c) session ])
37 |        session, 'f)
38 |       process
39 |     val choose_left :
40 |       ('e, ([>  ] as 'a, [>  ] as 'b) session, 'f) process ->
41 |       ('e,
42 |        ([ `Choice of ('a, 'b) session * ([>  ] as 'c, [>  ] as 'd) session ],
43 |         [ `Offer of ('b, 'a) session * ('d, 'c) session ])
44 |        session, 'f)
45 |       process
46 |     val choose_right :
47 |       ('e, ([>  ] as 'a, [>  ] as 'b) session, 'f) process ->
48 |       ('e,
49 |        ([ `Choice of ([>  ] as 'c, [>  ] as 'd) session * ('a, 'b) session ],
50 |         [ `Offer of ('d, 'c) session * ('b, 'a) session ])
51 |        session, 'f)
52 |       process
53 |     val stop : 'a -> ('a, ([ `Stop ], [ `Stop ]) session, unit) process
54 |     val lift_io : 'a io -> ('a, 'b, 'b) process
55 |     val return : 'a -> ('a, 'b, 'b) process
56 |     val ( >>= ) :
57 |       ('a, 'b, 'c) process ->
58 |       ('a -> ('d, 'c, 'e) process) -> ('d, 'b, 'e) process
59 |     val run_processes :
60 |       ('a, ([>  ] as 'b, [>  ] as 'c) session, unit) process ->
61 |       ('d, ('c, 'b) session, unit) process ->
62 |       ((unit -> 'a io) * (unit -> 'd io)) io
63 |   end -------------------------------------------------------------------------------- /docs/type_Binary_session_lwt.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | Binary_session_lwt 11 | 12 | 13 | sig
14 |   module Make :
15 |     sig
16 |       type 'a io = 'a Lwt.t
17 |       type chan_endpoint = Lwt_io.input_channel * Lwt_io.output_channel
18 |       type ('a, 'b) session constraint 'a = [>  ] constraint 'b = [>  ]
19 |       type ('a, 'b, 'c) process
20 |       val send :
21 |         'a ->
22 |         (unit,
23 |          ([ `Send of 'a * ([>  ] as 'b) ], [ `Recv of 'a * ([>  ] as 'c) ])
24 |          session, ('b, 'c) session)
25 |         process
26 |       val recv :
27 |         unit ->
28 |         ('a,
29 |          ([ `Recv of 'a * ([>  ] as 'b) ], [ `Send of 'a * ([>  ] as 'c) ])
30 |          session, ('b, 'c) session)
31 |         process
32 |       val offer :
33 |         ('e, ([>  ] as 'a, [>  ] as 'b) session, 'f) process ->
34 |         ('e, ([>  ] as 'c, [>  ] as 'd) session, 'f) process ->
35 |         ('e,
36 |          ([ `Offer of ('a, 'b) session * ('c, 'd) session ],
37 |           [ `Choice of ('b, 'a) session * ('d, 'c) session ])
38 |          session, 'f)
39 |         process
40 |       val choose_left :
41 |         ('e, ([>  ] as 'a, [>  ] as 'b) session, 'f) process ->
42 |         ('e,
43 |          ([ `Choice of ('a, 'b) session * ([>  ] as 'c, [>  ] as 'd) session ],
44 |           [ `Offer of ('b, 'a) session * ('d, 'c) session ])
45 |          session, 'f)
46 |         process
47 |       val choose_right :
48 |         ('e, ([>  ] as 'a, [>  ] as 'b) session, 'f) process ->
49 |         ('e,
50 |          ([ `Choice of ([>  ] as 'c, [>  ] as 'd) session * ('a, 'b) session ],
51 |           [ `Offer of ('d, 'c) session * ('b, 'a) session ])
52 |          session, 'f)
53 |         process
54 |       val stop : 'a -> ('a, ([ `Stop ], [ `Stop ]) session, unit) process
55 |       val lift_io : 'a io -> ('a, 'b, 'b) process
56 |       val return : 'a -> ('a, 'b, 'b) process
57 |       val ( >>= ) :
58 |         ('a, 'b, 'c) process ->
59 |         ('a -> ('d, 'c, 'e) process) -> ('d, 'b, 'e) process
60 |       val run_processes :
61 |         ('a, ([>  ] as 'b, [>  ] as 'c) session, unit) process ->
62 |         ('d, ('c, 'b) session, unit) process ->
63 |         ((unit -> 'a io) * (unit -> 'd io)) io
64 |     end
65 | end -------------------------------------------------------------------------------- /docs/Binary_session.Make.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | Binary_session.Make 14 | 15 | 16 |
 Up 17 |  
18 |

Functor Binary_session.Make

19 | 20 | 
module Make (I : IO) : Binary_process  with type 'a io = 'a I.t and type chan_endpoint = I.chan_endpoint
21 | Functor to create a module of type Binary_session.Binary_process given a message module I of type Binary_session.IO.
22 |
23 | 24 | 25 | 26 | 35 | 36 |
Parameters: 27 | 28 | 29 | 31 | 32 |
30 | I:IO 33 |
34 |
37 |
38 | 39 | 
type 'a io
40 |
41 | The abstract monadic type representing a computation returning 'a.
42 |
43 | 44 | 45 | 
type chan_endpoint
46 |
47 | The abstract type representing one end of a communication channel.
48 |
49 | 50 | 51 | 
type ([>  ], [>  ]) session
52 |
53 | The type representing a communication protocol made up of a sequence of operations between two processes. 54 | The type 'a is the sequence of operations from the point of view from the first process and 'b 55 | its dual is the sequence of operations from the point of view of the second process.
56 |
57 | 58 | 59 | 
type ('a, 'b, 'c) process
60 |
61 | The type representing a process returning a value of type 'a. The type 'b represents the next allowed 62 | sequnce of operations and 'c represents the sequence of operations after performing the first operation 63 | in 'b.
64 |
65 | 66 | 67 | 
val send : 'a ->
       (unit,
        ([ `Send of 'a * ([>  ] as 'b) ], [ `Recv of 'a * ([>  ] as 'c) ])
        session,
        ('b, 'c) session)
       process
68 | send v creates a process which is capable of sending a value of type 'a (v) to the other process.
69 |
70 | 71 | 
val recv : unit ->
       ('a,
        ([ `Recv of 'a * ([>  ] as 'b) ], [ `Send of 'a * ([>  ] as 'c) ])
        session,
        ('b, 'c) session)
       process
72 | recv () creates a process which is capable of receiving a value of type 'a to the other process.
73 |
74 | 75 | 
val offer : ('e, ([>  ] as 'a, [>  ] as 'b) session, 'f)
       process ->
       ('e, ([>  ] as 'c, [>  ] as 'd) session, 'f)
       process ->
       ('e,
        ([ `Offer of
             ('a, 'b) session *
             ('c, 'd) session ],
         [ `Choice of
             ('b, 'a) session *
             ('d, 'c) session ])
        session, 'f)
       process
76 | offer left_choice right_choice creates a process which allows the other process to make a choice between 77 | two choices left_choice and right_choice.
78 |
79 | 80 | 
val choose_left : ('e, ([>  ] as 'a, [>  ] as 'b) session, 'f)
       process ->
       ('e,
        ([ `Choice of
             ('a, 'b) session *
             ([>  ] as 'c, [>  ] as 'd) session ],
         [ `Offer of
             ('b, 'a) session *
             ('d, 'c) session ])
        session, 'f)
       process
81 | choose_left left_choice creates a process which internally chooses left_choice and communicates this choice 82 | to the other process.
83 |
84 | 85 | 
val choose_right : ('e, ([>  ] as 'a, [>  ] as 'b) session, 'f)
       process ->
       ('e,
        ([ `Choice of
             ([>  ] as 'c, [>  ] as 'd) session *
             ('a, 'b) session ],
         [ `Offer of
             ('d, 'c) session *
             ('b, 'a) session ])
        session, 'f)
       process
86 | choose_right right_choice creates a process which internally chooses rigth_choice and communicates this choice 87 | to the other process.
88 |
89 | 90 | 
val stop : 'a ->
       ('a, ([ `Stop ], [ `Stop ]) session, unit)
       process
91 | stop v creates a process which stops (is not capable of performing any further operations) and returns a 92 | value v.
93 |
94 | 95 | 
val lift_io : 'a io ->
       ('a, 'b, 'b) process
96 | lift_io io lifts the io computation into the process. The processes' capabilities are not altered.
97 |
98 | 99 | 
val return : 'a -> ('a, 'b, 'b) process
100 | return v creates a process which returns v its capabilities are not altered.
101 |
102 | 103 | 
val (>>=) : ('a, 'b, 'c) process ->
       ('a -> ('d, 'c, 'e) process) ->
       ('d, 'b, 'e) process
104 | p1 >>= f creates a process which is the composition of running p1 then applying.
105 |
106 | 107 | 
val run_processes : ('a, ([>  ] as 'b, [>  ] as 'c) session, unit)
       process ->
       ('d, ('c, 'b) session, unit)
       process ->
       ((unit -> 'a io) *
        (unit -> 'd io))
       io
108 | run_process p1 p2 will run two processes p1 and p2 which have dual session types and which have 109 | unit as their end state capabilities (i.e., are complete processes). The result is a 110 | Binary_session.IO.t returning a pair of functions which may be invoked to run each process. 111 |

112 | 113 | Note, the channel that is opened between the two processes is closed when the processes have completed.
114 |

115 | -------------------------------------------------------------------------------- /docs/Binary_session.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | Binary_session 15 | 16 | 17 |
 Up 18 |  Next 19 |
20 |

Module Binary_session

21 | 22 | 
module Binary_session: sig .. end
23 | This module provides modules to create binary sessions types for statically verifying protocols between 24 | a pair of concurrent processes. 25 |

26 | 27 | Binary processes which are parametrized by binary session types can be created using Binary_session.Binary_process. 28 | A pair of processes can only be run if they have compatible (dual) session types.
29 | Author(s): essdotteedot [<essdotteedot[at]gmail[dot]com>]
30 | Version: 0.1.0
31 |

32 |
33 |
34 | A session type ('a,'b) session represents a protocol that a particular process carries out. Here 35 | 'a and 'b are duals of each other. 36 |

37 | 38 | A process ('a,'b,'c) process is parameterized by a starting session type 'b, 'a is it's return value and 'c is it's final 39 | session type. Two processes can be run only if they have dual initial session types a final session type of unit. 40 |

41 | 42 | The following operations are duals of each other :

    43 |
  • [`Stop], [`Stop]
    • 44 |
  • [`Send of 'a * 'b], [`Recv of 'a * 'b], where 'b is a session type
    • 45 |
  • [`Offer of ('a, 'b) session * ('c, 'd) session ], [ `Choice of ('b, 'a) session * ('d, 'c) session ], 46 | where 'a, 'b, 'c, 'd are session types
    • 47 |
48 | 49 | Here are some examples of processes which are duals (assume we have an implementation of Binary_session.IO called ExIO) : 50 |

51 | 52 | 

      module BP = Binary_session.Make (ExIO)            

 53 |       let send_str_recv_int_stop = BP.(send "hello" >>= fun () -> recv () >>= fun (i : int) -> stop ())      

 54 |       let recv_str_send_int_stop = BP.(recv () >>= fun (s : string) -> send 1 >>= fun () -> stop ())        

 55 |       let _ = BP.run_processes send_str_recv_int_stop recv_str_send_int_stop

 56 |     
57 |

58 | 59 | Note that the session type associated with the process send_str_recv_int_stop was inferred as 60 |

61 | 62 | ([ `Send of string * [ `Recv of int * [ `Stop ] ] ],[ `Recv of string * [ `Send of int * [ `Stop ] ] ]) BP.session 63 |

64 | 65 | as you can see it provides it's own session type [ `Send of string * [ `Recv of int * [ `Stop ] ] ] as well as it's 66 | dual [ `Recv of string * [ `Send of int * [ `Stop ] ] ]. 67 |

68 | 69 | The session type associated with the process recv_str_send_int_stop is 70 | ([ `Recv of string * [ `Send of int * [ `Stop ] ] ], [ `Send of string * [ `Recv of int * [ `Stop ] ] ]) BP.session 71 |

72 | 73 | we see that it indeed has the dual of send_str_recv_int_stop which means that 74 | BP.run_processes send_str_recv_int_stop recv_str_send_int_stop can type check. 75 |

76 | 77 | If these two processes were to differ in such a way that they were not duals then 78 | BP.run_processes send_str_recv_int_stop recv_str_send_int_stop would not type check. 79 |

80 | 81 | Here is another example using `Offer and `Choice as well as recursion. 82 |

83 | 84 | 

      module BP = Binary_session.Make (ExIO)

 85 |       let rec print_server () = BP.(

 86 |           offer 

 87 |               (stop ())

 88 |                (recv () >>= fun (s : string) ->

 89 |                 lift_io (Lwt_io.printlf "print server : %s" s) >>=

 90 |                 print_server)

 91 |       )  

 92 |       let rec print_client (i : int) = BP.(

 93 |           lift_io (Lwt_io.read_line Lwt_io.stdin) >>= fun (s : string) ->

 94 |           if s = "q"

 95 |           then choose_right (send (Printf.sprintf "Total lines printed : %d" (i+1)) >>= fun () -> choose_left (stop ()))

 96 |           else choose_right (send s >>= fun () -> print_client (i+1))

 97 |       ) 

 98 |       let _ = BP.run_processes print_server (print_client 0)           

 99 |     

100 | 101 | 
module type IO = sig .. end
102 | Abstract type which can perform monadic concurrent IO. 103 |
104 | 105 | 
module type Binary_process = sig .. end
106 | A process which is parametrized by a binary session type. 107 |
108 | 109 | 
module Make (I : IO) : Binary_process  with type 'a io = 'a I.t and type chan_endpoint = I.chan_endpoint
110 | Functor to create a module of type Binary_session.Binary_process given a message module I of type Binary_session.IO. 111 |
112 | -------------------------------------------------------------------------------- /docs/type_Binary_session.Binary_process.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | Binary_session.Binary_process 11 | 12 | 13 | sig
14 |   type 'a io
15 |   type chan_endpoint
16 |   type ('a, 'b) session constraint 'a = [>  ] constraint 'b = [>  ]
17 |   type ('a, 'b, 'c) process
18 |   val send :
19 |     'a ->
20 |     (unit,
21 |      ([ `Send of 'a * ([>  ] as 'b) ], [ `Recv of 'a * ([>  ] as 'c) ])
22 |      Binary_session.Binary_process.session,
23 |      ('b, 'c) Binary_session.Binary_process.session)
24 |     Binary_session.Binary_process.process
25 |   val recv :
26 |     unit ->
27 |     ('a,
28 |      ([ `Recv of 'a * ([>  ] as 'b) ], [ `Send of 'a * ([>  ] as 'c) ])
29 |      Binary_session.Binary_process.session,
30 |      ('b, 'c) Binary_session.Binary_process.session)
31 |     Binary_session.Binary_process.process
32 |   val offer :
33 |     ('e, ([>  ] as 'a, [>  ] as 'b) Binary_session.Binary_process.session,
34 |      'f)
35 |     Binary_session.Binary_process.process ->
36 |     ('e, ([>  ] as 'c, [>  ] as 'd) Binary_session.Binary_process.session,
37 |      'f)
38 |     Binary_session.Binary_process.process ->
39 |     ('e,
40 |      ([ `Offer of
41 |           ('a, 'b) Binary_session.Binary_process.session *
42 |           ('c, 'd) Binary_session.Binary_process.session ],
43 |       [ `Choice of
44 |           ('b, 'a) Binary_session.Binary_process.session *
45 |           ('d, 'c) Binary_session.Binary_process.session ])
46 |      Binary_session.Binary_process.session, 'f)
47 |     Binary_session.Binary_process.process
48 |   val choose_left :
49 |     ('e, ([>  ] as 'a, [>  ] as 'b) Binary_session.Binary_process.session,
50 |      'f)
51 |     Binary_session.Binary_process.process ->
52 |     ('e,
53 |      ([ `Choice of
54 |           ('a, 'b) Binary_session.Binary_process.session *
55 |           ([>  ] as 'c, [>  ] as 'd) Binary_session.Binary_process.session ],
56 |       [ `Offer of
57 |           ('b, 'a) Binary_session.Binary_process.session *
58 |           ('d, 'c) Binary_session.Binary_process.session ])
59 |      Binary_session.Binary_process.session, 'f)
60 |     Binary_session.Binary_process.process
61 |   val choose_right :
62 |     ('e, ([>  ] as 'a, [>  ] as 'b) Binary_session.Binary_process.session,
63 |      'f)
64 |     Binary_session.Binary_process.process ->
65 |     ('e,
66 |      ([ `Choice of
67 |           ([>  ] as 'c, [>  ] as 'd) Binary_session.Binary_process.session *
68 |           ('a, 'b) Binary_session.Binary_process.session ],
69 |       [ `Offer of
70 |           ('d, 'c) Binary_session.Binary_process.session *
71 |           ('b, 'a) Binary_session.Binary_process.session ])
72 |      Binary_session.Binary_process.session, 'f)
73 |     Binary_session.Binary_process.process
74 |   val stop :
75 |     'a ->
76 |     ('a, ([ `Stop ], [ `Stop ]) Binary_session.Binary_process.session, unit)
77 |     Binary_session.Binary_process.process
78 |   val lift_io :
79 |     'a Binary_session.Binary_process.io ->
80 |     ('a, 'b, 'b) Binary_session.Binary_process.process
81 |   val return : 'a -> ('a, 'b, 'b) Binary_session.Binary_process.process
82 |   val ( >>= ) :
83 |     ('a, 'b, 'c) Binary_session.Binary_process.process ->
84 |     ('a -> ('d, 'c, 'e) Binary_session.Binary_process.process) ->
85 |     ('d, 'b, 'e) Binary_session.Binary_process.process
86 |   val run_processes :
87 |     ('a, ([>  ] as 'b, [>  ] as 'c) Binary_session.Binary_process.session,
88 |      unit)
89 |     Binary_session.Binary_process.process ->
90 |     ('d, ('c, 'b) Binary_session.Binary_process.session, unit)
91 |     Binary_session.Binary_process.process ->
92 |     ((unit -> 'a Binary_session.Binary_process.io) *
93 |      (unit -> 'd Binary_session.Binary_process.io))
94 |     Binary_session.Binary_process.io
95 | end -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: 96b6ec062b4d19ccdeec1ae413a4ed5a) *) 3 | module OASISGettext = struct 4 | (* # 22 "src/oasis/OASISGettext.ml" *) 5 | 6 | 7 | let ns_ str = 8 | str 9 | 10 | 11 | let s_ str = 12 | str 13 | 14 | 15 | let f_ (str: ('a, 'b, 'c, 'd) format4) = 16 | str 17 | 18 | 19 | let fn_ fmt1 fmt2 n = 20 | if n = 1 then 21 | fmt1^^"" 22 | else 23 | fmt2^^"" 24 | 25 | 26 | let init = 27 | [] 28 | 29 | 30 | end 31 | 32 | module OASISString = struct 33 | (* # 22 "src/oasis/OASISString.ml" *) 34 | 35 | 36 | (** Various string utilities. 37 | 38 | Mostly inspired by extlib and batteries ExtString and BatString libraries. 39 | 40 | @author Sylvain Le Gall 41 | *) 42 | 43 | 44 | let nsplitf str f = 45 | if str = "" then 46 | [] 47 | else 48 | let buf = Buffer.create 13 in 49 | let lst = ref [] in 50 | let push () = 51 | lst := Buffer.contents buf :: !lst; 52 | Buffer.clear buf 53 | in 54 | let str_len = String.length str in 55 | for i = 0 to str_len - 1 do 56 | if f str.[i] then 57 | push () 58 | else 59 | Buffer.add_char buf str.[i] 60 | done; 61 | push (); 62 | List.rev !lst 63 | 64 | 65 | (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the 66 | separator. 67 | *) 68 | let nsplit str c = 69 | nsplitf str ((=) c) 70 | 71 | 72 | let find ~what ?(offset=0) str = 73 | let what_idx = ref 0 in 74 | let str_idx = ref offset in 75 | while !str_idx < String.length str && 76 | !what_idx < String.length what do 77 | if str.[!str_idx] = what.[!what_idx] then 78 | incr what_idx 79 | else 80 | what_idx := 0; 81 | incr str_idx 82 | done; 83 | if !what_idx <> String.length what then 84 | raise Not_found 85 | else 86 | !str_idx - !what_idx 87 | 88 | 89 | let sub_start str len = 90 | let str_len = String.length str in 91 | if len >= str_len then 92 | "" 93 | else 94 | String.sub str len (str_len - len) 95 | 96 | 97 | let sub_end ?(offset=0) str len = 98 | let str_len = String.length str in 99 | if len >= str_len then 100 | "" 101 | else 102 | String.sub str 0 (str_len - len) 103 | 104 | 105 | let starts_with ~what ?(offset=0) str = 106 | let what_idx = ref 0 in 107 | let str_idx = ref offset in 108 | let ok = ref true in 109 | while !ok && 110 | !str_idx < String.length str && 111 | !what_idx < String.length what do 112 | if str.[!str_idx] = what.[!what_idx] then 113 | incr what_idx 114 | else 115 | ok := false; 116 | incr str_idx 117 | done; 118 | if !what_idx = String.length what then 119 | true 120 | else 121 | false 122 | 123 | 124 | let strip_starts_with ~what str = 125 | if starts_with ~what str then 126 | sub_start str (String.length what) 127 | else 128 | raise Not_found 129 | 130 | 131 | let ends_with ~what ?(offset=0) str = 132 | let what_idx = ref ((String.length what) - 1) in 133 | let str_idx = ref ((String.length str) - 1) in 134 | let ok = ref true in 135 | while !ok && 136 | offset <= !str_idx && 137 | 0 <= !what_idx do 138 | if str.[!str_idx] = what.[!what_idx] then 139 | decr what_idx 140 | else 141 | ok := false; 142 | decr str_idx 143 | done; 144 | if !what_idx = -1 then 145 | true 146 | else 147 | false 148 | 149 | 150 | let strip_ends_with ~what str = 151 | if ends_with ~what str then 152 | sub_end str (String.length what) 153 | else 154 | raise Not_found 155 | 156 | 157 | let replace_chars f s = 158 | let buf = Buffer.create (String.length s) in 159 | String.iter (fun c -> Buffer.add_char buf (f c)) s; 160 | Buffer.contents buf 161 | 162 | let lowercase_ascii = 163 | replace_chars 164 | (fun c -> 165 | if (c >= 'A' && c <= 'Z') then 166 | Char.chr (Char.code c + 32) 167 | else 168 | c) 169 | 170 | let uncapitalize_ascii s = 171 | if s <> "" then 172 | (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) 173 | else 174 | s 175 | 176 | let uppercase_ascii = 177 | replace_chars 178 | (fun c -> 179 | if (c >= 'a' && c <= 'z') then 180 | Char.chr (Char.code c - 32) 181 | else 182 | c) 183 | 184 | let capitalize_ascii s = 185 | if s <> "" then 186 | (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) 187 | else 188 | s 189 | 190 | end 191 | 192 | module OASISExpr = struct 193 | (* # 22 "src/oasis/OASISExpr.ml" *) 194 | 195 | 196 | 197 | 198 | 199 | open OASISGettext 200 | 201 | 202 | type test = string 203 | 204 | 205 | type flag = string 206 | 207 | 208 | type t = 209 | | EBool of bool 210 | | ENot of t 211 | | EAnd of t * t 212 | | EOr of t * t 213 | | EFlag of flag 214 | | ETest of test * string 215 | 216 | 217 | 218 | type 'a choices = (t * 'a) list 219 | 220 | 221 | let eval var_get t = 222 | let rec eval' = 223 | function 224 | | EBool b -> 225 | b 226 | 227 | | ENot e -> 228 | not (eval' e) 229 | 230 | | EAnd (e1, e2) -> 231 | (eval' e1) && (eval' e2) 232 | 233 | | EOr (e1, e2) -> 234 | (eval' e1) || (eval' e2) 235 | 236 | | EFlag nm -> 237 | let v = 238 | var_get nm 239 | in 240 | assert(v = "true" || v = "false"); 241 | (v = "true") 242 | 243 | | ETest (nm, vl) -> 244 | let v = 245 | var_get nm 246 | in 247 | (v = vl) 248 | in 249 | eval' t 250 | 251 | 252 | let choose ?printer ?name var_get lst = 253 | let rec choose_aux = 254 | function 255 | | (cond, vl) :: tl -> 256 | if eval var_get cond then 257 | vl 258 | else 259 | choose_aux tl 260 | | [] -> 261 | let str_lst = 262 | if lst = [] then 263 | s_ "" 264 | else 265 | String.concat 266 | (s_ ", ") 267 | (List.map 268 | (fun (cond, vl) -> 269 | match printer with 270 | | Some p -> p vl 271 | | None -> s_ "") 272 | lst) 273 | in 274 | match name with 275 | | Some nm -> 276 | failwith 277 | (Printf.sprintf 278 | (f_ "No result for the choice list '%s': %s") 279 | nm str_lst) 280 | | None -> 281 | failwith 282 | (Printf.sprintf 283 | (f_ "No result for a choice list: %s") 284 | str_lst) 285 | in 286 | choose_aux (List.rev lst) 287 | 288 | 289 | end 290 | 291 | 292 | # 292 "myocamlbuild.ml" 293 | module BaseEnvLight = struct 294 | (* # 22 "src/base/BaseEnvLight.ml" *) 295 | 296 | 297 | module MapString = Map.Make(String) 298 | 299 | 300 | type t = string MapString.t 301 | 302 | 303 | let default_filename = 304 | Filename.concat 305 | (Sys.getcwd ()) 306 | "setup.data" 307 | 308 | 309 | let load ?(allow_empty=false) ?(filename=default_filename) () = 310 | if Sys.file_exists filename then 311 | begin 312 | let chn = 313 | open_in_bin filename 314 | in 315 | let st = 316 | Stream.of_channel chn 317 | in 318 | let line = 319 | ref 1 320 | in 321 | let st_line = 322 | Stream.from 323 | (fun _ -> 324 | try 325 | match Stream.next st with 326 | | '\n' -> incr line; Some '\n' 327 | | c -> Some c 328 | with Stream.Failure -> None) 329 | in 330 | let lexer = 331 | Genlex.make_lexer ["="] st_line 332 | in 333 | let rec read_file mp = 334 | match Stream.npeek 3 lexer with 335 | | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> 336 | Stream.junk lexer; 337 | Stream.junk lexer; 338 | Stream.junk lexer; 339 | read_file (MapString.add nm value mp) 340 | | [] -> 341 | mp 342 | | _ -> 343 | failwith 344 | (Printf.sprintf 345 | "Malformed data file '%s' line %d" 346 | filename !line) 347 | in 348 | let mp = 349 | read_file MapString.empty 350 | in 351 | close_in chn; 352 | mp 353 | end 354 | else if allow_empty then 355 | begin 356 | MapString.empty 357 | end 358 | else 359 | begin 360 | failwith 361 | (Printf.sprintf 362 | "Unable to load environment, the file '%s' doesn't exist." 363 | filename) 364 | end 365 | 366 | 367 | let rec var_expand str env = 368 | let buff = 369 | Buffer.create ((String.length str) * 2) 370 | in 371 | Buffer.add_substitute 372 | buff 373 | (fun var -> 374 | try 375 | var_expand (MapString.find var env) env 376 | with Not_found -> 377 | failwith 378 | (Printf.sprintf 379 | "No variable %s defined when trying to expand %S." 380 | var 381 | str)) 382 | str; 383 | Buffer.contents buff 384 | 385 | 386 | let var_get name env = 387 | var_expand (MapString.find name env) env 388 | 389 | 390 | let var_choose lst env = 391 | OASISExpr.choose 392 | (fun nm -> var_get nm env) 393 | lst 394 | end 395 | 396 | 397 | # 397 "myocamlbuild.ml" 398 | module MyOCamlbuildFindlib = struct 399 | (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) 400 | 401 | 402 | (** OCamlbuild extension, copied from 403 | * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild 404 | * by N. Pouillard and others 405 | * 406 | * Updated on 2009/02/28 407 | * 408 | * Modified by Sylvain Le Gall 409 | *) 410 | open Ocamlbuild_plugin 411 | 412 | type conf = 413 | { no_automatic_syntax: bool; 414 | } 415 | 416 | (* these functions are not really officially exported *) 417 | let run_and_read = 418 | Ocamlbuild_pack.My_unix.run_and_read 419 | 420 | 421 | let blank_sep_strings = 422 | Ocamlbuild_pack.Lexers.blank_sep_strings 423 | 424 | 425 | let exec_from_conf exec = 426 | let exec = 427 | let env_filename = Pathname.basename BaseEnvLight.default_filename in 428 | let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in 429 | try 430 | BaseEnvLight.var_get exec env 431 | with Not_found -> 432 | Printf.eprintf "W: Cannot get variable %s\n" exec; 433 | exec 434 | in 435 | let fix_win32 str = 436 | if Sys.os_type = "Win32" then begin 437 | let buff = Buffer.create (String.length str) in 438 | (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. 439 | *) 440 | String.iter 441 | (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) 442 | str; 443 | Buffer.contents buff 444 | end else begin 445 | str 446 | end 447 | in 448 | fix_win32 exec 449 | 450 | let split s ch = 451 | let buf = Buffer.create 13 in 452 | let x = ref [] in 453 | let flush () = 454 | x := (Buffer.contents buf) :: !x; 455 | Buffer.clear buf 456 | in 457 | String.iter 458 | (fun c -> 459 | if c = ch then 460 | flush () 461 | else 462 | Buffer.add_char buf c) 463 | s; 464 | flush (); 465 | List.rev !x 466 | 467 | 468 | let split_nl s = split s '\n' 469 | 470 | 471 | let before_space s = 472 | try 473 | String.before s (String.index s ' ') 474 | with Not_found -> s 475 | 476 | (* ocamlfind command *) 477 | let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] 478 | 479 | (* This lists all supported packages. *) 480 | let find_packages () = 481 | List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) 482 | 483 | 484 | (* Mock to list available syntaxes. *) 485 | let find_syntaxes () = ["camlp4o"; "camlp4r"] 486 | 487 | 488 | let well_known_syntax = [ 489 | "camlp4.quotations.o"; 490 | "camlp4.quotations.r"; 491 | "camlp4.exceptiontracer"; 492 | "camlp4.extend"; 493 | "camlp4.foldgenerator"; 494 | "camlp4.listcomprehension"; 495 | "camlp4.locationstripper"; 496 | "camlp4.macro"; 497 | "camlp4.mapgenerator"; 498 | "camlp4.metagenerator"; 499 | "camlp4.profiler"; 500 | "camlp4.tracer" 501 | ] 502 | 503 | 504 | let dispatch conf = 505 | function 506 | | After_options -> 507 | (* By using Before_options one let command line options have an higher 508 | * priority on the contrary using After_options will guarantee to have 509 | * the higher priority override default commands by ocamlfind ones *) 510 | Options.ocamlc := ocamlfind & A"ocamlc"; 511 | Options.ocamlopt := ocamlfind & A"ocamlopt"; 512 | Options.ocamldep := ocamlfind & A"ocamldep"; 513 | Options.ocamldoc := ocamlfind & A"ocamldoc"; 514 | Options.ocamlmktop := ocamlfind & A"ocamlmktop"; 515 | Options.ocamlmklib := ocamlfind & A"ocamlmklib" 516 | 517 | | After_rules -> 518 | 519 | (* When one link an OCaml library/binary/package, one should use 520 | * -linkpkg *) 521 | flag ["ocaml"; "link"; "program"] & A"-linkpkg"; 522 | 523 | if not (conf.no_automatic_syntax) then begin 524 | (* For each ocamlfind package one inject the -package option when 525 | * compiling, computing dependencies, generating documentation and 526 | * linking. *) 527 | List.iter 528 | begin fun pkg -> 529 | let base_args = [A"-package"; A pkg] in 530 | (* TODO: consider how to really choose camlp4o or camlp4r. *) 531 | let syn_args = [A"-syntax"; A "camlp4o"] in 532 | let (args, pargs) = 533 | (* Heuristic to identify syntax extensions: whether they end in 534 | ".syntax"; some might not. 535 | *) 536 | if Filename.check_suffix pkg "syntax" || 537 | List.mem pkg well_known_syntax then 538 | (syn_args @ base_args, syn_args) 539 | else 540 | (base_args, []) 541 | in 542 | flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; 543 | flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; 544 | flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; 545 | flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; 546 | flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; 547 | 548 | (* TODO: Check if this is allowed for OCaml < 3.12.1 *) 549 | flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; 550 | flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; 551 | flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; 552 | flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; 553 | end 554 | (find_packages ()); 555 | end; 556 | 557 | (* Like -package but for extensions syntax. Morover -syntax is useless 558 | * when linking. *) 559 | List.iter begin fun syntax -> 560 | flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 561 | flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 562 | flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 563 | flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & 564 | S[A"-syntax"; A syntax]; 565 | end (find_syntaxes ()); 566 | 567 | (* The default "thread" tag is not compatible with ocamlfind. 568 | * Indeed, the default rules add the "threads.cma" or "threads.cmxa" 569 | * options when using this tag. When using the "-linkpkg" option with 570 | * ocamlfind, this module will then be added twice on the command line. 571 | * 572 | * To solve this, one approach is to add the "-thread" option when using 573 | * the "threads" package using the previous plugin. 574 | *) 575 | flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); 576 | flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); 577 | flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); 578 | flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); 579 | flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); 580 | flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); 581 | flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); 582 | flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); 583 | 584 | | _ -> 585 | () 586 | end 587 | 588 | module MyOCamlbuildBase = struct 589 | (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) 590 | 591 | 592 | (** Base functions for writing myocamlbuild.ml 593 | @author Sylvain Le Gall 594 | *) 595 | 596 | 597 | 598 | 599 | 600 | open Ocamlbuild_plugin 601 | module OC = Ocamlbuild_pack.Ocaml_compiler 602 | 603 | 604 | type dir = string 605 | type file = string 606 | type name = string 607 | type tag = string 608 | 609 | 610 | (* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) 611 | 612 | 613 | type t = 614 | { 615 | lib_ocaml: (name * dir list * string list) list; 616 | lib_c: (name * dir * file list) list; 617 | flags: (tag list * (spec OASISExpr.choices)) list; 618 | (* Replace the 'dir: include' from _tags by a precise interdepends in 619 | * directory. 620 | *) 621 | includes: (dir * dir list) list; 622 | } 623 | 624 | 625 | let env_filename = 626 | Pathname.basename 627 | BaseEnvLight.default_filename 628 | 629 | 630 | let dispatch_combine lst = 631 | fun e -> 632 | List.iter 633 | (fun dispatch -> dispatch e) 634 | lst 635 | 636 | 637 | let tag_libstubs nm = 638 | "use_lib"^nm^"_stubs" 639 | 640 | 641 | let nm_libstubs nm = 642 | nm^"_stubs" 643 | 644 | 645 | let dispatch t e = 646 | let env = 647 | BaseEnvLight.load 648 | ~filename:env_filename 649 | ~allow_empty:true 650 | () 651 | in 652 | match e with 653 | | Before_options -> 654 | let no_trailing_dot s = 655 | if String.length s >= 1 && s.[0] = '.' then 656 | String.sub s 1 ((String.length s) - 1) 657 | else 658 | s 659 | in 660 | List.iter 661 | (fun (opt, var) -> 662 | try 663 | opt := no_trailing_dot (BaseEnvLight.var_get var env) 664 | with Not_found -> 665 | Printf.eprintf "W: Cannot get variable %s\n" var) 666 | [ 667 | Options.ext_obj, "ext_obj"; 668 | Options.ext_lib, "ext_lib"; 669 | Options.ext_dll, "ext_dll"; 670 | ] 671 | 672 | | After_rules -> 673 | (* Declare OCaml libraries *) 674 | List.iter 675 | (function 676 | | nm, [], intf_modules -> 677 | ocaml_lib nm; 678 | let cmis = 679 | List.map (fun m -> (OASISString.uncapitalize_ascii m) ^ ".cmi") 680 | intf_modules in 681 | dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis 682 | | nm, dir :: tl, intf_modules -> 683 | ocaml_lib ~dir:dir (dir^"/"^nm); 684 | List.iter 685 | (fun dir -> 686 | List.iter 687 | (fun str -> 688 | flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) 689 | ["compile"; "infer_interface"; "doc"]) 690 | tl; 691 | let cmis = 692 | List.map (fun m -> dir^"/"^(OASISString.uncapitalize_ascii m)^".cmi") 693 | intf_modules in 694 | dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] 695 | cmis) 696 | t.lib_ocaml; 697 | 698 | (* Declare directories dependencies, replace "include" in _tags. *) 699 | List.iter 700 | (fun (dir, include_dirs) -> 701 | Pathname.define_context dir include_dirs) 702 | t.includes; 703 | 704 | (* Declare C libraries *) 705 | List.iter 706 | (fun (lib, dir, headers) -> 707 | (* Handle C part of library *) 708 | flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] 709 | (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; 710 | A("-l"^(nm_libstubs lib))]); 711 | 712 | flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] 713 | (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); 714 | 715 | flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] 716 | (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); 717 | 718 | (* When ocaml link something that use the C library, then one 719 | need that file to be up to date. 720 | This holds both for programs and for libraries. 721 | *) 722 | dep ["link"; "ocaml"; tag_libstubs lib] 723 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; 724 | 725 | dep ["compile"; "ocaml"; tag_libstubs lib] 726 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; 727 | 728 | (* TODO: be more specific about what depends on headers *) 729 | (* Depends on .h files *) 730 | dep ["compile"; "c"] 731 | headers; 732 | 733 | (* Setup search path for lib *) 734 | flag ["link"; "ocaml"; "use_"^lib] 735 | (S[A"-I"; P(dir)]); 736 | ) 737 | t.lib_c; 738 | 739 | (* Add flags *) 740 | List.iter 741 | (fun (tags, cond_specs) -> 742 | let spec = BaseEnvLight.var_choose cond_specs env in 743 | let rec eval_specs = 744 | function 745 | | S lst -> S (List.map eval_specs lst) 746 | | A str -> A (BaseEnvLight.var_expand str env) 747 | | spec -> spec 748 | in 749 | flag tags & (eval_specs spec)) 750 | t.flags 751 | | _ -> 752 | () 753 | 754 | 755 | let dispatch_default conf t = 756 | dispatch_combine 757 | [ 758 | dispatch t; 759 | MyOCamlbuildFindlib.dispatch conf; 760 | ] 761 | 762 | 763 | end 764 | 765 | 766 | # 766 "myocamlbuild.ml" 767 | open Ocamlbuild_plugin;; 768 | let package_default = 769 | { 770 | MyOCamlbuildBase.lib_ocaml = 771 | [("sessions", ["src"], []); ("sessions-lwt", ["src"], [])]; 772 | lib_c = []; 773 | flags = []; 774 | includes = [("examples", ["src"])] 775 | } 776 | ;; 777 | 778 | let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} 779 | 780 | let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; 781 | 782 | # 783 "myocamlbuild.ml" 783 | (* OASIS_STOP *) 784 | Ocamlbuild_plugin.dispatch dispatch_default;; 785 | --------------------------------------------------------------------------------