├── .dockerignore ├── .gitignore ├── .travis.yml ├── Dockerfile ├── Makefile ├── README.md ├── bin ├── jbuild └── main.ml ├── fuzz ├── idempotent.ml └── jbuild ├── lambda-app.opam ├── lambda-protobuf.opam ├── lambda.opam ├── mirage ├── README.md ├── config.ml ├── cstruct_buffer.ml ├── jbuild ├── key_gen.ml ├── main.ml └── unikernel.ml ├── proto ├── jbuild ├── lambda.proto ├── lambda_protobuf.ml ├── lambda_protobuf.mli ├── lambda_rpc.ml └── request.proto ├── rpc-protocol.md ├── src ├── eq.ml ├── fuzzer.ml ├── jbuild ├── lambda.ml ├── lambda.mli ├── lexer.mll ├── parser.mly ├── parsetree.ml ├── parsetree.mli ├── primitive.ml ├── primitive.mli ├── t.ml ├── typedtree.ml ├── typedtree.mli ├── value.ml └── value.mli └── test ├── jbuild ├── test.ml └── test.mli /.dockerignore: -------------------------------------------------------------------------------- 1 | _build 2 | _opam* 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .merlin 2 | _build 3 | *~ 4 | *# 5 | _opam* 6 | *.install 7 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh 3 | script: bash -ex .travis-docker.sh 4 | services: 5 | - docker 6 | env: 7 | global: 8 | - PINS="lambda:. lambda-protobuf:. crowbar:--dev" 9 | - DISTRO="debian-stable" 10 | matrix: 11 | - PACKAGE="lambda" OCAML_VERSION="4.05.0" 12 | - PACKAGE="lambda-protobuf" OCAML_VERSION="4.05.0" 13 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam2:alpine-3.7 as build 2 | 3 | ENV OPAMYES=1 4 | 5 | RUN opam pin add crowbar --dev -n 6 | RUN opam install opam-depext 7 | RUN opam depext -i jbuilder fmt logs lwt menhir higher ppx_deriving \ 8 | crowbar ocaml-protoc \ 9 | mirage-runtime mirage-block-lwt mirage-stack-lwt mirage-unix \ 10 | mirage-net-unix tcpip mirage-clock-unix mirage-block-unix \ 11 | mirage-logs 12 | 13 | COPY . /src 14 | RUN sudo chown -R opam /src 15 | WORKDIR /src 16 | 17 | RUN opam exec -- jbuilder build mirage/main.exe 18 | 19 | FROM scratch 20 | 21 | COPY --from=build /src/_build/default/mirage/main.exe /app 22 | ENTRYPOINT ["/app"] 23 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: test all clean 2 | 3 | all: 4 | jbuilder build --dev 5 | 6 | clean: 7 | jbuilder clean 8 | 9 | test: 10 | jbuilder runtest --dev 11 | 12 | block: 13 | dd if=/dev/zero of=disk.img count=1024 14 | 15 | docker: 16 | docker build -t samoht/mirage-lambda . 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## mirage-lambda -- an eDSL to ship computation to MirageOS applications 2 | 3 | Mirage Lambda allows to describe functions using a monomorphic typed 4 | lambda calculus with well-typed host primitives (for instance calls to 5 | the MirageOS APIs). A client can use the eDSL to describe the function 6 | to execute remotely. The Mirage Lambda API provides ways to parse, 7 | print, type, untype and to evaluate these terms. These functions can 8 | be used by both the client and the servers to ship code to be run on 9 | remotely. 10 | 11 | ## Installation 12 | 13 | Mirage Lambda can be installed with `opam`: 14 | 15 | opam install mirage-lambda 16 | 17 | If you don't use `opam` consult the [`opam`](opam) file for build 18 | instructions. 19 | 20 | 21 | ## Documentation 22 | 23 | The documentation and API reference is automatically generated by from 24 | the source interfaces. It can be consulted [online][doc] or via 25 | `odig doc cmdliner`. 26 | 27 | [doc]: https://mirage.github.io/mirage-lambda 28 | 29 | ## Example 30 | 31 | The factorial can be defined as a `('a, int -> int) Lambda.Expr.t` value. 32 | The `'a` is the of the environment, `int -> int` is the type of the expression: 33 | 34 | ```ocaml 35 | open Lambda 36 | 37 | let fact = 38 | let open Expr in 39 | let main = 40 | let_rec Type.("x", int ** int) Type.int (fun ~context ~return ~continue -> 41 | let acc = fst context in 42 | let n = snd context in 43 | (if_ (n = int 0) 44 | (return acc) 45 | (continue (pair (acc * n) (n - int 1)))) 46 | ) in 47 | lambda ("x", Type.int) (main $ (pair (int 1) (var Var.o))) 48 | ``` 49 | 50 | To ship the code and waiting for a server response: 51 | 52 | ```ocaml 53 | let u = Expr.untype fact in (* Generate an AST *) 54 | let s = Parsetree.to_string u in (* Pretty-print the AST *) 55 | send s >>= receive 56 | ``` 57 | 58 | The lambda server, on the other-side will receive the code, type it, and 59 | evaluate it and send the response back: 60 | 61 | ```ocaml 62 | receive () >>= fun s -> 63 | let u = parse_exn s in (* Parse *) 64 | let e = typ_exn u in (* Type *) 65 | let v = eval e in (* Evaluate *) 66 | send (string_of_value v) 67 | ``` 68 | 69 | The server can also defines a list of host function primitives that it can 70 | exposes to the clients: 71 | 72 | ```ocaml 73 | let primitives = [ 74 | primitive "string_of_int" [Type.int] Type.string string_of_int 75 | primitive "string_of_float" [Type.float] Type.string string_of_int 76 | ] in 77 | ... 78 | (* Exposes the names [string_of_int] and [string_of_float] in the context. *) 79 | let v = parse_exn ~primitives s in 80 | ... 81 | ``` 82 | 83 | ## Docker Image 84 | 85 | To run the mirage-lambda demo app: 86 | 87 | ``` 88 | $ make block # this create an empty ./disk.img 89 | $ docker run -it -v `pwd`/disk.img:/disk.img -p 1234:1234 samoht/mirage-lambda 90 | ``` 91 | 92 | This app will listen on port `1234` for incoming connections and use 93 | `./disk.img` as block-device storage backend. 94 | 95 | ## Sponsors 96 | 97 |          98 | [](http://tweag.io) 99 | -------------------------------------------------------------------------------- /bin/jbuild: -------------------------------------------------------------------------------- 1 | (executable 2 | ((name main) 3 | (public_name lambda-client) 4 | (package lambda-protobuf) 5 | (libraries (cmdliner rresult lambda lambda-protobuf)))) 6 | -------------------------------------------------------------------------------- /bin/main.ml: -------------------------------------------------------------------------------- 1 | let cstruct : Cstruct.t Lambda.Type.t = Lambda.Type.abstract "Cstruct.t" 2 | let error : string Lambda.Type.t = Lambda.Type.abstract "Block.error" 3 | 4 | let gamma = 5 | [ "Cstruct.t", (Lambda.Type.abstract_injection cstruct) 6 | ; "Block.error", (Lambda.Type.abstract_injection error) ] 7 | 8 | let primitives = 9 | let niet1 _ = assert false in 10 | let niet2 _ _ = assert false in 11 | let niet4 _ _ _ _ = assert false in 12 | Lambda.[ 13 | L.primitive "Block.read" Type.[ int64; list cstruct; ] Type.(lwt (result unit error)) niet2; 14 | primitive "Cstruct.to_string" [cstruct] Type.string niet1; 15 | primitive "Cstruct.blit" Type.[ cstruct; int; cstruct; int; int; ] Type.unit niet4; 16 | ] 17 | 18 | let pp_chr = 19 | Fmt.using 20 | (function '\032' .. '\126' as x -> x 21 | | _ -> '.') 22 | Fmt.char 23 | 24 | let pp_scalar : type buffer. get:(buffer -> int -> char) -> length:(buffer -> int) -> buffer Fmt.t 25 | = fun ~get ~length ppf b -> 26 | let l = length b in 27 | 28 | for i = 0 to l / 16 29 | do Fmt.pf ppf "%08x: " (i * 16); 30 | let j = ref 0 in 31 | 32 | while !j < 16 33 | do if (i * 16) + !j < l 34 | then Fmt.pf ppf "%02x" (Char.code @@ get b ((i * 16) + !j)) 35 | else Fmt.pf ppf " "; 36 | 37 | if !j mod 2 <> 0 then Fmt.pf ppf " "; 38 | 39 | incr j; 40 | done; 41 | 42 | Fmt.pf ppf " "; 43 | j := 0; 44 | 45 | while !j < 16 46 | do if (i * 16) + !j < l 47 | then Fmt.pf ppf "%a" pp_chr (get b ((i * 16) + !j)) 48 | else Fmt.pf ppf " "; 49 | 50 | incr j; 51 | done; 52 | 53 | Fmt.pf ppf "@\n" 54 | done 55 | 56 | let pp_string = pp_scalar ~get:String.get ~length:String.length 57 | 58 | let load_file filename = 59 | let ic = open_in filename in 60 | let ln = in_channel_length ic in 61 | let rs = Bytes.create ln in 62 | really_input ic rs 0 ln; 63 | Bytes.unsafe_to_string rs 64 | 65 | let eval ?(gamma = []) ?(primitives = []) s = 66 | match Lambda.Request.parse ~primitives ~gamma s with 67 | | Error _ as e -> e 68 | | Ok (ast, typ) -> 69 | let Lambda.Type.V typ = Lambda.Type.typ typ in 70 | match Lambda.type_and_eval ast typ with 71 | | Ok value -> Ok (Lambda.uncast typ value) 72 | | Error e -> Fmt.kstrf (fun e -> Error (`Msg e)) "%a" Lambda.pp_error e 73 | 74 | let request ~block_n ~block_size ~block_output ?(gamma = []) ?(primitives = []) s = 75 | match Lambda.Request.parse ~primitives ~gamma s with 76 | | Error _ as e -> e 77 | | Ok v -> 78 | let (ast, typ) = v in 79 | Fmt.(pf stdout) "Ready to send: %a:%a.\n%!" Lambda.Parsetree.pp ast Lambda.Parsetree.Type.pp typ; 80 | match Lambda_protobuf.to_request (ast, typ, Int64.of_int block_output) with 81 | | Error _ as e -> e 82 | | Ok request -> 83 | let encoder = Lambda_protobuf.Rpc.Encoder.default 84 | Lambda_protobuf.Rpc.Encoder.Request 85 | request 86 | (Int64.of_int block_size) 87 | (Int64.of_int block_n) 88 | in 89 | Ok encoder 90 | 91 | let make_socket addr port = 92 | Printf.printf "Connecting to %s:%d\n%!" addr port; 93 | let inet_addr = Unix.(gethostbyname addr).h_addr_list.(0) in 94 | let socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in 95 | Unix.connect socket Unix.(ADDR_INET (inet_addr, port)); 96 | Unix.out_channel_of_descr socket, Unix.in_channel_of_descr socket 97 | 98 | let src = Cstruct.create 0x8000 99 | let dst = Cstruct.create 0x8000 100 | let tmp = Bytes.create 0x8000 101 | 102 | let send_request oc blocks encoder = 103 | let open Lambda_protobuf in 104 | 105 | let rec go encoder = 106 | Format.printf "Evaluation of: %a.\n%!" Rpc.Encoder.pp encoder; 107 | 108 | match Rpc.Encoder.eval src dst encoder with 109 | | `Await t -> 110 | Fmt.(pf stdout) "> Await.\n%!"; 111 | 112 | let block_n, block_consumed = Rpc.Encoder.block t in 113 | let len = min (Cstruct.len src) (String.length blocks.(Int64.to_int block_n) - block_consumed) in 114 | Cstruct.blit_from_string blocks.(Int64.to_int block_n) block_consumed src 0 len; 115 | 116 | go (Rpc.Encoder.refill 0 len t) 117 | | `Flush t -> 118 | Fmt.(pf stdout) "> Flush.\n%!"; 119 | 120 | let chunk = Cstruct.to_string dst in 121 | output_substring oc chunk 0 (Rpc.Encoder.used_out t); 122 | 123 | Fmt.(pf stdout) "Send a chunk:\n\n%a\n%!" pp_string (String.sub chunk 0 (Rpc.Encoder.used_out t)); 124 | 125 | go (Rpc.Encoder.flush 0 0x8000 t) 126 | | `Error (_, err) -> 127 | Fmt.epr "Retrieve an error: %a\n%!" Rpc.Encoder.pp_error err 128 | | `End t -> 129 | Fmt.(pf stdout) "> End: %a.\n%!" Rpc.Encoder.pp t; 130 | 131 | if Rpc.Encoder.used_out t > 0 132 | then (let chunk = Cstruct.to_string dst in output_substring oc chunk 0 (Rpc.Encoder.used_out t)); 133 | 134 | Fmt.(pf stdout) "Send a chunk:\n\n%a\n%!" pp_string (String.sub (Cstruct.to_string dst) 0 (Rpc.Encoder.used_out t)); 135 | 136 | flush oc in 137 | go encoder 138 | 139 | let receive_reply ic decoder = 140 | let open Lambda_protobuf in 141 | 142 | let clean_and_return buffer = 143 | let ret = Buffer.contents buffer in 144 | Buffer.clear buffer; ret in 145 | 146 | let buffer_protobuf = Buffer.create 0x800 in 147 | let buffer_block = Buffer.create 0x800 in 148 | 149 | let rec go blocks t = match Rpc.Decoder.eval src t with 150 | | `Await t -> 151 | let len = input ic tmp 0 (Bytes.length tmp) in 152 | Cstruct.blit_from_bytes tmp 0 src 0 len; 153 | go blocks (Rpc.Decoder.refill 0 len t) 154 | | `Flush (t, `Protobuf, raw) -> 155 | Buffer.add_string buffer_protobuf (Cstruct.to_string raw); 156 | go blocks (Rpc.Decoder.flush t) 157 | | `Flush (t, `Block n, raw) -> 158 | let blocks = 159 | if Int64.to_int n = List.length blocks 160 | then blocks 161 | else (clean_and_return buffer_block :: blocks) in 162 | Buffer.add_string buffer_block (Cstruct.to_string raw); 163 | go blocks (Rpc.Decoder.flush t) 164 | | `Error (_, err) -> 165 | Fmt.epr "Retrieve an error: %a.\n%!" Rpc.Decoder.pp_error err 166 | | `End _ -> 167 | let blocks = 168 | if Buffer.length buffer_block > 0 169 | then (clean_and_return buffer_block :: blocks) 170 | else blocks in 171 | 172 | Fmt.(pf stdout) ">>> protobuf:\n\n%a.\n%!" pp_string (Buffer.contents buffer_protobuf); 173 | 174 | let reply = Buffer.contents buffer_protobuf in 175 | let decoder = Pbrt.Decoder.of_bytes (Bytes.unsafe_of_string reply) in 176 | let reply = Pb.decode_reply decoder in 177 | let gamma = 178 | List.fold_left (fun acc (k, v) -> 179 | Lambda_protobuf.Gamma.add k v acc 180 | ) Lambda_protobuf.Gamma.empty gamma 181 | in 182 | let reply = of_reply ~gamma reply in 183 | 184 | let pp ppf = function 185 | | Ok (Lambda.Parsetree.V { v; pp; _ }) -> pp ppf v 186 | | Error (`Msg err) -> Fmt.pf ppf "(Error: %s)" err in 187 | 188 | Fmt.(pf stdout) ">>> receive: %a.\n%!" pp reply; 189 | List.iteri (fun idx block -> Fmt.(pf stdout) "block %d:\n\n%a\n%!" idx pp_string block) (List.rev blocks) in 190 | go [] decoder 191 | 192 | let repl ?(block_n = 0) ?(block_size = 0) ~block_output (socketo, socketi) blocks = 193 | let rec go () = 194 | output_string stdout "# "; 195 | flush stdout; 196 | 197 | match input_line stdin with 198 | | expr -> 199 | (match request ~block_n ~block_size ~block_output ~primitives ~gamma expr with 200 | | Ok encoder -> 201 | send_request socketo blocks encoder; 202 | Fmt.(pf stdout) "Send a lambda-calculus expression.\n%!"; 203 | receive_reply socketi (Lambda_protobuf.Rpc.(Decoder.default Reply)); 204 | go () 205 | | Error (`Msg e) -> Fmt.epr "Retrieve an error: %s" e) 206 | | exception End_of_file -> () in go () 207 | 208 | let main host port output blocks = 209 | let blocks = List.map load_file blocks in 210 | let socket = make_socket host port in 211 | 212 | let status = 213 | let lens = List.map String.length blocks in 214 | 215 | try 216 | if List.for_all ((=) (List.hd lens)) lens 217 | then Ok (Some (List.length blocks, List.hd lens)) 218 | else Error (Rresult.R.msgf "Size of blocks mismatchs") 219 | with _ -> Ok None in 220 | 221 | match status with 222 | | Ok (Some (block_n, block_size)) -> 223 | repl ~block_n ~block_size ~block_output:output socket (Array.of_list blocks); `Ok () 224 | | Ok None -> 225 | repl socket ~block_output:output [||]; `Ok () 226 | | Error (`Msg err) -> `Error (true, err) 227 | 228 | open Cmdliner 229 | 230 | let port = 231 | let doc = "Port to the unikernel" in 232 | Arg.(value & opt int 1234 & info ["p"; "port"] ~doc ~docv:"") 233 | 234 | let host = 235 | let doc = "Hostname to the unikernel" in 236 | Arg.(value & opt string "localhost" & info ["h"; "host"] ~doc ~docv:"") 237 | 238 | let file = 239 | let parser s = 240 | if Sys.file_exists s 241 | then Ok s else Error (Rresult.R.msgf "%s does not exist" s) in 242 | let pp = Fmt.string in 243 | Arg.conv (parser, pp) 244 | 245 | let blocks = 246 | let doc = "List of blocks to send to the unikernel" in 247 | Arg.(value & opt (list file) [] & info ["blocks"] ~doc ~docv:"") 248 | 249 | let output = 250 | let doc = "Expected output blocks" in 251 | Arg.(required & opt (some int) None & info ["o"; "output"] ~doc ~docv:"") 252 | 253 | let cmd = 254 | let doc = "Binary example to communicate with unikernel." in 255 | let exits = Term.default_exits in 256 | Term.(ret (const main $ host $ port $ output $ blocks)), 257 | Term.info "main" ~version:"" ~doc ~exits 258 | 259 | let () = Term.(exit @@ eval cmd) 260 | -------------------------------------------------------------------------------- /fuzz/idempotent.ml: -------------------------------------------------------------------------------- 1 | open Lambda.Fuzzer 2 | open Crowbar 3 | 4 | let pp ppf _ = assert false 5 | 6 | let () = 7 | add_test ~name:"idempotent" [ unsafe_expr_gen ] @@ fun unsafe_expr -> 8 | match Lambda.typ unsafe_expr with 9 | | Error _ -> bad_test () 10 | | Ok (Lambda.Expr.V (expr, ty)) -> 11 | let unsafe_expr' = Lambda.Expr.untype expr in 12 | match Lambda.typ unsafe_expr' with 13 | | Error err -> Crowbar.fail (Fmt.strf "type(untype(type(expr))): %a" (Fmt.hvbox Lambda.pp_error) err) 14 | | Ok (Lambda.Expr.V (expr', ty')) -> 15 | check_eq ~pp:Lambda.Parsetree.pp ~eq:Lambda.Parsetree.equal 16 | (Lambda.Expr.untype expr) (Lambda.Expr.untype expr') 17 | -------------------------------------------------------------------------------- /fuzz/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (executable 4 | ((name idempotent) 5 | (libraries (lambda)))) 6 | -------------------------------------------------------------------------------- /lambda-app.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "Thomas Gazagnaire " 3 | authors: ["Thomas Gazagnaire" "Romain Calascibetta"] 4 | homepage: "https://github.com/samoht/mirage-lambda" 5 | license: "ISC" 6 | dev-repo: "https://github.com/samoht/mirage-lambda.git" 7 | bug-reports: "https://github.com/samoht/mirage-lambda/issues" 8 | 9 | build: [ "jbuilder" "build" "-p" name "-j" jobs ] 10 | depends: [ 11 | "jbuilder" {build} 12 | "mirage" 13 | "lambda" 14 | "mirage-runtime" 15 | "mirage-block-lwt" 16 | "mirage-stack-lwt" 17 | "mirage-unix" 18 | "mirage-net-unix" 19 | "tcpip" 20 | "mirage-clock-unix" 21 | "mirage-block-unix" 22 | "mirage-logs" 23 | ] 24 | -------------------------------------------------------------------------------- /lambda-protobuf.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "Thomas Gazagnaire " 3 | authors: ["Thomas Gazagnaire" "Romain Calascibetta"] 4 | homepage: "https://github.com/samoht/mirage-lambda" 5 | license: "ISC" 6 | dev-repo: "https://github.com/samoht/mirage-lambda.git" 7 | bug-reports: "https://github.com/samoht/mirage-lambda/issues" 8 | 9 | build: [ "jbuilder" "build" "-p" name "-j" jobs ] 10 | depends: [ 11 | "jbuilder" {build} 12 | "ocaml-protoc" 13 | "lambda" 14 | "cstruct" 15 | "rresult" 16 | ] 17 | -------------------------------------------------------------------------------- /lambda.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "Thomas Gazagnaire " 3 | authors: ["Thomas Gazagnaire" "Romain Calascibetta"] 4 | homepage: "https://github.com/samoht/mirage-lambda" 5 | license: "ISC" 6 | dev-repo: "https://github.com/samoht/mirage-lambda.git" 7 | bug-reports: "https://github.com/samoht/mirage-lambda/issues" 8 | 9 | build: [ "jbuilder" "build" "-p" name "-j" jobs ] 10 | depends: [ 11 | "jbuilder" {build} 12 | "fmt" 13 | "logs" 14 | "lwt" 15 | "menhir" 16 | "higher" 17 | "ppx_deriving" 18 | "crowbar" 19 | "alcotest" {test} 20 | ] 21 | -------------------------------------------------------------------------------- /mirage/README.md: -------------------------------------------------------------------------------- 1 | ## Instructions 2 | 3 | 4 | ### Install MirageOS 5 | 6 | ``` 7 | opam install mirage 8 | ``` 9 | 10 | ### Configure the application 11 | 12 | For testing on Unix: 13 | 14 | ``` 15 | $ mirage configure --network=unix 16 | ... 17 | $ make depends 18 | ... 19 | $ mirage build 20 | ... 21 | $ ls main.native 22 | main.native 23 | ``` 24 | 25 | ### Run the application 26 | 27 | ``` 28 | $ ./main.native -p 1234 & 29 | $ nc localhost 1234 30 | # 1 + 2*2 31 | 5 32 | # let x: int = 3 in x*x 33 | 9 34 | ``` 35 | -------------------------------------------------------------------------------- /mirage/config.ml: -------------------------------------------------------------------------------- 1 | (* from mirage-skeleton/device-usage/block *) 2 | open Mirage 3 | 4 | (* configuration step to create disk.img *) 5 | type img = Img 6 | let img = Type Img 7 | 8 | let img = impl @@ object 9 | inherit base_configurable 10 | method clean _i = Bos.OS.File.delete (Fpath.v "disk.img") 11 | method module_name = "Functoria_runtime" 12 | method name = "img" 13 | method ty = img 14 | 15 | method packages = Key.pure [ 16 | package ~build:true "bos"; 17 | package ~build:true "fpath"; 18 | ] 19 | 20 | method build _i = 21 | let open Bos in 22 | OS.Cmd.run Cmd.(v "dd" % "if=/dev/zero" % "of=disk.img" % "count=100000") 23 | end 24 | 25 | let port = 26 | let doc = 27 | Key.Arg.info 28 | ~doc:"The TCP port on which to listen for incoming connections." 29 | ["p"; "port"] 30 | in 31 | Key.(create "port" Arg.(opt int 1234 doc)) 32 | 33 | let disk = 34 | let doc = 35 | Key.Arg.info 36 | ~doc:"The path to the block device to use." 37 | ["d"; "disk"] 38 | in 39 | Key.(create "disk" Arg.(opt string "./disk.img" doc)) 40 | 41 | let () = 42 | register "lambda" [ 43 | foreign "Unikernel.Main" 44 | ~packages:[ package "lambda" 45 | ; package "lambda-protobuf" 46 | ; package "rresult" ] 47 | ~deps:[abstract img] 48 | ~keys:[Key.abstract port; Key.abstract disk] 49 | (block @-> stackv4 @-> job) 50 | $ block_of_file "XXX" 51 | $ generic_stackv4 default_network 52 | ] 53 | -------------------------------------------------------------------------------- /mirage/cstruct_buffer.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2017 Thomas Gazagnaire 3 | * and Romain Calascibetta 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | module String = Buffer 19 | 20 | type t = 21 | { mutable buf : Cstruct.t 22 | ; mutable pos : int 23 | ; mutable len : int 24 | ; init : Cstruct.t } 25 | 26 | type raw = string 27 | type fixe = Cstruct.t 28 | 29 | let create n = 30 | let n = if n < 1 then 1 else n in 31 | let n = if n > Sys.max_string_length then Sys.max_string_length else n in 32 | let buf = Cstruct.create n in 33 | { buf; pos = 0; len = n; init = buf; } 34 | 35 | let contents { buf; pos; _ } = 36 | Cstruct.copy buf 0 pos 37 | 38 | let unsafe_contents { buf; pos; _ } = 39 | Cstruct.sub buf 0 pos 40 | 41 | let has { pos; _ } = pos 42 | 43 | let resize t more = 44 | let len = t.len in 45 | let new_len = ref len in 46 | 47 | while t.pos + more > !new_len do new_len := 2 * !new_len done; 48 | 49 | if !new_len > Sys.max_string_length 50 | then begin 51 | if t.pos + more <= Sys.max_string_length 52 | then new_len := Sys.max_string_length 53 | else failwith "Cstruct_buffer.add: cannot grow buffer" 54 | end; 55 | 56 | let new_buffer = Cstruct.create !new_len in 57 | Cstruct.blit t.buf 0 new_buffer 0 t.pos; 58 | t.buf <- new_buffer; 59 | t.len <- !new_len 60 | 61 | let add t fixe = 62 | let len = Cstruct.len fixe in 63 | let new_pos = t.pos + len in 64 | 65 | if new_pos > t.len then resize t len; 66 | Cstruct.blit fixe 0 t.buf t.pos len; 67 | t.pos <- new_pos 68 | 69 | let clear t = t.pos <- 0 70 | let reset t = 71 | t.pos <- 0; 72 | t.buf <- t.init; 73 | t.len <- Cstruct.len t.init 74 | -------------------------------------------------------------------------------- /mirage/jbuild: -------------------------------------------------------------------------------- 1 | (executable 2 | ((name main) 3 | (flags (:standard -cclib -static)) 4 | (libraries (lambda-protobuf mirage-runtime 5 | mirage-block-lwt mirage-stack-lwt 6 | mirage-unix mirage-net-unix 7 | tcpip.stack-socket 8 | mirage-block-unix mirage-logs 9 | mirage-clock-unix)))) 10 | -------------------------------------------------------------------------------- /mirage/key_gen.ml: -------------------------------------------------------------------------------- 1 | (* Generated by mirage configure --net=socket (Wed, 18 Jul 2018 13:48:14 GMT). *) 2 | 3 | let dhcp () = false 4 | 5 | let disk =Functoria_runtime.Key.create 6 | (Functoria_runtime.Arg.opt Cmdliner.Arg.string "./disk.img" (Cmdliner.Arg.info 7 | ~docs:"APPLICATION OPTIONS" ?docv:(None) 8 | ?doc:(Some "The path to the block device to use. ") ?env:(None) 9 | ["d"; "disk"])) 10 | let disk_t = Functoria_runtime.Key.term disk 11 | let disk () = Functoria_runtime.Key.get disk 12 | 13 | let interfaces =Functoria_runtime.Key.create 14 | (Functoria_runtime.Arg.opt (Cmdliner.Arg.list Mirage_runtime.Arg.ipv4_address) 15 | [(Ipaddr.V4.t_of_sexp (Sexplib.Sexp.of_string "0.0.0.0"))] (Cmdliner.Arg.info 16 | ~docs:"UNIKERNEL PARAMETERS" ?docv:(Some "INTERFACES") 17 | ?doc:(Some "The interfaces bound by the socket in the unikernel. ") 18 | ?env:(None) ["interfaces"])) 19 | let interfaces_t = Functoria_runtime.Key.term interfaces 20 | let interfaces () = Functoria_runtime.Key.get interfaces 21 | 22 | let logs =Functoria_runtime.Key.create 23 | (Functoria_runtime.Arg.opt (Cmdliner.Arg.list Mirage_runtime.Arg.log_threshold) [] (Cmdliner.Arg.info 24 | ~docs:"UNIKERNEL PARAMETERS" ?docv:(Some "LEVEL") 25 | ?doc:(Some 26 | "Be more or less verbose. $(docv) must be of the form\n$(b,*:info,foo:debug) means that that the log threshold is set to\n$(b,info) for every log sources but the $(b,foo) which is set to\n$(b,debug). ") 27 | ?env:(Some (Cmdliner.Arg.env_var "MIRAGE_LOGS")) ["l"; "logs"])) 28 | let logs_t = Functoria_runtime.Key.term logs 29 | let logs () = Functoria_runtime.Key.get logs 30 | 31 | let net () = `Socket 32 | 33 | let port =Functoria_runtime.Key.create 34 | (Functoria_runtime.Arg.opt Cmdliner.Arg.int 1234 (Cmdliner.Arg.info 35 | ~docs:"APPLICATION OPTIONS" ?docv:(None) 36 | ?doc:(Some "The TCP port on which to listen for incoming connections. ") 37 | ?env:(None) ["p"; "port"])) 38 | let port_t = Functoria_runtime.Key.term port 39 | let port () = Functoria_runtime.Key.get port 40 | 41 | let prng () = `Stdlib 42 | 43 | let socket =Functoria_runtime.Key.create 44 | (Functoria_runtime.Arg.opt (Cmdliner.Arg.some Mirage_runtime.Arg.ipv4_address) 45 | (None) (Cmdliner.Arg.info ~docs:"UNIKERNEL PARAMETERS" 46 | ?docv:(Some "SOCKET") 47 | ?doc:(Some "The address bounds by the socket in the unikernel. ") 48 | ?env:(None) ["socket"])) 49 | let socket_t = Functoria_runtime.Key.term socket 50 | let socket () = Functoria_runtime.Key.get socket 51 | 52 | let target () = `MacOSX 53 | 54 | let target_debug () = false 55 | 56 | let warn_error () = false 57 | 58 | let runtime_keys = List.combine [disk_t; interfaces_t; logs_t; port_t; 59 | socket_t] ["disk"; "interfaces"; "logs"; 60 | "port"; "socket"] 61 | 62 | -------------------------------------------------------------------------------- /mirage/main.ml: -------------------------------------------------------------------------------- 1 | (* Generated by mirage configure --net=socket (Wed, 18 Jul 2018 13:48:14 GMT). *) 2 | 3 | open Lwt.Infix 4 | let return = Lwt.return 5 | let run = 6 | OS.Main.run 7 | 8 | let _ = Printexc.record_backtrace true 9 | 10 | module Unikernel1 = Unikernel.Main(Block)(Tcpip_stack_socket) 11 | 12 | module Mirage_logs1 = Mirage_logs.Make(Pclock) 13 | 14 | let tcpv4_socket11 = lazy ( 15 | Tcpv4_socket.connect (Key_gen.socket ()) 16 | ) 17 | 18 | let udpv4_socket11 = lazy ( 19 | Udpv4_socket.connect (Key_gen.socket ()) 20 | ) 21 | 22 | let argv_unix1 = lazy ( 23 | OS.Env.argv () 24 | ) 25 | 26 | let img1 = lazy ( 27 | return () 28 | ) 29 | 30 | let block11 = lazy ( 31 | Block.connect (Key_gen.disk ()) 32 | ) 33 | 34 | let stackv4_socket1 = lazy ( 35 | let __udpv4_socket11 = Lazy.force udpv4_socket11 in 36 | let __tcpv4_socket11 = Lazy.force tcpv4_socket11 in 37 | __udpv4_socket11 >>= fun _udpv4_socket11 -> 38 | __tcpv4_socket11 >>= fun _tcpv4_socket11 -> 39 | let config = { Mirage_stack_lwt.name = "stackv4_socket"; 40 | interface = (Key_gen.interfaces ()) ;} in 41 | Tcpip_stack_socket.connect config _udpv4_socket11 _tcpv4_socket11 42 | ) 43 | 44 | let pclock1 = lazy ( 45 | Pclock.connect () 46 | ) 47 | 48 | let key1 = lazy ( 49 | let __argv_unix1 = Lazy.force argv_unix1 in 50 | __argv_unix1 >>= fun _argv_unix1 -> 51 | return (Functoria_runtime.with_argv (List.map fst Key_gen.runtime_keys) "lambda" _argv_unix1) 52 | ) 53 | 54 | let noop1 = lazy ( 55 | return () 56 | ) 57 | 58 | let f11 = lazy ( 59 | let __block11 = Lazy.force block11 in 60 | let __stackv4_socket1 = Lazy.force stackv4_socket1 in 61 | let __img1 = Lazy.force img1 in 62 | __block11 >>= fun _block11 -> 63 | __stackv4_socket1 >>= fun _stackv4_socket1 -> 64 | __img1 >>= fun _img1 -> 65 | Unikernel1.start _block11 _stackv4_socket1 _img1 66 | ) 67 | 68 | let mirage_logs1 = lazy ( 69 | let __pclock1 = Lazy.force pclock1 in 70 | __pclock1 >>= fun _pclock1 -> 71 | let ring_size = None in 72 | let reporter = Mirage_logs1.create ?ring_size _pclock1 in 73 | Mirage_runtime.set_level ~default:Logs.Info (Key_gen.logs ()); 74 | Mirage_logs1.set_reporter reporter; 75 | Lwt.return reporter 76 | ) 77 | 78 | let mirage1 = lazy ( 79 | let __noop1 = Lazy.force noop1 in 80 | let __noop1 = Lazy.force noop1 in 81 | let __key1 = Lazy.force key1 in 82 | let __mirage_logs1 = Lazy.force mirage_logs1 in 83 | let __f11 = Lazy.force f11 in 84 | __noop1 >>= fun _noop1 -> 85 | __noop1 >>= fun _noop1 -> 86 | __key1 >>= fun _key1 -> 87 | __mirage_logs1 >>= fun _mirage_logs1 -> 88 | __f11 >>= fun _f11 -> 89 | Lwt.return_unit 90 | ) 91 | 92 | let () = 93 | let t = 94 | Lazy.force noop1 >>= fun _ -> 95 | Lazy.force noop1 >>= fun _ -> 96 | Lazy.force key1 >>= fun _ -> 97 | Lazy.force mirage_logs1 >>= fun _ -> 98 | Lazy.force mirage1 99 | in run t 100 | -------------------------------------------------------------------------------- /mirage/unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module type BLOCK = Mirage_block_lwt.S 4 | module type TCP = Mirage_stack_lwt.V4 5 | 6 | [@@@warning "-40"] 7 | 8 | let pp_chr = 9 | Fmt.using 10 | (function '\032' .. '\126' as x -> x 11 | | _ -> '.') 12 | Fmt.char 13 | 14 | let pp_scalar : type buffer. get:(buffer -> int -> char) -> length:(buffer -> int) -> buffer Fmt.t 15 | = fun ~get ~length ppf b -> 16 | let l = length b in 17 | 18 | for i = 0 to l / 16 19 | do Fmt.pf ppf "%08x: " (i * 16); 20 | let j = ref 0 in 21 | 22 | while !j < 16 23 | do if (i * 16) + !j < l 24 | then Fmt.pf ppf "%02x" (Char.code @@ get b ((i * 16) + !j)) 25 | else Fmt.pf ppf " "; 26 | 27 | if !j mod 2 <> 0 then Fmt.pf ppf " "; 28 | 29 | incr j; 30 | done; 31 | 32 | Fmt.pf ppf " "; 33 | j := 0; 34 | 35 | while !j < 16 36 | do if (i * 16) + !j < l 37 | then Fmt.pf ppf "%a" pp_chr (get b ((i * 16) + !j)) 38 | else Fmt.pf ppf " "; 39 | 40 | incr j; 41 | done; 42 | 43 | Fmt.pf ppf "@\n" 44 | done 45 | 46 | let pp_string = pp_scalar ~get:String.get ~length:String.length 47 | let pp_bytes = pp_scalar ~get:Bytes.get ~length:Bytes.length 48 | let pp_cstruct = pp_scalar ~get:Cstruct.get_char ~length:Cstruct.len 49 | 50 | let log_src = Logs.Src.create "lambda" ~doc:"lambda" 51 | module Log = (val Logs.src_log log_src : Logs.LOG) 52 | 53 | module Main (B: BLOCK) (S: TCP) = struct 54 | 55 | module AbstractTypes = struct 56 | (* XXX(dinosaure): we need to define types at top-level. *) 57 | 58 | let cstruct = Lambda.Type.abstract "Cstruct.t" 59 | let formatter = Lambda.Type.abstract "Format.formatter" 60 | let error = Lambda.Type.abstract "Block.error" 61 | let write_error = Lambda.Type.abstract "Block.write_error" 62 | let info = Lambda.Type.abstract "Mirage_block.info" 63 | end 64 | 65 | let make_environment b = 66 | let open AbstractTypes in 67 | let open Lambda_protobuf in 68 | List.fold_left 69 | (fun primitives (k, v) -> match v with 70 | | Lambda.Parsetree.Prm primitive -> Primitives.add k primitive primitives 71 | | _ -> Fmt.invalid_arg "Invalid expression as primitive") 72 | Primitives.empty 73 | Lambda.[ 74 | primitive "stdout" [ ] formatter Format.(formatter_of_out_channel stdout) 75 | ; primitive "stderr" [ ] formatter Format.(formatter_of_out_channel stderr) 76 | ; primitive "Block.error_to_string" [ error; ] 77 | Type.string (Format.asprintf "%a%!" B.pp_error) 78 | ; primitive "Block.write_error_to_string" [ write_error ] 79 | Type.string (Format.asprintf "%a%!" B.pp_write_error) 80 | ; primitive "Block.pp_error" [ formatter; error; ] 81 | Type.unit B.pp_error 82 | ; primitive "Block.pp_write_error" [ formatter; write_error; ] 83 | Type.unit B.pp_write_error 84 | ; L.primitive "Block.disconnect" [ Type.unit ] 85 | Type.(lwt unit) (fun () -> B.disconnect b) 86 | ; L.primitive "Block.get_info" [ Type.unit ] 87 | Type.(lwt info) (fun () -> B.get_info b) 88 | ; primitive "read_write" [ info ] 89 | Type.bool (fun b -> b.Mirage_block.read_write) 90 | ; primitive "sector_size" [ info ] 91 | Type.int (fun b -> b.Mirage_block.sector_size) 92 | ; primitive "size_sectors" [ info ] 93 | Type.int64 (fun b -> b.Mirage_block.size_sectors) 94 | ; L.primitive "Block.read" Type.[ int64; list cstruct; ] 95 | Type.(lwt (result unit error)) B.(read b) 96 | ; L.primitive "Block.write" Type.[ int64; list cstruct; ] 97 | Type.(lwt (result unit write_error)) B.(write b) 98 | ; primitive "Cstruct.to_bytes" [ cstruct ] 99 | Type.bytes Cstruct.to_bytes 100 | ; primitive "Cstruct.of_bytes" [ Type.bytes ] 101 | cstruct (fun s -> Cstruct.of_bytes s) 102 | ; primitive "Cstruct.blit" Type.[ cstruct; int; cstruct; int; int; ] 103 | Type.unit Cstruct.blit 104 | ; primitive "Cstruct.blit_to_bytes" Type.[ cstruct; int; bytes; int; int; ] 105 | Type.unit Cstruct.blit_to_bytes 106 | ; primitive "Cstruct.blit_from_bytes" Type.[ bytes; int; cstruct; int; int; ] 107 | Type.unit Cstruct.blit_from_bytes 108 | ; primitive "Cstruct.get_uint8" Type.[ cstruct; int; ] 109 | Type.int Cstruct.get_uint8 110 | ; primitive "Cstruct.set_uint8" Type.[ cstruct; int; int; ] 111 | Type.unit Cstruct.set_uint8 112 | ; primitive "Cstruct.LE.get_uint16" Type.[ cstruct; int; ] 113 | Type.int Cstruct.LE.get_uint16 114 | ; primitive "Cstruct.LE.get_uint32" Type.[ cstruct; int; ] 115 | Type.int32 Cstruct.LE.get_uint32 116 | ; primitive "Cstruct.LE.get_uint64" Type.[ cstruct; int; ] 117 | Type.int64 Cstruct.LE.get_uint64 118 | ; primitive "Cstruct.BE.get_uint16" Type.[ cstruct; int; ] 119 | Type.int Cstruct.BE.get_uint16 120 | ; primitive "Cstruct.BE.get_uint32" Type.[ cstruct; int; ] 121 | Type.int32 Cstruct.BE.get_uint32 122 | ; primitive "Cstruct.BE.get_uint64" Type.[ cstruct; int; ] 123 | Type.int64 Cstruct.BE.get_uint64 124 | ; primitive "Cstruct.LE.set_uint16" Type.[ cstruct; int; int; ] 125 | Type.unit Cstruct.LE.set_uint16 126 | ; primitive "Cstruct.LE.set_uint32" Type.[ cstruct; int; int32; ] 127 | Type.unit Cstruct.LE.set_uint32 128 | ; primitive "Cstruct.LE.set_uint64" Type.[ cstruct; int; int64; ] 129 | Type.unit Cstruct.LE.set_uint64 130 | ; primitive "Cstruct.BE.set_uint16" Type.[ cstruct; int; int; ] 131 | Type.unit Cstruct.BE.set_uint16 132 | ; primitive "Cstruct.BE.set_uint32" Type.[ cstruct; int; int32; ] 133 | Type.unit Cstruct.BE.set_uint32 134 | ; primitive "Cstruct.BE.set_uint64" Type.[ cstruct; int; int64; ] 135 | Type.unit Cstruct.BE.set_uint64 136 | ; primitive "int64_of_int" Type.[ int; ] 137 | Type.int64 Int64.of_int 138 | ; primitive "int64_to_int" Type.[ int64; ] 139 | Type.int Int64.to_int 140 | ; primitive "int32_of_int" Type.[ int; ] 141 | Type.int32 Int32.of_int 142 | ; primitive "int32_to_int" Type.[ int32 ] 143 | Type.int Int32.to_int 144 | ], 145 | List.fold_left 146 | (fun gamma (k, v) -> Gamma.add k v gamma) 147 | Gamma.empty 148 | [ "Format.formatter", Lambda.Type.abstract_injection formatter 149 | ; "Block.error", Lambda.Type.abstract_injection error 150 | ; "Cstruct.t", Lambda.Type.abstract_injection cstruct 151 | ; "Mirage_block.info", Lambda.Type.abstract_injection info 152 | ; "Block.write_error", Lambda.Type.abstract_injection write_error ] 153 | 154 | let bind_err flow x f = 155 | x >>= function 156 | | Ok () -> f () 157 | | Error e -> 158 | Log.err (fun l -> l "Got %a, closing" S.TCPV4.pp_write_error e); 159 | S.TCPV4.close flow 160 | 161 | let result: type a. a Lambda.Type.t -> a -> (a, _) result Lwt.t = 162 | fun ret x -> 163 | match ret with 164 | | Lambda.Type.Apply (ty, Lambda.Type.Lwt) -> 165 | let Lambda.Type.App x = x in 166 | let x = Lambda.Type.Lwt.prj x in 167 | x >|= fun x -> 168 | let x = Lambda.Expr.return x in 169 | Ok x 170 | | _ -> 171 | Lwt.return (Ok x) 172 | 173 | let err fmt = Fmt.kstrf (fun e -> Lwt.return (Error (`Msg e))) fmt 174 | let list_init n f = 175 | let rec go acc = function 176 | | 0 -> List.rev acc 177 | | n -> go (f n :: acc) (n - 1) in 178 | go [] n 179 | 180 | let eval ~block_size ~blocks ~gamma ~primitives request = 181 | let allocated_outputs = ref None in 182 | let request_extracted = ref None in 183 | 184 | (* XXX(dinosaure): order (and control flow) to set references is __very__ 185 | important to know where computation leaks exception - and by this way, be 186 | able to respond the best error message to the client. 187 | 188 | TODO(dinosaure): wrap this stuff in result monad. *) 189 | 190 | try 191 | Log.info (fun l -> l "Parse protobuf request:\n\n%a%!" pp_string request); 192 | 193 | let request = Pbrt.Decoder.of_bytes (Bytes.unsafe_of_string request) in 194 | let request = Lambda_protobuf.Pb.decode_request request in 195 | 196 | request_extracted := Some request; 197 | 198 | let ast, ret, output = Lambda_protobuf.of_request ~gamma ~primitives request in 199 | let Lambda.Type.V ret = Lambda.Type.typ ret in 200 | let expected = 201 | Lambda.Type.(list AbstractTypes.cstruct 202 | @-> list AbstractTypes.cstruct 203 | @-> ret) 204 | in 205 | let outputs = 206 | list_init 207 | (Int64.to_int output) 208 | (fun _ -> Cstruct.create (Int64.to_int block_size)) 209 | in 210 | 211 | allocated_outputs := Some (output, outputs); 212 | 213 | (match Lambda.type_and_eval ast expected with 214 | | Error e -> err "%a" Lambda.pp_error e 215 | | Ok f -> result ret (f blocks outputs)) 216 | >|= fun res -> 217 | 218 | let pp_value = Lambda.Type.pp_val ret in 219 | 220 | Logs.info (fun l -> l "Process and eval: %a => %a.\n%!" 221 | Lambda.Parsetree.pp ast 222 | (Fmt.Dump.result ~ok:pp_value ~error:Rresult.R.pp_msg) res); 223 | 224 | let res = Rresult.R.map (Lambda.uncast ret) res in 225 | let res = Lambda_protobuf.to_reply res in 226 | let encoder = Lambda_protobuf.Rpc.Encoder.(default Reply res block_size output) in 227 | 228 | Ok (outputs, encoder) 229 | with exn -> match !allocated_outputs, !request_extracted with 230 | | Some (output, outputs), _ -> 231 | (* XXX(dinosaure): exception leaks after [Lambda_protobuf.of_request]. *) 232 | Logs.err (fun l -> l "Got an error with allocated outputs: %a" Fmt.exn exn); 233 | let res = Lambda_protobuf.to_reply (Rresult.R.error_msgf "%a" Fmt.exn exn) in 234 | let encoder = Lambda_protobuf.Rpc.Encoder.(default Reply res block_size output) in 235 | Lwt.return_ok (outputs, encoder) 236 | | None, Some request -> 237 | (* XXX(dinosaure): exceptions leaks after [Lambda_protobuf.Pb.decode_request] and 238 | before [Lambda_protobuf.of_request]. *) 239 | let output = Lambda_protobuf.output_of_request request in 240 | let outputs = 241 | list_init 242 | (Int64.to_int output) 243 | (fun _ -> Cstruct.create (Int64.to_int block_size)) in 244 | let res = Lambda_protobuf.to_reply (Rresult.R.error_msgf "%a" Fmt.exn exn) in 245 | let encoder = Lambda_protobuf.Rpc.Encoder.(default Reply res block_size output) in 246 | Lwt.return_ok (outputs, encoder) 247 | | None, None -> 248 | (* XXX(dinosaure): exception leaks before [Lambda_protobuf.Pb.decode_request]. *) 249 | Logs.err (fun l -> l "Got an error: %a" Fmt.exn exn); 250 | err "%a" Fmt.exn exn 251 | 252 | let send flow (blocks, encoder) = 253 | let (>>?) = bind_err flow in 254 | let open Lambda_protobuf in 255 | 256 | let src = Cstruct.create 0x8000 in 257 | let dst = Cstruct.create 0x8000 in 258 | 259 | let rec loop encoder = match Rpc.Encoder.eval src dst encoder with 260 | | `Await t -> 261 | let block_n, block_consumed = Rpc.Encoder.block t in 262 | let len = 263 | min 264 | (Cstruct.len src) 265 | (Cstruct.len (List.nth blocks (Int64.to_int block_n)) - block_consumed) 266 | in 267 | Cstruct.blit (List.nth blocks (Int64.to_int block_n)) block_consumed src 0 len; 268 | loop (Rpc.Encoder.refill 0 len t) 269 | 270 | | `Flush t -> 271 | S.TCPV4.write flow (Cstruct.sub dst 0 (Rpc.Encoder.used_out t)) >>? fun () -> 272 | loop (Rpc.Encoder.flush 0 (Cstruct.len dst) t) 273 | | `Error (_, err) -> 274 | Log.err (fun f -> 275 | f "Retrieve an error when we encode reply: %a." Rpc.Encoder.pp_error err); 276 | Lwt.return_unit 277 | | `End t -> 278 | (if Rpc.Encoder.used_out t > 0 279 | then S.TCPV4.write flow (Cstruct.sub dst 0 (Rpc.Encoder.used_out t)) 280 | else Lwt.return_ok ()) >>? fun () -> 281 | Lwt.return_unit in 282 | loop encoder 283 | 284 | let process ~gamma ~primitives flow = 285 | let dst, dst_port = S.TCPV4.dst flow in 286 | 287 | Logs.info (fun f -> 288 | f "new tcp connection from IP %a on port %d" 289 | Ipaddr.V4.pp_hum dst dst_port); 290 | 291 | let buffer = Buffer.create 512 in 292 | let block_buffer = Cstruct_buffer.create 512 in 293 | let decoder = Lambda_protobuf.Rpc.(Decoder.default Request) in 294 | 295 | let (>>?) v f = v >>= function 296 | | Ok v -> f v 297 | | Error (`Msg err) -> 298 | Log.err (fun f -> f "Got an evaluation error: %s." err); 299 | Lwt.return_unit in 300 | 301 | let rec loop blocks decoder = 302 | S.TCPV4.read flow >>= function 303 | | Ok `Eof -> 304 | Logs.info (fun f -> f "Closing connection!"); 305 | Lwt.return_unit 306 | | Error e -> 307 | Logs.warn (fun f -> 308 | f "Error reading data from established connection: %a" 309 | S.TCPV4.pp_error e); 310 | Lwt.return_unit 311 | | Ok (`Data src) -> 312 | 313 | let rec go blocks decoder = 314 | Log.info (fun f -> f "State of the decoder: %a." Lambda_protobuf.Rpc.Decoder.pp decoder); 315 | 316 | match Lambda_protobuf.Rpc.Decoder.eval src decoder with 317 | | `Await decoder -> Lwt.return (decoder, blocks) 318 | | `Flush (decoder, `Protobuf, raw) -> 319 | Buffer.add_string buffer (Cstruct.to_string raw); 320 | go blocks (Lambda_protobuf.Rpc.Decoder.flush decoder) 321 | | `Flush (decoder, `Block n, raw) -> 322 | let blocks = 323 | if Int64.to_int n = List.length blocks then blocks 324 | else 325 | (Log.info (fun f -> 326 | f "Retrieve block %d:\n\n%a\n%!" 327 | (List.length blocks) 328 | pp_string (Cstruct_buffer.contents block_buffer)) 329 | ; let block = Cstruct_buffer.contents block_buffer in 330 | Cstruct_buffer.clear block_buffer 331 | ; block :: blocks) in 332 | 333 | Cstruct_buffer.add block_buffer raw; 334 | 335 | go blocks (Lambda_protobuf.Rpc.Decoder.flush decoder) 336 | | `Error (decoder, err) -> 337 | Logs.warn (fun f -> 338 | f "Retrieve an error: %a." 339 | Lambda_protobuf.Rpc.Decoder.pp_error err); 340 | Lwt.return (Lambda_protobuf.Rpc.Decoder.reset decoder, []) 341 | | `End decoder -> 342 | 343 | let blocks = 344 | if Cstruct_buffer.has block_buffer > 0 345 | then (Log.info (fun f -> 346 | f "Retrieve block %d:\n%a\n%!" 347 | (List.length blocks) 348 | pp_string (Cstruct_buffer.contents block_buffer)) 349 | ; let block = Cstruct_buffer.contents block_buffer in 350 | Cstruct_buffer.clear block_buffer 351 | ; block :: blocks) 352 | else blocks in 353 | 354 | eval 355 | ~block_size:(Lambda_protobuf.Rpc.Decoder.block_size decoder) 356 | ~blocks:(List.map (fun x -> Cstruct.of_string x) (List.rev blocks)) 357 | ~gamma 358 | ~primitives 359 | (Buffer.contents buffer) 360 | >>? send flow >|= fun () -> 361 | Buffer.clear buffer; 362 | (Lambda_protobuf.Rpc.Decoder.reset decoder, []) 363 | in 364 | 365 | go blocks (Lambda_protobuf.Rpc.Decoder.refill 0 (Cstruct.len src) decoder) 366 | >>= fun (decoder, blocks) -> 367 | loop blocks decoder 368 | in 369 | loop [] decoder 370 | 371 | let start b s () = 372 | let primitives, gamma = make_environment b in 373 | 374 | let port = Key_gen.port () in 375 | S.listen_tcpv4 s ~port (process ~gamma ~primitives); 376 | S.listen s 377 | 378 | end 379 | -------------------------------------------------------------------------------- /proto/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (rule 4 | ((targets (lambda_types.ml lambda_types.mli lambda_pb.ml lambda_pb.mli)) 5 | (deps (lambda.proto)) 6 | (action (run ocaml-protoc -binary -ml_out . lambda.proto)))) 7 | 8 | (library 9 | ((name lambda_protobuf) 10 | (flags (:standard -w -30)) 11 | (public_name lambda-protobuf) 12 | (libraries (lambda cstruct ocaml-protoc)))) 13 | -------------------------------------------------------------------------------- /proto/lambda.proto: -------------------------------------------------------------------------------- 1 | syntax = "proto2"; 2 | 3 | message Type { 4 | message Unit { } 5 | message Int { } 6 | message Int32 { } 7 | message Int64 { } 8 | message Bool { } 9 | message String { } 10 | message Bytes { } 11 | message Lwt { } 12 | message List { 13 | required Type value = 1; 14 | } 15 | message Array { 16 | required Type value = 1; 17 | } 18 | message Option { 19 | required Type value = 1; 20 | } 21 | message Apply { 22 | required Type a = 1; 23 | required Type b = 2; 24 | } 25 | message Arrow { 26 | required Type a = 1; 27 | required Type b = 2; 28 | } 29 | message Pair { 30 | required Type a = 1; 31 | required Type b = 2; 32 | } 33 | message Either { 34 | required Type a = 1; 35 | required Type b = 2; 36 | } 37 | message Result { 38 | required Type a = 1; 39 | required Type b = 2; 40 | } 41 | message Abstract { 42 | required string witness = 1; 43 | } 44 | 45 | oneof t { 46 | Unit unit = 1; 47 | Int int = 2; 48 | Int32 int32 = 3; 49 | Int64 int64 = 4; 50 | Bool bool = 5; 51 | String string = 6; 52 | Lwt lwt = 7; 53 | List list = 8; 54 | Array array = 9; 55 | Option option = 10; 56 | Apply apply = 11; 57 | Arrow arrow = 12; 58 | Pair pair = 13; 59 | Either either = 14; 60 | Result result = 15; 61 | Abstract abstract = 16; 62 | Bytes bytes = 17; 63 | } 64 | } 65 | 66 | message Primitive { 67 | required string name = 1; 68 | repeated Type arguments = 2; 69 | required Type return = 3; 70 | } 71 | 72 | enum Binop { 73 | ADD = 1; 74 | SUB = 2; 75 | MUL = 3; 76 | DIV = 4; 77 | PAIR = 5; 78 | EQ = 6; 79 | GET = 7; 80 | SHIFTL = 8; 81 | SHIFTR = 9; 82 | OR = 10; 83 | XOR = 11; 84 | AND = 12; 85 | } 86 | 87 | message Unop { 88 | message Fst { } 89 | message Snd { } 90 | message L { required Type value = 1; } 91 | message R { required Type value = 1; } 92 | message Ok { required Type value = 1; } 93 | message Error { required Type value = 1; } 94 | message Prj { } 95 | message Not { } 96 | 97 | oneof t { 98 | Fst fst = 1; 99 | Snd snd = 2; 100 | L l = 3; 101 | R r = 4; 102 | Ok ok = 5; 103 | Error error = 6; 104 | Prj prj = 7; 105 | Not not = 8; 106 | } 107 | } 108 | 109 | message Value { 110 | message Unit { } 111 | message Int { required int32 value = 1; } 112 | message Int32 { required int32 value = 1; } 113 | message Int64 { required int64 value = 1; } 114 | message Bool { required bool value = 1; } 115 | message String { required string value = 1; } 116 | message Bytes { required bytes value = 1; } 117 | message List { 118 | required Type typ = 1; 119 | repeated Value value = 2; 120 | } 121 | message Array { 122 | required Type typ = 1; 123 | repeated Value value = 2; 124 | } 125 | message Option { 126 | required Type typ = 1; 127 | optional Value value = 2; 128 | } 129 | message Pair { 130 | required Value a = 1; 131 | required Value b = 2; 132 | } 133 | message Result { 134 | message Ok { required Value value = 1; } 135 | message Error { required Value value = 1; } 136 | message ResultValue { 137 | oneof t { 138 | Ok ok = 1; 139 | Error error = 2; 140 | } 141 | } 142 | required ResultValue value = 1; 143 | required Type typ_ok = 2; 144 | required Type typ_error = 3; 145 | } 146 | message Either { 147 | message Left { required Value value = 1; } 148 | message Right { required Value value = 1; } 149 | message EitherValue { 150 | oneof t { 151 | Left left = 1; 152 | Right right = 2; 153 | } 154 | } 155 | required EitherValue value = 1; 156 | required Type typ_l = 2; 157 | required Type typ_r = 3; 158 | } 159 | message Return { 160 | required Type typ = 1; 161 | required Value value = 2; 162 | } 163 | 164 | oneof t { 165 | Unit unit = 1; 166 | Int int = 2; 167 | Int32 int32 = 3; 168 | Int64 int64 = 4; 169 | Bool bool = 5; 170 | String string = 6; 171 | List list = 7; 172 | Array array = 8; 173 | Option option = 9; 174 | Pair pair = 10; 175 | Bytes bytes = 11; 176 | Result result = 12; 177 | Either either = 13; 178 | Return return = 14; 179 | } 180 | } 181 | 182 | message Expr { 183 | message Val { required Value value = 1; } 184 | message Prm { required Primitive value = 1; } 185 | message Lst { optional Type typ = 1; 186 | repeated Expr expr = 2; } 187 | message Arr { optional Type typ = 1; 188 | repeated Expr expr = 2; } 189 | message Opt { required Type typ = 1; 190 | optional Expr expr = 2; } 191 | message Ret { required Expr expr = 1; } 192 | message Bnd { required Expr expr = 1; 193 | required Expr func = 2; } 194 | message Var { required int32 var = 1; } 195 | message Lam { required Type typ = 1; 196 | required string var = 2; 197 | required Expr expr = 3; } 198 | message Rec { required Type ret = 1; 199 | required string name = 2; 200 | required Type argument = 3; 201 | required Expr expr = 4; } 202 | message App { required Expr a = 1; 203 | required Expr b = 2; } 204 | message Bin { 205 | required Binop op = 1; 206 | required Expr a = 2; 207 | required Expr b = 3; 208 | } 209 | message Uno { 210 | required Unop op = 1; 211 | required Expr x = 2; 212 | } 213 | message Let { 214 | required Type typ = 1; 215 | required string name = 2; 216 | required Expr expr = 3; 217 | required Expr body = 4; 218 | } 219 | message Swt { 220 | required Expr a = 1; 221 | required Expr b = 2; 222 | required Expr s = 3; 223 | } 224 | message If { 225 | required Expr a = 1; 226 | required Expr b = 2; 227 | required Expr s = 3; 228 | } 229 | 230 | oneof t { 231 | Val val = 1; 232 | Prm prm = 2; 233 | Lst lst = 3; 234 | Arr arr = 4; 235 | Opt opt = 5; 236 | Var var = 6; 237 | Lam lam = 7; 238 | Rec rec = 8; 239 | App app = 9; 240 | Bin bin = 10; 241 | Uno uno = 11; 242 | Let let = 12; 243 | Swt swt = 13; 244 | If if = 14; 245 | Ret ret = 15; 246 | Bnd bnd = 16; 247 | } 248 | } 249 | 250 | message Request { 251 | required Expr expr = 1; 252 | required Type typ = 2; 253 | required int64 output = 3; 254 | } 255 | 256 | message Reply { 257 | oneof t { 258 | Value value = 1; 259 | string error = 2; 260 | } 261 | } -------------------------------------------------------------------------------- /proto/lambda_protobuf.ml: -------------------------------------------------------------------------------- 1 | module Types = Lambda_types 2 | module Pb = Lambda_pb 3 | module Rpc = Lambda_rpc 4 | 5 | type error = [`Msg of string] 6 | 7 | type ('a, 'b) either = ('a, 'b) Lambda.Value.either = 8 | | L of 'a 9 | | R of 'b 10 | 11 | let opt_eq ~eq a b = match a, b with 12 | | Some a, Some b -> eq a b 13 | | None, None -> true 14 | | _, _ -> false 15 | 16 | let lst_eq ~eq a b = 17 | try List.for_all2 eq a b 18 | with _ -> false 19 | 20 | let arr_eq ~eq a b = 21 | try List.for_all2 eq (Array.to_list a) (Array.to_list b) 22 | with _ -> false 23 | 24 | let pair_eq ~eqa ~eqb (x, y) (a, b) = eqa x a && eqb y b 25 | 26 | let either_eq ~eql ~eqr a b = match a, b with 27 | | L a, L b -> eql a b 28 | | R a, R b -> eqr a b 29 | | _, _ -> false 30 | 31 | let result_eq ~eq_ok ~eq_error a b = match a, b with 32 | | Ok a, Ok b -> eq_ok a b 33 | | Error a, Error b -> eq_error a b 34 | | _, _ -> false 35 | 36 | let pp_either 37 | : ppl:'a Fmt.t -> ppr:'b Fmt.t -> ('a, 'b) Lambda.Value.either Fmt.t 38 | = fun ~ppl ~ppr ppf -> function 39 | | L l -> Fmt.pf ppf "(L %a)" ppl l 40 | | R r -> Fmt.pf ppf "(R %a)" ppr r 41 | 42 | open Lambda.Parsetree 43 | 44 | module Gamma = Map.Make(String) 45 | module Primitives = Map.Make(String) 46 | 47 | let to_typ ~gamma x = 48 | let rec go : Types.type_ -> Type.t = function 49 | | Types.Unit -> Type.unit 50 | | Types.Int -> Type.int 51 | | Types.Int32 -> Type.int32 52 | | Types.Int64 -> Type.int64 53 | | Types.Bool -> Type.bool 54 | | Types.String -> Type.string 55 | | Types.Bytes -> Type.bytes 56 | | Types.Lwt -> Type.lwt 57 | | Types.List { value; } -> Type.list (go value) 58 | | Types.Array { value; } -> Type.array (go value) 59 | | Types.Option { value; } -> Type.option (go value) 60 | | Types.Apply { a; b; } -> Type.apply (go a) (go b) 61 | | Types.Arrow { a; b; } -> Type.(go a @-> go b) 62 | | Types.Pair { a; b; } -> Type.(go a ** go b) 63 | | Types.Either { a; b; } -> Type.(go a || go b) 64 | | Types.Result { a; b; } -> Type.result (go a) (go b) 65 | | Types.Abstract { witness; } -> 66 | try Type.unsafe_abstract (Gamma.find witness gamma) 67 | with Not_found -> Fmt.invalid_arg "Abstract type %s not found" witness 68 | in 69 | go x 70 | 71 | let of_typ = 72 | let rec go : Type.t -> Types.type_ = function 73 | | Type.Unit -> Types.Unit 74 | | Type.Int -> Types.Int 75 | | Type.Int32 -> Types.Int32 76 | | Type.Int64 -> Types.Int64 77 | | Type.Bool -> Types.Bool 78 | | Type.String -> Types.String 79 | | Type.Bytes -> Types.Bytes 80 | | Type.Lwt -> Types.Lwt 81 | | Type.List t -> Types.List { value = go t } 82 | | Type.Array t -> Types.Array { value = go t } 83 | | Type.Option t -> Types.Option { value = go t } 84 | | Type.Apply (a, b) -> Types.Apply { a = go a; b = go b; } 85 | | Type.Arrow (a, b) -> Types.Arrow { a = go a; b = go b; } 86 | | Type.Pair (a, b) -> Types.Pair { a = go a; b = go b; } 87 | | Type.Either (a, b) -> Types.Either { a = go a; b = go b; } 88 | | Type.Result (a, b) -> Types.Result { a = go a; b = go b; } 89 | | Type.Abstract (Type.A (eq, _)) -> Types.Abstract { witness = eq.Lambda.Eq.name } 90 | in go 91 | 92 | let to_binop : binop -> Types.binop = function 93 | | `Add -> Types.Add 94 | | `Sub -> Types.Sub 95 | | `Mul -> Types.Mul 96 | | `Div -> Types.Div 97 | | `Pair -> Types.Pair 98 | | `Eq -> Types.Eq 99 | | `Get -> Types.Get 100 | | `ShiftL -> Types.Shiftl 101 | | `ShiftR -> Types.Shiftr 102 | | `Or -> Types.Or 103 | | `Xor -> Types.Xor 104 | | `And -> Types.And 105 | 106 | let to_unop : unop -> Types.unop = function 107 | | Prj -> Types.Prj 108 | | Fst -> Types.Fst 109 | | Snd -> Types.Snd 110 | | L t -> Types.L { value = of_typ t } 111 | | R t -> Types.R { value = of_typ t } 112 | | Ok t -> Types.Ok { value = of_typ t } 113 | | Error t -> Types.Error { value = of_typ t } 114 | | Not -> Types.Not 115 | 116 | let state (Lambda.Type.App x) = match Lwt.state (Lambda.Type.Lwt.prj x) with 117 | | Return x -> Some x 118 | | _ -> None 119 | 120 | let of_value ~gamma ?(unwrap = true) x = 121 | let to_typ = to_typ ~gamma in 122 | let rec go: Types.value -> value = function 123 | | Types.Unit -> 124 | V { v = (); t = Unit; 125 | pp = (fun ppf () -> Fmt.pf ppf "()"); eq = (fun () () -> true); } 126 | | Types.Int { value; } -> 127 | V { v = Int32.to_int value; t = Int; pp = Fmt.int; eq = Pervasives.(=); } 128 | | Types.Int32 { value; } -> 129 | V { v = value; t = Int32; pp = Fmt.int32; eq = Pervasives.(=) } 130 | | Types.Int64 { value; } -> 131 | V { v = value; t = Int64; pp = Fmt.int64; eq = Pervasives.(=) } 132 | | Types.Bool { value; } -> 133 | V { v = value; t = Bool; pp = Fmt.bool; eq = Pervasives.(=) } 134 | | Types.String { value; } -> 135 | V { v = value; t = String; pp = Fmt.string; eq = Pervasives.(=) } 136 | | Types.Bytes { value; } -> 137 | V { v = value; t = Bytes; 138 | pp = Fmt.using Bytes.unsafe_to_string Fmt.string; eq = Pervasives.(=) } 139 | | Types.Option { typ; value = Some value; } -> 140 | let V { v; t; pp; eq; } = go value in 141 | let Lambda.Type.V t' = Lambda.Type.typ (to_typ typ) in 142 | (match Lambda.Type.equal t t' with 143 | | Some Lambda.Eq.Refl -> V { v = Some v; t = Option t; 144 | pp = Fmt.option pp; eq = opt_eq ~eq } 145 | | None -> Fmt.invalid_arg "Cannot unify %a and %a" 146 | Lambda.Type.pp t 147 | Lambda.Type.pp t') 148 | | Types.Option { typ; value = None; } -> 149 | let Lambda.Type.V t = Lambda.Type.typ (to_typ typ) in 150 | let pp = Lambda.Type.pp_val t in 151 | let eq = Lambda.Type.eq_val t in 152 | V { v = None; t = Option t; pp = Fmt.option pp; eq = opt_eq ~eq } 153 | | Types.List { typ; value = []; } -> 154 | let Lambda.Type.V t = Lambda.Type.typ (to_typ typ) in 155 | let pp = Lambda.Type.pp_val t in 156 | let eq = Lambda.Type.eq_val t in 157 | V { v = []; t = List t; pp = Fmt.list pp; eq = lst_eq ~eq } 158 | | Types.Array { typ; value = []; } -> 159 | let Lambda.Type.V t = Lambda.Type.typ (to_typ typ) in 160 | let pp = Lambda.Type.pp_val t in 161 | let eq = Lambda.Type.eq_val t in 162 | V { v = [||]; t = Array t; pp = Fmt.array pp; eq = arr_eq ~eq } 163 | | Types.List { typ; value; } -> 164 | let Lambda.Type.V t' = Lambda.Type.typ (to_typ typ) in 165 | let pp = Lambda.Type.pp_val (List t') in 166 | let eq = Lambda.Type.eq_val (List t') in 167 | let rec aux acc = function 168 | | [] -> 169 | let V { v; t; pp; eq; } = acc in 170 | (match Lambda.Type.equal t (List t') with 171 | | Some Lambda.Eq.Refl -> V { v = List.rev v; t; pp; eq; } 172 | | None -> Fmt.invalid_arg "Cannot unify %a and %a" 173 | Lambda.Type.pp t 174 | Lambda.Type.pp (List t')) 175 | | x :: r -> 176 | let V { v = x; t; pp = _; eq = _; } = go x in 177 | let V { v = acc; t = tacc; pp; eq; } = acc in 178 | (match Lambda.Type.equal t t', Lambda.Type.equal (List t) tacc with 179 | | Some Lambda.Eq.Refl, Some Lambda.Eq.Refl -> 180 | aux (V { v = x :: acc; t = List t; pp; eq; }) r 181 | | _, _ -> Fmt.invalid_arg "Cannot unify %a and %a" 182 | Lambda.Type.pp t 183 | Lambda.Type.pp t) in 184 | aux (V { v = []; t = List t'; pp; eq; }) value 185 | | Types.Array { typ; value; } -> 186 | let Lambda.Type.V t' = Lambda.Type.typ (to_typ typ) in 187 | let pp = Lambda.Type.pp_val (List t') in 188 | let eq = Lambda.Type.eq_val (List t') in 189 | let cast (V { v; t; _ }) = match Lambda.Type.equal (List t') t with 190 | | Some Lambda.Eq.Refl -> 191 | let pp = Lambda.Type.pp_val (Array t') in 192 | let eq = Lambda.Type.eq_val (Array t') in 193 | V { v = Array.of_list v; t = Array t'; pp; eq; } 194 | | None -> Fmt.invalid_arg "Cannot unify %a and %a" 195 | Lambda.Type.pp (List t') 196 | Lambda.Type.pp t in 197 | let rec aux acc = function 198 | | [] -> 199 | let V { v; t; pp; eq; } = acc in 200 | (match Lambda.Type.equal t (List t') with 201 | | Some Lambda.Eq.Refl -> V { v = List.rev v; t; pp; eq; } 202 | | None -> Fmt.invalid_arg "Cannot unify %a and %a" 203 | Lambda.Type.pp t 204 | Lambda.Type.pp (List t')) 205 | | x :: r -> 206 | let V { v = x; t; pp = _; eq = _; } = go x in 207 | let V { v = acc; t = tacc; pp; eq; } = acc in 208 | (match Lambda.Type.equal t t', Lambda.Type.equal (List t) tacc with 209 | | Some Lambda.Eq.Refl, Some Lambda.Eq.Refl -> 210 | aux (V { v = x :: acc; t = List t; pp; eq; }) r 211 | | _, _ -> Fmt.invalid_arg "Cannot unify %a and %a" 212 | Lambda.Type.pp t 213 | Lambda.Type.pp t) in 214 | aux (V { v = []; t = List t'; pp; eq; }) value |> cast 215 | | Types.Pair { a; b; } -> 216 | let V { v = a; t = ta; pp = ppa; eq = eqa; } = go a in 217 | let V { v = b; t = tb; pp = ppb; eq = eqb; } = go b in 218 | V { v = (a, b); t = Pair (ta, tb); pp = Fmt.pair ppa ppb; eq = pair_eq ~eqa ~eqb } 219 | | Types.Either { value = Types.Left { value; }; typ_l; typ_r; } -> 220 | let V { v; t; pp = ppl; eq = eql; } = go value in 221 | let Lambda.Type.V tl = Lambda.Type.typ (to_typ typ_l) in 222 | let Lambda.Type.V tr = Lambda.Type.typ (to_typ typ_r) in 223 | 224 | let ppr, eqr = Lambda.Type.pp_val tr, Lambda.Type.eq_val tr in 225 | 226 | (match Lambda.Type.equal t tl with 227 | | Some Lambda.Eq.Refl -> 228 | V { v = Lambda.Value.L v; t = Either (tl, tr); pp = pp_either ~ppl ~ppr; 229 | eq = either_eq ~eql ~eqr } 230 | | None -> Fmt.invalid_arg "Cannot unify %a and %a" 231 | Lambda.Type.pp t 232 | Lambda.Type.pp tl) 233 | | Types.Either { value = Types.Right { value; }; typ_l; typ_r; } -> 234 | let V { v; t; pp = ppr; eq = eqr; } = go value in 235 | let Lambda.Type.V tl = Lambda.Type.typ (to_typ typ_l) in 236 | let Lambda.Type.V tr = Lambda.Type.typ (to_typ typ_r) in 237 | 238 | let ppl, eql = Lambda.Type.pp_val tl, Lambda.Type.eq_val tl in 239 | 240 | (match Lambda.Type.equal t tr with 241 | | Some Lambda.Eq.Refl -> 242 | V { v = Lambda.Value.R v; t = Either (tl, tr); pp = pp_either ~ppl ~ppr; 243 | eq = either_eq ~eql ~eqr } 244 | | None -> Fmt.invalid_arg "Cannot unify %a and %a" 245 | Lambda.Type.pp t 246 | Lambda.Type.pp tl) 247 | | Types.Result { value = Types.Ok { value; }; typ_ok; typ_error; } -> 248 | let V { v; t; pp = pp_ok; eq = eq_ok; } = go value in 249 | let Lambda.Type.V tok = Lambda.Type.typ (to_typ typ_ok) in 250 | let Lambda.Type.V terror = Lambda.Type.typ (to_typ typ_error) in 251 | 252 | let pp_error, eq_error = Lambda.Type.pp_val terror, Lambda.Type.eq_val terror in 253 | 254 | (match Lambda.Type.equal t tok with 255 | | Some Lambda.Eq.Refl -> 256 | V { v = Pervasives.Ok v; t = Result (tok, terror); 257 | pp = Fmt.result ~ok:pp_ok ~error:pp_error; 258 | eq = result_eq ~eq_ok ~eq_error } 259 | | None -> Fmt.invalid_arg "Cannot unify %a and %a" 260 | Lambda.Type.pp t 261 | Lambda.Type.pp tok) 262 | | Types.Result { value = Types.Error { value; }; typ_ok; typ_error; } -> 263 | let V { v; t; pp = pp_error; eq = eq_error; } = go value in 264 | let Lambda.Type.V tok = Lambda.Type.typ (to_typ typ_ok) in 265 | let Lambda.Type.V terror = Lambda.Type.typ (to_typ typ_error) in 266 | 267 | let pp_ok, eq_ok = Lambda.Type.pp_val tok, Lambda.Type.eq_val tok in 268 | 269 | (match Lambda.Type.equal t terror with 270 | | Some Lambda.Eq.Refl -> 271 | V { v = Pervasives.Error v; t = Result (tok, terror); 272 | pp = Fmt.result ~ok:pp_ok ~error:pp_error; 273 | eq = result_eq ~eq_ok ~eq_error } 274 | | None -> Fmt.invalid_arg "Cannot unify %a and %a" 275 | Lambda.Type.pp t 276 | Lambda.Type.pp terror) 277 | | Types.Return { value; _ } -> 278 | if unwrap 279 | (* Client automatically unwrap toplevel lwt values. *) 280 | then go value 281 | else 282 | let V { v; t; pp; eq } = go value in 283 | let pp ppf x = match state x with 284 | | Some x -> pp ppf x 285 | | _ -> Fmt.string ppf " eq x y 289 | | _ -> false 290 | in 291 | let t = Lambda.Type.lwt t in 292 | let v = Lambda.Expr.return v in 293 | V { v; t; pp; eq } 294 | in 295 | go x 296 | 297 | module Option = struct let map f = function Some v -> Some (f v) | None -> None end 298 | 299 | let to_value : value -> (Types.value, [`Msg of string]) result = fun v -> 300 | let rec go : Lambda.Value.t -> Types.value = function 301 | | Lambda.Value.Unit -> Types.Unit 302 | | Lambda.Value.Int value -> Types.Int { value = Int32.of_int value; } 303 | | Lambda.Value.Int32 value -> Types.Int32 { value; } 304 | | Lambda.Value.Int64 value -> Types.Int64 { value; } 305 | | Lambda.Value.Bool value -> Types.Bool { value; } 306 | | Lambda.Value.String value -> Types.String { value; } 307 | | Lambda.Value.List (typ, value) -> 308 | Types.List { typ = of_typ typ; value = List.map go value; } 309 | | Lambda.Value.Array (typ, value) -> 310 | Types.Array { typ = of_typ typ; value = Array.map go value |> Array.to_list; } 311 | | Lambda.Value.Option (typ, value) -> 312 | Types.Option { typ = of_typ typ; value = Option.map go value; } 313 | | Lambda.Value.Bytes value -> Types.Bytes { value; } 314 | | Lambda.Value.Pair (a, b) -> Types.Pair { a = go a; b = go b; } 315 | | Lambda.Value.Either (L value, typl, typr) -> 316 | Types.Either { value = Types.Left { value = go value }; 317 | typ_l = of_typ typl; typ_r = of_typ typr } 318 | | Lambda.Value.Either (R value, typl, typr) -> 319 | Types.Either { value = Types.Right { value = go value }; 320 | typ_l = of_typ typl; typ_r = of_typ typr } 321 | | Lambda.Value.Result (Ok value, typ_ok, typ_error) -> 322 | Types.Result { value = Types.Ok { value = go value }; 323 | typ_ok = of_typ typ_ok; typ_error = of_typ typ_error } 324 | | Lambda.Value.Result (Error value, typ_ok, typ_error) -> 325 | Types.Result { value = Types.Error { value = go value }; 326 | typ_ok = of_typ typ_ok; typ_error = of_typ typ_error } 327 | | Lambda.Value.Return (value, typ) -> 328 | Types.Return { typ = of_typ typ; value = go value; } 329 | in 330 | match Lambda.Value.unsafe_value v with 331 | | Ok v -> Ok (go v) 332 | | Error _ as e -> e 333 | 334 | let of_expr 335 | : ?gamma:Type.abstract Gamma.t -> 336 | ?primitives:primitive Primitives.t -> 337 | Types.expr -> expr 338 | = fun ?(gamma = Gamma.empty) ?(primitives = Primitives.empty) -> 339 | let of_value = of_value ~gamma ~unwrap:false in 340 | let to_typ = to_typ ~gamma in 341 | let rec go : Types.expr -> expr = function 342 | | Types.Val { value = Types.Unit; } -> unit 343 | | Types.Val { value = Types.Int { value; }; } -> int (Int32.to_int value) 344 | | Types.Val { value = Types.Int32 { value; }; } -> int32 value 345 | | Types.Val { value = Types.Int64 { value; }; } -> int64 value 346 | | Types.Val { value = Types.Bool { value = true; }; } -> true_ 347 | | Types.Val { value = Types.Bool { value = false; }; } -> false_ 348 | | Types.Val { value = Types.String { value; }; } -> string value 349 | | Types.Val { value = x; } -> 350 | let V { v; t; pp; eq; } = of_value x in 351 | value v t pp eq 352 | | Types.Prm { value = { name 353 | ; arguments 354 | ; return } } -> 355 | (match Primitives.find name primitives with 356 | | primitive -> 357 | if String.equal primitive.name name 358 | && List.for_all2 equal_typ (List.map (to_typ ) arguments) primitive.args 359 | && equal_typ (to_typ return) primitive.ret 360 | then prim primitive 361 | else Fmt.invalid_arg "Remote primitive %s mismatch with local primitive" name 362 | | exception Not_found -> Fmt.invalid_arg "Primitive %s not found" name) 363 | | Types.Lst { typ; expr; } -> 364 | list ?typ:(Option.map to_typ typ) (List.map go expr) 365 | | Types.Arr { typ; expr; } -> 366 | array ?typ:(Option.map to_typ typ) (Array.of_list (List.map go expr)) 367 | | Types.Opt { typ; expr = None; } -> 368 | none (to_typ typ) 369 | | Types.Opt { expr = Some expr; _ } -> 370 | some (go expr) 371 | | Types.Var { var = id; } -> 372 | var (Int32.to_int id) 373 | | Types.Lam { typ; var; expr; } -> 374 | lambda [ var, to_typ typ ] (go expr) 375 | | Types.Rec { ret; name; argument; expr; } -> 376 | fix (name, to_typ argument) (to_typ ret) (go expr) 377 | | Types.App { a; b; } -> 378 | apply (go a) (go b) 379 | | Types.Bin { op = Types.Add; a; b; } -> 380 | (go a) + (go b) 381 | | Types.Bin { op = Types.Sub; a; b; } -> 382 | (go a) - (go b) 383 | | Types.Bin { op = Types.Mul; a; b; } -> 384 | (go a) * (go b) 385 | | Types.Bin { op = Types.Div; a; b; } -> 386 | (go a) / (go b) 387 | | Types.Bin { op = Types.Pair; a; b; } -> 388 | pair (go a) (go b) 389 | | Types.Bin { op = Types.Eq; a; b; } -> 390 | (go a) = (go b) (* XXX(dinosaure): we use Parsetree.(=). *) 391 | | Types.Bin { op = Types.Get; a; b } -> 392 | get (go a) (go b) 393 | | Types.Bin { op = Types.Shiftl; a; b; } -> 394 | (go a) << (go b) 395 | | Types.Bin { op = Types.Shiftr; a; b; } -> 396 | (go a) >> (go b) 397 | | Types.Bin { op = Types.Or; a; b; } -> 398 | (go a) lor (go b) 399 | | Types.Bin { op = Types.Xor; a; b; } -> 400 | (go a) lxor (go b) 401 | | Types.Bin { op = Types.And; a; b; } -> 402 | (go a) land (go b) 403 | | Types.Uno { op = Types.Fst; x; } -> 404 | fst (go x) 405 | | Types.Uno { op = Types.Prj; x; } -> 406 | prj (go x) 407 | | Types.Uno { op = Types.Snd; x; } -> 408 | snd (go x) 409 | | Types.Uno { op = Types.L { value; }; x; } -> 410 | left (to_typ value) (go x) 411 | | Types.Uno { op = Types.R { value; }; x; } -> 412 | right (to_typ value) (go x) 413 | | Types.Uno { op = Types.Ok { value; }; x; } -> 414 | ok (to_typ value) (go x) 415 | | Types.Uno { op = Types.Error { value }; x; } -> 416 | error (to_typ value) (go x) 417 | | Types.Uno { op = Types.Not; x; } -> 418 | lnot (go x) 419 | | Types.Let { typ; name; expr; body; } -> 420 | let_var (to_typ typ) name (go expr) (go body) 421 | | Types.Swt { a; b; s; } -> 422 | match_ (go s) (go a) (go b) 423 | | Types.Ret { expr; } -> 424 | return (go expr) 425 | | Types.Bnd { expr; func; } -> 426 | bind (go expr) (go func) 427 | | Types.If { a; b; s; } -> 428 | if_ (go s) (go a) (go b) 429 | in 430 | go 431 | 432 | exception Error of [`Msg of string] 433 | 434 | let err e = raise (Error e) 435 | 436 | let (>>?) x f = match x with 437 | | Result.Error e -> err e 438 | | Result.Ok x -> f x 439 | 440 | let to_expr : expr -> (Types.expr, [`Msg of string]) result = fun e -> 441 | let rec go = function 442 | | Val v -> to_value v >>? fun value -> Types.Val { value } 443 | | Prm { name; args; ret; _ } -> 444 | Types.Prm { value = { name; arguments = List.map of_typ args; 445 | return = of_typ ret; }; } 446 | | Lst (typ, lst) -> 447 | Types.Lst { typ = Option.map of_typ typ; expr = List.map go lst; } 448 | | Arr (typ, arr) -> 449 | Types.Arr { typ = Option.map of_typ typ; 450 | expr = Array.map go arr |> Array.to_list; } 451 | | Opt (Some typ, opt) -> 452 | Types.Opt { typ = of_typ typ; expr = Option.map go opt; } 453 | | Opt (None, _) -> invalid_arg "Optional construction needs to be typed" 454 | | Ret expr -> Types.Ret { expr = go expr; } 455 | | Bnd (expr, func) -> Types.Bnd { expr = go expr; func = go func; } 456 | | Var { id; } -> Types.Var { var = Int32.of_int id; } 457 | | Lam (typ, var, expr) -> 458 | Types.Lam { typ = of_typ typ; var; expr = go expr; } 459 | | Rec { r = ret; p = (name, argument); e = expr; } -> 460 | Types.Rec { ret = of_typ ret 461 | ; name 462 | ; argument = of_typ argument 463 | ; expr = go expr; } 464 | | App (a, b) -> Types.App { a = go a; b = go b; } 465 | | Bin (op, a, b) -> 466 | Types.Bin { op = to_binop op; a = go a; b = go b; } 467 | | Uno (op, x) -> Types.Uno { op = to_unop op; x = go x; } 468 | | Let (typ, name, expr, body) -> 469 | Types.Let { typ = of_typ typ; name; expr = go expr; body = go body; } 470 | | Swt { a; b; s; } -> Types.Swt { a = go a; b = go b; s = go s; } 471 | | If (s, a, b) -> Types.If { a = go a; b = go b; s = go s; } 472 | in 473 | try Ok (go e) 474 | with Error e -> Error e 475 | 476 | let of_request 477 | : ?gamma:Type.abstract Gamma.t -> 478 | ?primitives:primitive Primitives.t -> 479 | Types.request -> expr * Type.t * int64 480 | = fun ?(gamma = Gamma.empty) ?primitives request -> 481 | of_expr ~gamma ?primitives request.Types.expr, 482 | to_typ ~gamma request.Types.typ, request.Types.output 483 | 484 | let output_of_request : Types.request -> int64 = 485 | fun request -> request.Types.output 486 | 487 | let to_request 488 | : expr * Type.t * int64 -> (Types.request, [`Msg of string]) result 489 | = fun (expr, typ, output) -> 490 | match to_expr expr with 491 | | Error _ as e -> e 492 | | Ok expr -> Ok { Types.expr; typ = of_typ typ ; output } 493 | 494 | let of_reply 495 | : ?gamma:Type.abstract Gamma.t -> Types.reply -> (value, [ `Msg of string ]) result 496 | = fun ?(gamma = Gamma.empty) -> function 497 | | Types.Value value -> Ok (of_value ~gamma value) 498 | | Types.Error err -> Error (`Msg err) 499 | 500 | let to_reply 501 | : (value, [ `Msg of string ]) result -> Types.reply 502 | = function 503 | | Error (`Msg err) -> Types.Error err 504 | | Ok value -> 505 | match to_value value with 506 | | Error (`Msg e) -> Types.Error e 507 | | Ok v -> Types.Value v 508 | -------------------------------------------------------------------------------- /proto/lambda_protobuf.mli: -------------------------------------------------------------------------------- 1 | open Lambda.Parsetree 2 | 3 | module Rpc: (module type of Lambda_rpc) 4 | module Pb: (module type of Lambda_pb) 5 | 6 | module Primitives: Map.S with type key = string 7 | module Gamma: Map.S with type key = string 8 | 9 | type error = [`Msg of string] 10 | 11 | val to_request: expr * Type.t * int64 -> (Lambda_types.request, error) result 12 | 13 | val of_request: 14 | ?gamma:Type.abstract Gamma.t -> 15 | ?primitives:primitive Primitives.t -> 16 | Lambda_types.request -> expr * Type.t * int64 17 | 18 | val output_of_request: Lambda_types.request -> int64 19 | 20 | val of_reply: 21 | ?gamma:Type.abstract Gamma.t -> Lambda_types.reply -> 22 | (value, [ `Msg of string ]) result 23 | 24 | val to_reply: (value, [ `Msg of string ]) result -> Lambda_types.reply 25 | -------------------------------------------------------------------------------- /proto/lambda_rpc.ml: -------------------------------------------------------------------------------- 1 | module Int64 = struct 2 | let ( lsl ) a n = Int64.shift_left (Int64.of_int a) n 3 | let ( lsr ) a n = Int64.(to_int (shift_right a n)) 4 | let ( lor ) = Int64.logor 5 | let ( land ) = Int64.logand 6 | let of_int = Int64.of_int 7 | let to_int = Int64.to_int 8 | let ( + ) = Int64.add 9 | let ( - ) = Int64.sub 10 | let succ = Int64.succ 11 | end 12 | 13 | type request = Request 14 | type reply = Reply 15 | 16 | module Decoder = struct 17 | type error 18 | 19 | let pp_error : error Fmt.t = fun _ _ -> assert false 20 | 21 | type 'kind t = 22 | { i_off : int 23 | ; i_pos : int 24 | ; i_len : int 25 | ; proto_size : int64 26 | ; block_size : int64 27 | ; block_n : int64 28 | ; i_tmp : Cstruct.t 29 | ; kind : 'kind 30 | ; state : 'kind state } 31 | and 'kind state = 32 | | Header of 'kind k 33 | | Raw of { kind : kind; consumed : int64 } 34 | | Stp of { kind : kind; consumed : int64; buf : Cstruct.t } 35 | | Exception of error 36 | | End 37 | and 'kind k = Cstruct.t -> 'kind t -> 'kind res 38 | and 'kind res = 39 | | Wait of 'kind t 40 | | Error of 'kind t * error 41 | | Flush of 'kind t * kind * Cstruct.t 42 | | Cont of 'kind t 43 | | Ok of 'kind t 44 | and kind = [ `Protobuf | `Block of int64 ] 45 | 46 | let pp_kind ppf = function 47 | | `Protobuf -> Fmt.string ppf "`Protobuf" 48 | | `Block n -> Fmt.pf ppf "(`Block %Ld)" n 49 | 50 | let pp_state ppf = function 51 | | Header _ -> Fmt.pf ppf "(Header #fun)" 52 | | Raw { kind; consumed; } -> Fmt.pf ppf "(Raw { @[kind = %a;@ consumed = %Ld;@] })" pp_kind kind consumed 53 | | Stp { kind; consumed; _ } -> Fmt.pf ppf "(Stp { @[kind = %a;@ consumed = %Ld;@] })" pp_kind kind consumed 54 | | Exception err -> Fmt.pf ppf "(Exception %a)" pp_error err 55 | | End -> Fmt.string ppf "End" 56 | 57 | let pp ppf t = 58 | Fmt.pf ppf "{ @[i_off = %d;@ \ 59 | i_pos = %d;@ \ 60 | i_len = %d;@ \ 61 | proto_size = %Ld;@ \ 62 | block_size = %Ld;@ \ 63 | block_n = %Ld;@ \ 64 | i_tmp = #buf;@ \ 65 | state = %a;@] }" 66 | t.i_off t.i_pos t.i_len 67 | t.proto_size t.block_size t.block_n 68 | pp_state t.state 69 | 70 | let await t = Wait t 71 | let error t err = Error ({ t with state = Exception err }, err) 72 | let ok t = Ok { t with state = End } 73 | let flush t kind consumed buf = 74 | Flush ({ t with state = Stp { kind; consumed; buf; }}, kind, buf) 75 | 76 | let rec get_byte ~ctor k src t = 77 | if (t.i_len - t.i_pos) > 0 78 | then let byte = Cstruct.get_uint8 src (t.i_off + t.i_pos) in 79 | k byte src 80 | { t with i_pos = t.i_pos + 1 } 81 | else await { t with state = ctor (fun src t -> (get_byte[@tailcall]) ~ctor k src t) } 82 | 83 | let rec get_int64 ~ctor k src t = 84 | let get_byte k src t = get_byte ~ctor k src t in 85 | 86 | if (t.i_len - t.i_pos) > 7 87 | then let n = Cstruct.LE.get_uint64 src (t.i_off + t.i_pos) in 88 | k n src 89 | { t with i_pos = t.i_pos + 8 } 90 | else if (t.i_len - t.i_pos) > 0 91 | then (get_byte 92 | @@ fun byte7 -> get_byte 93 | @@ fun byte6 -> get_byte 94 | @@ fun byte5 -> get_byte 95 | @@ fun byte4 -> get_byte 96 | @@ fun byte3 -> get_byte 97 | @@ fun byte2 -> get_byte 98 | @@ fun byte1 -> get_byte 99 | @@ fun byte0 -> 100 | let n = 101 | Int64.((byte7 lsl 56) 102 | lor (byte6 lsl 48) 103 | lor (byte5 lsl 40) 104 | lor (byte4 lsl 32) 105 | lor (byte3 lsl 24) 106 | lor (byte2 lsl 16) 107 | lor (byte1 lsl 8) 108 | lor (of_int byte0)) in 109 | k n) src t 110 | else await { t with state = ctor (fun src t -> (get_int64[@tailcall]) ~ctor k src t) } 111 | 112 | module KHeader = struct 113 | let ctor k = Header k 114 | let get_byte k src t = get_byte ~ctor k src t 115 | let get_int64 k src t = get_int64 ~ctor k src t 116 | end 117 | 118 | let block src t n consumed = 119 | if consumed = t.block_size 120 | then flush t (`Block n) consumed (Cstruct.sub t.i_tmp 0 0) 121 | else if (t.i_len - t.i_pos) = 0 122 | then await t 123 | else 124 | let len = min (Cstruct.len t.i_tmp) (t.i_len - t.i_pos) in 125 | let len = min len Int64.(to_int (t.block_size - consumed)) in 126 | Cstruct.blit src (t.i_off + t.i_pos) t.i_tmp 0 len; 127 | flush { t with i_pos = t.i_pos + len } (`Block n) Int64.(consumed + (of_int len)) (Cstruct.sub t.i_tmp 0 len) 128 | 129 | let proto src t consumed = 130 | if consumed = t.proto_size 131 | then flush t `Protobuf consumed (Cstruct.sub t.i_tmp 0 0) 132 | else if (t.i_len - t.i_pos) = 0 133 | then await t 134 | else 135 | let len = min (Cstruct.len t.i_tmp) (t.i_len - t.i_pos) in 136 | let len = min len Int64.(to_int (t.proto_size - consumed)) in 137 | Cstruct.blit src (t.i_off + t.i_pos) t.i_tmp 0 len; 138 | flush { t with i_pos = t.i_pos + len } `Protobuf Int64.(consumed + (of_int len)) (Cstruct.sub t.i_tmp 0 len) 139 | 140 | let header src t = 141 | (KHeader.get_int64 142 | @@ fun proto_size -> KHeader.get_int64 143 | @@ fun block_size -> KHeader.get_int64 144 | @@ fun block_n _src t -> 145 | Cont { t with proto_size 146 | ; block_size 147 | ; block_n 148 | ; state = Raw { kind = `Protobuf 149 | ; consumed = 0L } }) 150 | src t 151 | 152 | let default ?(len = 0x8000) kind = 153 | { i_off = 0 154 | ; i_pos = 0 155 | ; i_len = 0 156 | ; proto_size = 0L 157 | ; block_size = 0L 158 | ; block_n = 0L 159 | ; i_tmp = Cstruct.create len 160 | ; kind 161 | ; state = Header header } 162 | 163 | let reset t = 164 | { t with proto_size = 0L 165 | ; block_size = 0L 166 | ; block_n = 0L 167 | ; state = Header header } 168 | 169 | let eval0 src t = 170 | match t.state with 171 | | Header k -> k src t 172 | | Raw { kind = `Protobuf; consumed; } -> proto src t consumed 173 | | Raw { kind = (`Block n); consumed; } -> block src t n consumed 174 | | Stp { kind; consumed; buf; } -> flush t kind consumed buf 175 | | Exception err -> error t err 176 | | End -> ok t 177 | 178 | let eval src t = 179 | let rec loop t = match eval0 src t with 180 | | Flush (t, kind, buf) -> `Flush (t, kind, buf) 181 | | Wait t -> `Await t 182 | | Error (t, err) -> `Error (t, err) 183 | | Cont t -> loop t 184 | | Ok t -> `End t in 185 | loop t 186 | 187 | let flush t = match t.state with 188 | | Stp { kind = `Protobuf; consumed; _ } -> 189 | if consumed = t.proto_size 190 | then { t with state = if t.block_n = 0L then End else Raw { kind = `Block 0L; consumed = 0L } } 191 | else { t with state = Raw { kind = `Protobuf; consumed; } } 192 | | Stp { kind = `Block n; consumed; _ } -> 193 | if consumed = t.block_size 194 | then { t with state = if Int64.succ n = t.block_n then End else Raw { kind = `Block (Int64.succ n); consumed = 0L } } 195 | else { t with state = Raw { kind = `Block n; consumed; } } 196 | | _ -> invalid_arg "Rpc.Decoder.flush: invalid state" 197 | 198 | let refill off len t = 199 | { t with i_off = off 200 | ; i_len = len 201 | ; i_pos = 0 } 202 | 203 | let block_size t = t.block_size 204 | let proto_size t = t.proto_size 205 | let block_n t = t.block_n 206 | end 207 | 208 | module Encoder = struct 209 | type error 210 | 211 | let pp_error : error Fmt.t = fun _ _ -> assert false 212 | 213 | type 'kind t = 214 | { o_off : int 215 | ; o_pos : int 216 | ; o_len : int 217 | ; i_off : int 218 | ; i_pos : int 219 | ; i_len : int 220 | ; proto_size : int64 221 | ; block_size : int64 222 | ; block_n : int64 223 | ; p_tmp : string 224 | ; o_tmp : Cstruct.t 225 | ; kind : 'kind 226 | ; state : 'kind state } 227 | and 'kind state = 228 | | Header of 'kind k 229 | | Protobuf of { consumed : int } 230 | | Block of { n : int64; consumed : int } 231 | | Exception of error 232 | | End 233 | and 'kind k = Cstruct.t -> Cstruct.t -> 'kind t -> 'kind res 234 | and 'kind res = 235 | | Cont of 'kind t 236 | | Flush of 'kind t 237 | | Wait of 'kind t 238 | | Ok of 'kind t 239 | | Error of 'kind t * error 240 | 241 | let pp_state ppf = function 242 | | Header _ -> Fmt.pf ppf "(Header #k)" 243 | | Protobuf { consumed; } -> Fmt.pf ppf "(Protobuf { @[consumed = %d;@] })" consumed 244 | | Block { n; consumed; } -> Fmt.pf ppf "(Block { @[n = %Ld;@ consumed = %d;@] })" n consumed 245 | | Exception err -> Fmt.pf ppf "(Exception %a)" pp_error err 246 | | End -> Fmt.string ppf "End" 247 | 248 | let pp ppf t = 249 | Fmt.pf ppf "{ @[o_off = %d;@ \ 250 | o_pos = %d;@ \ 251 | o_len = %d;@ \ 252 | i_off = %d;@ \ 253 | i_pos = %d;@ \ 254 | i_len = %d;@ \ 255 | proto_size = %Ld;@ \ 256 | block_size = %Ld;@ \ 257 | block_n = %Ld;@ \ 258 | p_tmp = #buffer;@ \ 259 | o_tmp = #buffer;@ \ 260 | state = %a;@] }" 261 | t.o_off t.o_pos t.o_len 262 | t.i_off t.i_pos t.i_len 263 | t.proto_size t.block_size t.block_n 264 | pp_state t.state 265 | 266 | let ok t = Ok { t with state = End } 267 | let await t = Wait t 268 | let flush t = Flush t 269 | let error t err = Error ({ t with state = Exception err }, err) 270 | 271 | let rec put_byte ~ctor byte k src dst t = 272 | if (t.o_len - t.o_pos) > 0 273 | then begin 274 | Cstruct.set_uint8 dst (t.o_off + t.o_pos) byte; 275 | k src dst { t with o_pos = t.o_pos + 1 } 276 | end else flush { t with state = ctor (fun dst t -> (put_byte[@tailcall]) ~ctor byte k dst t) } 277 | 278 | let rec put_int64 ~ctor n k src dst t = 279 | let put_byte byte k dst t = put_byte ~ctor byte k dst t in 280 | if (t.o_len - t.o_pos) > 8 281 | then begin 282 | Cstruct.LE.set_uint64 dst (t.o_off + t.o_pos) n; 283 | k src dst { t with o_pos = t.o_pos + 8 } 284 | end else if (t.o_len - t.o_pos) > 0 285 | then begin 286 | let byte7 = Int64.((n land 0xFF00000000000000L) lsr 56) in 287 | let byte6 = Int64.((n land 0x00FF000000000000L) lsr 48) in 288 | let byte5 = Int64.((n land 0x0000FF0000000000L) lsr 40) in 289 | let byte4 = Int64.((n land 0x000000FF00000000L) lsr 32) in 290 | let byte3 = Int64.((n land 0x00000000FF000000L) lsr 24) in 291 | let byte2 = Int64.((n land 0x0000000000FF0000L) lsr 16) in 292 | let byte1 = Int64.((n land 0x000000000000FF00L) lsr 8) in 293 | let byte0 = Int64.(to_int (n land 0x00000000000000FFL)) in 294 | 295 | (put_byte byte0 296 | @@ put_byte byte1 297 | @@ put_byte byte2 298 | @@ put_byte byte3 299 | @@ put_byte byte4 300 | @@ put_byte byte5 301 | @@ put_byte byte6 302 | @@ put_byte byte7 k) 303 | src dst t 304 | end else flush { t with state = ctor (fun dst t -> (put_int64[@tailcall]) ~ctor n k dst t) } 305 | 306 | module KHeader = struct 307 | let ctor k = Header k 308 | let put_byte byte k src dst t = put_byte ~ctor byte k src dst t 309 | let put_int64 n k src dst t = put_int64 ~ctor n k src dst t 310 | end 311 | 312 | let block src dst t n consumed = 313 | if consumed = (Int64.to_int t.block_size) 314 | then flush { t with state = 315 | if Int64.succ n = t.block_n 316 | then End 317 | else Block { n = Int64.succ n; consumed = 0 } } 318 | else begin 319 | let len = min (t.o_len - t.o_pos) (t.i_len - t.i_pos) in 320 | let len = min len (Int64.to_int t.block_size - consumed) in 321 | Cstruct.blit src (t.i_off + t.i_pos) dst (t.o_off + t.o_pos) len; 322 | 323 | match (t.i_len - (t.i_pos + len)) > 0, (t.o_len - (t.o_pos + len)) > 0 with 324 | | true, true 325 | | false, false 326 | | true, false -> flush { t with i_pos = t.i_pos + len 327 | ; o_pos = t.o_pos + len 328 | ; state = Block { n; consumed = consumed + len; } } 329 | | false, true -> await { t with i_pos = t.i_pos + len 330 | ; o_pos = t.o_pos + len 331 | ; state = Block { n; consumed = consumed + len; } } 332 | end 333 | 334 | let proto _src dst t consumed = 335 | if consumed = String.length t.p_tmp 336 | then Cont { t with state = 337 | if t.block_n = 0L 338 | then End 339 | else Block { n = 0L; consumed = 0 } } 340 | else begin 341 | let len = min (t.o_len - t.o_pos) (String.length t.p_tmp - consumed) in 342 | let len = min len (Int64.to_int t.proto_size - consumed) in 343 | Cstruct.blit_from_string t.p_tmp consumed dst (t.o_off + t.o_pos) len; 344 | flush { t with o_pos = t.o_pos + len 345 | ; state = Protobuf { consumed = consumed + len } } 346 | end 347 | 348 | let header src dst t = 349 | (KHeader.put_int64 t.proto_size 350 | @@ KHeader.put_int64 t.block_size 351 | @@ KHeader.put_int64 t.block_n 352 | @@ fun _src _dst t -> Cont { t with state = Protobuf { consumed = 0 } }) 353 | src dst t 354 | 355 | type ('k, 'v) protobuf = 356 | | Request : (Lambda_types.request, request) protobuf 357 | | Reply : (Lambda_types.reply, reply) protobuf 358 | 359 | let default 360 | : type p k. (p, k) protobuf -> ?len:int -> p -> int64 -> int64 -> k t 361 | = fun kind ?(len = 0x8000) protobuf block_size block_n -> 362 | let encoder = Pbrt.Encoder.create () in 363 | let () = match kind with 364 | | Request -> Lambda_pb.encode_request protobuf encoder 365 | | Reply -> Lambda_pb.encode_reply protobuf encoder in 366 | let p_tmp = Pbrt.Encoder.to_bytes encoder |> Bytes.unsafe_to_string in 367 | { i_off = 0 368 | ; i_pos = 0 369 | ; i_len = 0 370 | ; o_off = 0 371 | ; o_pos = 0 372 | ; o_len = 0 373 | ; proto_size = Int64.of_int (String.length p_tmp) 374 | ; block_size 375 | ; block_n 376 | ; p_tmp 377 | ; o_tmp = Cstruct.create len 378 | ; kind = (match kind with Request -> Request | Reply -> Reply) (* GADT LOLILOL *) 379 | ; state = Header header } 380 | 381 | let eval0 src dst t = 382 | match t.state with 383 | | Header k -> k src dst t 384 | | Protobuf { consumed } -> proto src dst t consumed 385 | | Block { n; consumed; } -> block src dst t n consumed 386 | | Exception err -> error t err 387 | | End -> ok t 388 | 389 | let eval src dst t = 390 | let rec loop t = match eval0 src dst t with 391 | | Wait t -> `Await t 392 | | Flush t -> `Flush t 393 | | Cont t -> loop t 394 | | Error (t, err) -> `Error (t, err) 395 | | Ok t -> `End t in 396 | loop t 397 | 398 | let refill off len t = 399 | { t with i_off = off 400 | ; i_len = len 401 | ; i_pos = 0 } 402 | 403 | let flush off len t = 404 | { t with o_off = off 405 | ; o_len = len 406 | ; o_pos = 0 } 407 | 408 | let used_out t = t.o_pos 409 | let used_in t = t.i_pos 410 | 411 | let block t = match t.state with 412 | | Block { n; consumed; } -> n, consumed 413 | | _ -> invalid_arg "block: invalid state" 414 | end 415 | -------------------------------------------------------------------------------- /proto/request.proto: -------------------------------------------------------------------------------- 1 | syntax = "proto2"; 2 | 3 | /* Import path relative to WORKSPACE file */ 4 | import "numero-mirage/proto/lambda.proto"; 5 | 6 | /* Client request to server */ 7 | message Request { 8 | oneof request { 9 | Execute execute = 1; 10 | } 11 | } 12 | 13 | /* Server response to client */ 14 | message Reply { 15 | oneof reply { 16 | ExecuteFailed failed = 1; 17 | ExecuteResult result = 2; 18 | } 19 | } 20 | 21 | /* Program execution request */ 22 | message Execute { 23 | required Expr program = 1; 24 | required uint64 output_blocks = 2; 25 | } 26 | 27 | /* Program execution failed */ 28 | message ExecuteFailed { 29 | required string error = 1; 30 | } 31 | 32 | /* Program execution succeeded and produced a result */ 33 | message ExecuteResult { 34 | required Expr result = 1; 35 | } 36 | -------------------------------------------------------------------------------- /rpc-protocol.md: -------------------------------------------------------------------------------- 1 | # TCP wire-protocol 2 | 3 | Protocol buffers has a few limitations w.r.t. to TCP. Protobufs are not 4 | delimited or self-describing. However, with an open TCP connection we need to 5 | know how many bytes we expect to receive to make sure to receive the full 6 | message. The [documentation recommends][protobufs-streaming] to implement your 7 | own framing. The simplest approach, is to prefix every protobufs message by its 8 | length in a fixed width format. We choose a `fixed64`, i.e. 64-bit unsigned 9 | integer. 10 | 11 | Furthermore, the [documentation says][protobufs-large] that protobufs are not 12 | designed for large messages (more than 1 MiB). Instead, one should separate 13 | messages into smaller chunks. For us that means that inlining block-data into 14 | lambda programs (which will be encoded using protobufs) should be avoided. 15 | 16 | For a TCP connection with the Mirage server we define the following protocol. 17 | 18 | [protobufs-streaming]: https://developers.google.com/protocol-buffers/docs/techniques#streaming 19 | [protobufs-large]: https://developers.google.com/protocol-buffers/docs/techniques#large-data 20 | 21 | 22 | ## Messages 23 | 24 | Each message has a fixed size header defining the length of the contained 25 | protobufs message, and the length and number of additional following blocks of 26 | raw data. Once a TCP connection has been established the client can send a 27 | `Request` and the server is expected to send a `Reply` in return. This repeats 28 | until the connection is closed by either side. The binary encoding of messages 29 | is as follows. See [`proto/request.proto`](proto/request.proto) for the 30 | encoding of `Request` and `Reply`. 31 | 32 | - `header` 33 | 34 | ``` 35 | +----------------+----------------+---------------+ 36 | | proto-size <8> | block-size <8> | block-num <8> | 37 | +----------------+----------------+---------------+ 38 | ``` 39 | 40 | - `proto-size` 41 | The size in bytes of the protobufs encoded message as `fixed64`. 42 | - `block-size` 43 | The size in bytes of one block as `fixed64`. 44 | - `block-num` 45 | The number of blocks following the protobufs encoded message as 46 | `fixed64`. 47 | 48 | - `request` 49 | 50 | ``` 51 | +-------------+----------------------+---------------------------------+ 52 | | header <24> | Request | blocks | 53 | +-------------+----------------------+---------------------------------+ 54 | ``` 55 | 56 | A request from the client to the server. For instance a request to execute 57 | a lambda program with some input blocks and return the result and output 58 | blocks. The request message may define the number of expected output 59 | blocks. 60 | 61 | If `n` is the number of input blocks and `m` the number of expected output 62 | blocks, then the sent lambda program should expect `n + m` string 63 | arguments. The first `n` will be the attached input blocks, the following 64 | `m` will be buffers to write the output blocks into. 65 | 66 | E.g. with `n = 3` and `m = 2`, the lambda program should have the type 67 | 68 | ``` 69 | string -> string -> string (* input blocks *) 70 | -> string -> string (* output blocks *) 71 | -> a (* result *) 72 | ``` 73 | 74 | - `reply` 75 | 76 | ``` 77 | +-------------+--------------------+---------------------------------+ 78 | | header <24> | Reply | blocks | 79 | +-------------+--------------------+---------------------------------+ 80 | ``` 81 | 82 | Response to request with success or failure. On success, the message will 83 | contain the result value and the expected output blocks will be appended to 84 | the message. 85 | 86 | 87 | ## Protocol 88 | 89 | The protocol is very simple. The client opens a TCP connection to the server. 90 | Once the connection is established, the client can send a `request` message, 91 | and will expect a `reply` message in return. The sequence of `request`, `reply` 92 | messages is repeated until the connection is closed by either side. 93 | 94 | ``` 95 | Client Server 96 | 97 | 98 | 99 | | request | 100 | | -------------------> | 101 | | | 102 | | reply | 103 | | <------------------- | 104 | | | 105 | | . | 106 | | . | 107 | | . | 108 | | | 109 | | request | 110 | | -------------------> | 111 | | | 112 | | reply | 113 | | <------------------- | 114 | 115 | 116 | ``` 117 | 118 | Communication on a TCP connection is fully sequential. Parallel requests can 119 | only be made through separate TCP connections. The client can keep a connection 120 | pool to manage parallel requests. 121 | -------------------------------------------------------------------------------- /src/eq.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2018 Thomas Gazagnaire 3 | * and Romain Calascibetta 4 | * and Frédéric Bour 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type ('l, 'r) either = 20 | | L of 'l 21 | | R of 'r 22 | 23 | type (_, _) refl = Refl : ('a, 'a) refl 24 | 25 | let trans 26 | : type m n p. (m, n) refl -> (n, p) refl -> (m, p) refl 27 | = fun Refl Refl -> Refl 28 | 29 | let arrow 30 | : type a b c d. (a, b) refl -> (c, d) refl option -> 31 | (a -> c, b -> d) refl option 32 | = fun Refl -> function 33 | | Some Refl -> Some Refl 34 | | None -> None 35 | 36 | let pair 37 | : type a b c d. (a, b) refl -> (c, d) refl option -> 38 | (a * c, b * d) refl option 39 | = fun Refl -> function 40 | | Some Refl -> Some Refl 41 | | None -> None 42 | 43 | let either 44 | : type a b c d. (a, b) refl -> (c, d) refl option -> 45 | ((a, c) either, (b, d) either) refl option 46 | = fun Refl -> function 47 | | Some Refl -> Some Refl 48 | | None -> None 49 | 50 | let ( >>= ) 51 | 52 | : type a b c d. 53 | (a, b) refl option 54 | -> ((a, b) refl 55 | -> (c, d) refl option) 56 | -> (a -> c, b -> d) refl option 57 | 58 | = fun x f -> match x with 59 | | Some (Refl as x) -> arrow x (f x) 60 | | None -> None 61 | 62 | let ( >&= ) 63 | 64 | : type a b c d. 65 | (a, b) refl option 66 | -> ((a, b) refl 67 | -> (c, d) refl option) 68 | -> (a * c, b * d) refl option 69 | 70 | = fun x f -> match x with 71 | | Some (Refl as x) -> pair x (f x) 72 | | None -> None 73 | 74 | let ( >*= ) 75 | 76 | : type a b c d. 77 | (a, b) refl option 78 | -> ((a, b) refl 79 | -> (c, d) refl option) 80 | -> (a * c, b * d) refl option 81 | 82 | = fun x f -> match x with 83 | | Some (Refl as x) -> pair x (f x) 84 | | None -> None 85 | 86 | let ( >?= ) 87 | 88 | : type a b c d. 89 | (a, b) refl option 90 | -> ((a, b) refl 91 | -> (c, d) refl option) 92 | -> ((a, c) either, (b, d) either) refl option 93 | 94 | = fun x f -> match x with 95 | | Some (Refl as x) -> either x (f x) 96 | | None -> None 97 | 98 | module Witness : sig 99 | type 'a t 100 | val v : unit -> 'a t 101 | val eq: 'a t -> 'b t -> ('a, 'b) refl option 102 | val cmp: 'a t -> 'b t -> int 103 | end = struct 104 | 105 | type _ equality = .. 106 | 107 | module type Inst = sig 108 | type t 109 | type _ equality += Eq : t equality 110 | end 111 | 112 | type 'a t = (module Inst with type t = 'a) 113 | 114 | let v: type a. unit -> a t = fun () -> 115 | let module Inst = struct 116 | type t = a 117 | type _ equality += Eq : t equality 118 | end 119 | in 120 | (module Inst) 121 | 122 | let eq: type a b. a t -> b t -> (a, b) refl option = 123 | fun (module A) (module B) -> 124 | match A.Eq with 125 | | B.Eq -> Some Refl 126 | | _ -> None 127 | 128 | let cmp: type a b. a t -> b t -> int = 129 | fun ((module A) as a) ((module B) as b) -> match eq a b with 130 | | Some Refl -> 0 131 | | None -> 132 | let ext_a = Obj.extension_id (Obj.extension_constructor A.Eq) in 133 | let ext_b = Obj.extension_id (Obj.extension_constructor B.Eq) in 134 | ext_a - ext_b 135 | end 136 | 137 | type 'a witness = { name: string; wit : 'a Witness.t } 138 | 139 | let witness name = 140 | let wit = Witness.v () in 141 | {name; wit} 142 | -------------------------------------------------------------------------------- /src/fuzzer.ml: -------------------------------------------------------------------------------- 1 | let unsafe_type_gen : Parsetree.Type.t Crowbar.gen = 2 | let open Parsetree in 3 | 4 | Crowbar.fix @@ fun unsafe_type_gen -> 5 | Crowbar.choose 6 | [ Crowbar.const Type.unit 7 | ; Crowbar.const Type.int 8 | ; Crowbar.const Type.int32 9 | ; Crowbar.const Type.int64 10 | ; Crowbar.const Type.bool 11 | ; Crowbar.const Type.string 12 | ; Crowbar.map [ unsafe_type_gen ] (fun t -> Type.list t) 13 | ; Crowbar.map [ unsafe_type_gen ] (fun t -> Type.array t) 14 | ; Crowbar.map [ unsafe_type_gen ] (fun t -> Type.option t) 15 | ; Crowbar.map [ unsafe_type_gen; unsafe_type_gen ] (fun ta tb -> Type.either ta tb) 16 | ; Crowbar.map [ unsafe_type_gen; unsafe_type_gen ] (fun ta tb -> Type.result ta tb) 17 | ; Crowbar.map [ unsafe_type_gen; ] (fun t -> Type.apply t Type.lwt) 18 | ; Crowbar.map [ Crowbar.bytes ] (fun name -> Type.abstract (Eq.witness name)) 19 | (* XXX(dinosaure): lol je suis vraiment pas sûr. *) 20 | ; Crowbar.map [ unsafe_type_gen; unsafe_type_gen ] (fun ta tb -> Type.(ta ** tb)) 21 | ; Crowbar.map [ unsafe_type_gen; unsafe_type_gen ] (fun ta tb -> Type.(ta @-> tb)) ] 22 | 23 | let type_gen = Crowbar.map [ unsafe_type_gen ] Typedtree.Type.typ 24 | 25 | let pp_unit ppf () = Fmt.string ppf "()" 26 | let pp_either ppa ppb ppf = function 27 | | T.L a -> Fmt.pf ppf "(L %a)" ppa a 28 | | T.R b -> Fmt.pf ppf "(R %a)" ppb b 29 | let eq_int : int -> int -> bool = (=) 30 | let eq_bool : bool -> bool -> bool = (=) 31 | 32 | let value t pp eq v = Parsetree.V { v; t; pp; eq; } 33 | 34 | let (<.>) f g = fun x -> f (g x) 35 | 36 | let pp : type a. a T.t -> Parsetree.value -> a Fmt.t = fun witness -> function 37 | | Parsetree.V { pp; t; v; _ } -> match T.equal t witness with 38 | | Some Eq.Refl -> pp 39 | | None -> Fmt.invalid_arg "Type %a does not match with value %a." Typedtree.Type.pp witness pp v 40 | 41 | let eq: type a. a T.t -> Parsetree.value -> a Parsetree.eq = fun witness -> function 42 | | Parsetree.V { pp; eq; t; v; } -> match T.equal t witness with 43 | | Some Eq.Refl -> eq 44 | | None -> Fmt.invalid_arg "Type %a does not match with value %a." Typedtree.Type.pp witness pp v 45 | 46 | let to_list witness l = 47 | let rec map : type a. a T.t -> Parsetree.value list -> a list -> a list = fun witness l a -> match l with 48 | | [] -> List.rev a 49 | | Parsetree.V { v; t; _ } :: r -> match T.equal t witness with 50 | | Some Eq.Refl -> map witness r (v :: a) 51 | | None -> map witness r a in 52 | map witness l [] 53 | 54 | let pp_bytes ppf s = Fmt.string ppf (Bytes.unsafe_to_string s) 55 | 56 | let rec value_gen : type a. a T.t -> Parsetree.value Crowbar.gen = fun ty -> 57 | match ty with 58 | | T.Unit -> Crowbar.const (value ty pp_unit (fun () () -> true) ()) 59 | | T.Int -> Crowbar.(map [ int ] (value ty Fmt.int eq_int)) 60 | | T.Int32 -> Crowbar.(map [ int32 ] (value ty Fmt.int32 Int32.equal)) 61 | | T.Int64 -> Crowbar.(map [ int64 ] (value ty Fmt.int64 Int64.equal)) 62 | | T.Bool -> Crowbar.(map [ bool ] (value ty Fmt.bool eq_bool)) 63 | | T.String -> Crowbar.(map [ bytes ] (value ty Fmt.string String.equal)) 64 | | T.Bytes -> 65 | Crowbar.(map [ bytes ] (fun s -> 66 | value ty pp_bytes Bytes.equal (Bytes.unsafe_of_string s) 67 | )) 68 | | T.List ta -> 69 | let cmp = Typedtree.Type.eq_val ty in 70 | Crowbar.(map [ list (value_gen ta); (value_gen ta) ]) (fun l x -> value ty Fmt.(list (pp ta x)) cmp (to_list ta l)) 71 | | T.Array ta -> 72 | let cmp = Typedtree.Type.eq_val ty in 73 | Crowbar.(map [ list (value_gen ta); (value_gen ta) ]) (fun l x -> value ty Fmt.(array (pp ta x)) cmp (Array.of_list @@ to_list ta l)) 74 | | T.Option ta -> 75 | Crowbar.(map [ bool; (value_gen ta) ]) 76 | (fun o x -> 77 | let pp = Fmt.(option (pp ta x)) in 78 | let cmp = Typedtree.Type.eq_val ty in 79 | 80 | match o with 81 | | true -> value ty pp cmp (Some (Typedtree.Value.cast x ta)) 82 | | false -> value ty pp cmp None) 83 | | T.Pair (ta, tb) -> 84 | Crowbar.(map [ (value_gen ta); (value_gen tb) ]) 85 | (fun va vb -> 86 | let ppa = pp ta va in 87 | let ppb = pp tb vb in 88 | let cmp = Typedtree.Type.eq_val ty in 89 | 90 | value ty Fmt.(pair ppa ppb) cmp (Typedtree.Value.cast va ta, Typedtree.Value.cast vb tb)) 91 | | T.Either (ta, tb) -> 92 | Crowbar.(map [ bool; (value_gen ta); (value_gen tb) ]) 93 | (fun c va vb -> 94 | let ppa = pp ta va in 95 | let ppb = pp tb vb in 96 | let pp = pp_either ppa ppb in 97 | let cmp = Typedtree.Type.eq_val ty in 98 | 99 | match c with 100 | | true -> value ty pp cmp (T.L (Typedtree.Value.cast va ta)) 101 | | false -> value ty pp cmp (T.R (Typedtree.Value.cast vb tb))) 102 | | T.Result (ta, tb) -> 103 | Crowbar.(map [ bool; (value_gen ta); (value_gen tb) ]) 104 | (fun c va vb -> 105 | let ppa = pp ta va in 106 | let ppb = pp tb vb in 107 | let pp = Fmt.result ~ok:ppa ~error:ppb in 108 | let cmp = Typedtree.Type.eq_val ty in 109 | 110 | match c with 111 | | true -> value ty pp cmp (Ok (Typedtree.Value.cast va ta)) 112 | | false -> value ty pp cmp (Error (Typedtree.Value.cast vb tb))) 113 | | T.Lwt -> Crowbar.bad_test () 114 | | T.Apply _ -> Crowbar.bad_test () 115 | | T.Abstract _ -> Crowbar.bad_test () 116 | | T.Arrow _ -> Crowbar.bad_test () 117 | 118 | let pair_gen : 'a Crowbar.gen -> 'b Crowbar.gen -> ('a * 'b) Crowbar.gen = fun a b -> Crowbar.map [a; b] (fun a b -> (a, b)) 119 | 120 | let unsafe_expr_gen : Parsetree.expr Crowbar.gen = 121 | Crowbar.fix @@ fun unsafe_expr_gen -> 122 | Crowbar.choose 123 | [ Crowbar.dynamic_bind type_gen (fun (Typedtree.Type.V ty) -> Crowbar.map [ (value_gen ty) ] Parsetree.of_value) 124 | ; Crowbar.map [ Crowbar.int ] Parsetree.var 125 | ; Crowbar.(map [ unsafe_type_gen; list unsafe_expr_gen ]) (fun typ expr -> Parsetree.list ~typ expr) 126 | ; Crowbar.(map [ unsafe_type_gen; list unsafe_expr_gen ]) (fun typ expr -> Parsetree.array ~typ (Array.of_list expr)) 127 | ; Crowbar.(map [ unsafe_type_gen ] (fun ty -> Parsetree.none ty)) 128 | ; Crowbar.(map [ unsafe_expr_gen ]) Parsetree.some 129 | ; Crowbar.(map [ unsafe_type_gen; unsafe_expr_gen ]) Parsetree.ok 130 | ; Crowbar.(map [ unsafe_type_gen; unsafe_expr_gen ]) Parsetree.error 131 | ; Crowbar.(map [ list (pair_gen bytes unsafe_type_gen); unsafe_expr_gen ]) Parsetree.lambda 132 | ; Crowbar.(map [ unsafe_expr_gen; unsafe_expr_gen ]) Parsetree.pair 133 | ; Crowbar.(map [ unsafe_expr_gen ]) Parsetree.fst 134 | ; Crowbar.(map [ unsafe_expr_gen ]) Parsetree.snd 135 | ; Crowbar.(map [ unsafe_type_gen; unsafe_expr_gen ]) Parsetree.left 136 | ; Crowbar.(map [ unsafe_type_gen; unsafe_expr_gen ]) Parsetree.right 137 | ; Crowbar.(map [ unsafe_type_gen; bytes; unsafe_expr_gen; unsafe_expr_gen ]) Parsetree.let_var 138 | ; Crowbar.(map [ unsafe_type_gen; bytes; list (pair_gen bytes unsafe_type_gen); unsafe_expr_gen; unsafe_expr_gen ]) Parsetree.let_fun 139 | ; Crowbar.(map [ unsafe_type_gen; bytes; pair_gen bytes unsafe_type_gen; unsafe_expr_gen; unsafe_expr_gen ]) Parsetree.let_rec 140 | ; Crowbar.(map [ unsafe_expr_gen; unsafe_expr_gen; unsafe_expr_gen ]) Parsetree.if_ 141 | ; Crowbar.(map [ unsafe_expr_gen; unsafe_expr_gen; unsafe_expr_gen ]) Parsetree.match_ 142 | ; Crowbar.(map [ unsafe_expr_gen; unsafe_expr_gen ]) Parsetree.apply 143 | ; Crowbar.(map [ pair_gen bytes unsafe_type_gen; unsafe_type_gen; unsafe_expr_gen ]) Parsetree.fix 144 | ; Crowbar.(map [ unsafe_expr_gen; unsafe_expr_gen ]) Parsetree.( = ) 145 | ; Crowbar.(map [ unsafe_expr_gen; unsafe_expr_gen ]) Parsetree.( + ) 146 | ; Crowbar.(map [ unsafe_expr_gen; unsafe_expr_gen ]) Parsetree.( - ) 147 | ; Crowbar.(map [ unsafe_expr_gen; unsafe_expr_gen ]) Parsetree.( * ) ] 148 | -------------------------------------------------------------------------------- /src/jbuild: -------------------------------------------------------------------------------- 1 | (library 2 | ((name lambda) 3 | (public_name lambda) 4 | (libraries (crowbar fmt logs lwt higher)) 5 | (preprocess (pps (ppx_deriving.show ppx_deriving.eq ppx_deriving.ord))))) 6 | 7 | (ocamllex (lexer)) 8 | 9 | (menhir 10 | ((flags (--explain)) 11 | (modules (parser)))) 12 | -------------------------------------------------------------------------------- /src/lambda.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2018 Thomas Gazagnaire 3 | * and Romain Calascibetta 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | let src = Logs.Src.create "lambda" 19 | module Log = (val Logs.src_log src : Logs.LOG) 20 | 21 | module Eq = Eq 22 | 23 | (* Parser *) 24 | 25 | let pp_position file ppf lexbuf = 26 | let p = Lexing.lexeme_start_p lexbuf in 27 | Fmt.pf ppf 28 | "File \"%s\", line %d, character %d" 29 | file p.Lexing.pos_lnum 30 | (p.Lexing.pos_cnum - p.Lexing.pos_bol) 31 | 32 | let parse ?(file="") ?(primitives=[]) ?(gamma=[]) str = 33 | let lexbuf = Lexing.from_string str in 34 | let err msg = 35 | let msg = Fmt.strf "%a: %s\n.%!" (pp_position file) lexbuf msg in 36 | Log.err (fun l -> l "%s" msg); 37 | Error (`Msg msg) in 38 | match Parser.main Lexer.(token @@ v ()) lexbuf primitives gamma with 39 | | Ok _ as x -> x 40 | | Error e -> err e 41 | | exception Lexer.Error msg -> err msg 42 | | exception Parser.Error -> err "syntax error" 43 | 44 | let parse_exn ?file ?primitives ?gamma str = 45 | match parse ?file ?primitives ?gamma str with 46 | | Ok y -> y 47 | | Error (`Msg e) -> invalid_arg e 48 | 49 | module Request = struct 50 | let parse ?(file="") ?(primitives=[]) ?(gamma=[]) str = 51 | let lexbuf = Lexing.from_string str in 52 | let err msg = 53 | let msg = Fmt.strf "%a: %s\n.%!" (pp_position file) lexbuf msg in 54 | Log.err (fun l -> l "%s" msg); 55 | Error (`Msg msg) in 56 | match Parser.request Lexer.(token @@ v ()) lexbuf primitives gamma with 57 | | Ok _ as x -> x 58 | | Error e -> err e 59 | | exception Lexer.Error msg -> err msg 60 | | exception Parser.Error -> err "syntax error" 61 | 62 | let parse_exn ?file ?primitives ?gamma str = 63 | match parse ?file ?primitives ?gamma str with 64 | | Ok y -> y 65 | | Error (`Msg e) -> invalid_arg e 66 | end 67 | 68 | (* Typer *) 69 | 70 | module Parsetree = Parsetree 71 | module Fuzzer = Fuzzer 72 | 73 | module Type = Typedtree.Type 74 | module Var = Typedtree.Var 75 | module Expr = Typedtree.Expr 76 | module Value = Value 77 | 78 | let typ = Expr.typ 79 | 80 | let typ_exn e = match typ e with 81 | | Ok t -> t 82 | | Error e -> Fmt.kstrf invalid_arg "%a" Expr.pp_error e 83 | 84 | let untype (Expr.V (e, _)) = Expr.untype e 85 | 86 | type 'a typ = 'a Type.t 87 | type expr = Typedtree.expr 88 | type value = Typedtree.value 89 | 90 | let pp_value = Typedtree.pp_value 91 | let string_of_value = Fmt.to_to_string pp_value 92 | 93 | type error = Expr.error 94 | let pp_error = Expr.pp_error 95 | 96 | let ( $ ) f x = match f with Ok f -> Ok (f x) | Error e -> Error e 97 | 98 | let eval e = 99 | let open Expr in 100 | let Typedtree.Expr.V (m, t) = e in 101 | Typedtree.V (eval m (), t) 102 | 103 | let cast: type a. value -> a typ -> a option = fun v t' -> 104 | let Typedtree.V (v, t) = v in 105 | match Type.equal t t' with 106 | | Some Eq.Refl -> Some v 107 | | None -> None 108 | 109 | let uncast: type a. a typ -> a -> Parsetree.value = fun t v -> Typedtree.Value.untype t v 110 | 111 | let type_and_eval: 112 | type a. Parsetree.expr -> a typ -> (a, error) result = fun m t' -> 113 | match Typedtree.Expr.typ m with 114 | | Error _ as e -> e 115 | | Ok e -> 116 | let Typedtree.V (v, t) = eval e in 117 | match Type.equal t t' with 118 | | Some Eq.Refl -> Ok v 119 | | None -> Typedtree.err_type_mismatch m t t' 120 | 121 | (* 122 | let untype: expr -> Parsetree.expr = fun e -> 123 | let Typedtree.E (m, t) = e in 124 | Typed 125 | *) 126 | 127 | type primitive = string * Parsetree.expr 128 | 129 | module Args = Primitive.Args 130 | 131 | let primitive name args out f = 132 | name, Primitive.(v name args out f |> untype) 133 | 134 | module L = struct 135 | 136 | let primitive name args out f = 137 | name, Primitive.L.(v name args out f |> untype) 138 | 139 | let cast 140 | : type a. value -> (a, Type.lwt) Type.app typ -> a Lwt.t option 141 | = fun v t' -> 142 | let Typedtree.V (v, t) = v in 143 | match Type.equal t t' with 144 | | Some Eq.Refl -> let Type.App v = v in Some (Type.Lwt.prj v) 145 | | None -> None 146 | 147 | let uncast : type a. a Lwt.t Type.t -> (a, Type.lwt) Type.app -> Parsetree.value = Typedtree.Value.untype_lwt 148 | 149 | let type_and_eval 150 | : type a. Parsetree.expr -> (a, Type.lwt) Type.app typ -> 151 | (a Lwt.t, error) result 152 | = fun m t' -> 153 | match Typedtree.Expr.typ m with 154 | | Error _ as e -> e 155 | | Ok e -> 156 | let Typedtree.V (v, t) = eval e in 157 | match Type.equal t t' with 158 | | Some Eq.Refl -> let Type.App v = v in Ok (Type.Lwt.prj v) 159 | | None -> Typedtree.err_type_mismatch m t t' 160 | 161 | end 162 | -------------------------------------------------------------------------------- /src/lambda.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2018 Thomas Gazagnaire 3 | * and Romain Calascibetta 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | module Parsetree = Parsetree 19 | module Fuzzer = Fuzzer 20 | 21 | module Eq = Eq 22 | 23 | module Type = Typedtree.Type 24 | module Var = Typedtree.Var 25 | module Expr = Typedtree.Expr 26 | module Value = Value 27 | 28 | type 'a typ = 'a Typedtree.typ 29 | type expr = Typedtree.expr 30 | type value = Typedtree.value 31 | val pp_value: value Fmt.t 32 | val string_of_value: value -> string 33 | 34 | (** Type of errors. *) 35 | type error 36 | 37 | (** Pretty-printer of {!error}. *) 38 | val pp_error: error Fmt.t 39 | 40 | module Args: sig 41 | 42 | (** Arguments of a primitive. *) 43 | type ('a, 'res) t = 44 | | [] : ('res, 'res) t 45 | | (::) : 'a typ * ('k, 'res) t -> ('a -> 'k, 'res) t 46 | 47 | end 48 | 49 | val ( $ ): ('a -> 'b, 'c) result -> 'a -> ('b, 'c) result 50 | 51 | type primitive = string * Parsetree.expr 52 | 53 | val primitive: string -> ('a, 'b) Args.t -> 'b typ -> 'a -> primitive 54 | (** [primitives name types_of_args type_of_res f] records a new primitive with 55 | [name]. *) 56 | 57 | val parse: 58 | ?file:string -> 59 | ?primitives:primitive list -> 60 | ?gamma:(string * Parsetree.Type.abstract) list -> 61 | string -> (Parsetree.expr, [`Msg of string]) result 62 | (** [parse ?file ?primitives input] tries to parse [input] and binds primitives 63 | with their associated names (see {!primitive}) in resulted {!Parsetree.expr} 64 | expression. [?file] helps to produce a better error message. *) 65 | 66 | val parse_exn: ?file:string -> ?primitives:primitive list -> ?gamma:(string * Parsetree.Type.abstract) list -> string -> Parsetree.expr 67 | 68 | module Request: sig 69 | val parse: 70 | ?file:string -> 71 | ?primitives:primitive list -> 72 | ?gamma:(string * Parsetree.Type.abstract) list -> 73 | string -> (Parsetree.expr * Parsetree.Type.t, [`Msg of string]) result 74 | (** [parse ?file ?primitives input] tries to parse [input] and binds primitives 75 | with their associated names (see {!primitive}) in resulted {!Parsetree.expr} 76 | expression. [?file] helps to produce a better error message. *) 77 | 78 | val parse_exn: ?file:string -> ?primitives:primitive list -> ?gamma:(string * Parsetree.Type.abstract) list -> string -> Parsetree.expr * Parsetree.Type.t 79 | end 80 | 81 | val typ: Parsetree.expr -> (expr, error) result 82 | (** [typ unsafe_expr] tries to type [unsafe_expr]. *) 83 | 84 | val typ_exn: Parsetree.expr -> expr 85 | 86 | val untype: expr -> Parsetree.expr 87 | 88 | val eval: expr -> value 89 | (** [eval safe_expr] safely evals [safe_expr] and returns resulting computation. 90 | *) 91 | 92 | val cast: value -> 'a typ -> 'a option 93 | (** [cast v typ] unwraps value [v] and proves type of it is equivalent to [ty]. 94 | *) 95 | val uncast: 'a typ -> 'a -> Parsetree.value 96 | 97 | val type_and_eval: Parsetree.expr -> 'a typ -> ('a, error) result 98 | (** [type_and_eval unsafe_expr ty] tries to type [unsafe_expr] to [ty], evals it 99 | safely and returns resulting computation. *) 100 | 101 | (** {1 Lwt} *) 102 | 103 | module L: sig 104 | val primitive: 105 | string -> ('a, 'b Lwt.t) Args.t -> ('b, Type.lwt) Type.app typ -> 106 | 'a -> primitive 107 | (** [primitives name types_of_args type_of_res f] records a new LWT primitive. 108 | *) 109 | 110 | val cast: value -> ('a, Type.lwt) Type.app typ -> 'a Lwt.t option 111 | (** [cast v typ] unwraps LWT value [v] and proves type of it is equivalent to 112 | [ty]. *) 113 | 114 | val uncast: 'a Lwt.t typ -> ('a, Type.lwt) Type.app -> Parsetree.value 115 | 116 | val type_and_eval: 117 | Parsetree.expr -> ('a, Type.lwt) Type.app typ -> ('a Lwt.t, error) result 118 | (** [type_and_eval unsafe_lwt_expr ty] tries to type [unsafe_lwt_expr] to 119 | [ty], evals it under LWT context safely and returns resulting 120 | computation. *) 121 | end 122 | -------------------------------------------------------------------------------- /src/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | (* 3 | * Copyright (c) 2018 Thomas Gazagnaire 4 | * and Romain Calascibetta 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Parser 20 | 21 | type t = { 22 | debug : bool; 23 | buffer : Buffer.t 24 | } 25 | 26 | let v ?(debug=false) () = { debug; buffer = Buffer.create 8196 } 27 | let p t fmt = Fmt.kstrf (fun s -> if t.debug then print_endline s) fmt 28 | 29 | let eof t = 30 | p t "EOF"; 31 | EOF 32 | 33 | let get_string t = 34 | let str = Buffer.contents t.buffer in 35 | Buffer.reset t.buffer; 36 | p t "STRING %S" str; 37 | STRING str 38 | 39 | let add_char t c = 40 | p t "adding %c" c; 41 | Buffer.add_char t.buffer c 42 | 43 | let add_newline t l = 44 | Lexing.new_line l; 45 | let str = Lexing.lexeme l in 46 | for i = 0 to String.length str - 1 do 47 | add_char t str.[i] 48 | done 49 | 50 | let check_newlines l = 51 | let s = Lexing.lexeme l in 52 | for i=0 to String.length s - 1 do 53 | if s.[i] = '\n' then Lexing.new_line l 54 | done 55 | 56 | exception Error of string 57 | let syntax_error s = raise (Error s) 58 | 59 | } 60 | 61 | let digit = ['0'-'9'] 62 | let alpha = ['a'-'z' 'A'-'Z' '_'] 63 | let var = alpha (alpha | digit | '-' | '.' | '\'')* 64 | let newline = '\r' | '\n' | "\r\n" 65 | let white = [' ' '\t']+ 66 | 67 | rule program t = parse 68 | | white { program t lexbuf } 69 | | newline { Lexing.new_line lexbuf; program t lexbuf } 70 | | '"' { string t lexbuf } 71 | | (digit+ as s) 'L' { p t "INT64 %s" s; INT64 (Int64.of_string s) } 72 | | (digit+ as s) 'l' { p t "INT32 %s" s; INT32 (Int32.of_string s) } 73 | | digit+ as s { p t "INT %s" s; INT (int_of_string s)} 74 | | "->" { p t "ARROW"; ARROW } 75 | | "+" { p t "PLUS"; PLUS } 76 | | "-" { p t "MINUS"; MINUS } 77 | | "*" { p t "TIMES"; TIMES } 78 | | "=" { p t "EQ"; EQ } 79 | | "," { p t "COMMA"; COMMA } 80 | | ":" { p t "COLON"; COLON } 81 | | ";" { p t "SEMI"; SEMI } 82 | | "$" { p t "DOLLAR"; DOLLAR } 83 | | "(" { p t "LPAR"; LPAR } 84 | | ")" { p t "RPAR"; RPAR } 85 | | "[" { p t "LSQU"; LSQU } 86 | | "]" { p t "RSQU"; RSQU } 87 | | "|" { p t "BAR"; BAR } 88 | | "if" { p t "IF"; IF } 89 | | "then" { p t "THEN"; THEN } 90 | | "else" { p t "ELSE"; ELSE } 91 | | "R" { p t "R"; R } 92 | | "L" { p t "L"; L } 93 | | "unit" { p t "unit"; UNIT } 94 | | "get" { p t "get"; GET } 95 | | "fst" { p t "FST"; FST } 96 | | "prj" { p t "PRJ"; PRJ } 97 | | "snd" { p t "SND"; SND } 98 | | "let" { p t "LET"; LET } 99 | | "in" { p t "IN"; IN } 100 | | "fun" { p t "FUN"; FUN } 101 | | "rec" { p t "REC"; REC } 102 | | "true" { p t "TRUE"; BOOL true } 103 | | "false" { p t "FALSE"; BOOL false } 104 | | "int" { p t "int"; S_INT } 105 | | "int32" { p t "int32"; S_INT32 } 106 | | "int64" { p t "int64"; S_INT64 } 107 | | "list" { p t "list"; S_LIST } 108 | | "array" { p t "array"; S_ARRAY } 109 | | "option" { p t "option"; S_OPTION } 110 | | "return" { p t "RETURN"; RETURN } 111 | | ">>=" { p t ">>="; BIND } 112 | | "Ok" { p t "Ok"; OK } 113 | | "Error" { p t "Error"; ERROR } 114 | | "Some" { p t "Some"; SOME } 115 | | "None" { p t "None"; NONE } 116 | | "result" { p t "result"; S_RESULT } 117 | | "bool" { p t "bool"; S_BOOL } 118 | | "string" { p t "string"; S_STRING } 119 | | "Lwt.t" { p t "Lwt.t"; S_LWT } 120 | | var as s { p t "VAR %s" s; VAR s } 121 | | eof { EOF } 122 | 123 | and string t = parse 124 | | '"' { get_string t } 125 | | newline { add_newline t lexbuf; string t lexbuf } 126 | | _ as c { add_char t c; string t lexbuf } 127 | 128 | { 129 | 130 | let token t lexbuf = program t lexbuf 131 | 132 | } 133 | -------------------------------------------------------------------------------- /src/parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | 3 | (* 4 | * Copyright (c) 2018 Thomas Gazagnaire 5 | * and Romain Calascibetta 6 | * 7 | * Permission to use, copy, modify, and distribute this software for any 8 | * purpose with or without fee is hereby granted, provided that the above 9 | * copyright notice and this permission notice appear in all copies. 10 | * 11 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 12 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 13 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 14 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 15 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 16 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 17 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 18 | *) 19 | 20 | exception Internal of string 21 | 22 | let err fmt = Fmt.kstrf (fun s -> raise (Internal s)) fmt 23 | 24 | let err_unbound v prims ctx = 25 | err "The variable %s is not bound in %a" 26 | v Fmt.(Dump.list string) (List.map fst prims @ ctx) 27 | 28 | let index v l = 29 | let rec aux i = function 30 | | [] -> None 31 | | h::t -> if String.equal h v then Some i else aux (i+1) t 32 | in 33 | aux 0 l 34 | 35 | let resolve_name v prims ctx = 36 | match index v ctx with 37 | | Some i -> Parsetree.var i 38 | | None -> 39 | if List.mem_assoc v prims then List.assoc v prims 40 | else err_unbound v prims ctx 41 | 42 | let add_ctx a ctx = List.rev_map fst a @ ctx 43 | 44 | let add_prim (_, l) r prims = 45 | let stop = Primitive.stop l r in 46 | let continue = Primitive.continue l r in 47 | stop :: continue :: prims 48 | 49 | open Parsetree 50 | %} 51 | 52 | %token UNIT 53 | %token INT 54 | %token INT32 55 | %token INT64 56 | %token VAR STRING 57 | %token BOOL 58 | 59 | %token NONE SOME OK ERROR 60 | %token RETURN BIND 61 | %token PLUS MINUS 62 | %token TIMES 63 | %token EQ IN COLON SEMI 64 | %token EOF 65 | %token LPAR RPAR LSQU RSQU 66 | %token FUN REC IF ELSE LET THEN 67 | %token COMMA 68 | %token L R 69 | %token APP 70 | %token DOLLAR 71 | %token FST SND GET PRJ 72 | 73 | %token S_INT S_INT32 S_INT64 S_BOOL S_STRING S_LIST S_ARRAY S_OPTION S_RESULT S_LWT 74 | %token ARROW BAR 75 | 76 | %right ARROW 77 | %nonassoc below_SEMI 78 | %nonassoc SEMI 79 | %nonassoc LET 80 | %nonassoc ELSE 81 | %nonassoc COMMA 82 | %left EQ 83 | %left PLUS MINUS 84 | %left TIMES 85 | %left BIND 86 | 87 | %left S_OPTION S_LIST S_ARRAY S_LWT 88 | %nonassoc LSQU VAR INT INT32 INT64 STRING LPAR BOOL REC R L IF FUN FST SND PRJ 89 | OK ERROR SOME RETURN NONE GET UNIT 90 | S_STRING S_INT S_INT32 S_INT64 S_BOOL 91 | %nonassoc APP 92 | 93 | %left BAR 94 | 95 | %start main 96 | %type <(string * Parsetree.expr) list -> (string * Parsetree.Type.abstract) list -> (Parsetree.expr, string) result> main 97 | %type <(string * Parsetree.expr) list -> (string * Parsetree.Type.abstract) list -> string list -> Parsetree.expr> expr 98 | 99 | %start request 100 | %type <(string * Parsetree.expr) list -> (string * Parsetree.Type.abstract) list -> (Parsetree.expr * Parsetree.Type.t, string) result> request 101 | 102 | %% 103 | 104 | main: 105 | | e=expr_seq EOF { fun prims gams -> 106 | try Ok (e prims gams []) 107 | with Internal s -> Error s } 108 | 109 | request: 110 | | e=expr_seq COLON t=typ EOF 111 | { fun prims gams -> 112 | try Ok (e prims gams [], t gams) 113 | with Internal s -> Error s } 114 | 115 | expr_seq: 116 | | e=expr %prec below_SEMI { e } 117 | | e=expr SEMI { e } 118 | | e=expr SEMI b=expr_seq 119 | { fun prims gams ctx -> 120 | let v = "_" and t = Type.unit in 121 | let e = e prims gams ctx in 122 | let b = b prims gams ctx in 123 | let_var t v e b } 124 | 125 | base_expr: 126 | | LPAR e=expr RPAR { e } 127 | | i=INT { fun _ _ _ -> int i } 128 | | i=INT32 { fun _ _ _ -> int32 i } 129 | | i=INT64 { fun _ _ _ -> int64 i } 130 | | s=STRING { fun _ _ _ -> string s } 131 | | b=BOOL { fun _ _ _ -> if b then true_ else false_ } 132 | | v=VAR { fun prims _ ctx -> resolve_name v prims ctx } 133 | | v=VAR DOLLAR i=INT { 134 | fun prims _ ctx -> 135 | let id = index v ctx in 136 | if Pervasives.(id = Some i) then resolve_name v prims ctx 137 | else err "%s$%d should have id %a" v i Fmt.(option int) id } 138 | 139 | 140 | expr: 141 | | e=base_expr { e } 142 | | GET i=base_expr e=base_expr { fun p g c -> get (i p g c) (e p g c) } 143 | | R t=base_typ e=base_expr { fun p g c -> right (t g) (e p g c) } 144 | | L e=base_expr t=base_typ { fun p g c -> left (t g) (e p g c) } 145 | | OK e=base_expr t=base_typ { fun p g c -> ok (t g) (e p g c) } 146 | | ERROR t=base_typ e=base_expr { fun p g c -> error (t g) (e p g c) } 147 | | RETURN e=base_expr { fun p g c -> return (e p g c) } 148 | | x=expr BIND f=expr { fun p g c -> bind (x p g c) (f p g c) } 149 | | SOME e=base_expr { fun p g c -> some (e p g c) } 150 | | NONE t=base_typ { fun _ g _ -> none (t g) } 151 | | FST e=base_expr { fun p g c -> fst (e p g c) } 152 | | SND e=base_expr { fun p g c -> snd (e p g c) } 153 | | PRJ e=base_expr { fun p g c -> prj (e p g c) } 154 | | LSQU BAR BAR RSQU t=base_typ { fun _ g _ -> array ~typ:(t g) [||] } 155 | | LSQU BAR l=list BAR RSQU 156 | { fun p g c -> 157 | let l = List.map (fun e -> e p g c) l in 158 | array (Array.of_list l) } 159 | | LSQU RSQU t=base_typ { fun _ g _ -> list ~typ:(t g) [] } 160 | | LSQU l=list RSQU { fun p g c -> list (List.map (fun e -> e p g c) l) } 161 | | a=expr COMMA b=expr { fun p g c -> pair (a p g c) (b p g c) } 162 | | IF i=expr THEN t=expr ELSE e=expr 163 | { fun prims gams ctx -> 164 | let i = i prims gams ctx in 165 | let t = t prims gams ctx in 166 | let e = e prims gams ctx in 167 | if_ i t e } 168 | | LET v=VAR COLON t=typ EQ e=expr IN b=expr_seq 169 | { fun prims gams ctx -> 170 | let e = e prims gams ctx in 171 | let b = b prims gams (v::ctx) in 172 | let_var (t gams) v e b } 173 | | LET n=VAR LPAR a=args RPAR COLON t=typ EQ e=expr IN b=expr_seq 174 | { fun prims gams ctx -> 175 | let a = a gams in 176 | let e = e prims gams (add_ctx a ctx) in 177 | let b = b prims gams (n :: ctx) in 178 | let_fun (t gams) n a e b 179 | } 180 | | REC n=VAR LPAR a=arg RPAR COLON t=typ EQ e=expr IN b=expr_seq 181 | { fun prims gams ctx -> 182 | let a = a gams in 183 | let t = t gams in 184 | let e = e (add_prim a t prims) gams (add_ctx [a] ctx) in 185 | let b = b prims gams (n :: ctx) in 186 | let_rec t n a e b } 187 | | REC LPAR a=arg RPAR COLON t=base_typ ARROW e=expr 188 | { fun prims gams ctx -> 189 | let a = a gams in 190 | let e = e prims gams (add_ctx [a] ctx) in 191 | fix a (t gams) e } 192 | | FUN LPAR a=args RPAR ARROW e=expr 193 | { fun prims gams ctx -> 194 | let a = a gams in 195 | let e = e prims gams (add_ctx a ctx) in 196 | lambda a e } 197 | | a=expr f=binop b=expr { 198 | fun prims gams ctx -> 199 | let a = a prims gams ctx in 200 | let b = b prims gams ctx in 201 | f a b } 202 | | f=expr x=expr %prec APP { 203 | fun prims gams ctx -> 204 | let f = f prims gams ctx in 205 | let x = x prims gams ctx in 206 | apply f x } 207 | 208 | %inline binop: 209 | | PLUS { ( + ) } 210 | | MINUS { ( - ) } 211 | | TIMES { ( * ) } 212 | | EQ { ( = ) } 213 | 214 | base_typ: 215 | | LPAR a=typ RPAR { a } 216 | | UNIT { fun _ -> Type.unit } 217 | | S_INT { fun _ -> Type.int } 218 | | S_INT32 { fun _ -> Type.int32 } 219 | | S_INT64 { fun _ -> Type.int64 } 220 | | S_BOOL { fun _ -> Type.bool } 221 | | S_STRING { fun _ -> Type.string } 222 | | S_LWT { fun _ -> Type.lwt } 223 | | v=VAR { fun gams -> 224 | try let Type.A ({ name; _}, _ ) = List.assoc v gams in 225 | if String.equal name v 226 | then Type.unsafe_abstract (List.assoc v gams) 227 | else err "Mismatch abstract type: %s <> %s (expected)" v name 228 | with _ -> 229 | err "Invalid abstract type: %s (%a)" 230 | v Fmt.(list (pair string Type.pp_abstract)) gams } 231 | 232 | typ: 233 | | ty=base_typ { ty } 234 | | a=typ S_LIST { fun g -> Type.list (a g) } 235 | | a=typ S_ARRAY { fun g -> Type.array (a g) } 236 | | a=typ S_OPTION { fun g -> Type.option (a g) } 237 | | a=typ ARROW b=typ { fun g -> Type.((a g) @-> (b g)) } 238 | | a=typ TIMES b=typ { fun g -> Type.((a g) ** (b g)) } 239 | | a=typ BAR b=typ { fun g -> Type.((a g) || (b g)) } 240 | | LPAR a=typ COMMA b=typ RPAR S_RESULT { fun g -> Type.result (a g) (b g) } 241 | | a=typ b=typ %prec APP { fun g -> Type.apply (a g) (b g) } 242 | 243 | list: 244 | | x=separated_nonempty_list(SEMI, expr) { x } 245 | 246 | args: 247 | | l=separated_nonempty_list(COMMA, arg) { fun g -> List.map (fun a -> a g) l } 248 | 249 | arg: 250 | | v=VAR COLON t=typ { fun g -> (v, t g) } 251 | -------------------------------------------------------------------------------- /src/parsetree.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2018 Thomas Gazagnaire 3 | * and Romain Calascibetta 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | let pp_infix ~infix pp_a pp_b ppf (a, b) = 19 | Fmt.pf ppf "@[<1>(@[%a@]@ %s @[%a@])@]" pp_a a infix pp_b b 20 | 21 | module Type = struct 22 | 23 | type abstract = A: 'a Eq.witness * 'a Fmt.t option -> abstract 24 | 25 | let pp_abstract ppf (A (a, _)) = Fmt.string ppf a.name 26 | 27 | let equal_abstract (A (a, _)) (A (b, _)) = 28 | a.name = b.name && match Eq.Witness.eq a.wit b.wit with 29 | | Some Eq.Refl -> true 30 | | _ -> false 31 | 32 | type t = 33 | | Unit 34 | | Int 35 | | Int32 36 | | Int64 37 | | Bool 38 | | String 39 | | Bytes 40 | | Lwt 41 | | List of t 42 | | Array of t 43 | | Option of t 44 | | Apply of t * t 45 | | Arrow of t * t 46 | | Pair of t * t 47 | | Either of t * t 48 | | Result of t * t 49 | | Abstract of abstract 50 | [@@deriving show, eq] 51 | 52 | let _ = show 53 | let dump = pp 54 | 55 | let rec pp ppf = function 56 | | Unit -> Fmt.string ppf "unit" 57 | | Int -> Fmt.string ppf "int" 58 | | Int32 -> Fmt.string ppf "int32" 59 | | Int64 -> Fmt.string ppf "int64" 60 | | Bool -> Fmt.string ppf "bool" 61 | | String -> Fmt.string ppf "string" 62 | | Bytes -> Fmt.string ppf "bytes" 63 | | Lwt -> Fmt.pf ppf "Lwt.t" 64 | | List a -> Fmt.pf ppf "%a list" pp a 65 | | Array a -> Fmt.pf ppf "%a array" pp a 66 | | Option a -> Fmt.pf ppf "%a option" pp a 67 | | Abstract a -> Fmt.pf ppf "@[%a@]" pp_abstract a 68 | | Apply (a, b) -> Fmt.pf ppf "@[(%a %a)@]" pp a pp b 69 | | Arrow (a, b) -> Fmt.pf ppf "%a" (pp_infix ~infix:"->" pp pp) (a, b) 70 | | Pair (a, b) -> Fmt.pf ppf "%a" (pp_infix ~infix:"*" pp pp) (a, b) 71 | | Either (a, b) -> Fmt.pf ppf "%a" (pp_infix ~infix:"|" pp pp) (a, b) 72 | | Result (a, b) -> Fmt.pf ppf "(%a, %a) result" pp a pp b 73 | 74 | let unit = Unit 75 | let int = Int 76 | let int32 = Int32 77 | let int64 = Int64 78 | let bool = Bool 79 | let string = String 80 | let bytes = Bytes 81 | let lwt = Lwt 82 | 83 | let list a = List a 84 | let option a = Option a 85 | let array a = Array a 86 | 87 | let arrow a b = Arrow (a, b) 88 | let either a b = Either (a, b) 89 | let abstract ?pp a = Abstract (A (a, pp)) 90 | let unsafe_abstract a = Abstract a 91 | let apply a b = Apply (a, b) 92 | let result a b = Result (a, b) 93 | 94 | let ( ** ) a b = Pair (a, b) 95 | let ( @->) = arrow 96 | let ( || ) = either 97 | 98 | end 99 | 100 | type typ = Type.t 101 | let pp_typ = Type.pp 102 | let equal_typ = Type.equal 103 | 104 | type 'a eq = 'a -> 'a -> bool 105 | type value = V: { v: 'a; t: 'a T.t; pp: 'a Fmt.t; eq: 'a eq; } -> value 106 | 107 | let pp_value ppf (V t) = t.pp ppf t.v 108 | 109 | let equal_value (V a) (V b) = 110 | match T.equal a.t b.t with 111 | | Some Eq.Refl -> a.eq a.v b.v 112 | | None -> false 113 | 114 | type primitive = 115 | { name : string 116 | ; args : typ list 117 | ; ret : typ 118 | ; exp : value list -> value [@equal fun _ _ -> true] } 119 | [@@deriving show, eq] 120 | 121 | type arithmetic = [ `Add | `Sub | `Mul | `Div | `ShiftL | `ShiftR | `Xor | `Or | `And ] 122 | [@@deriving show, eq] 123 | 124 | type binop = [ arithmetic | `Pair | `Eq | `Get ] 125 | and unop = Fst | Snd | L of typ | R of typ | Ok of typ | Error of typ | Prj | Not 126 | and var = { id : int } 127 | and expr = 128 | | Val of value 129 | | Prm of primitive 130 | | Lst of typ option * expr list 131 | | Arr of typ option * expr array 132 | | Opt of typ option * expr option 133 | | Ret of expr 134 | | Bnd of expr * expr 135 | | Var of var 136 | | Lam of typ * string * expr 137 | | Rec of { r: typ; p: string * typ; e: expr } 138 | | App of expr * expr 139 | | Bin of binop * expr * expr 140 | | Uno of unop * expr 141 | | Let of typ * string * expr * expr 142 | | Swt of { a : expr 143 | ; b : expr 144 | ; s : expr } 145 | | If of expr * expr * expr 146 | [@@deriving show, eq] 147 | 148 | let _ = 149 | show_expr, show_primitive, show_arithmetic, show_binop, show_unop, 150 | show_var 151 | 152 | let dump = pp_expr 153 | let equal = equal_expr 154 | 155 | let dump_var ppf v = Fmt.pf ppf "$%d" v.id 156 | 157 | let pp_params ppf ts = 158 | let aux ppf (n, t) = Fmt.pf ppf "%s: %a" n Type.pp t in 159 | Fmt.pf ppf "@[<2>(%a)@]" Fmt.(list ~sep:(unit ",@ ") aux) ts 160 | 161 | let pp_get pp ppf (x, y) = 162 | Fmt.pf ppf "@[Get %a %a@]" pp x pp y 163 | 164 | let nth ctx n = 165 | try List.nth ctx n.id 166 | with Failure _ -> 167 | Fmt.failwith "$%d not bound in %a" n.id Fmt.(Dump.list string) ctx 168 | 169 | let pp_op pp x = 170 | match x with 171 | | `Pair -> Fmt.Dump.pair pp pp 172 | | `Get -> pp_get pp 173 | | `Eq | #arithmetic as x -> 174 | let infix = match x with 175 | | `Add -> "+" 176 | | `Sub -> "-" 177 | | `Mul -> "*" 178 | | `Div -> "/" 179 | | `Eq -> "=" 180 | | `ShiftL -> "<<" 181 | | `ShiftR -> ">>" 182 | | `Xor -> "^" 183 | | `Or -> "|" 184 | | `And -> "&" 185 | in 186 | pp_infix ~infix pp pp 187 | 188 | let pp ppf t = 189 | let pp_typ_opt = Fmt.(option ~none:(unit "?") Type.pp) in 190 | let rec aux ctx ppf t = 191 | let pp = aux ctx in 192 | match t with 193 | | Var n -> Fmt.pf ppf "%s$%d" (nth ctx n) n.id 194 | | Val c -> pp_value ppf c 195 | | Lst (t, []) -> Fmt.pf ppf "[] %a" pp_typ_opt t 196 | | Lst (_, l) -> Fmt.Dump.list pp ppf l 197 | | Arr (t, [||]) -> Fmt.pf ppf "[||] %a" pp_typ_opt t 198 | | Arr (_, a) -> Fmt.Dump.array pp ppf a 199 | | Opt (_, Some x) -> Fmt.Dump.option pp ppf (Some x) 200 | | Opt (t, None ) -> Fmt.pf ppf "None %a" pp_typ_opt t 201 | | Ret e -> Fmt.pf ppf "(return (%a))" pp e 202 | | Bnd (x, f) -> Fmt.pf ppf "(%a >>= %a)" pp x pp f 203 | | Prm { name; _ } -> Fmt.string ppf name 204 | | Lam (t, name, e) -> 205 | let pp = aux (name :: ctx) in 206 | Fmt.pf ppf "@[<2>(fun @[(%s:@ %a)@]@ -> @[<2>%a@])@]" 207 | name Type.pp t pp e 208 | | Rec r -> 209 | let pp = aux (fst r.p :: ctx) in 210 | Fmt.pf ppf "@[<2>(rec %a: %a@ ->@ @[<2>%a@])@]" 211 | pp_params [r.p] Type.pp r.r pp r.e 212 | | App (f, a) -> Fmt.pf ppf "@[(@[%a@]@ @[%a@])@]" pp f pp a 213 | | Bin (op, a, b) -> pp_op pp op ppf (a, b) 214 | | Uno (Not, a ) -> Fmt.pf ppf "@[<2>(~@ @[%a@])@]" pp a 215 | | Uno (Prj, a ) -> Fmt.pf ppf "@[<2>(prj@ @[%a@])@]" pp a 216 | | Uno (Fst, a) -> Fmt.pf ppf "@[<2>(fst@ @[%a@])@]" pp a 217 | | Uno (Snd, a) -> Fmt.pf ppf "@[<2>(snd@ @[%a@])@]" pp a 218 | | Uno (L t, a) -> Fmt.pf ppf "@[<2>L@ @[(%a)@] @[(%a)@]@]" pp a Type.pp t 219 | | Uno (R t, a) -> Fmt.pf ppf "@[<2>R@ @[(%a)@] @[(%a)@]@]" Type.pp t pp a 220 | | Uno (Ok t, a) -> Fmt.pf ppf "@[<2>Ok@ @[(%a)@] @[(%a)@]@]" pp a Type.pp t 221 | | Uno (Error t, a) -> 222 | Fmt.pf ppf "@[<2>Error@ @[(%a)@] @[(%a)@]@]" Type.pp t pp a 223 | | Let (t, n, v, f) -> 224 | let pp' = aux (n :: ctx) in 225 | Fmt.pf ppf "@[@[let @[%s: %a@] =@ @[%a@]@]@ in@ @[<2>%a@]@]" 226 | n (Fmt.hvbox Type.pp) t (Fmt.hvbox pp) v (Fmt.hvbox pp') f 227 | | Swt { a; b; s; } -> 228 | Fmt.pf ppf "@[<2>@[match %a with@\n| @[<2>@[L $1@] ->@ \ 229 | @[%a@]@]@\n| @[<2>@[R $1@] ->@ @[%a@]@]@]@]" 230 | pp s pp a pp b 231 | | If (t, a, b) -> 232 | Fmt.pf ppf "@[@[if %a then@,(%a)@]@,@[else@,(%a)@]@]" 233 | pp t pp a pp b 234 | in 235 | aux [] ppf t 236 | 237 | let to_string = Fmt.to_to_string pp 238 | let value v t pp eq = Val (V {v; t; pp; eq;}) 239 | let of_value v = Val v 240 | let prim p = Prm p 241 | 242 | let equal_int : int -> int -> bool = (=) 243 | let equal_bool : bool -> bool -> bool = (=) 244 | 245 | let unit = value () Unit (fun ppf () -> Fmt.pf ppf "()") (fun () () -> true) 246 | let int n = value n Int Fmt.int equal_int 247 | let int32 n = value n Int32 Fmt.int32 Int32.equal 248 | let int64 n = value n Int64 Fmt.int64 Int64.equal 249 | let string s = value s String (fun ppf s -> Fmt.pf ppf "%S" s) String.equal 250 | 251 | let list ?typ l = Lst (typ, l) 252 | let array ?typ l = Arr (typ, l) 253 | let option ?typ l = Opt (typ, l) 254 | let return x = Ret x 255 | let bind x f = Bnd (x, f) 256 | let none typ = option ~typ None 257 | let some e = option (Some e) 258 | let ok t e = Uno (Ok t, e) 259 | let error t e = Uno (Error t, e) 260 | let pair a b = Bin (`Pair, a, b) 261 | let get i x = Bin (`Get, i, x) 262 | let apply f a = App (f, a) 263 | let var id = Var { id } 264 | let match_ s a b = Swt {a; b; s} 265 | let bool b = value b Bool Fmt.bool equal_bool 266 | let true_ = bool true 267 | let false_ = bool false 268 | let fix p r e = Rec {r; p; e} 269 | 270 | let lambda args e = 271 | List.fold_right (fun (name, t) acc -> Lam (t, name, acc)) args e 272 | 273 | let if_ t a b = If (t, a, b) 274 | let left rtyp x = Uno (L rtyp, x) 275 | let right ltyp x = Uno (R ltyp, x) 276 | let fst x = Uno (Fst, x) 277 | let snd x = Uno (Snd, x) 278 | let prj x = Uno (Prj, x) 279 | 280 | let let_var t n x y = Let (t, n, x, y) 281 | 282 | let let_fun t n args e body = 283 | let t = List.fold_right (fun (_, t) acc -> Type.Arrow (t, acc)) args t in 284 | let e = lambda args e in 285 | Let (t, n, e, body) 286 | 287 | let let_rec t n ((_, i) as a) e body = 288 | let ty = Type.Arrow (i, t) in 289 | Let (ty, n, fix a t e, body) 290 | 291 | let primitive name args ret exp = Prm {name; args; ret; exp} 292 | 293 | let ( = ) a b = Bin (`Eq, a, b) 294 | let ( + ) a b = Bin (`Add, a, b) 295 | let ( * ) a b = Bin (`Mul, a, b) 296 | let ( - ) a b = Bin (`Sub, a, b) 297 | let ( / ) a b = Bin (`Div, a, b) 298 | 299 | let ( << ) a b = Bin (`ShiftL, a, b) 300 | let ( >> ) a b = Bin (`ShiftR, a, b) 301 | let ( lor ) a b = Bin (`Or, a, b) 302 | let ( lxor ) a b = Bin (`Xor, a, b) 303 | let ( land ) a b = Bin (`And, a, b) 304 | let lnot x = Uno (Not, x) 305 | -------------------------------------------------------------------------------- /src/parsetree.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2018 Thomas Gazagnaire 3 | * and Romain Calascibetta 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | (** Parsetree *) 19 | 20 | module Type: sig 21 | 22 | type abstract = A: 'a Eq.witness * 'a Fmt.t option -> abstract 23 | 24 | type t = private 25 | | Unit 26 | (** Unit type. *) 27 | | Int 28 | (** Native integer. *) 29 | | Int32 30 | (** 32-bits integer. *) 31 | | Int64 32 | (** 64-bits integer. *) 33 | | Bool 34 | (** Bool type. *) 35 | | String 36 | (** String type. *) 37 | | Bytes 38 | (** Bytes type. *) 39 | | Lwt 40 | (** Lwt constructor. *) 41 | | List of t 42 | (** List type (unary type constructor). *) 43 | | Array of t 44 | (** Array type (unary type constructor). *) 45 | | Option of t 46 | (** Option type (unary type constructor). *) 47 | | Apply of t * t 48 | (** Application of unary constructor with type. *) 49 | | Arrow of t * t 50 | (** Function type constructor. *) 51 | | Pair of t * t 52 | (** Pair type constructor. *) 53 | | Either of t * t 54 | (** Either type constructor. *) 55 | | Result of t * t 56 | (** Result type constructor. *) 57 | | Abstract of abstract 58 | (** Abstract type. *) 59 | 60 | (** {2 Type constructor.} *) 61 | 62 | val unit: t 63 | val int: t 64 | val int32: t 65 | val int64: t 66 | val bool: t 67 | val string: t 68 | val bytes: t 69 | val lwt: t 70 | 71 | val list: t -> t 72 | val array: t -> t 73 | val option: t -> t 74 | val either: t -> t -> t 75 | val result: t -> t -> t 76 | 77 | val abstract: ?pp:'a Fmt.t -> 'a Eq.witness -> t 78 | val unsafe_abstract: abstract -> t 79 | val apply: t -> t -> t 80 | 81 | (** {2 Infix operators.} *) 82 | 83 | val ( ** ): t -> t -> t 84 | val ( @->): t -> t -> t 85 | val ( || ): t -> t -> t 86 | 87 | (** {2 Pretty-printer.} *) 88 | 89 | val pp: t Fmt.t 90 | val pp_abstract: abstract Fmt.t 91 | val dump: t Fmt.t 92 | end 93 | 94 | type 'a eq = 'a -> 'a -> bool 95 | 96 | (** OCaml value (with type and pretty-printer). *) 97 | type value = V: { v: 'a; t: 'a T.t; pp: 'a Fmt.t; eq: 'a eq; } -> value 98 | 99 | (** Type of {!expr}. *) 100 | type typ = Type.t 101 | 102 | (** De-bruijn variable. *) 103 | type var = {id: int} 104 | 105 | (** Arithmetic operations. *) 106 | type arithmetic = [ `Add | `Sub | `Mul | `Div | `ShiftL | `ShiftR | `Xor | `Or | `And ] 107 | 108 | type expr = private 109 | | Val of value 110 | (** OCaml value. *) 111 | | Prm of primitive 112 | (** Primitive. *) 113 | | Lst of typ option * expr list 114 | (** List term. *) 115 | | Arr of typ option * expr array 116 | (** Array term. *) 117 | | Opt of typ option * expr option 118 | (** Option term. *) 119 | | Ret of expr 120 | (** Monadic return *) 121 | | Bnd of expr * expr 122 | (** Monadic bind *) 123 | | Var of var 124 | (** Variable. *) 125 | | Lam of typ * string * expr 126 | (** Lambda expression. *) 127 | | Rec of { r: typ; p: string * typ; e: expr } 128 | (** Recursive expression. *) 129 | | App of expr * expr 130 | (** Application term. *) 131 | | Bin of binop * expr * expr 132 | (** Binary operation. *) 133 | | Uno of unop * expr 134 | (** Unary operation. *) 135 | | Let of typ * string * expr * expr 136 | (** Let expression. *) 137 | | Swt of { a : expr 138 | ; b : expr 139 | ; s : expr } 140 | (** Switch on either value term. *) 141 | | If of expr * expr * expr 142 | (** Conditional term. *) 143 | 144 | and primitive = 145 | { name : string 146 | ; args : typ list 147 | ; ret : typ 148 | ; exp : value list -> value } 149 | (** A user-defined primitive. *) 150 | 151 | and binop = [ arithmetic | `Pair | `Eq | `Get ] 152 | (** Binary operations. *) 153 | 154 | (** Unary operations. *) 155 | and unop = Fst | Snd | L of typ | R of typ | Ok of typ | Error of typ | Prj | Not 156 | 157 | (** {2 Pretty-printers.} *) 158 | 159 | val pp: expr Fmt.t 160 | val to_string: expr -> string 161 | val equal_typ: typ eq 162 | val equal: expr eq 163 | val dump: expr Fmt.t 164 | 165 | val pp_value: value Fmt.t 166 | 167 | val dump_var: var Fmt.t 168 | 169 | (** {2 Constructors.} *) 170 | 171 | val unit: expr 172 | val prim: primitive -> expr 173 | 174 | val int: int -> expr 175 | val int32: int32 -> expr 176 | val int64: int64 -> expr 177 | val list: ?typ:typ -> expr list -> expr 178 | val array: ?typ:typ -> expr array -> expr 179 | val none: typ -> expr 180 | val some: expr -> expr 181 | val ok: typ -> expr -> expr 182 | val error: typ -> expr -> expr 183 | val return: expr -> expr 184 | val bind: expr -> expr -> expr 185 | 186 | val string: string -> expr 187 | 188 | val true_: expr 189 | val false_: expr 190 | 191 | val value: 'a -> 'a T.t -> 'a Fmt.t -> 'a eq -> expr 192 | val of_value: value -> expr 193 | 194 | val lambda: (string * typ) list -> expr -> expr 195 | 196 | val pair: expr -> expr -> expr 197 | val get: expr -> expr -> expr 198 | 199 | val fst: expr -> expr 200 | val snd: expr -> expr 201 | val prj: expr -> expr 202 | 203 | val left: typ -> expr -> expr 204 | val right: typ -> expr -> expr 205 | 206 | val let_var: typ -> string -> expr -> expr -> expr 207 | val let_fun: typ -> string -> (string * typ) list -> expr -> expr -> expr 208 | val let_rec: typ -> string -> string * typ -> expr -> expr -> expr 209 | 210 | val if_: expr -> expr -> expr -> expr 211 | val match_: expr -> expr -> expr -> expr 212 | val apply: expr -> expr -> expr 213 | val fix: (string * typ) -> typ -> expr -> expr 214 | 215 | val var: int -> expr 216 | val primitive: string -> typ list -> typ -> (value list -> value) -> expr 217 | 218 | (** {2 Infix operators.} *) 219 | 220 | val ( = ): expr -> expr -> expr 221 | val ( + ): expr -> expr -> expr 222 | val ( - ): expr -> expr -> expr 223 | val ( * ): expr -> expr -> expr 224 | val ( / ): expr -> expr -> expr 225 | val ( << ): expr -> expr -> expr 226 | val ( >> ): expr -> expr -> expr 227 | val ( lor ): expr -> expr -> expr 228 | val ( land ): expr -> expr -> expr 229 | val ( lxor ): expr -> expr -> expr 230 | val lnot: expr -> expr 231 | -------------------------------------------------------------------------------- /src/primitive.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2018 Thomas Gazagnaire 3 | * and Romain Calascibetta 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | open Typedtree 19 | 20 | module Args = struct 21 | 22 | type ('a, 'res) t = 23 | | [] : ('res, 'res) t 24 | | (::) : 'a typ * ('k, 'res) t -> ('a -> 'k, 'res) t 25 | 26 | end 27 | 28 | type ('f, 'a) t = { 29 | name : string; 30 | args : ('f, 'a) Args.t; 31 | output: 'a typ; 32 | body : 'f; 33 | } 34 | 35 | let v name args output body = { name; args; output; body } 36 | 37 | let untype_args args = 38 | let open Args in 39 | let rec aux: 40 | type a b. Parsetree.typ list -> (a, b) Args.t -> Parsetree.typ list 41 | = fun acc -> function 42 | | [] -> List.rev acc 43 | | h::t -> aux (Type.untype h :: acc) t 44 | in 45 | aux args 46 | 47 | let rec apply: 48 | type a b. (a, b) Args.t -> a -> Parsetree.value list -> b * (b, b) Args.t 49 | = fun args f params -> 50 | let open Args in 51 | match args, params with 52 | | [] , [] -> f, [] 53 | | a::b, h::t -> apply b (f @@ Value.cast h a) t 54 | | _ -> failwith "invalid arity" 55 | 56 | let untype v = 57 | let inputs = untype_args [] v.args in 58 | Parsetree.primitive v.name inputs (Type.untype v.output) (fun l -> 59 | let r, _ = apply v.args v.body l in 60 | Value.untype v.output r 61 | ) 62 | 63 | let continue l r = 64 | let Type.V l = Type.typ l in 65 | let Type.V r = Type.typ r in 66 | let ty = Type.either l r in 67 | let f x = T.L x in 68 | let n = "continue" in 69 | n, (v n Args.[l] ty f |> untype) 70 | 71 | let stop l r = 72 | let Type.V l = Type.typ l in 73 | let Type.V r = Type.typ r in 74 | let ty = Type.either l r in 75 | let f x = T.R x in 76 | let n = "stop" in 77 | n, (v n Args.[r] ty f |> untype) 78 | 79 | module L = struct 80 | 81 | (* XXX(samoht): there's probably a better way then to duplicate the 82 | module, but I didn't find it. *) 83 | 84 | type ('f, 'a) t = { 85 | name : string; 86 | args : ('f, 'a Lwt.t) Args.t; 87 | output: ('a, Type.lwt) Type.app typ; 88 | body : 'f; 89 | } 90 | 91 | let v name args output body = { name; args; output; body } 92 | 93 | let untype_args args = 94 | let open Args in 95 | let rec aux: 96 | type a b. Parsetree.typ list -> (a, b) Args.t -> Parsetree.typ list 97 | = fun acc -> function 98 | | [] -> List.rev acc 99 | | h::t -> aux (Type.untype h :: acc) t 100 | in 101 | aux args 102 | 103 | let rec apply: 104 | type a b. (a, b) Args.t -> a -> Parsetree.value list -> b * (b, b) Args.t 105 | = fun args f params -> 106 | let open Args in 107 | match args, params with 108 | | [] , [] -> f, [] 109 | | a::b, h::t -> apply b (f @@ Value.cast h a) t 110 | | _ -> failwith "invalid arity" 111 | 112 | let untype v = 113 | let inputs = untype_args [] v.args in 114 | Parsetree.primitive v.name inputs (Type.untype v.output) (fun l -> 115 | let r, _ = apply v.args v.body l in 116 | Value.untype v.output (App (Type.Lwt.inj r)) 117 | ) 118 | end 119 | -------------------------------------------------------------------------------- /src/primitive.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2018 Thomas Gazagnaire 3 | * and Romain Calascibetta 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | open Typedtree 19 | 20 | module Args: sig 21 | 22 | (** Arguments of a primitive. *) 23 | type ('a, 'res) t = 24 | | [] : ('res, 'res) t 25 | | (::) : 'a typ * ('k, 'res) t -> ('a -> 'k, 'res) t 26 | 27 | end 28 | 29 | type ('f, 'a) t 30 | 31 | val v: string -> ('a, 'b) Args.t -> 'b typ -> 'a -> ('a, 'b) t 32 | val untype_args: Parsetree.typ list -> ('a, 'b) Args.t -> Parsetree.typ list 33 | val apply: ('a, 'b) Args.t -> 'a -> Parsetree.value list -> 'b * ('b, 'b) Args.t 34 | val untype: ('a, 'b) t -> Parsetree.expr 35 | 36 | val continue: Parsetree.typ -> Parsetree.typ -> string * Parsetree.expr 37 | val stop: Parsetree.typ -> Parsetree.typ -> string * Parsetree.expr 38 | 39 | module L: sig 40 | 41 | (** Lwt primitive. *) 42 | 43 | type ('f, 'a) t 44 | 45 | val v: string -> 46 | ('a, 'b Lwt.t) Args.t -> ('b, Type.lwt) Type.app typ -> 'a -> ('a, 'b) t 47 | (** [v args ty f] makes an Lwt primitive which take [args] and return a Lwt 48 | [value : ty]. *) 49 | 50 | val untype_args: Parsetree.typ list -> ('a, 'b) Args.t -> Parsetree.typ list 51 | (** [untype_args acc types] puts successively untype element of [types] to 52 | [acc] and reverse [acc] at the end of process. *) 53 | 54 | val apply: ('a, 'b) Args.t -> 'a -> Parsetree.value list -> 'b * ('b, 'b) Args.t 55 | (** [apply types_of_args f args] applies successively [f] with values [args] 56 | which follow types [types_of_args]. If one of [args] does not have expected 57 | type of [types_of_args], we raise [Invalid_argument]. If length of [args] 58 | is not equal to length of [types_of_args], we raise [Failure]. *) 59 | 60 | val untype: ('a, 'b) t -> Parsetree.expr 61 | (** [untype p] transforms a typed primitive [t] to an un-typed primitives. *) 62 | 63 | end 64 | -------------------------------------------------------------------------------- /src/t.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2018 Thomas Gazagnaire 3 | * and Romain Calascibetta 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | module Lwt = Higher.Newtype1(Lwt) 19 | let lwt: Lwt.t Eq.witness = Eq.witness "Lwt.t" 20 | 21 | type ('l, 'r) either = ('l, 'r) Eq.either = 22 | | L of 'l 23 | | R of 'r 24 | 25 | type ('a, 'b) app = App of ('a, 'b) Higher.app 26 | 27 | type lwt = Lwt.t 28 | 29 | type 'a abstract = { eq: 'a Eq.witness; pp: 'a Fmt.t option } 30 | 31 | type _ t = 32 | | Unit : unit t 33 | | Int : int t 34 | | Int32 : int32 t 35 | | Int64 : int64 t 36 | | Bool : bool t 37 | | String : string t 38 | | Bytes : bytes t 39 | | Lwt : lwt t 40 | | List : 'a t -> 'a list t 41 | | Array : 'a t -> 'a array t 42 | | Option : 'a t -> 'a option t 43 | | Abstract: 'a abstract -> 'a t 44 | | Apply : 'a t * 'b t -> ('a, 'b) app t 45 | | Arrow : 'a t * 'b t -> ('a -> 'b) t 46 | | Pair : 'a t * 'b t -> ('a * 'b) t 47 | | Either : 'a t * 'b t -> ('a, 'b) either t 48 | | Result : 'a t * 'b t -> ('a, 'b) result t 49 | 50 | let rec equal: type a b. a t -> b t -> (a, b) Eq.refl option = fun a b -> 51 | match a, b with 52 | | Unit , Unit -> Some Eq.Refl 53 | | Int , Int -> Some Eq.Refl 54 | | Int32 , Int32 -> Some Eq.Refl 55 | | Int64 , Int64 -> Some Eq.Refl 56 | | Bool , Bool -> Some Eq.Refl 57 | | String, String -> Some Eq.Refl 58 | | Bytes , Bytes -> Some Eq.Refl 59 | | Lwt , Lwt -> Some Eq.Refl 60 | | List a , List b -> 61 | (match equal a b with Some Eq.Refl -> Some Eq.Refl | _ -> None) 62 | | Array a , Array b -> 63 | (match equal a b with Some Eq.Refl -> Some Eq.Refl | _ -> None) 64 | | Option a, Option b -> 65 | (match equal a b with Some Eq.Refl -> Some Eq.Refl | _ -> None) 66 | | Abstract a, Abstract b -> Eq.Witness.eq a.eq.wit b.eq.wit 67 | | Apply (a, a') , Apply (b, b') -> 68 | (match equal a b, equal a' b' with 69 | | Some Eq.Refl, Some Eq.Refl -> Some Eq.Refl 70 | | _ -> None) 71 | | Arrow (a, a') , Arrow (b, b') -> Eq.(equal a b >>= fun Refl -> equal a' b') 72 | | Either (a, a'), Either (b, b') -> Eq.(equal a b >?= fun Refl -> equal a' b') 73 | | Result (a, a'), Result (b, b') -> 74 | (match equal a b, equal a' b' with 75 | | Some Eq.Refl, Some Eq.Refl -> Some Eq.Refl 76 | | _ -> None) 77 | | Pair (a, a') , Pair (b, b') -> Eq.(equal a b >&= fun Refl -> equal a' b') 78 | | Int , _ -> None | Bool, _ -> None | String, _ -> None 79 | | Abstract _, _ -> None | Arrow _, _ -> None | Either _, _ -> None 80 | | Pair _, _ -> None | Unit, _ -> None | Lwt, _ -> None 81 | | Apply _, _ -> None | Int32, _ -> None | Int64, _ -> None 82 | | List _, _ -> None | Array _, _ -> None | Option _, _ -> None 83 | | Result _, _ -> None 84 | | Bytes, _ -> None 85 | -------------------------------------------------------------------------------- /src/typedtree.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2018 Thomas Gazagnaire 3 | * and Romain Calascibetta 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | module Type: sig 19 | 20 | module Lwt: Higher.Newtype1 with type 'a s = 'a Lwt.t and type t = T.lwt 21 | 22 | type lwt = Lwt.t 23 | 24 | type ('a, 'b) app = ('a, 'b) T.app = App of ('a, 'b) Higher.app 25 | 26 | type ('a, 'b) either = ('a, 'b) T.either = 27 | | L of 'a 28 | | R of 'b 29 | 30 | type 'a abstract = 'a T.abstract = { eq: 'a Eq.witness; pp: 'a Fmt.t option } 31 | 32 | type 'a t = 'a T.t = 33 | | Unit : unit t 34 | | Int : int t 35 | | Int32 : int32 t 36 | | Int64 : int64 t 37 | | Bool : bool t 38 | | String : string t 39 | | Bytes : bytes t 40 | | Lwt : lwt t 41 | | List : 'a t -> 'a list t 42 | | Array : 'a t -> 'a array t 43 | | Option : 'a t -> 'a option t 44 | | Abstract: 'a abstract -> 'a t 45 | | Apply : 'a t * 'b t -> ('a, 'b) app t 46 | | Arrow : 'a t * 'b t -> ('a -> 'b) t 47 | | Pair : 'a t * 'b t -> ('a * 'b) t 48 | | Either : 'a t * 'b t -> ('a, 'b) either t 49 | | Result : 'a t * 'b t -> ('a, 'b) result t 50 | 51 | val equal: 'a t -> 'b t -> ('a, 'b) Eq.refl option 52 | (** [eq a b] proves than [a] and [b] have the same type if we return [Some 53 | Eq.Refl]. *) 54 | 55 | val untype: 'a t -> Parsetree.typ 56 | (** [untype t] un-types [t] to a {!Parsetree.typ} value. *) 57 | 58 | val abstract_injection: 'a t -> Parsetree.Type.abstract 59 | 60 | (** {2 Constructors.} *) 61 | 62 | val unit: unit t 63 | val int: int t 64 | val int32: int32 t 65 | val int64: int64 t 66 | val bool: bool t 67 | val string: string t 68 | val bytes: bytes t 69 | 70 | val list: 'a t -> 'a list t 71 | val option: 'a t -> 'a option t 72 | val array: 'a t -> 'a array t 73 | val abstract: ?pp:'a Fmt.t -> string -> 'a t 74 | 75 | val lwt: 'a t -> ('a, lwt) app t 76 | val apply: 'a t -> 'b t -> ('a, 'b) app t 77 | 78 | val either: 'a t -> 'b t -> ('a, 'b) either t 79 | val result: 'a t -> 'b t -> ('a, 'b) result t 80 | 81 | (** {2 Infix operators.} *) 82 | 83 | val ( @->): 'a t -> 'b t -> ('a -> 'b) t 84 | val ( ** ): 'a t -> 'b t -> ('a * 'b) t 85 | val ( || ): 'a t -> 'b t -> ('a, 'b) either t 86 | 87 | (** {2 Pretty-printer.} *) 88 | 89 | val pp_val: 'a t -> 'a Fmt.t 90 | val eq_val: 'a t -> 'a Parsetree.eq 91 | 92 | (** {2 Witness type value.} *) 93 | 94 | type v = V : 'a t -> v 95 | 96 | val typ: Parsetree.typ -> v 97 | (** [typ ut] returns a witness of type [ut]. *) 98 | 99 | val eq: 'a t Parsetree.eq 100 | val pp: 'a t Fmt.t 101 | end 102 | 103 | module Value: sig 104 | 105 | val cast: Parsetree.value -> 'a Type.t -> 'a 106 | (** [cast value typ] casts unsafe [value] with [typ]. If [value] does have the 107 | type [typ], we raise [Invalid_argument]. *) 108 | 109 | val untype: 'a Type.t -> 'a -> Parsetree.value 110 | (** [untype ty value] wraps [value] to {!Parsetree.value} and, by this way, 111 | untypes it (however, we keep a witness of type). *) 112 | 113 | val untype_lwt: 'a Lwt.t Type.t -> ('a, Type.lwt) Type.app -> Parsetree.value 114 | (** [untype_lwt ty value] wraps an LWT [value] to {!Parsetree.value} and, by this way, 115 | untypes it (however, we keep a witness of type). *) 116 | end 117 | 118 | module Var: sig 119 | 120 | type ('a, 'b) t 121 | 122 | val o : ('a * 'b, 'b) t 123 | (** Zero De-bruijn indice. *) 124 | 125 | val x : unit 126 | (** Unit value. *) 127 | 128 | val ( $ ) : ('a, 'b) t -> unit -> ('a * 'c, 'b) t 129 | (** Infix operator to construct De-bruijn indice in a church-style (e.g. 130 | [o$x$x$x = 3]). *) 131 | end 132 | 133 | module Expr: sig 134 | 135 | type ('a, 'e) t 136 | (** Type of a typed expression. *) 137 | 138 | type 'a lwt = ('a, Type.lwt) Type.app 139 | (** The type for lwt expressions. *) 140 | 141 | (** {2 Constructors.} *) 142 | 143 | val unit: unit -> ('a, unit) t 144 | val int: int -> ('a, int) t 145 | val int32: int32 -> ('a, int32) t 146 | val int64: int64 -> ('a, int64) t 147 | 148 | val list: 'a Type.t -> 'a list -> ('e, 'a list) t 149 | val array: 'a Type.t -> 'a array -> ('e, 'a array) t 150 | val option: 'a Type.t -> 'a option -> ('a, 'a option) t 151 | 152 | val bool: bool -> ('a, bool) t 153 | val string: string -> ('a, string) t 154 | val pair: ('a, 'b) t -> ('a, 'c) t -> ('a, 'b * 'c) t 155 | 156 | val fst: ('a, 'b * 'c) t -> ('a, 'b) t 157 | val snd: ('a, 'b * 'c) t -> ('a, 'c) t 158 | 159 | val left : ('a, 'b) t -> 'c Type.t -> ('a, ('b, 'c) Type.either) t 160 | val right: 'c Type.t -> ('a, 'b) t -> ('a, ('c, 'b) Type.either) t 161 | 162 | val var: ('a, 'b) Var.t -> ('a, 'b) t 163 | 164 | val if_: ('a, bool) t -> ('a, 'b) t -> ('a, 'b) t -> ('a, 'b) t 165 | 166 | val fix: 167 | (string * 'a Type.t) -> 'b Type.t -> 168 | ('c * 'a, ('a, 'b) Type.either) t -> ('c, 'a -> 'b) t 169 | 170 | val let_rec: 171 | (string * 'a Type.t) -> 'b Type.t -> 172 | (context : ('e *'a, 'a) t -> 173 | return :(('f, 'b) t -> ('f, ('a, 'b) Type.either) t) -> 174 | continue:(('g, 'a) t -> ('g, ('a, 'b) Type.either) t) -> 175 | ('e * 'a, ('a, 'b) Type.either) t 176 | ) -> ('e, 'a -> 'b) t 177 | 178 | val lambda: (string * 'a Type.t) -> ('b * 'a, 'c) t -> ('b, 'a -> 'c) t 179 | val apply: ('a, 'b -> 'c) t -> ('a, 'b) t -> ('a, 'c) t 180 | val return: 'a -> 'a lwt 181 | val eval: ('e, 'a) t -> 'e -> 'a 182 | 183 | (** {2 Infix operators.} *) 184 | 185 | val ( = ): ('a, 'b) t -> ('a, 'b) t -> ('a, bool) t 186 | val ( + ): ('a, int) t -> ('a, int) t -> ('a, int) t 187 | val ( - ): ('a, int) t -> ('a, int) t -> ('a, int) t 188 | val ( * ): ('a, int) t -> ('a, int) t -> ('a, int) t 189 | val ( $ ): ('a, 'b -> 'c) t -> ('a, 'b) t -> ('a, 'c) t 190 | 191 | val untype: ('e, 'a) t -> Parsetree.expr 192 | 193 | type error 194 | (** Type of errors. *) 195 | 196 | val pp_error: error Fmt.t 197 | (** Pretty-printer of {!error}. *) 198 | 199 | type v = V: (unit, 'a) t * 'a Type.t -> v 200 | 201 | val typ: Parsetree.expr -> (v, error) result 202 | (** [typ unsafe_expr] tries to type [unsafe_expr] and returns an {!expr}. *) 203 | 204 | val pp: ('e, 'a) t Fmt.t 205 | (** Pretty-printer of {!t}. *) 206 | 207 | end 208 | 209 | type 'a typ = 'a Type.t 210 | type expr = Expr.v 211 | type value = V: 'a * 'a Type.t -> value 212 | (** Value with type witness. *) 213 | 214 | val pp_value: value Fmt.t 215 | 216 | val err_type_mismatch: 217 | Parsetree.expr -> 'a Type.t -> 'b Type.t -> ('c, Expr.error) result 218 | -------------------------------------------------------------------------------- /src/value.ml: -------------------------------------------------------------------------------- 1 | type ('a, 'b) either = ('a, 'b) T.either = 2 | | L of 'a 3 | | R of 'b 4 | 5 | type t = 6 | | Unit 7 | | Int of int 8 | | Int32 of int32 9 | | Int64 of int64 10 | | Bool of bool 11 | | String of string 12 | | Bytes of Bytes.t 13 | | List of Parsetree.Type.t * t list 14 | | Array of Parsetree.Type.t * t array 15 | | Option of Parsetree.Type.t * t option 16 | | Pair of (t * t) 17 | | Either of (t, t) either * Parsetree.Type.t * Parsetree.Type.t 18 | | Result of (t, t) result * Parsetree.Type.t * Parsetree.Type.t 19 | | Return of (t * Parsetree.Type.t) 20 | 21 | let option_map f = function 22 | | Some v -> Some (f v) 23 | | None -> None 24 | 25 | let pair_map fa fb = fun (a, b) -> (fa a, fb b) 26 | 27 | let either_map fa fb = function 28 | | L a -> L (fa a) 29 | | R b -> R (fb b) 30 | 31 | let result_map fa fb = function 32 | | Ok a -> Ok (fa a) 33 | | Error b -> Error (fb b) 34 | 35 | exception Error of string 36 | 37 | let err fmt = Fmt.kstrf (fun s -> raise (Error s)) fmt 38 | 39 | let unsafe_value : Parsetree.value -> (t, [`Msg of string]) result = 40 | fun (Parsetree.V x) -> 41 | let rec go : type a. a T.t -> a -> t = fun proof value -> match proof with 42 | | T.Unit -> Unit 43 | | T.Int -> Int value 44 | | T.Int32 -> Int32 value 45 | | T.Int64 -> Int64 value 46 | | T.Bool -> Bool value 47 | | T.String -> String value 48 | | T.Bytes -> Bytes value 49 | | T.List t -> List (Typedtree.Type.untype t, List.map (go t) value) 50 | | T.Array t -> Array (Typedtree.Type.untype t, Array.map (go t) value) 51 | | T.Option t -> Option (Typedtree.Type.untype t, option_map (go t) value) 52 | | T.Pair (ta, tb) -> Pair (pair_map (go ta) (go tb) value) 53 | | T.Either (ta, tb) -> Either (either_map (go ta) (go tb) value, Typedtree.Type.untype ta, Typedtree.Type.untype tb) 54 | | T.Result (ta, tb) -> Result (result_map (go ta) (go tb) value, Typedtree.Type.untype ta, Typedtree.Type.untype tb) 55 | | T.Apply (tx, T.Lwt) -> 56 | let Typedtree.Type.App v = value in 57 | let v = Typedtree.Type.Lwt.prj v in 58 | (* The thread is already resolved by `L.eval`. *) 59 | begin match Lwt.state v with 60 | | Fail e -> raise e 61 | | Sleep -> Fmt.invalid_arg "the lwt thread is sleeping" 62 | | Return v -> Return (go tx v, Typedtree.Type.untype tx) 63 | end 64 | | T.Abstract a -> 65 | (match a.pp with 66 | | Some pp -> err "%a" pp value 67 | | None -> err "") 68 | | T.Lwt -> err "lwt" 69 | | T.Arrow _ -> err "" 70 | | T.Apply _ -> err "" 71 | in 72 | try Ok (go x.t x.v) 73 | with Error e -> Error (`Msg e) 74 | -------------------------------------------------------------------------------- /src/value.mli: -------------------------------------------------------------------------------- 1 | type ('a, 'b) either = ('a, 'b) T.either = 2 | | L of 'a 3 | | R of 'b 4 | 5 | type t = 6 | | Unit 7 | | Int of int 8 | | Int32 of int32 9 | | Int64 of int64 10 | | Bool of bool 11 | | String of string 12 | | Bytes of Bytes.t 13 | | List of Parsetree.Type.t * t list 14 | | Array of Parsetree.Type.t * t array 15 | | Option of Parsetree.Type.t * t option 16 | | Pair of (t * t) 17 | | Either of (t, t) either * Parsetree.Type.t * Parsetree.Type.t 18 | | Result of (t, t) result * Parsetree.Type.t * Parsetree.Type.t 19 | | Return of (t * Parsetree.Type.t) 20 | 21 | val unsafe_value: Parsetree.value -> (t, [`Msg of string]) result 22 | -------------------------------------------------------------------------------- /test/jbuild: -------------------------------------------------------------------------------- 1 | (executable 2 | ((name test) 3 | (libraries (lambda alcotest logs.fmt lwt.unix)))) 4 | 5 | (alias 6 | ((name runtest) 7 | (package lambda) 8 | (deps (test.exe)) 9 | (action (run ${exe:test.exe} -q --color=always)))) 10 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2018 Thomas Gazagnaire 3 | * and Romain Calascibetta 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | let reporter ?(prefix="") () = 19 | let report src level ~over k msgf = 20 | let k _ = over (); k () in 21 | let ppf = match level with Logs.App -> Fmt.stdout | _ -> Fmt.stderr in 22 | let with_stamp h _tags k fmt = 23 | Fmt.kpf k ppf ("%s %a %a @[" ^^ fmt ^^ "@]@.") 24 | prefix 25 | Fmt.(styled `Magenta string) (Logs.Src.name src) 26 | Logs_fmt.pp_header (level, h) 27 | in 28 | msgf @@ fun ?header ?tags fmt -> 29 | with_stamp header tags k fmt 30 | in 31 | { Logs.report = report } 32 | 33 | let () = 34 | Logs.set_level (Some Logs.Debug); 35 | Logs.set_reporter (reporter ()); 36 | Printexc.record_backtrace true 37 | 38 | open Lambda 39 | 40 | let pexpr = Alcotest.testable Parsetree.dump Parsetree.equal 41 | let error = Alcotest.testable pp_error (=) 42 | let ok x = Alcotest.result x error 43 | 44 | let parse_exn ?primitives e = 45 | match Lambda.parse ?primitives e with 46 | | Ok y -> y 47 | | Error (`Msg e) -> Alcotest.failf "parsing: %s" e 48 | 49 | let typ_exn e = 50 | match Lambda.typ e with 51 | | Ok y -> y 52 | | Error e -> Alcotest.failf "typing: %a" Lambda.pp_error e 53 | 54 | let test_if () = 55 | let x = Parsetree.(if_ true_ (int 42) (int 21)) in 56 | Alcotest.(check @@ ok int) "if" (Ok 42) (type_and_eval x Type.int); 57 | Alcotest.(check @@ neg @@ ok string) "failure" (Ok "") 58 | (type_and_eval x Type.string) 59 | 60 | let test_match () = 61 | let x = 62 | let open Parsetree in 63 | match_ (left Type.int (string "Hello World!")) 64 | (var 0) 65 | (string "") 66 | in 67 | Alcotest.(check @@ ok string) "match" 68 | (Ok "Hello World!") 69 | (type_and_eval x Type.string) 70 | 71 | 72 | let test_lambda () = 73 | let x = 74 | let open Parsetree in 75 | apply ( 76 | apply ( 77 | lambda [ ("x", Type.int); ("y", Type.int) ] (var 1) 78 | ) (int 42) 79 | ) (int 21) 80 | in 81 | Alcotest.(check @@ ok int) "lambda" (type_and_eval x Type.int) (Ok 42); 82 | let y = parse_exn {| 83 | let f (x: int, y: int): int = x + y in 84 | f 42 21 85 | |} in 86 | Alcotest.(check @@ ok int) "lambda" (type_and_eval y Type.int) (Ok 63) 87 | 88 | let test_fact () = 89 | let code = 90 | let init x = ((fun _ -> 1), x) in 91 | let rec fact v = 92 | if 0 = (snd v) 93 | then (fst v, 0) 94 | else fact ((fun x -> (fst v) x * (snd v)), (snd v) - 1) 95 | in 96 | fun x -> (fst ((fun x -> fact (init x)) x)) 0 97 | in 98 | Alcotest.(check int) "code" 120 (code 5); 99 | 100 | let safe = 101 | let open Expr in 102 | let main = 103 | let_rec Type.("x", int ** int) Type.int (fun ~context ~return ~continue -> 104 | let acc = fst context in 105 | let n = snd context in 106 | (if_ (n = int 0) 107 | (return acc) 108 | (continue (pair (acc * n) (n - int 1)))) 109 | ) in 110 | lambda ("x", Type.int) (main $ (pair (int 1) (var Var.o))) 111 | in 112 | Alcotest.(check @@ int) "safe" 120 (Expr.eval safe () 5); 113 | (* check untyping -> pretty-printing -> parsing -> typing *) 114 | let u = Lambda.Expr.untype safe in 115 | let _ = typ_exn u in 116 | let s = Fmt.to_to_string Lambda.Parsetree.pp u in 117 | let u' = parse_exn s in 118 | let _ = typ_exn u' in 119 | Alcotest.(check pexpr) "full" u u'; 120 | 121 | let unsafe = 122 | let open Parsetree in 123 | let init = pair (lambda ["_", Type.int] (int 1)) (var 0) in 124 | let ptyp = Type.((int @-> int) ** int) in 125 | let main = 126 | fix 127 | ("v", ptyp) Type.int 128 | (if_ 129 | (snd (var 0) = int 0) 130 | (right ptyp (apply (fst (var 0)) (int 0))) 131 | (left Type.int 132 | (pair 133 | (lambda ["y", Type.int] 134 | ((apply (fst (var 1)) (var 0)) * (snd (var 1)))) 135 | (snd (var 0) - int 1)))) 136 | in 137 | lambda ["x", Type.int] (apply main init) 138 | in 139 | Alcotest.(check @@ ok int) "unsafe" (Ok 120) 140 | (type_and_eval unsafe Type.(int @-> int) $ 5); 141 | 142 | let str = parse_exn {| 143 | rec fact (v: int * int): int = 144 | let acc: int = fst v in 145 | let n : int = snd v in 146 | if n = 1 then 147 | stop acc 148 | else 149 | continue (acc * n, n - 1) 150 | in 151 | fun (x: int) -> fact (1, x) 152 | |} in 153 | Alcotest.(check @@ ok int) "parse" (Ok 120) 154 | (type_and_eval str Type.(int @-> int) $ 5) 155 | 156 | let test_prim () = 157 | let _, padd = primitive "%add" [Type.int; Type.int] Type.int (+) in 158 | Alcotest.(check @@ ok int) "padd" (Ok 42) 159 | (type_and_eval padd Type.(int @-> int @-> int) $ 21 $ 21); 160 | 161 | let _, padebool = 162 | primitive "%add-bool" [Type.int; Type.bool] Type.int (fun a -> function 163 | | true -> a + 1 164 | | false -> a 165 | ) in 166 | Alcotest.(check @@ ok int) "padebool" (Ok 1) 167 | (type_and_eval padebool Type.(int @-> bool @-> int) $ 0 $ true); 168 | 169 | let env_and_prim = 170 | let open Parsetree in 171 | (lambda ["x", Type.string] (apply (apply padd (int 21)) (int 21))) 172 | in 173 | 174 | Alcotest.(check @@ ok int) "env_and_prim safe" (Ok 42) 175 | (type_and_eval env_and_prim Type.(string @-> int) $ "Hello World!"); 176 | Alcotest.(check @@ ok int) "env_and_prim unsafe" (Ok 42) 177 | (type_and_eval 178 | Parsetree.(lambda ["x", Type.int] env_and_prim) 179 | Type.(int @-> string @-> int) 180 | $ 0 $ "Hello World!") 181 | 182 | let parse_exn ?primitives s = match parse ?primitives s with 183 | | Ok e -> e 184 | | Error (`Msg e) -> Alcotest.fail e 185 | 186 | let test_parse_expr () = 187 | let check s (a, t) r = 188 | let e = parse_exn s in 189 | Alcotest.(check @@ ok a) ("parse: " ^ s) (Ok r) (type_and_eval e t); 190 | let te = typ_exn e in 191 | let ete = untype te in 192 | Alcotest.(check pexpr) "parse untyped" e ete; 193 | let s' = Fmt.to_to_string Parsetree.pp e in 194 | Logs.debug (fun l -> l "roundtrip: %s => %s" s s'); 195 | let e' = parse_exn s' in 196 | Alcotest.(check @@ pexpr) ("roundtrip: " ^ s') e e'; 197 | let te' = typ_exn e' in 198 | let ete' = untype te' in 199 | Alcotest.(check pexpr) "parse untyped (2)" e' ete' 200 | in 201 | let int = (Alcotest.int, Type.int) in 202 | let bool = (Alcotest.bool, Type.bool) in 203 | let string = (Alcotest.string, Type.string) in 204 | let list l = (Alcotest.list (fst l), Type.list (snd l)) in 205 | let array l = (Alcotest.array (fst l), Type.array (snd l)) in 206 | let option a = (Alcotest.option (fst a), Type.option (snd a)) in 207 | let result a b = 208 | (Alcotest.result (fst a) (fst b), Type.result (snd a) (snd b)) 209 | in 210 | let either a b = 211 | let pp ppf = function 212 | | Type.L x -> Fmt.pf ppf "L %a" (Alcotest.pp (fst a)) x 213 | | R x -> Fmt.pf ppf "R %a" (Alcotest.pp (fst b)) x 214 | in 215 | let eq x y = match x, y with 216 | | Type.L x, Type.L y -> Alcotest.equal (fst a) x y 217 | | R x, R y -> Alcotest.equal (fst b) x y 218 | | _ -> false 219 | in 220 | Alcotest.testable pp eq, Type.either (snd a) (snd b) 221 | in 222 | check "1 + 1 + 1" int 3; 223 | check "1 + 1 * 3" int 4; 224 | check "1 + 1 = 2" bool true; 225 | check "(1 = 2)" bool false; 226 | check "[1;2]" (list int) [1; 2]; 227 | check "[] string" (list string) []; 228 | check "[|1;2|]" (array int) [|1; 2|]; 229 | check "[||] bool" (array bool) [||]; 230 | check "None int" (option int) None; 231 | check "Ok 1 bool" (result int bool) (Ok 1); 232 | check "Error int true" (result int bool) (Error true); 233 | check "Some \"foo\"" (option string) (Some "foo"); 234 | check "L (None int) string" (either (option int) string) (L None); 235 | check "(fun (x:int) -> x + 1) 1" int 2; 236 | check "(fun (x:int, y:bool) -> y) 1 false" bool false; 237 | check {| 238 | (fun (f: int -> int, k:int) -> f k) 239 | (fun (x:int) -> x + 1) 240 | 2 |} int 3 241 | 242 | let test_ping () = 243 | let app t f x = 244 | let f = parse_exn f in 245 | let x = parse_exn x in 246 | match type_and_eval Parsetree.(apply f x) t with 247 | | Ok x -> Fmt.to_to_string (Type.pp_val t) x 248 | | Error e -> Fmt.failwith "%a" pp_error e 249 | in 250 | Alcotest.(check string) "ping" "20" 251 | (app Type.int "(fun (x:int) -> x * 2)" "10") 252 | 253 | let test_primitives () = 254 | let primitives = [ 255 | primitive "string_of_int" [Type.int] Type.string string_of_int 256 | ] in 257 | Alcotest.(check @@ ok string) "safe" (Ok "10") 258 | (type_and_eval (parse_exn ~primitives "string_of_int 10") Type.string) 259 | 260 | module Block: sig 261 | type t 262 | val pp: t Fmt.t 263 | type error 264 | val pp_error: error Fmt.t 265 | val connect: string -> t 266 | val read: t -> int64 -> string list -> (unit, error) result Lwt.t 267 | end = struct 268 | type error = [ `Foo ] 269 | let pp_error ppf `Foo = Fmt.string ppf "Foo" 270 | type t = C of string 271 | let pp ppf (C t) = Fmt.pf ppf "(C %S)" t 272 | let connect n = C n 273 | 274 | let read (C n) off pages = 275 | Logs.debug (fun l -> 276 | l "READ[%s] off=%Ld pages=%a" n off Fmt.(Dump.list string) pages); 277 | if off = 0L then Lwt.return (Error `Foo) else Lwt.return (Ok ()) 278 | 279 | end 280 | 281 | let error_t = Alcotest.testable Block.pp_error (=) 282 | 283 | let lwt_t a = 284 | Alcotest.testable 285 | (fun ppf x -> Alcotest.pp a ppf (Lwt_main.run x)) 286 | (fun x y -> Alcotest.equal a (Lwt_main.run x) (Lwt_main.run y)) 287 | 288 | let test_block () = 289 | let t = Type.abstract "Block.t" in 290 | let error = Type.abstract "Block.error" in 291 | let primitives = [ 292 | primitive "Block.connect" [Type.string] t Block.connect; 293 | primitive "Block.to_string" [t] Type.string (Fmt.to_to_string Block.pp); 294 | L.primitive "Block.read" 295 | Type.[t; int64; list string] Type.(lwt (result unit error)) 296 | Block.read 297 | ] in 298 | let t_t = Alcotest.testable Block.pp (=) in 299 | Alcotest.(check @@ ok t_t) "Block.connect" 300 | (Ok (Block.connect "foo")) 301 | (type_and_eval (parse_exn ~primitives "Block.connect \"foo\"") t); 302 | Alcotest.(check @@ ok string) "compose" 303 | (Ok "(C \"foo\")") 304 | (type_and_eval 305 | (parse_exn ~primitives "Block.to_string (Block.connect \"foo\")") 306 | Type.string); 307 | Alcotest.(check @@ ok (lwt_t (result unit error_t))) "read" 308 | (Ok (Lwt.return (Ok ()))) 309 | (L.type_and_eval 310 | (parse_exn ~primitives "Block.read (Block.connect \"foo\") 1L [\"x\"]") 311 | Type.(lwt (result unit error))); 312 | 313 | let _ = Block.read in 314 | () 315 | 316 | let test_lwt () = 317 | let primitives = [ 318 | L.primitive "double" [Type.int] Type.(lwt int) (fun x -> Lwt.return (x+x)); 319 | ] in 320 | Alcotest.(check @@ ok (lwt_t int)) "double" 321 | (Ok (Lwt.return 4)) 322 | (L.type_and_eval (parse_exn ~primitives "return 2 >>= double") Type.(lwt int)) 323 | 324 | let () = 325 | Alcotest.run "compute" [ 326 | "basic", [ 327 | "if" , `Quick, test_if; 328 | "match" , `Quick, test_match; 329 | "lambda", `Quick, test_lambda; 330 | ]; 331 | "fonctions", [ 332 | "fact" , `Quick, test_fact; 333 | "primitives", `Quick, test_prim; 334 | ]; 335 | "parsing", [ 336 | "expr", `Quick, test_parse_expr; 337 | "ping", `Quick, test_ping; 338 | ]; 339 | "primitives", [ 340 | "simple" , `Quick, test_primitives; 341 | "abstract", `Quick, test_block; 342 | "lwt" , `Quick, test_lwt; 343 | ]; 344 | ] 345 | -------------------------------------------------------------------------------- /test/test.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mirage/mirage-lambda/a89b265b552f8b63ff725fc942f41a276fabb4f5/test/test.mli --------------------------------------------------------------------------------