unikernel/duniverse/ocaml-syntax-shims/CHANGES.md

@@ -0,0 +1,4 @@
+1.0.0 (09/12/2019)
+------------------
+
+Initial release

unikernel/duniverse/ocaml-syntax-shims/LICENSE.md

@@ -0,0 +1,21 @@
+The MIT License
+
+Copyright (c) 2016 Jane Street Group, LLC <opensource@janestreet.com>
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

unikernel/duniverse/ocaml-syntax-shims/README.md

@@ -0,0 +1,17 @@
+ocaml-syntax-shims
+==================
+
+This package provides a small utility that backports some of the newer
+OCaml syntax to older OCaml compilers. This allows adopting new
+features such as `let+` while still keeping compatibility with older
+OCaml compiler.
+
+To use it, simply depend on this package and add the following field
+to your `library` or `executable` stanzas in your `dune` files:
+`(preprocess future_syntax)`. For instance:
+
+```scheme
+(library
+ (name mylib)
+ (preprocess future_syntax))
+```

unikernel/duniverse/ocaml-syntax-shims/dune-project

@@ -0,0 +1,21 @@
+(lang dune 2.0)
+(name ocaml-syntax-shims)
+(version 1.0.0)
+
+(generate_opam_files true)
+
+(license "MIT")
+(maintainers jeremie@dimino.org)
+(authors "Jérémie Dimino <jeremie@dimino.org>")
+(source (github ocaml-ppx/ocaml-syntax-shims))
+(documentation https://ocaml-ppx.github.io/ocaml-syntax-shims/)
+
+(package
+ (name ocaml-syntax-shims)
+ (depends
+  ("ocaml" (>= "4.02.3")))
+ (synopsis "Backport new syntax to older OCaml versions")
+ (description "\
+This packages backports new features of the language to older
+compilers, such as let+.
+"))

unikernel/duniverse/ocaml-syntax-shims/dune-workspace.dev

@@ -0,0 +1,9 @@
+(lang dune 1.0)
+
+(context (opam (switch 4.02.3)))
+(context (opam (switch 4.03.0)))
+(context (opam (switch 4.04.2)))
+(context (opam (switch 4.05.0)))
+(context (opam (switch 4.06.1)))
+(context (opam (switch 4.07.1)))
+(context (opam (switch 4.08.0)))

unikernel/duniverse/ocaml-syntax-shims/ocaml-syntax-shims.opam

@@ -0,0 +1,33 @@
+version: "1.0.0"
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "Backport new syntax to older OCaml versions"
+description: """
+This packages backports new features of the language to older
+compilers, such as let+.
+"""
+maintainer: ["jeremie@dimino.org"]
+authors: ["Jérémie Dimino <jeremie@dimino.org>"]
+license: "MIT"
+homepage: "https://github.com/ocaml-ppx/ocaml-syntax-shims"
+doc: "https://ocaml-ppx.github.io/ocaml-syntax-shims/"
+bug-reports: "https://github.com/ocaml-ppx/ocaml-syntax-shims/issues"
+depends: [
+  "dune" {>= "2.0"}
+  "ocaml" {>= "4.02.3"}
+]
+build: [
+  ["dune" "subst"] {pinned}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+dev-repo: "git+https://github.com/ocaml-ppx/ocaml-syntax-shims.git"

unikernel/duniverse/ocaml-syntax-shims/src/dune

@@ -0,0 +1,32 @@
+(executable
+ (name pp)
+ (public_name ocaml-syntax-shims)
+ (libraries compiler-libs.common))
+
+(ocamllex let_trail)
+
+(rule
+ (with-stdout-to
+  impl
+  (run ocaml %{dep:select-impl} %{ocaml_version})))
+
+(rule
+ (with-stdout-to
+  shims
+  (run ocaml %{dep:select-shims} %{ocaml_version})))
+
+(rule
+ (copy# pp.%{read:impl}.ml pp.ml))
+
+(rule
+ (copy# shims.%{read:shims}.ml shims.ml))
+
+(rule
+ (with-stdout-to
+  pp.nop.ml
+  (echo "")))
+
+(rule
+ (with-stdout-to
+  shims.nop.ml
+  (echo "")))

unikernel/duniverse/ocaml-syntax-shims/src/let_trail.mli

@@ -0,0 +1 @@
+val op : Lexing.lexbuf -> string option

unikernel/duniverse/ocaml-syntax-shims/src/let_trail.mll

@@ -0,0 +1,37 @@
+{
+  let name = function
+    | '!' -> "bang"
+    | '$' -> "dollar"
+    | '%' -> "percent"
+    | '&' -> "ampersand"
+    | '*' -> "star"
+    | '+' -> "plus"
+    | '-' -> "minus"
+    | '/' -> "slash"
+    | ':' -> "colon"
+    | '<' -> "lesser"
+    | '=' -> "equal"
+    | '>' -> "greater"
+    | '?' -> "question"
+    | '@' -> "at"
+    | '^' -> "circumflex"
+    | '|' -> "pipe"
+    | _ -> assert false
+
+  let expand s =
+    let buf = Buffer.create 128 in
+    for i = 0 to String.length s - 1 do
+      if i > 0 then Buffer.add_char buf '_';
+      Buffer.add_string buf (name s.[i])
+    done;
+    Buffer.contents buf
+}
+
+let dotsymbolchar =
+  ['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|']
+let kwdopchar =
+  ['$' '&' '*' '+' '-' '/' '<' '=' '>' '@' '^' '|']
+
+rule op = parse
+  | kwdopchar dotsymbolchar* as s { Some (expand s) }
+  | "" { None }

unikernel/duniverse/ocaml-syntax-shims/src/pp.real.ml

@@ -0,0 +1,239 @@
+open StdLabels
+open Shims
+
+let prog_name = Filename.basename Sys.executable_name
+
+let dump_ast = ref false
+
+(* Table from positions to custom operators at these positions *)
+let custom_operators = Hashtbl.create 128
+
+module Wrap_lexer = struct
+  let save_loc = Location.curr
+
+  let restore_loc (lexbuf : Lexing.lexbuf) (loc : Location.t) =
+    lexbuf.lex_start_p <- loc.loc_start;
+    lexbuf.lex_curr_p <- loc.loc_end
+
+  let encode_op (tok : Parser.token) op =
+    (match tok with LET -> "let__" | AND -> "and__" | _ -> assert false) ^ op
+
+  let pending = Queue.create ()
+
+  let add (x : Parser.token * _) = Queue.push x pending
+
+  let register_custom_operator tok op (loc1 : Location.t) (loc2 : Location.t) =
+    let op = encode_op tok op in
+    Hashtbl.add custom_operators loc1.loc_start
+      ({ loc1 with loc_end = loc2.loc_end }, op)
+
+  let wrap (lexer : Lexing.lexbuf -> Parser.token) lb =
+    if not (Queue.is_empty pending) then (
+      let tok, loc = Queue.pop pending in
+      restore_loc lb loc;
+      tok )
+    else
+      match lexer lb with
+      | (LET | AND) as tok ->
+          let loc = save_loc lb in
+          ( match Let_trail.op lb with
+          | None -> ()
+          | Some op -> register_custom_operator tok op loc (save_loc lb) );
+          restore_loc lb loc;
+          tok
+      | LPAREN ->
+          let loc1 = save_loc lb in
+          let tok2 = lexer lb in
+          let loc2 = save_loc lb in
+          let tok, loc =
+            match tok2 with
+            | LET | AND -> (
+                match Let_trail.op lb with
+                | None ->
+                    add (tok2, loc2);
+                    (Parser.LPAREN, loc1)
+                | Some op -> (
+                    let loc3 = save_loc lb in
+                    match lexer lb with
+                    | RPAREN ->
+                        ( LIDENT (encode_op tok2 op),
+                          { loc2 with loc_end = loc3.loc_end } )
+                    | tok4 ->
+                        let loc4 = save_loc lb in
+                        add (tok2, loc2);
+                        add (tok4, loc4);
+                        register_custom_operator tok2 op loc2 loc3;
+                        (LPAREN, loc1) ) )
+            | _ ->
+                add (tok2, loc2);
+                (LPAREN, loc1)
+          in
+          restore_loc lb loc;
+          tok
+      | tok -> tok
+
+  let () = Lexer.set_preprocessor (fun () -> Queue.clear pending) wrap
+end
+
+module Map_ast = struct
+  open Ast_mapper
+  open Asttypes
+  open Parsetree
+  open Ast_helper
+
+  let get_op vb =
+    match Hashtbl.find custom_operators vb.pvb_loc.loc_start with
+    | exception Not_found -> None
+    | loc, op -> Some (Exp.ident ~loc { txt = Lident op; loc })
+
+  let mapper =
+    let super = default_mapper in
+    let expr self expr =
+      let expr =
+        match expr.pexp_desc with
+        | Pexp_let (rf, (vb :: _ as vbs), body) -> (
+            match get_op vb with
+            | None -> expr
+            | Some op ->
+                if rf = Recursive then
+                  Location.raise_errorf ~loc:expr.pexp_loc
+                    "Custom 'let' operators cannot be recursive";
+                let patts, exprs =
+                  List.map vbs ~f:(fun vb ->
+                      let {
+                        pvb_pat = patt;
+                        pvb_expr = expr;
+                        pvb_attributes = attrs;
+                        pvb_loc = loc;
+                      } =
+                        vb
+                      in
+                      ( match attrs with
+                      | [] -> ()
+                      | ({ loc; _ }, _) :: _ ->
+                          Location.raise_errorf ~loc
+                            "This attribute will be discarded" );
+                      let op =
+                        match get_op vb with
+                        | Some op ->
+                            Hashtbl.remove custom_operators vb.pvb_loc.loc_start;
+                            op
+                        | None ->
+                            Location.raise_errorf ~loc
+                              "Custom 'and' operator expected, got stantard \
+                               'and' keyword"
+                      in
+                      (patt, (loc, op, expr)))
+                  |> List.split
+                in
+                let patt =
+                  List.fold_left (List.tl patts) ~init:(List.hd patts)
+                    ~f:(fun acc patt ->
+                      let loc = patt.ppat_loc in
+                      Pat.tuple ~loc [ acc; patt ])
+                in
+                let vars =
+                  List.mapi exprs ~f:(fun i _ ->
+                      Printf.sprintf "__future_syntax__%d__" i)
+                in
+                let pvars =
+                  List.map2 vars patts ~f:(fun v p ->
+                      let loc = { p.ppat_loc with loc_ghost = true } in
+                      Pat.var ~loc { txt = v; loc })
+                in
+                let evars =
+                  List.map2 vars exprs ~f:(fun v (_, _, e) ->
+                      let loc = { e.pexp_loc with loc_ghost = true } in
+                      Exp.ident ~loc { txt = Lident v; loc })
+                in
+                let expr =
+                  List.fold_left2 (List.tl evars) (List.tl exprs)
+                    ~init:(List.hd evars) ~f:(fun acc var (loc, op, _) ->
+                      Exp.apply ~loc op [ (nolabel, acc); (nolabel, var) ])
+                in
+                let body =
+                  let loc = expr.pexp_loc in
+                  Exp.apply ~loc op
+                    [
+                      (nolabel, expr);
+                      (nolabel, Exp.fun_ ~loc nolabel None patt body);
+                    ]
+                in
+                List.fold_right2 pvars exprs ~init:body
+                  ~f:(fun var (loc, _, expr) acc ->
+                    Exp.let_ Nonrecursive ~loc [ Vb.mk ~loc var expr ] acc) )
+        | _ -> expr
+      in
+      super.expr self expr
+    in
+    { super with expr }
+
+  let map f ast =
+    let ast = f mapper ast in
+    let fail _ (loc, _) =
+      Location.raise_errorf ~loc "Invalid use of custom 'let' or 'and' operator"
+    in
+    Hashtbl.iter fail custom_operators;
+    ast
+
+  let structure = mapper.structure mapper
+
+  let signature = mapper.signature mapper
+end
+
+let process_file fn ~magic ~parse ~print ~map ~mk_ext =
+  let lexbuf = Lexing.from_channel (open_in_bin fn) in
+  Location.init lexbuf fn;
+  Location.input_lexbuf := Some lexbuf;
+  let ast =
+    try map (parse lexbuf)
+    with exn -> (
+      match error_of_exn exn with
+      | Some error ->
+          if !dump_ast then
+            [
+              mk_ext ?loc:None ?attrs:None (Ast_mapper.extension_of_error error);
+            ]
+          else (
+            Location.report_error Format.err_formatter error;
+            exit 1 )
+      | None -> raise exn )
+  in
+  if !dump_ast then (
+    set_binary_mode_out stdout true;
+    output_string stdout magic;
+    output_value stdout fn;
+    output_value stdout ast;
+    flush stdout )
+  else Format.printf "%a@?" print ast
+
+let process_file fn =
+  let ext =
+    match String.rindex fn '.' with
+    | exception Not_found -> ""
+    | i -> String.sub fn ~pos:i ~len:(String.length fn - i)
+  in
+  match ext with
+  | ".ml" ->
+      process_file fn ~magic:Config.ast_impl_magic_number
+        ~parse:Parse.implementation ~print:Pprintast.structure
+        ~map:Map_ast.structure ~mk_ext:Ast_helper.Str.extension
+  | ".mli" ->
+      process_file fn ~magic:Config.ast_intf_magic_number ~parse:Parse.interface
+        ~print:Pprintast.signature ~map:Map_ast.signature
+        ~mk_ext:Ast_helper.Sig.extension
+  | _ ->
+      Printf.eprintf "%s: Don't know what to do with %s.\n%!" prog_name fn;
+      exit 2
+
+let () =
+  let args =
+    Arg.align
+      [
+        ( "-dump-ast",
+          Arg.Set dump_ast,
+          " Output a binary AST rather than a pretty-printed source file" );
+      ]
+  in
+  let usage = Printf.sprintf "Usage: %s [-dump-ast] FILES" prog_name in
+  Arg.parse args process_file usage

unikernel/duniverse/ocaml-syntax-shims/src/select-impl

@@ -0,0 +1,9 @@
+(* -*- tuareg -*- *)
+
+let v = Scanf.sscanf Sys.argv.(1) "%d.%d" (fun a b -> a, b) in
+print_string (
+  if v < (4, 08) then
+    "real"
+  else
+    "nop"
+)

unikernel/duniverse/ocaml-syntax-shims/src/select-shims

@@ -0,0 +1,13 @@
+(* -*- tuareg -*- *)
+
+let v = Scanf.sscanf Sys.argv.(1) "%d.%d" (fun a b -> a, b) in
+print_string (
+  if v < (4, 03) then
+    "402"
+  else if v < (4, 06) then
+    "403"
+  else if v < (4, 08) then
+    "406"
+  else
+    "nop"
+)

unikernel/duniverse/ocaml-syntax-shims/src/shims.402.ml

@@ -0,0 +1,3 @@
+let nolabel = ""
+
+let error_of_exn = Location.error_of_exn

unikernel/duniverse/ocaml-syntax-shims/src/shims.403.ml

@@ -0,0 +1,3 @@
+let nolabel = Asttypes.Nolabel
+
+let error_of_exn = Location.error_of_exn

unikernel/duniverse/ocaml-syntax-shims/src/shims.406.ml

@@ -0,0 +1,7 @@
+let nolabel = Asttypes.Nolabel
+
+let error_of_exn exn =
+  match Location.error_of_exn exn with
+  | Some (`Ok exn) -> Some exn
+  | Some `Already_displayed -> None
+  | None -> None

unikernel/duniverse/ocaml-syntax-shims/test/dune

@@ -0,0 +1,3 @@
+(test
+ (name test)
+ (preprocess future_syntax))

unikernel/duniverse/ocaml-syntax-shims/test/test.ml

@@ -0,0 +1,27 @@
+let ( let+ ) x f = `Let (x, f)
+
+let ( and+ ) a b = `And (a, b)
+
+let t =
+  let+ x = 1 and+ y = 2 and+ z = 3 in
+  (x, y, z)
+
+let () =
+  match t with
+  | `Let (`And (`And (1, 2), 3), f) -> assert (f ((1, 2), 3) = (1, 2, 3))
+  | _ -> assert false
+
+(* Make sure the evaluation order is the same as with OCaml >= 4.08 *)
+
+let ( let+ ) x f = f x
+
+let ( and+ ) a b = (a, b)
+
+let () =
+  let q1 = Queue.create () in
+  let q2 = Queue.create () in
+  let () = Queue.add 1 q1 and () = Queue.add 2 q1 and () = Queue.add 3 q1 in
+  let+ () = Queue.add 1 q2 and+ () = Queue.add 2 q2 and+ () = Queue.add 3 q2 in
+  let l1 = Queue.fold (fun l x -> x :: l) [] q1 in
+  let l2 = Queue.fold (fun l x -> x :: l) [] q2 in
+  assert (l1 = l2)