(***********************************************************************)
(*                                                                     *)
(*    Copyright 2012 OCamlPro                                          *)
(*    Copyright 2012 INRIA                                             *)
(*                                                                     *)
(*  All rights reserved.  This file is distributed under the terms of  *)
(*  the GNU Public License version 3.0.                                *)
(*                                                                     *)
(*  TypeRex is distributed in the hope that it will be useful,         *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(*  GNU General Public License for more details.                       *)
(*                                                                     *)
(***********************************************************************)

open ExtString

(* XXX: config:// andn install:// are weird URI *)
type uri =
  | Http
  | Git
  | Local

let uri_of_url s =
  try
    let s1, s2 = String.split s "://" in
    match s1 with
    | "git"     -> Some Git    , s2
    | "local"   -> Some Local  , s2
    | "http"    -> Some Http   , s2
    | _         -> None        , s2
  with _->
    None, s

let string_of_uri = function
  | Local   -> "local://"
  | Http    -> "http://"
  | Git     -> "git://"

Improve the detection of git urls

(***********************************************************************)
(*                                                                     *)
(*    Copyright 2012 OCamlPro                                          *)
(*    Copyright 2012 INRIA                                             *)
(*                                                                     *)
(*  All rights reserved.  This file is distributed under the terms of  *)
(*  the GNU Public License version 3.0.                                *)
(*                                                                     *)
(*  TypeRex is distributed in the hope that it will be useful,         *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(*  GNU General Public License for more details.                       *)
(*                                                                     *)
(***********************************************************************)

open ExtString

(* XXX: config:// andn install:// are weird URI *)
type uri =
  | Http
  | Git
  | Local

let uri_of_url s =
  let git = Filename.check_suffix s ".git" in
  try let s1, s2 = String.split s "://" in
    match s1 with
    | "git"      -> Some Git    , s2
    | _ when git -> Some Git    , s
    | "local"    -> Some Local  , s2
    | "http"     -> Some Http   , s2
    | _          -> None        , s2
  with _->
    None, s

let string_of_uri = function
  | Local   -> "local://"
  | Http    -> "http://"
  | Git     -> "git://"


module Net = Net
module SHA1 = Git.Hash.Make(Digestif.SHA1)
module FS = Fs

module Store (X: Mirage_fs_lwt.S) = struct
  module F = Fs.Make(X)
  module S = Git.Store.FS(SHA1)(F)(Git.Inflate)(Git.Deflate)
  include S
  let create ?temp_dir ?current_dir ?root ?dotgit ?compression ?buffer fs =
    let fs = F.v ?temp_dir ?current_dir fs in
    create ?root ?dotgit ?compression ?buffer fs
end

module Sync (C: Net.CONDUIT) = Git.Sync.Make(Net.Make(C))
(* module HTTP = Git_http.Sync.Make(Client) *)

Apply the Make functor instead the FS function (see the previous commit) on git-mirage

module Net = Net
module SHA1 = Git.Hash.Make(Digestif.SHA1)
module FS = Fs

module Store (X: Mirage_fs_lwt.S) = struct
  module F = Fs.Make(X)
  module S = Git.Store.Make(SHA1)(F)(Git.Inflate)(Git.Deflate)
  include S
  let create ?temp_dir ?current_dir ?root ?dotgit ?compression ?buffer fs =
    let fs = F.v ?temp_dir ?current_dir fs in
    create ?root ?dotgit ?compression ?buffer fs
end

module Sync (C: Net.CONDUIT) = Git.Sync.Make(Net.Make(C))
(* module HTTP = Git_http.Sync.Make(Client) *)


type version = Ocaml_version.t

let primary = Ocaml_version.Releases.latest
let recents = Ocaml_version.Releases.recent

let older_than_4_07 v =
  Ocaml_version.compare v Ocaml_version.Releases.v4_07_0 < 0

let to_string v =
  Ocaml_version.to_string (Ocaml_version.with_just_major_and_minor v)

Add beta versions of the compiler to the CI matrix

type version = Ocaml_version.t

let primary = Ocaml_version.Releases.latest
let recents = Ocaml_version.Releases.recent @ Ocaml_version.Releases.unreleased_betas

let older_than_4_07 v =
  Ocaml_version.compare v Ocaml_version.Releases.v4_07_0 < 0

let to_string v =
  Ocaml_version.to_string (Ocaml_version.with_just_major_and_minor v)


(** FASTQ data. *)

type record = {
  name: string;
  sequence: string;
  comment: string;
  qualities: string;
}

type parser

val feed_line: parser -> string -> unit

val next :
  parser ->
  [> `error of
      [> `sequence_and_qualities_do_not_match of int * string * string
      | `wrong_comment_line of int * string
      | `wrong_name_line of int * string ]
  | `nothing_ready
  | `record of record ]

Fix missing function in the interface

(** FASTQ data. *)

type record = {
  name: string;
  sequence: string;
  comment: string;
  qualities: string;
}

type parser
val parser: unit -> parser

val feed_line: parser -> string -> unit

val next :
  parser ->
  [> `error of
      [> `sequence_and_qualities_do_not_match of int * string * string
      | `wrong_comment_line of int * string
      | `wrong_name_line of int * string ]
  | `nothing_ready
  | `record of record ]


open Defaults (* CircInterval needs initialized conf *)

let domains: (module Lattice.S) list = [
  (* (module IntDomain.Integers);
      (module IntDomain.Flattened);
      (module IntDomain.Lifted);
      (module IntDomain.Interval32);
      (module IntDomain.Booleans);
      (module IntDomain.CircInterval);
      (module IntDomain.DefExc);
      (module IntDomain.Enums);
      (module IntDomain.IntDomTuple); *)
  (module IntDomainProperties.IntegerSet)
]

let intDomains: (module IntDomain.S) list = [
  (module IntDomain.Integers);
  (module IntDomain.Flattened);
  (module IntDomain.Lifted);
  (module IntDomain.Interval32);
  (module IntDomain.Booleans);
  (module IntDomain.CircInterval);
  (module IntDomain.DefExc);
  (module IntDomain.Enums);
  (module IntDomain.IntDomTuple)
]

let testsuite =
  List.map (fun d ->
      let module D = (val d: Lattice.S) in
      let module DP = DomainProperties.All (D) in
      DP.tests)
    domains
  |> List.flatten
let intTestsuite =
  List.map (fun d ->
      let module D = (val d: IntDomain.S) in
      let module DP = IntDomainProperties.All (D) in
      DP.tests)
    intDomains
  |> List.flatten

let () =
  QCheck_runner.run_tests_main ~argv:Sys.argv (testsuite @ intTestsuite)

Remove some invalid domains from domaintest

open Defaults (* CircInterval needs initialized conf *)

let domains: (module Lattice.S) list = [
  (module IntDomainProperties.IntegerSet); (* TODO: top properties error *)
  (module IntDomain.Lifted); (* not abstraction of IntegerSet *)
]

let intDomains: (module IntDomain.S) list = [
  (module IntDomain.Flattened);
  (module IntDomain.Interval32);
  (module IntDomain.Booleans);
  (module IntDomain.CircInterval);
  (module IntDomain.DefExc);
  (module IntDomain.Enums);
  (module IntDomain.IntDomTuple)
]

let testsuite =
  List.map (fun d ->
      let module D = (val d: Lattice.S) in
      let module DP = DomainProperties.All (D) in
      DP.tests)
    domains
  |> List.flatten
let intTestsuite =
  List.map (fun d ->
      let module D = (val d: IntDomain.S) in
      let module DP = IntDomainProperties.All (D) in
      DP.tests)
    intDomains
  |> List.flatten

let () =
  QCheck_runner.run_tests_main ~argv:Sys.argv (testsuite @ intTestsuite)


module GCM = Nocrypto.Cipher_block.AES.GCM
module Rng = Nocrypto.Rng

type encData = {
  iv: Cstruct.t;
  data: Cstruct.t;
} [@@deriving sexp]

module Make
  (K : S.EncKey)
  : S.Encryptor =
struct
  let key = GCM.of_secret K.key

  let decrypt s =
    let { iv ; data } = (Sexplib.Sexp.of_string s |> encData_of_sexp) in
    let res = GCM.decrypt ~key ~iv data in
    let plain = res.GCM.message in
    Cstruct.to_string plain

  let encrypt s =
    let iv = Rng.generate 12 in
    let res = GCM.encrypt ~key ~iv (Cstruct.of_string s) in
    let data = res.GCM.message in
    sexp_of_encData { iv; data } |> Sexplib.Sexp.to_string
end

module Null : S.Encryptor = struct
  let encrypt s = s
  let decrypt s = s
end

Change encrypted format to more compact JSON format

module GCM = Nocrypto.Cipher_block.AES.GCM
module Rng = Nocrypto.Rng
module YB = Yojson.Basic

let cs_of_json_val json key =
  YB.Util.member key json
  |> YB.Util.to_string
  |> B64.decode ~alphabet:B64.uri_safe_alphabet
  |> Cstruct.of_string

let b64_of_cs cs = Cstruct.to_string cs
  |> B64.encode ~alphabet:B64.uri_safe_alphabet

module Make
  (K : S.EncKey)
  : S.Encryptor =
struct
  let key = GCM.of_secret K.key

  let decrypt s =
    let json = YB.from_string s in
    let iv = cs_of_json_val json "iv" in
    let data = cs_of_json_val json "data" in
    let res = GCM.decrypt ~key ~iv data in
    Cstruct.to_string res.GCM.message

  let encrypt s =
    let iv = Rng.generate 12 in
    let res = GCM.encrypt ~key ~iv (Cstruct.of_string s) in
    let json = (`Assoc [
      ("iv", `String (b64_of_cs iv));
      ("data", `String (b64_of_cs res.GCM.message))
    ]) in
    YB.to_string json
end

module Null : S.Encryptor = struct
  let encrypt s = s
  let decrypt s = s
end


open Hyperapp

type msg = Increment | Decrement | Reset | Edit of string | Set

let initModel = 0, "0"

let view (value, edit) msg =
  let text = "Current value is: " ^ string_of_int value in

  h "div" [
    h_ "p" ~a:[%obj { _class = "main" }] text;
    h_ "button" ~a:[%obj { onclick = fun _ -> msg Increment }] "Increment";
    h_ "button" ~a:[%obj { onclick = fun _ -> msg Decrement }] "Decrement";
    h_ "button" ~a:[%obj { onclick = fun _ -> msg Reset }] "Reset";
    h "input" ~a:[%obj { value = edit; onchange = fun e -> msg (Edit (valueOfEvent e)) }] [];
    h_ "button" ~a:[%obj { onclick = fun _ -> msg Set }] "Set" ]

let update ((value, edit) as model) = function
  | Increment -> value + 1, edit
  | Decrement -> value - 1, edit
  | Reset -> initModel
  | Edit edit -> value, edit
  | Set -> try int_of_string edit, edit with  _ -> model

let () = app ~model:initModel ~view ~update "root"

Add edit and set feature to counter example

open Hyperapp

type msg =
  Increment | Decrement | Reset | Edit of int | Set | Disable of bool

(** Current value, edited value, 'set' button disabled or not *)
let initModel = 0, 0, false

let view (value, edit, disabled) msg =
  let text = "Current value is: " ^ string_of_int value in
  let onchange e =
    let m = try Edit (int_of_string (valueOfEvent e))
      with _ -> Disable true in

    msg m in

  let button ?(disabled=false) title m =
    h_ "button" ~a:[%obj { disabled; onclick = fun _ -> msg m }] title in

  h "div" [
    h_ "p" ~a:[%obj { _class = "main" }] text;
    button "Increment" Increment;
    button "Decrement" Decrement;
    button "Reset" Reset;
    h "input" ~a:[%obj { value = edit; onchange }] [];
    button ~disabled "Set" Set ]

let update (value, edit, disabled) = function
  | Increment -> value + 1, edit, disabled
  | Decrement -> value - 1, edit, disabled
  | Reset -> initModel
  | Edit edit -> value, edit, false
  | Set -> edit, edit, disabled
  | Disable bool -> value, edit, bool

let () = app ~model:initModel ~view ~update "root"


let () =
  let argv =
    match Sys.argv with
    | [|program; input_file; output_file|] ->
      [|
        program;
        input_file;
        "-o"; output_file;
        "--dump-ast";
        "--conditional";
      |]
    | _ ->
      Sys.argv
  in

  Migrate_parsetree.Driver.run_main ~argv ()

Support taking PPX options from BuckleScript

let () =
  let argc = Array.length Sys.argv in
  let argv =
    let output_file = Sys.argv.(argc - 1) in
    Array.(append
      (sub Sys.argv 0 (argc - 1))
      [|"-o"; output_file; "--dump-ast"; "--conditional"|])
  in

  Migrate_parsetree.Driver.run_main ~argv ()


(*
ocamlbuild -use-ocamlfind -pkgs lacaml,ocephes,lbfgs -I src/scripts/ -I src/lib/ fishers_mad_argument.native
*)

open Oml.Util
module D = Oml.Statistics.Descriptive
module S = Oml.Statistics.Sampling

let r = S.normal_std ()

let mad_norm = sqrt (pi /. 2.)

let sample ?(n=1000) r =
  let data = Array.init n (fun _ -> r ()) in
  D.sd data, mad_norm *. D.ad ~center:`Mean data

let test ?(m=1000) r =
  let by_sd, by_mad = Array.init m (fun _ -> sample r ) |> Array.unzip in
  D.sd by_sd, D.sd by_mad

let () =
  let s, m = test r in
  Printf.printf "standard: %0.4f\t absolute: %0.4f\t better: %b\n"
    s m (s < m)

Add error demo to mad demo.

(*
  Inspired by "Revisiting a 90-year-old debate: the advantages of the mean deviation"
  by Stephen Gorard
  http://www.leeds.ac.uk/educol/documents/00003759.htm

  ocamlbuild -use-ocamlfind -pkgs lacaml,ocephes,lbfgs -I src/scripts/ -I src/lib/ fishers_mad_argument.native
*)

open Oml.Util
module D = Oml.Statistics.Descriptive
module S = Oml.Statistics.Sampling

let r = S.normal_std ()
let r_e = S.normal ~mean:0. ~std:9. ()

let mad_norm = sqrt (pi /. 2.)

let sample ?(n=1000) ?error r =
  let data = Array.init n (fun _ -> r ()) in
  let t = match error with | None -> -1 | Some v -> truncate (v *. float n) in
  for i = 0 to t do data.(i) <- r_e () done;
  let s = D.sd data in
  let m = mad_norm *. D.ad ~center:`Mean data in
  s, m

let test ?(m=1000) ?error r =
  let by_sd, by_mad = Array.init m (fun _ -> sample ?error r ) |> Array.unzip in
  D.sd by_sd, D.sd by_mad

let () =
  let s, m = test r in
  Printf.printf "standard: %0.4f\t absolute: %0.4f\t better: %b\n" s m (s < m);
  let error = 0.002 in
  let s_e, m_e = test ~error r in
  Printf.printf "But with %f error\n" error;
  Printf.printf "standard: %0.4f\t absolute: %0.4f\t better: %b\n" s_e m_e (s_e < m_e);


type argument =
  | Int32 of int32
  | Float32 of float
  | Str of string
  | Blob of string

let encode_float f =
  BITSTRING {
    Int32.bits_of_float f : 32 : bigendian
  }

let decode_float b =
  bitmatch b with {
    i : 4*8 : bigendian
  } ->
    Int32.float_of_bits i

Add helper functions for handling int32s

type argument =
  | Int32 of int32
  | Float32 of float
  | Str of string
  | Blob of string

let encode_int i =
  BITSTRING { i : 32 : bigendian }

let decode_int b =
  bitmatch b with {
    i : 4*8 : bigendian
  } -> i

let encode_float f =
  BITSTRING {
    Int32.bits_of_float f : 32 : bigendian
  }

let decode_float b =
  bitmatch b with {
    i : 4*8 : bigendian
  } ->
    Int32.float_of_bits i


(* Copyright (C) 2015, Thomas Leonard
 * See the README file for details. *)

(* RPC over XMLHttpRequest, getting the access token from the user if necessary. *)

open Lwt

module XHR = Cohttp_lwt_xhr.Client

let token = ref None

let get_token () =
  Js.Opt.case (Dom_html.window##prompt(Js.string "Enter access token", Js.string ""))
    (fun () -> `Cancelled_by_user)
    (fun s -> token := Some (Js.to_string s); `Ok)

let rec with_token fn uri =
  match !token with
  | None ->
      begin match get_token() with
      | `Ok -> with_token fn uri
      | `Cancelled_by_user as c -> return c
      end
  | Some access_token ->
      let uri = Uri.add_query_param uri ("token", [access_token]) in
      fn uri >>= function
      | (resp, _body) when resp.Cohttp.Response.status = `Unauthorized -> token := None; with_token fn uri
      | result -> return (`Ok result)

let get ?headers uri = with_token (XHR.get ?headers) uri
let post ?body ?headers uri = with_token (XHR.post ?body ?headers) uri

Store access token in local storage

(* Copyright (C) 2015, Thomas Leonard
 * See the README file for details. *)

(* RPC over XMLHttpRequest, getting the access token from the user if necessary. *)

open Lwt

module XHR = Cohttp_lwt_xhr.Client

let storage =
  lazy (
    Js.Optdef.get (Dom_html.window##localStorage)
      (fun () -> failwith "HTML 5 storage is not available")
  )

let token_key = Js.string "CueKeeper.auth.access_token"

let set_token value = (Lazy.force storage)##setItem(token_key, value)
let remove_token () = (Lazy.force storage)##removeItem(token_key)
let get_token () =
  let v = (Lazy.force storage)##getItem(token_key) in
  Js.Opt.map v Js.to_string
  |> Js.Opt.to_option

let input_token () =
  Js.Opt.case (Dom_html.window##prompt(Js.string "Enter access token", Js.string ""))
    (fun () -> `Cancelled_by_user)
    (fun s -> set_token s; `Ok)

let rec with_token fn uri =
  match get_token () with
  | None ->
      begin match input_token () with
      | `Ok -> with_token fn uri
      | `Cancelled_by_user as c -> return c
      end
  | Some access_token ->
      let uri = Uri.add_query_param uri ("token", [access_token]) in
      fn uri >>= function
      | (resp, _body) when resp.Cohttp.Response.status = `Unauthorized ->
          remove_token ();
          with_token fn uri
      | result -> return (`Ok result)

let get ?headers uri = with_token (XHR.get ?headers) uri
let post ?body ?headers uri = with_token (XHR.post ?body ?headers) uri


(* OASIS_START *)
(* OASIS_STOP *)

let dispatch = function
  | After_rules ->
    let env = BaseEnvLight.load () in
    let system = BaseEnvLight.var_get "system" env in
    let is_darwin = String.is_prefix "macos" system in
    let arch_sixtyfour = BaseEnvLight.var_get "arch_sixtyfour" env = "true" in

    let cpp = "gcc -E -xc -undef -w" in
    let cpp = if arch_sixtyfour then cpp ^ " -DARCH_SIXTYFOUR" else cpp in

    let cpp = S [A "-pp"; P cpp] in

    dep ["ocaml"; "ocamldep"; "mlh"] ["lib/int_codes.mlh"];

    flag ["ocamldep"; "ocaml"; "use_pa_bin_prot"]
      (S [A "-ppopt"; P "syntax/pa_bin_prot.cma"]);

    flag ["compile"; "ocaml"; "use_pa_bin_prot"]
      (S [A "-ppopt"; P "syntax/pa_bin_prot.cma"]);

    flag ["ocamldep"; "ocaml"; "cpp"] cpp;

    flag ["compile"; "ocaml"; "cpp"] cpp;

    flag ["doc"; "ocaml"; "cpp"] cpp;

    if is_darwin then
      flag ["compile"; "c"] (S [A "-ccopt"; A "-DOS_DARWIN"]);
  | _ ->
    ()

let () = Ocamlbuild_plugin.dispatch (fun hook -> dispatch hook; dispatch_default hook)

Use ccomp_type to determine C compiler

(* OASIS_START *)
(* OASIS_STOP *)

let dispatch = function
  | After_rules ->
    let env = BaseEnvLight.load () in
    let system = BaseEnvLight.var_get "system" env in
    let cc = BaseEnvLight.var_get "ccomp_type" env in
    let is_darwin = String.is_prefix "macos" system in
    let arch_sixtyfour = BaseEnvLight.var_get "arch_sixtyfour" env = "true" in

    let cpp = cc ^ " -E -xc -undef -w" in
    let cpp = if arch_sixtyfour then cpp ^ " -DARCH_SIXTYFOUR" else cpp in

    let cpp = S [A "-pp"; P cpp] in

    dep ["ocaml"; "ocamldep"; "mlh"] ["lib/int_codes.mlh"];

    flag ["ocamldep"; "ocaml"; "use_pa_bin_prot"]
      (S [A "-ppopt"; P "syntax/pa_bin_prot.cma"]);

    flag ["compile"; "ocaml"; "use_pa_bin_prot"]
      (S [A "-ppopt"; P "syntax/pa_bin_prot.cma"]);

    flag ["ocamldep"; "ocaml"; "cpp"] cpp;

    flag ["compile"; "ocaml"; "cpp"] cpp;

    flag ["doc"; "ocaml"; "cpp"] cpp;

    if is_darwin then
      flag ["compile"; "c"] (S [A "-ccopt"; A "-DOS_DARWIN"]);
  | _ ->
    ()

let () = Ocamlbuild_plugin.dispatch (fun hook -> dispatch hook; dispatch_default hook)


(*
 * Copyright (C) Citrix Systems Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation; version 2.1 only. with the special
 * exception on linking described in file LICENSE.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *)

let name = "ffs"
let major_version = 0
let minor_version = 1

type context = unit

let process _ _ = Rpc.failure (Rpc.String "not implemented")

Use the new Storage_skeleton module

(*
 * Copyright (C) Citrix Systems Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation; version 2.1 only. with the special
 * exception on linking described in file LICENSE.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *)

let name = "ffs"
let major_version = 0
let minor_version = 1

module Implementation = struct
  include Storage_skeleton
end

module Server = Storage_interface.Server(Implementation)


open Mirage

let mode =
  let x = try Unix.getenv "FS" with Not_found -> "crunch" in
  match x with
  | "fat" -> `Fat
  | "crunch" -> `Crunch
  | x -> failwith ("Unknown FS mode: " ^ x )

let fat_ro dir =
  kv_ro_of_fs (fat_of_files ~dir ())

let disk =
  match mode, get_mode () with
  | `Fat   , _     -> fat_ro "t"
  | `Crunch, `Xen  -> crunch "t"
  | `Crunch, `Unix -> direct_kv_ro "t"

let main =
  foreign "Unikernel.Main" (console @-> kv_ro @-> kv_ro @-> job)

let () =
  register "kv_ro" [ main $ default_console $ disk $ disk ]

Add one more missing `MacOSX match case

open Mirage

let mode =
  let x = try Unix.getenv "FS" with Not_found -> "crunch" in
  match x with
  | "fat" -> `Fat
  | "crunch" -> `Crunch
  | x -> failwith ("Unknown FS mode: " ^ x )

let fat_ro dir =
  kv_ro_of_fs (fat_of_files ~dir ())

let disk =
  match mode, get_mode () with
  | `Fat   , _     -> fat_ro "t"
  | `Crunch, `Xen  -> crunch "t"
  | `Crunch, (`Unix | `MacOSX) -> direct_kv_ro "t"

let main =
  foreign "Unikernel.Main" (console @-> kv_ro @-> kv_ro @-> job)

let () =
  register "kv_ro" [ main $ default_console $ disk $ disk ]


type version = (string * string)

let primary = ("4.05.0", "4.05")
let recents = [("4.03.0","4.03");("4.04.2","4.04");primary;("4.06.0","4.06")]

let to_string (_, v) = v

let docker_opam1 (v, _) =
  "ocaml-"^v

let docker_opam2 v =
  if v == primary then
    "ocaml"
  else
    "ocaml-"^snd v

let to_string_with_minor (v, _) = v

Fix versions test with opam2

type version = (string * string)

let primary = ("4.05.0", "4.05")
let recents = [("4.03.0","4.03");("4.04.2","4.04");("4.05.0","4.05");("4.06.0","4.06")]

let to_string (_, v) = v

let docker_opam1 (v, _) =
  "ocaml-"^v

let docker_opam2 v =
  if v == primary then
    "ocaml"
  else
    "ocaml-"^snd v

let to_string_with_minor (v, _) = v


(**
 * Copyright (c) 2015, Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the "hack" directory of this source tree.
 *
 *)

let () = Random.self_init ()

let base64_alphabet =
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

let alphanumeric_alphabet =
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"

let () =
  assert (String.length base64_alphabet = 64)

let short_string_with_alphabet alphabet =
  let r = ref ((Random.bits () lsl 30) lor Random.bits ()) in
  let cs = ref [] in
  while !r > 0 do
    let c = alphabet.[!r mod (String.length alphabet)] in
    cs := String.make 1 c :: !cs;
    r := !r lsr 6
  done;
  String.concat "" !cs

let short_string () =
  short_string_with_alphabet base64_alphabet

Fix random generation of names

(**
 * Copyright (c) 2015, Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the "hack" directory of this source tree.
 *
 *)

let initialized = ref false

let base64_alphabet =
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

let alphanumeric_alphabet =
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"

let () =
  assert (String.length base64_alphabet = 64)

let short_string_with_alphabet alphabet =
  (* If we haven't seeded random then do it now *)
  if not !initialized then begin
    initialized := true;
    Random.self_init ()
  end;
  let r = ref ((Random.bits () lsl 30) lor Random.bits ()) in
  let cs = ref [] in
  while !r > 0 do
    let c = alphabet.[!r mod (String.length alphabet)] in
    cs := String.make 1 c :: !cs;
    r := !r lsr 6
  done;
  String.concat "" !cs

let short_string () =
  short_string_with_alphabet base64_alphabet


(**
 * Copyright (c) 2015, Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the "hack" directory of this source tree.
 *
 *)

let initialized = ref false

let base64_alphabet =
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

let alphanumeric_alphabet =
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"

let () =
  assert (String.length base64_alphabet = 64)

let short_string_with_alphabet alphabet =
  (* If we haven't seeded random then do it now *)
  if not !initialized then begin
    initialized := true;
    Random.self_init ()
  end;
  let r = ref ((Random.bits () lsl 30) lor Random.bits ()) in
  let cs = ref [] in
  while !r > 0 do
    let c = alphabet.[!r mod (String.length alphabet)] in
    cs := String.make 1 c :: !cs;
    r := !r lsr 6
  done;
  String.concat "" !cs

let short_string () =
  short_string_with_alphabet base64_alphabet

let short_alphanumeric_string () =
  short_string_with_alphabet alphanumeric_alphabet

Fix random id bug when it contains slashes

(**
 * Copyright (c) 2015, Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the "hack" directory of this source tree.
 *
 *)

let initialized = ref false

(* Do not use / in random ids as they appear in filenames. *)
let alphanumeric_alphabet =
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"

let short_string_with_alphabet alphabet =
  (* If we haven't seeded random then do it now *)
  if not !initialized then begin
    initialized := true;
    Random.self_init ()
  end;
  let r = ref ((Random.bits () lsl 30) lor Random.bits ()) in
  let cs = ref [] in
  while !r > 0 do
    let c = alphabet.[!r mod (String.length alphabet)] in
    cs := String.make 1 c :: !cs;
    r := !r lsr 6
  done;
  String.concat "" !cs

let short_string () =
  short_string_with_alphabet alphanumeric_alphabet


let () =
  let panel_conf = Ext_panel_Panel.config
                     ~title:"Hello Ext"
                     ~html:"Hello! Welcome to Ext JS."
                     () in

  let view_conf = Ext_container_Viewport.config
                    ~layout:"fit"
                    ~items:[|panel_conf|]
                    () in

  let launch () =
    Ext.create ~name:"Ext.container.Viewport" ~args:view_conf in
  let app_conf = Ext_app_Application.config
                   ~name:"HelloExt"
                   ~launch
                   () in

  let callback () =
    Firebug.console##log(Js.string "require callback") in
  let () =
    Ext.require
      ~expressions:[|"Ext.container.Viewport"|]
      ~fn:callback () in
  Ext.application ~config:app_conf

Remove Ext.require callback from helloext

let () =
  let panel_conf = Ext_panel_Panel.config
                     ~title:"Hello Ext"
                     ~html:"Hello! Welcome to Ext JS."
                     () in

  let view_conf = Ext_container_Viewport.config
                    ~layout:"fit"
                    ~items:[|panel_conf|]
                    () in

  let launch () =
    Ext.create ~name:"Ext.container.Viewport" ~args:view_conf in
  let app_conf = Ext_app_Application.config
                   ~name:"HelloExt"
                   ~launch
                   () in

  let () =
    Ext.require
      ~expressions:[|"Ext.container.Viewport"|]
      () in
  Ext.application ~config:app_conf


let _ =
  match Unix.fork () with
  | 0 ->
      (let fd = Unix.openfile "/bin/ls" [Unix.O_RDONLY] 0o640 in
      try Fd.fexecve fd [| "/bin/ls"; "/" |] [| |] with
      Fd.Fd_error s -> print_endline s)
  | _ ->
      (let fd = Unix.openfile "/etc/passwd" [Unix.O_RDONLY] 0o640 in
      try Fd.fexecve fd [| "/etc/passwd"; |] [| |] with
      Fd.Fd_error s -> Printf.printf "fexecve failed: %s\n" s)

Fix test by using labels. Still need to figure out why they are necessary.

let run_fexecve path args env =
  let fd = Unix.openfile path [Unix.O_RDONLY] 0o640 in
  try Fd.fexecve ~fd:fd ~args:args ~env:env with
  Fd.Fd_error s -> raise (Failure s)

let _ =
  match Unix.fork () with
  | 0 -> run_fexecve "/bin/ls" [| "/bin/ls"; "/" |] [| |]
  | _ -> run_fexecve "/etc/passwd" [| "/etc/passwd" |] [| |]


(* The Caml module binds everything that is available in the standard
   environment so that we can easily refer to standard things even if they've
   been rebound.
*)

module Arg = Arg
module Array = Array
module ArrayLabels = ArrayLabels
module Buffer = Buffer
module Callback = Callback
module Char = Char
module Complex = Complex

(* module Digest = Digest *)
module Filename = Filename
module Format = Format
module Gc = Gc
module Genlex = Genlex
module Hashtbl = Hashtbl
module Int32 = Int32
module Int64 = Int64
module Lazy = Lazy
module Lexing = Lexing
module List = List
module ListLabels = ListLabels
module Map = Map
module Marshal = Marshal
module MoreLabels = MoreLabels
module Nativeint = Nativeint
module Oo = Oo
module Parsing = Parsing
module Pervasives = Pervasives
module Printexc = Printexc
module Printf = Printf
module Queue = Queue
module Random = Random
module Scanf = Scanf
module Set = Set
module Sort = Sort
module Stack = Stack
module StdLabels = StdLabels
module Stream = Stream
module String = String
module StringLabels = StringLabels
module Sys = Sys
module Weak = Weak
include Pervasives

Drop Hack_caml.Sort module, no longer exists in 4.08

(* The Caml module binds everything that is available in the standard
   environment so that we can easily refer to standard things even if they've
   been rebound.
*)

module Arg = Arg
module Array = Array
module ArrayLabels = ArrayLabels
module Buffer = Buffer
module Callback = Callback
module Char = Char
module Complex = Complex

(* module Digest = Digest *)
module Filename = Filename
module Format = Format
module Gc = Gc
module Genlex = Genlex
module Hashtbl = Hashtbl
module Int32 = Int32
module Int64 = Int64
module Lazy = Lazy
module Lexing = Lexing
module List = List
module ListLabels = ListLabels
module Map = Map
module Marshal = Marshal
module MoreLabels = MoreLabels
module Nativeint = Nativeint
module Oo = Oo
module Parsing = Parsing
module Pervasives = Pervasives
module Printexc = Printexc
module Printf = Printf
module Queue = Queue
module Random = Random
module Scanf = Scanf
module Set = Set
module Stack = Stack
module StdLabels = StdLabels
module Stream = Stream
module String = String
module StringLabels = StringLabels
module Sys = Sys
module Weak = Weak
include Pervasives


open Mirage

let filename =
  let doc = Key.Arg.info ~doc:"The filename to print out." [ "filename" ] in
  Key.(create "filename" Arg.(required string doc))

let unikernel =
  foreign "Unikernel.Make" ~keys:[ Key.v filename ] (console @-> kv_ro @-> job)

let console = default_console
let remote = "https://github.com/mirage/mirage"

let () =
  register "docteur"
    [ unikernel $ console $ docteur ~branch:"refs/heads/main" remote ]

Rename the docteur example to static_kv_ro

open Mirage

let filename =
  let doc = Key.Arg.info ~doc:"The filename to print out." [ "filename" ] in
  Key.(create "filename" Arg.(required string doc))

let unikernel =
  foreign "Unikernel.Make" ~keys:[ Key.v filename ] (console @-> kv_ro @-> job)

let console = default_console
let remote = "https://github.com/mirage/mirage"

let () =
  register "static_kv_ro"
    [ unikernel $ console $ docteur ~branch:"refs/heads/main" remote ]


let pp_set_ansi_color_tags ppf =
  let stag_functions = Format.pp_get_formatter_stag_functions ppf () in
  let stag_functions' = {stag_functions with
      mark_open_stag = (function
        (* TODO: support all colors like colorize *)
        | Format.String_tag "red" -> Format.sprintf "\027[%sm" "0;31"
        | Format.String_tag "yellow" -> Format.sprintf "\027[%sm" "0;33"
        | Format.String_tag "blue" -> Format.sprintf "\027[%sm" "0;34"
        | Format.String_tag "white" -> Format.sprintf "\027[%sm" "0;37"
        | Format.String_tag "green" -> Format.sprintf "\027[%sm" "0;32"
        | Format.String_tag "violet" -> Format.sprintf "\027[%sm" "0;35"
        | Format.String_tag s -> Format.sprintf "{%s}" s
        | _ -> "");
      mark_close_stag = (function
        | Format.String_tag _ -> "\027[0m"
        | _ -> "");
    }
  in
  Format.pp_set_formatter_stag_functions ppf stag_functions';
  Format.pp_set_mark_tags ppf true

Use ANSI color table in GobFormat

let pp_set_ansi_color_tags ppf =
  let stag_functions = Format.pp_get_formatter_stag_functions ppf () in
  let reset_code = List.assoc "reset" MessageUtil.ansi_color_table in (* assoc only once *)
  let stag_functions' = {stag_functions with
      mark_open_stag = (function
        | Format.String_tag s ->
          begin match List.assoc_opt s MessageUtil.ansi_color_table with
            | Some code -> code
            | None -> Format.sprintf "{%s}" s
          end
        | _ -> "");
      mark_close_stag = (function
        | Format.String_tag _ -> reset_code
        | _ -> "");
    }
  in
  Format.pp_set_formatter_stag_functions ppf stag_functions';
  Format.pp_set_mark_tags ppf true


open Prelude

let exists p = function
  | Some x -> p x
  | None -> false

let for_all p = function
  | Some x -> p x
  | None -> true

Remove unused open in GobOption


(* This unikernel is based on tracing documentation:
   https://mirage.io/wiki/profiling
*)

open Lwt.Infix
let target_ip = Ipaddr.V4.of_string_exn "10.0.0.1"

module Main (S: V1_LWT.STACKV4) = struct

  let send_data t =
    let buffer = Io_page.get 1 |> Io_page.to_cstruct in

    S.TCPV4.create_connection t (target_ip, 7001) >>= function
    | `Error _err -> failwith "Connection to port 7001 failed"
    | `Ok flow ->

    let payload = Cstruct.sub buffer 0 1 in
    Cstruct.set_char payload 0 '!';

    S.TCPV4.write flow payload >>= function
    | `Error _ | `Eof -> assert false
    | `Ok () ->

    S.TCPV4.close flow

  let start s =
    let t = S.tcpv4 s in
    Lwt.pick [
      S.listen s;
      send_data t;
    ]

end

Revert "have tracing example explicitly call STACKV4.listen"

(* This unikernel is based on tracing documentation:
   https://mirage.io/wiki/profiling
*)

open Lwt.Infix
let target_ip = Ipaddr.V4.of_string_exn "10.0.0.1"

module Main (S: V1_LWT.STACKV4) = struct
  let buffer = Io_page.get 1 |> Io_page.to_cstruct

  let start s =
    let t = S.tcpv4 s in

    S.TCPV4.create_connection t (target_ip, 7001) >>= function
    | `Error _err -> failwith "Connection to port 7001 failed"
    | `Ok flow ->

    let payload = Cstruct.sub buffer 0 1 in
    Cstruct.set_char payload 0 '!';

    S.TCPV4.write flow payload >>= function
    | `Error _ | `Eof -> assert false
    | `Ok () ->

    S.TCPV4.close flow
end


(* error response *)
exception Error of string

module Make(IO : Make.IO)(Client : module type of Client.Make(IO)) = struct
  open Client

  let (>>=) = IO.(>>=)
  let (>>) x y = x >>= fun _ -> y

  let acquire conn ?(atime=10.) ?(ltime=10) mutex id =
    let etime = Unix.time() +. atime in

    let update_ttl () =
      ttl conn mutex >>= function
        | None -> expire conn mutex ltime >> IO.return ()
        | _ -> IO.return () in

    let rec loop () =
      setnx conn mutex id >>= function
        | true -> expire conn mutex ltime >> IO.return ()
        | _ -> update_ttl () >>
            if Unix.time() < etime then IO.sleep(0.1) >>= loop
            else IO.fail (Error "could not acquire lock")
    in
    loop ()

  let release conn mutex id =
    watch conn [mutex] >> get conn mutex >>= function
      | Some x when x = id ->
          multi conn >> queue (fun () -> del conn [mutex]) >> exec conn >>
          IO.return ()
      | _ -> unwatch conn >> IO.fail (Error "lock was lost")

  let with_mutex conn ?atime ?ltime mutex fn =
    let id = Uuidm.(to_string (create `V4)) in

    acquire conn ?atime ?ltime mutex id >>
    try
      fn () >>= fun res ->
      release conn mutex id >>
      IO.return res
    with e ->
      release conn mutex id >>
      IO.fail e
end

Remove introduced '>>' binding, and use Lwt.>>= instead

(* error response *)
exception Error of string

module Make(IO : Make.IO)(Client : module type of Client.Make(IO)) = struct
  open Client

  let (>>=) = IO.(>>=)

  let acquire conn ?(atime=10.) ?(ltime=10) mutex id =
    let etime = Unix.time() +. atime in

    let update_ttl () =
      ttl conn mutex >>= function
        | None -> expire conn mutex ltime >>= fun _ -> IO.return ()
        | _ -> IO.return () in

    let rec loop () =
      setnx conn mutex id >>= function
        | true -> expire conn mutex ltime >>= fun _ -> IO.return ()
        | _ -> update_ttl () >>= fun _ ->
            if Unix.time() < etime then IO.sleep(0.1) >>= loop
            else IO.fail (Error "could not acquire lock")
    in
    loop ()

  let release conn mutex id =
    watch conn [mutex] >>= fun _ -> get conn mutex >>= function
      | Some x when x = id ->
          multi conn >>= fun _ ->
          queue (fun () -> del conn [mutex]) >>= fun _ ->
          exec conn >>= fun _ ->
          IO.return ()
      | _ -> unwatch conn >>= fun _ -> IO.fail (Error "lock was lost")

  let with_mutex conn ?atime ?ltime mutex fn =
    let id = Uuidm.(to_string (create `V4)) in

    acquire conn ?atime ?ltime mutex id >>= fun _ ->
    try
      fn () >>= fun res ->
      release conn mutex id >>= fun _ ->
      IO.return res
    with e ->
      release conn mutex id >>= fun _ ->
      IO.fail e
end


type t

val size : t -> int

val of_int : int -> t

val of_char : char -> t

val of_string : string -> t

val to_int : t -> int

val to_char : t -> char

val to_ascii : t -> string

val unsafe_s : t -> string

val unsafe_b : string -> t

Add padding and concat signatures

type t

val size : t -> int

val of_int : int -> t

val of_char : char -> t

val of_string : string -> t

val to_int : t -> int

val to_char : t -> char

val to_ascii : t -> string

val pad_left : int -> t -> t

val pad_right : int -> t -> t

val concat : t -> t -> t

val unsafe_s : t -> string

val unsafe_b : string -> t


(*
 * Copyright (c) Facebook, Inc. and its affiliates.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the root directory of this source tree.
 *)

exception Worker_should_exit

let () = Callback.register_exception "worker_should_exit" Worker_should_exit

external stop_workers : unit -> unit = "hh_stop_workers"

external resume_workers : unit -> unit = "hh_resume_workers"

external check_should_exit : unit -> unit = "hh_check_should_exit"

external set_can_worker_stop : bool -> unit = "hh_set_can_worker_stop"

let on_worker_cancelled = ref (fun () -> ())

let set_on_worker_cancelled f = on_worker_cancelled := f

let with_no_cancellations f =
  Utils.try_finally
    ~f:
      begin
        fun () ->
        set_can_worker_stop false;
        f ()
      end
    ~finally:(fun () -> set_can_worker_stop true)

let with_worker_exit f =
  try f ()
  with Worker_should_exit ->
    !on_worker_cancelled ();
    exit 0

(* Check if the workers are stopped and exit if they are *)
let check_should_exit () = with_worker_exit check_should_exit

Add check_should_exit to the end of with_no_cancellations

(*
 * Copyright (c) Facebook, Inc. and its affiliates.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the root directory of this source tree.
 *)

exception Worker_should_exit

let () = Callback.register_exception "worker_should_exit" Worker_should_exit

external stop_workers : unit -> unit = "hh_stop_workers"

external resume_workers : unit -> unit = "hh_resume_workers"

external check_should_exit : unit -> unit = "hh_check_should_exit"

external set_can_worker_stop : bool -> unit = "hh_set_can_worker_stop"

let on_worker_cancelled = ref (fun () -> ())

let set_on_worker_cancelled f = on_worker_cancelled := f

let with_worker_exit f =
  try f ()
  with Worker_should_exit ->
    !on_worker_cancelled ();
    exit 0

(* Check if the workers are stopped and exit if they are *)
let check_should_exit () = with_worker_exit check_should_exit

let with_no_cancellations f =
  Utils.try_finally
    ~f:
      begin
        fun () ->
        set_can_worker_stop false;
        f ()
      end
    ~finally:(fun () ->
      set_can_worker_stop true;
      check_should_exit ())


open BatPervasives
type ('a, 'b) t = ('a, 'b) BatPervasives.result =
 | Ok  of 'a
 | Bad of 'b

let catch f x =
  try  Ok (f x)
  with e -> Bad e

let of_option = function
  | Some x -> Ok x
  | None   -> Bad ()

let to_option = function
  | Ok x   -> Some x
  | Bad _-> None

let default def = function
  | Ok x  -> x
  | Bad _ -> def

let map_default def f = function
  | Ok x -> f x
  | Bad _ -> def

let is_ok = function Ok _ -> true | Bad _ -> false

let is_bad = function Bad _ -> true | Ok _ -> false

let get = function Ok x -> x | Bad e -> raise e

let print print_val oc = function
  | Ok x -> BatInnerIO.fprintf oc "Ok(%a)" print_val x
  | Bad e -> BatInnerIO.fprintf oc "Bad(%a)" BatPrintexc.print e

module Monad = struct
  let bind m k = match m with
    | Ok  x      -> k x
    | Bad _ as e -> e

  let return x = Ok x

  let (>>=) = bind
end

module Infix = struct
  let (>>=) = Monad.bind
end

Fix reference to InnerIO.fprintf in Result

open BatPervasives
type ('a, 'b) t = ('a, 'b) BatPervasives.result =
 | Ok  of 'a
 | Bad of 'b

let catch f x =
  try  Ok (f x)
  with e -> Bad e

let of_option = function
  | Some x -> Ok x
  | None   -> Bad ()

let to_option = function
  | Ok x   -> Some x
  | Bad _-> None

let default def = function
  | Ok x  -> x
  | Bad _ -> def

let map_default def f = function
  | Ok x -> f x
  | Bad _ -> def

let is_ok = function Ok _ -> true | Bad _ -> false

let is_bad = function Bad _ -> true | Ok _ -> false

let get = function Ok x -> x | Bad e -> raise e

let print print_val oc = function
  | Ok x -> BatInnerIO.Printf.fprintf oc "Ok(%a)" print_val x
  | Bad e -> BatInnerIO.Printf.fprintf oc "Bad(%a)" BatPrintexc.print e

module Monad = struct
  let bind m k = match m with
    | Ok  x      -> k x
    | Bad _ as e -> e

  let return x = Ok x

  let (>>=) = bind
end

module Infix = struct
  let (>>=) = Monad.bind
end


module Html = Eliom_pervasives.HTML5

let main_service =
  Eliom_output.Html5.register_service
    ~path: [""]
    ~get_params: Eliom_parameters.unit
    (fun () () ->
      Lwt.return
        (Html.html
           (Html.head (Html.title (Html.pcdata "Hello World")) [])
           (Html.body [
             Html.p [
               Html.pcdata "Hello World"
             ]
           ])
        )
    )

Add the atom flux service

module Html = Eliom_pervasives.HTML5
module Calendar = CalendarLib.Calendar

let atom_service =
  Eliom_atom.Reg.register_service
    ~path: ["atom"]
    ~get_params: Eliom_parameters.unit
    (fun () () ->
      Lwt.return
        (Atom_feed.feed
           ~updated: (Calendar.make 2012 6 9 17 40 30)
           ~id: (Html.uri_of_string "http://cumulus.org")
           ~title: (Atom_feed.plain "An Atom flux")
           []
        )
    )

let main_service =
  Eliom_output.Html5.register_service
    ~path: [""]
    ~get_params: Eliom_parameters.unit
    (fun () () ->
      Lwt.return
        (Html.html
           (Html.head (Html.title (Html.pcdata "Hello World")) [])
           (Html.body [
             Html.p [
               Html.pcdata "Hello World"
             ]
           ])
        )
    )


type heap = unit

(* https://www.lexifi.com/blog/references-physical-equality *)
type 'a ref = {
  mutable contents: 'a;
  id: int
}

type ('a, 'b) mref = 'a ref

type aref =
   | Ref of (unit * unit)

let emp =
  ()

(* Logical functions on heap *)
(* TODO : complete the functions to have the same interface as in FStar.Heap.fsti *)

let addr_of _ = Obj.magic ()
let is_mm _ = Obj.magic ()

(* let compare_addrs *)

type ('a, 'b, 'c) contains
type ('a, 'b, 'c) unused_in
let fresh _ _ _ = Obj.magic ()

let sel _ _ = Obj.magic ()
let upd _ _ _ = Obj.magic ()
let alloc _ _ _ = Obj.magic ()

Refresh heap implementation with new untyped view of references

type heap = unit

(* https://www.lexifi.com/blog/references-physical-equality *)
type 'a ref = {
  mutable contents: 'a;
  id: int
}

type ('a, 'b) mref = 'a ref

let emp =
  ()

(* Logical functions on heap *)
(* TODO : complete the functions to have the same interface as in FStar.Heap.fsti *)

let addr_of _ = Obj.magic ()
let is_mm _ = Obj.magic ()

(* let compare_addrs *)

type ('a, 'b, 'c) contains
type ('a, 'b, 'c) unused_in
let fresh _ _ _ = Obj.magic ()

let sel _ _ = Obj.magic ()
let upd _ _ _ = Obj.magic ()
let alloc _ _ _ = Obj.magic ()

(* Untyped view of references *)
type aref =
   | Ref of (unit * unit)
let dummy_aref = Ref ((), ())
let aref_of _ = dummy_aref
let ref_of _ _ = Obj.magic ()


open Webtest.Suite
open Webtest.Utils

let test_bracket_succeed () =
  let state = ref `uninitialised in
  let setup () = state := `test_start; state in
  let teardown state =
    assert_equal !state `test_end;
    state := `torn_down
  in
  Sync.bracket
    setup
    (fun state ->
      assert_equal !state `test_start;
      state := `test_end)
    teardown ();
  assert_equal !state `torn_down

let test_bracket_fail () =
  let state = ref `uninitialised in
  let setup () = state := `test_start; state in
  let teardown state =
    state := `torn_down
  in
  try
    Sync.bracket
      setup
      (fun state ->
        assert_equal !state `test_start;
        assert_equal 5 6)
      teardown ();
  with TestFailure "not equal" ->
    assert_equal !state `torn_down

let test_bracket_error () =
  let state = ref `uninitialised in
  let setup () = state := `test_start; state in
  let teardown state =
    state := `torn_down
  in
  try
    Sync.bracket
      setup
      (fun state ->
        assert_equal !state `test_start;
        failwith "error")
      teardown ();
  with Failure "error" ->
    assert_equal !state `torn_down

let suite =
  "sync" >::: [
    "test_bracket_succeed" >:: test_bracket_succeed;
    "test_bracket_fail" >:: test_bracket_fail;
    "test_bracket_error" >:: test_bracket_error;
  ]

Remove an unused module open

open Webtest.Suite

let test_bracket_succeed () =
  let state = ref `uninitialised in
  let setup () = state := `test_start; state in
  let teardown state =
    assert_equal !state `test_end;
    state := `torn_down
  in
  Sync.bracket
    setup
    (fun state ->
      assert_equal !state `test_start;
      state := `test_end)
    teardown ();
  assert_equal !state `torn_down

let test_bracket_fail () =
  let state = ref `uninitialised in
  let setup () = state := `test_start; state in
  let teardown state =
    state := `torn_down
  in
  try
    Sync.bracket
      setup
      (fun state ->
        assert_equal !state `test_start;
        assert_equal 5 6)
      teardown ();
  with TestFailure "not equal" ->
    assert_equal !state `torn_down

let test_bracket_error () =
  let state = ref `uninitialised in
  let setup () = state := `test_start; state in
  let teardown state =
    state := `torn_down
  in
  try
    Sync.bracket
      setup
      (fun state ->
        assert_equal !state `test_start;
        failwith "error")
      teardown ();
  with Failure "error" ->
    assert_equal !state `torn_down

let suite =
  "sync" >::: [
    "test_bracket_succeed" >:: test_bracket_succeed;
    "test_bracket_fail" >:: test_bracket_fail;
    "test_bracket_error" >:: test_bracket_error;
  ]


let rec find p xs =
    match xs with
    | [] -> None
    | x :: xs' -> if (p x) then (Some x)
                  else find p xs'

let rec remove p xs =
    match xs with
    | [] -> []
    | x :: xs' -> if (p x) then xs'
                  else x :: (remove p xs')

let rec replace p x xs =
    match xs with
    | [] -> []
    | x' :: xs' -> if (p x') then x :: xs'
                   else x' :: (replace p x xs')

let rec insert_before p x xs =
    match xs with
    | [] -> raise Not_found
    | y :: ys -> if (p y) then x :: y :: ys
                 else y :: (insert_before p x ys)

let rec insert_after p x xs =
    match xs with
    | [] -> raise Not_found
    | y :: ys -> if (p y) then y :: x :: ys
                 else y :: (insert_after p x ys)

Make Vylist.replace raise Not_found for nonexistent elements.

let rec find p xs =
    match xs with
    | [] -> None
    | x :: xs' -> if (p x) then (Some x)
                  else find p xs'

let rec remove p xs =
    match xs with
    | [] -> []
    | x :: xs' -> if (p x) then xs'
                  else x :: (remove p xs')

let rec replace p x xs =
    match xs with
    | [] -> raise Not_found
    | x' :: xs' -> if (p x') then x :: xs'
                   else x' :: (replace p x xs')

let rec insert_before p x xs =
    match xs with
    | [] -> raise Not_found
    | y :: ys -> if (p y) then x :: y :: ys
                 else y :: (insert_before p x ys)

let rec insert_after p x xs =
    match xs with
    | [] -> raise Not_found
    | y :: ys -> if (p y) then y :: x :: ys
                 else y :: (insert_after p x ys)


let filewrite fn st =
  let o = open_out fn in
  output_string o st;
  close_out o;
  Printf.fprintf stderr "Output written on %s (%d bytes)\n%t"
    fn (String.length st) flush

let syspr cmd =
  Printf.fprintf stderr "(*%s*)\n%t" cmd flush;
  0==Sys.command cmd

let isyspr cmd = ignore(syspr cmd)

let drive stem bl =
  filewrite (stem^".tex") (Latex.xlate bl);
  filewrite (stem^".nr") (Nroff.xlate bl);
  filewrite (stem^".html") (Html.xlate bl);
  filewrite (stem^".rtf") (Rtf.xlate bl);

  if syspr("latex "^stem) then begin
    isyspr("dvips "^stem^" -o");
 (* isyspr("pdflatex "^stem) *)
    isyspr("dvipdfm -v "^stem)
  end;

  if syspr("nroff "^stem^".nr > "^stem^".tty") then begin
    isyspr("ul -t ansi "^stem^".tty > "^stem^".ansi");
    isyspr("ul -t dumb "^stem^".tty > "^stem^".txt");
  end

Make newer nroffs behave in the traditional way we expect.

let filewrite fn st =
  let o = open_out fn in
  output_string o st;
  close_out o;
  Printf.fprintf stderr "Output written on %s (%d bytes)\n%t"
    fn (String.length st) flush

let syspr cmd =
  Printf.fprintf stderr "(*%s*)\n%t" cmd flush;
  0==Sys.command cmd

let isyspr cmd = ignore(syspr cmd)

let drive stem bl =
  filewrite (stem^".tex") (Latex.xlate bl);
  filewrite (stem^".nr") (Nroff.xlate bl);
  filewrite (stem^".html") (Html.xlate bl);
  filewrite (stem^".rtf") (Rtf.xlate bl);

  if syspr("latex "^stem) then begin
    isyspr("dvips "^stem^" -o");
    (* isyspr("pdflatex "^stem) *)
    isyspr("dvipdfm -v "^stem)
  end;

  if syspr("nroff -c "^stem^".nr > "^stem^".tty") then begin
    isyspr("ul -t ansi "^stem^".tty > "^stem^".ansi");
    isyspr("ul -t dumb "^stem^".tty > "^stem^".txt");
  end


let hdhcpd debug verbose = `Ok

(* Parse command line and start the ball *)
open Cmdliner
let cmd =
  let debug = Arg.(value & flag & info ["d" ; "debug"]
                       ~doc:"Don't daemonize and be uber-verbose.") in
  let verbose = Arg.(value & flag & info ["v" ; "verbose"]
                       ~doc:"Verbose output.") in
  Term.(pure hdhcpd $ debug $ verbose),
  Term.info "hdhcpd" ~version:"0.1" ~doc:"Haesbaert DHCP"
let () = match Term.eval cmd with `Error _ -> exit 1 | _ -> exit 0

Initialize the logger, will need more work for syslog.

open Lwt

let config_log verbosity =
  match verbosity with
  | None -> `Ok ()
  | Some verbosity ->
    let vlevel = match verbosity with
      | "debug" -> Some Lwt_log.Debug
      | "info" -> Some Lwt_log.Info
      | "notice" -> Some Lwt_log.Notice
      | _ -> None
    in match vlevel with
    | Some vlevel -> Lwt_log.Section.(set_level main vlevel);
      `Ok ()
    | None -> `Error (true, "invalid verbosity")

let hdhcpd verbosity =
  match (config_log verbosity) with
  | `Error (t, e) -> `Error (t, e)
  | _ -> Lwt_main.run(
      Lwt_log.notice "Haesbaert DHCPD started" >>= fun () ->
      Lwt_log.notice "Haesbaert DHCPD finished" >>= fun () ->
      Lwt.return (`Ok ()))

(* Parse command line and start the ball *)
open Cmdliner
let cmd =
  let verbosity = Arg.(value & opt (some string) None & info ["v" ; "verbosity"]
                         ~doc:"Log verbosity, debug|info|notice") in
  Term.(ret (pure hdhcpd $ verbosity)),
  Term.info "hdhcpd" ~version:"0.1" ~doc:"Haesbaert DHCP"
let () = match Term.eval cmd with `Error _ -> exit 1 | _ -> exit 0


(*
 * Copyright (C) Citrix Systems Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation; version 2.1 only. with the special
 * exception on linking described in file LICENSE.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *)

open Pervasiveext
open Client

let rpc xml =
    let open Xmlrpc_client in
    XML_protocol.rpc ~transport:(Unix "/var/xapi/xapi") ~http:(xmlrpc ~version:"1.0" "/") xml

let _ =
    let session_id = Client.Session.login_with_password ~rpc ~uname:"" ~pwd:"" ~version:"1.0" in
	finally
		(fun () -> Create_templates.create_all_templates rpc session_id)
		(fun () -> Client.Session.logout rpc session_id)

Fix build: add 'originator' param to Session.login_with_password

(*
 * Copyright (C) Citrix Systems Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation; version 2.1 only. with the special
 * exception on linking described in file LICENSE.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *)

open Pervasiveext
open Client

let rpc xml =
    let open Xmlrpc_client in
    XML_protocol.rpc ~transport:(Unix "/var/xapi/xapi") ~http:(xmlrpc ~version:"1.0" "/") xml

let _ =
	let session_id = Client.Session.login_with_password
		~rpc ~uname:"" ~pwd:"" ~version:"1.0" ~originator:"create_templates" in
	finally
		(fun () -> Create_templates.create_all_templates rpc session_id)
		(fun () -> Client.Session.logout rpc session_id)


(* List the subfolders of a folder.
 * The head of the list returned is the folder given in arg *)
let rec ls folder =

  let dh_opt = ref None in

  begin try
    (* Check if the given folder exists in argument *)
    match Sys.is_directory folder with
    | true ->  dh_opt := Some (Unix.opendir folder)
    | false -> ()
  with Sys_error _ -> ()
  end;

  match !dh_opt with
  | None -> []
  | Some dh ->
      let l = ref [folder] in
      begin
	try
	  while true do
	    let entry = Unix.readdir dh in
	    try
	      let fullpath = (folder^"/"^entry) in
	      (* Test if it's a file or a folder *)
	      match Sys.is_directory fullpath with
	      | true ->
		  begin
		    match entry with
		    | ("." | "..") -> ()
		    | _            -> l := (!l)@(ls fullpath)
		  end
	      | false -> ()
	    with Sys_error err -> print_endline err

	  done;
	with End_of_file -> Unix.closedir dh
      end;
      !l
;;

Fix a possible crash by catching an exception Unix_error with 'opendir' in Dirs.ls when a subdirectory can't be accessed due to permissions for example

open Ast;;

(* List the subfolders of a folder.
 * The head of the list returned is the folder given in arg *)
let rec ls folder =

  let dh_opt = ref None in

  begin try
    (* Check if the given folder exists in argument *)
    match Sys.is_directory folder with
    | true ->  dh_opt := Some (Unix.opendir folder)
    | false -> ()
  with Sys_error _ -> ()
  end;

  match !dh_opt with
  | None -> []
  | Some dh ->
      let l = ref [folder] in
      begin
	try
	  while true do
	    let entry = Unix.readdir dh in
	    try
	      let fullpath = (folder^"/"^entry) in
	      (* Test if it's a file or a folder *)
	      match Sys.is_directory fullpath with
	      | true ->
		  begin
		    match entry with
		    | ("." | "..") -> ()
		    | _            -> l := (!l)@(ls fullpath)
		  end
	      | false -> ()
	    with Sys_error err -> print_endline err

	  done;
	with
	| End_of_file -> Unix.closedir dh
	| Unix.Unix_error (_,function',file_or_dir) ->
	    Report.Report.report (
	    Log (("Unix error: "^function'^", "^file_or_dir), Error) )
      end;
      !l
;;


(**
 * Copyright (c) 2013-present, Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the BSD-style license found in the
 * LICENSE file in the "flow" directory of this source tree. An additional grant
 * of patent rights can be found in the PATENTS file in the same directory.
 *
 *)

open Utils_js

val dependent_files:
  Worker.t list option -> (* workers *)
  unchanged:FilenameSet.t ->
  new_or_changed:FilenameSet.t ->
  changed_modules:Modulename.Set.t ->
  FilenameSet.t * FilenameSet.t

val file_dependencies: (filename -> FilenameSet.t) Expensive.t

val calc_dependency_graph:
  Worker.t list option -> (* workers *)
  filename list -> (* files *)
  FilenameSet.t FilenameMap.t

val calc_all_dependencies:
  FilenameSet.t FilenameMap.t -> (* dependency graph *)
  FilenameSet.t -> (* files *)
  FilenameSet.t

Document the return type of Dep_service.dependent_files

(**
 * Copyright (c) 2013-present, Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the BSD-style license found in the
 * LICENSE file in the "flow" directory of this source tree. An additional grant
 * of patent rights can be found in the PATENTS file in the same directory.
 *
 *)

open Utils_js

val dependent_files:
  Worker.t list option -> (* workers *)
  unchanged:FilenameSet.t ->
  new_or_changed:FilenameSet.t ->
  changed_modules:Modulename.Set.t ->
  (* (transitive_dependents, direct_dependents) of changed_modules *)
  FilenameSet.t * FilenameSet.t

val file_dependencies: (filename -> FilenameSet.t) Expensive.t

val calc_dependency_graph:
  Worker.t list option -> (* workers *)
  filename list -> (* files *)
  FilenameSet.t FilenameMap.t

val calc_all_dependencies:
  FilenameSet.t FilenameMap.t -> (* dependency graph *)
  FilenameSet.t -> (* files *)
  FilenameSet.t


open Amqp_spec.Basic

type message = (Content.t * string)

type t =
  { delivery_tag : int;
    redelivered : bool;
    exchange : string;
    routing_key : string;
    message: message;
  }

let make
    ?content_type
    ?content_encoding
    ?headers
    ?delivery_mode
    ?priority
    ?correlation_id
    ?reply_to
    ?expiration
    ?message_id
    ?timestamp
    ?amqp_type
    ?user_id
    ?app_id
    ?reserved body : message =
  ({ Content.content_type;
     content_encoding;
     headers;
     delivery_mode;
     priority;
     correlation_id;
     reply_to;
     expiration;
     message_id;
     timestamp;
     amqp_type;
     user_id;
     app_id;
     reserved;
   }, body)

Use better types for message

open Amqp_spec.Basic

type message = (Content.t * string)

type t =
  { delivery_tag : int;
    redelivered : bool;
    exchange : string;
    routing_key : string;
    message: message;
  }

let make
    ?(content_type:string option)
    ?(content_encoding: string option)
    ?(headers: Amqp_types.table option)
    ?(delivery_mode: int option)
    ?(priority: int option)
    ?(correlation_id: string option)
    ?(reply_to: string option)
    ?(expiration: int option)
    ?(message_id: string option)
    ?(timestamp: int option)
    ?(amqp_type: string option)
    ?(user_id: string option)
    ?(app_id: string option)
    body : message =
  let expiration = match expiration with
    | None -> None
    | Some n -> Some (string_of_int n)
  in

  ({ Content.content_type;
     content_encoding;
     headers;
     delivery_mode;
     priority;
     correlation_id;
     reply_to;
     expiration;
     message_id;
     timestamp;
     amqp_type;
     user_id;
     app_id;
     reserved = None;
   }, body)


(* This file is free software, part of containers. See file "license" for more details. *)

(** {1 Drop-In replacement to Stdlib} *)

module Array = CCArray
module ArrayLabels = CCArrayLabels
module Array_slice = CCArray_slice
module Bool = CCBool
module Char = Char
module Equal = CCEqual
module Float = CCFloat
module Format = CCFormat
module Fun = CCFun
module Hash = CCHash

(** @since 0.14 *)
module Hashtbl = struct
  include (Hashtbl : module type of Hashtbl
    with type statistics = Hashtbl.statistics
     and module Make = Hashtbl.Make
     and type ('a,'b) t = ('a,'b) Hashtbl.t
  )
  include CCHashtbl.Poly
  module type S' = CCHashtbl.S
  module Make' = CCHashtbl.Make
end
module Heap = CCHeap
module Int = CCInt
module Int64 = CCInt64
module IO = CCIO
module List = CCList
module ListLabels = CCListLabels
module Map = CCMap
module Option = CCOpt
module Ord = CCOrd
module Pair = CCPair
module Parse = CCParse
module Random = CCRandom
module Ref = CCRef
module Result = CCResult
module Set = CCSet
module String = CCString
module Vector = CCVector

Add Containers.Monomorphic and include it by default

(* This file is free software, part of containers. See file "license" for more details. *)

(** {1 Drop-In replacement to Stdlib} *)

module Array = CCArray
module ArrayLabels = CCArrayLabels
module Array_slice = CCArray_slice
module Bool = CCBool
module Char = Char
module Equal = CCEqual
module Float = CCFloat
module Format = CCFormat
module Fun = CCFun
module Hash = CCHash

(** @since 0.14 *)
module Hashtbl = struct
  include (Hashtbl : module type of Hashtbl
    with type statistics = Hashtbl.statistics
     and module Make = Hashtbl.Make
     and type ('a,'b) t = ('a,'b) Hashtbl.t
  )
  include CCHashtbl.Poly
  module type S' = CCHashtbl.S
  module Make' = CCHashtbl.Make
end
module Heap = CCHeap
module Int = CCInt
module Int64 = CCInt64
module IO = CCIO
module List = CCList
module ListLabels = CCListLabels
module Map = CCMap
module Option = CCOpt
module Ord = CCOrd
module Pair = CCPair
module Parse = CCParse
module Random = CCRandom
module Ref = CCRef
module Result = CCResult
module Set = CCSet
module String = CCString
module Vector = CCVector
module Monomorphic = CCMonomorphic

include Monomorphic


open Mirage

let main =
  foreign "Dispatch.Main" (console @-> http @-> clock @-> job)

let ipv4_config =
  let address = Ipaddr.V4.of_string_exn "10.0.0.10" in
  let netmask = Ipaddr.V4.of_string_exn "255.255.255.0" in
  let gateways = [Ipaddr.V4.of_string_exn "10.0.0.1"] in
  { address; netmask; gateways }

let stack console = direct_stackv4_with_static_ipv4 console tap0 ipv4_config

let server =
  conduit_direct (stack default_console)

let http_srv =
  http_server server

let () =
  add_to_ocamlfind_libraries ["re.str";"str"];

  register "www" [
    main $ default_console $ http_srv $ default_clock
  ]

Allow to set-up the IP address on the command line

open Mirage

let get_exn name fn =
  let res = Sys.getenv name in
  Printf.printf "\027[33mENV\027[m         %s => %s\n%!" name res;
  fn (String.lowercase res)
let get name ~default fn = try get_exn name fn with Not_found -> default
let ip name default =
  let fn = Ipaddr.V4.of_string_exn in
  get name ~default:(fn default) fn

let main =
  foreign "Dispatch.Main" (console @-> http @-> clock @-> job)

let ipv4_config =
  let address  = ip "IP" "10.0.0.10" in
  let netmask  = ip "NM" "255.255.255.0" in
  let gateways = [ip "GW" "10.0.0.1"] in
  { address; netmask; gateways }

let stack console = direct_stackv4_with_static_ipv4 console tap0 ipv4_config

let server =
  conduit_direct (stack default_console)

let http_srv =
  http_server server

let () =
  add_to_ocamlfind_libraries ["re.str";"str"];

  register "www" [
    main $ default_console $ http_srv $ default_clock
  ]


(*
 * Copyright (c) Facebook, Inc. and its affiliates.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the root directory of this source tree.
 *)

val key : allow_optional:bool -> ('loc, 'loc) Flow_ast.Expression.t -> Key.t option

val get :
  allow_optional:bool -> Context.t -> ('loc, 'loc) Flow_ast.Expression.t -> ALoc.t -> Type.t option

val key_of_pattern : allow_optional:bool -> ('loc, 'loc) Flow_ast.Pattern.t -> Key.t option

val get_of_pattern :
  allow_optional:bool -> Context.t -> ('loc, 'loc) Flow_ast.Pattern.t -> ALoc.t -> Type.t option

Make Refinement API accept typed AST as well

(*
 * Copyright (c) Facebook, Inc. and its affiliates.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the root directory of this source tree.
 *)

val key : allow_optional:bool -> ('loc, 't) Flow_ast.Expression.t -> Key.t option

val get :
  allow_optional:bool -> Context.t -> ('loc, 't) Flow_ast.Expression.t -> ALoc.t -> Type.t option

val key_of_pattern : allow_optional:bool -> ('loc, 't) Flow_ast.Pattern.t -> Key.t option

val get_of_pattern :
  allow_optional:bool -> Context.t -> ('loc, 't) Flow_ast.Pattern.t -> ALoc.t -> Type.t option


(*
 * Copyright (c) 2013-2017 Thomas Gazagnaire <thomas@gazagnaire.org>
 * and Romain Calascibetta <romain.calascibetta@gmail.com>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

type tz_offset =
  { sign    : [ `Plus | `Minus ]
  ; hours   : int
  ; minutes : int }

type t =
  { name  : string
  ; email : string
  ; date  : int64 * tz_offset option }

include S.BASE with type t := t

module A: S.ANGSTROM with type t = t

module F: S.FARADAY with type t = t

module M: S.MINIENC with type t = t

module D: S.DECODER
  with type t = t
   and type init = Cstruct.t
   and type error = [ `Decoder of string ]

Update errors on User module

(*
 * Copyright (c) 2013-2017 Thomas Gazagnaire <thomas@gazagnaire.org>
 * and Romain Calascibetta <romain.calascibetta@gmail.com>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

type tz_offset =
  { sign    : [ `Plus | `Minus ]
  ; hours   : int
  ; minutes : int }

type t =
  { name  : string
  ; email : string
  ; date  : int64 * tz_offset option }

include S.BASE with type t := t

module A: S.ANGSTROM with type t = t

module F: S.FARADAY with type t = t

module M: S.MINIENC with type t = t

module D: S.DECODER
  with type t = t
   and type init = Cstruct.t
   and type error = Error.Decoder.t


open Amqp_thread
open Amqp

let handler var { Message.message = (_, body); _ } = Ivar.fill var body; return ()

let test =
  Connection.connect ~id:"fugmann" "localhost" >>= fun connection ->
  Log.info "Connection started";
  Connection.open_channel ~id:"queue.test" Channel.with_confirm connection >>= fun channel ->
  Log.info "Channel opened";

  Exchange.publish channel Exchange.amq_direct ~mandatory:false ~routing_key:"non_existant_queue" (Message.make "") >>= fun r ->
  assert (r = `Ok);
  Exchange.publish channel Exchange.amq_direct ~mandatory:true ~routing_key:"non_existant_queue" (Message.make "") >>= fun r ->
  assert (r = `Failed);

  Channel.close channel >>= fun () ->
  Log.info "Channel closed";
  Connection.close connection >>| fun () ->
  Log.info "Connection closed";
  Scheduler.shutdown 0

let _ =
  Scheduler.go ()

Extend mandatory test to test on_return message delivery

open Amqp_thread
open Amqp

let handler var { Message.message = (_, body); _ } = Ivar.fill var body; return ()

let assert_returned_message reader body =
  Pipe.read reader >>| function
  | `Ok (_, (_, m)) -> assert (m = body); ()
  | `Eof -> assert false

let assert_reader_closed reader =
  Pipe.read reader >>| function
  | `Ok _ -> assert false
  | `Eof -> ()

let test =
  Connection.connect ~id:"fugmann" "localhost" >>= fun connection ->
  Log.info "Connection started";
  Connection.open_channel ~id:"queue.test" Channel.with_confirm connection >>= fun channel ->
  Log.info "Channel opened";

  Exchange.publish channel Exchange.amq_direct ~mandatory:false ~routing_key:"non_existant_queue" (Message.make "") >>= fun r ->
  assert (r = `Ok);
  Exchange.publish channel Exchange.amq_direct ~mandatory:true ~routing_key:"non_existant_queue" (Message.make "") >>= fun r ->
  assert (r = `Failed);

  (* Test on_return delivery handler *)
  let reader1 = Channel.on_return channel in
  let reader2 = Channel.on_return channel in
  let body = "Return this message" in
  Exchange.publish channel Exchange.amq_direct ~mandatory:true ~routing_key:"non_existant_queue" (Message.make body) >>= fun r ->
  assert (r = `Failed);
  assert_returned_message reader1 body >>= fun () ->
  assert_returned_message reader2 body >>= fun () ->

  Channel.close channel >>= fun () ->
  Log.info "Channel closed";
  assert_reader_closed reader1 >>= fun () ->
  assert_reader_closed reader2 >>= fun () ->

  Connection.close connection >>| fun () ->
  Log.info "Connection closed";
  Scheduler.shutdown 0

let _ =
  Scheduler.go ()


open Decompress

module Input =
  struct
    type t = Pervasives.in_channel

    let std = Pervasives.stdin

    let read_byte = Pervasives.input_byte
    let input ch n =
      if n <= 0 then Bytes.empty
      else
        let bytes = Bytes.create n in
        let len = ref n in
        let pos = ref 0 in

        try
          while !len > 0 do
            let rest = Pervasives.input ch bytes !pos !len in
            if rest = 0 then raise End_of_file;
            pos := !pos + rest;
            len := !len - rest;
          done;

          bytes
        with End_of_file as exn ->
          if !pos = 0 then raise exn
          else Bytes.sub bytes 0 !pos

  end

module Output =
  struct
    type t = Pervasives.out_channel

    let std = Pervasives.stdout

    let output_char = Pervasives.output_char
    let output_bytes = Pervasives.output_bytes
  end

module Inflate = Inflate.Make(Input)(Output)

let () =
  let inflater = Inflate.init Input.std Output.std in
  try Inflate.eval inflater
  with exn ->
    Printexc.to_string exn |> Printf.fprintf stderr "%s\n%!"

Use new inflater and instantiate Deflate module

open Decompress

module Input =
    struct
      type t = Pervasives.in_channel
      type buffer = Bytes.t

      let std = Pervasives.stdin

      let read_byte = Pervasives.input_byte
      let input ch n =
        if n <= 0 then Bytes.empty
        else
          let bytes = Bytes.create n in
          let len = ref n in
          let pos = ref 0 in

          try
            while !len > 0 do
              let rest = Pervasives.input ch bytes !pos !len in
              if rest = 0 then raise End_of_file;
              pos := !pos + rest;
              len := !len - rest;
            done;

            bytes
          with End_of_file as exn ->
            if !pos = 0 then raise exn
            else Bytes.sub bytes 0 !pos
    end

module Inflate = Inflate.Make(Input)(struct include Bytes let of_bytes x = x end)
module Deflate =
  Deflate.Make(Input)(
    Bitstream.StreamNativeInt(
      Bitstream.Target(
        Bitstream.NativeInt(
          Bitstream.BufferNativeInt))))

let () =
  let buffer = Bytes.create 1 in
  let inflater = Inflate.init Input.std buffer in
  try
    while not (Inflate.finish inflater)
    do Inflate.eval inflater;
       Printf.printf "%s%!" buffer;
       Inflate.clear inflater 1
    done
  with exn ->
    Printexc.to_string exn |> Printf.fprintf stderr "%s\n%!"


(* XML escape extracted here to avoid dependency cycle:
   CilType -> Goblintutil -> GobConfig -> Tracing -> Node -> CilType *)

let escape (x:string):string =
  (* Safe to escape all these everywhere in XML: https://stackoverflow.com/a/1091953/854540 *)
  Str.global_replace (Str.regexp "&") "&" x |>
  Str.global_replace (Str.regexp "<") "<" |>
  Str.global_replace (Str.regexp ">") ">" |>
  Str.global_replace (Str.regexp "\"") """ |>
  Str.global_replace (Str.regexp "'") "'" |>
  Str.global_replace (Str.regexp "[\x0b\001\x0c\x0f\x0e]") "" (* g2html just cannot handle from some kernel benchmarks, even when escaped... *)

Add \x1b escape to XmlUtil for chrony

(* XML escape extracted here to avoid dependency cycle:
   CilType -> Goblintutil -> GobConfig -> Tracing -> Node -> CilType *)

let escape (x:string):string =
  (* Safe to escape all these everywhere in XML: https://stackoverflow.com/a/1091953/854540 *)
  Str.global_replace (Str.regexp "&") "&" x |>
  Str.global_replace (Str.regexp "<") "<" |>
  Str.global_replace (Str.regexp ">") ">" |>
  Str.global_replace (Str.regexp "\"") """ |>
  Str.global_replace (Str.regexp "'") "'" |>
  Str.global_replace (Str.regexp "[\x0b\001\x0c\x0f\x0e]") "" |> (* g2html just cannot handle from some kernel benchmarks, even when escaped... *)
  Str.global_replace (Str.regexp "[\x1b]") "" (* g2html cannot handle from chrony *)


module Compat = Odoc__compat
module Html = Odoc__html
module Loader = Odoc__loader
module Model = Odoc__model
module Odoc = Odoc__odoc
module Parser_ = Odoc__parser
module Xref = Odoc__xref

Add link to explanation of Odoc__alias

(* See explanation at:

     https://github.com/ocaml/odoc/issues/236#issuecomment-440248694. *)

module Compat = Odoc__compat
module Html = Odoc__html
module Loader = Odoc__loader
module Model = Odoc__model
module Odoc = Odoc__odoc
module Parser_ = Odoc__parser
module Xref = Odoc__xref


module Bisect_visit___source___ml =
  struct
    let ___bisect_visit___ =
      let point_definitions =
        "\132\149\166\190\000\000\000\t\000\000\000\003\000\000\000\t\000\000\000\t\160\160\000EA\160\000[@"
         in
      let point_state = Array.make 2 0  in
      Bisect.Runtime.register_file "source.ml" point_state point_definitions;
      (fun point_index  ->
         let current_count = point_state.(point_index)  in
         point_state.(point_index) <-
           (if current_count < Pervasives.max_int
            then Pervasives.succ current_count
            else current_count))

  end
open Bisect_visit___source___ml
let f1 x y = if x = y then x + y else x - y
let g s =
  ___bisect_visit___ 1;
  for i = 1 to 5 do (___bisect_visit___ 0; print_endline s) done
let f2 b x = if b then x * x else x
let f3 : 'a . 'a -> string = fun (type a) ->
  (fun _  -> "Hello" : a -> string)

Fix testing diff on 4.05 and 4.06

module Bisect_visit___source___ml =
  struct
    let ___bisect_visit___ =
      let point_definitions =
        "\132\149\166\190\000\000\000\t\000\000\000\003\000\000\000\t\000\000\000\t\160\160\000EA\160\000[@"
         in
      let point_state = Array.make 2 0  in
      Bisect.Runtime.register_file "source.ml" point_state point_definitions;
      (fun point_index  ->
         let current_count = point_state.(point_index)  in
         point_state.(point_index) <-
           (if current_count < Pervasives.max_int
            then Pervasives.succ current_count
            else current_count))

  end
open Bisect_visit___source___ml
let f1 x y = if x = y then x + y else x - y
let g s =
  ___bisect_visit___ 1;
  for i = 1 to 5 do (___bisect_visit___ 0; print_endline s) done
let f2 b x = if b then x * x else x
let f3 : type a.a -> string = fun _  -> "Hello"


module Client = struct
  let connect ?src host sa =
    Lwt.fail_with "Tls not available"
end

module Server = struct
  let init' ?backlog ?stop ?timeout tls sa callback =
    Lwt.fail_with "Tls not available"

  let init ?backlog ~certfile ~keyfile ?stop ?timeout sa callback =
    Lwt.fail_with "Tls not available"
end

let available = false

Fix warnings when tls is missing

module Client = struct
  let connect ?src:_ _host _sa =
    Lwt.fail_with "Tls not available"
end

module Server = struct
  let init' ?backlog:_ ?stop:_ ?timeout:_ _tls _sa _callback =
    Lwt.fail_with "Tls not available"

  let init ?backlog:_ ~certfile:_ ~keyfile:_ ?stop:_ ?timeout:_ _sa _callback =
    Lwt.fail_with "Tls not available"
end

let available = false


(*
 * Copyright (c) 2012-2014 Anil Madhavapeddy <anil@recoil.org>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *
 *)

open Lwt.Infix

module Client = struct
  let default_ctx = `Ssl_not_available

  let connect ?(ctx=default_ctx) ?src sa = Lwt.fail_with "Ssl not available"
end

module Server = struct

  let default_ctx = `Ssl_not_available

  let listen ?(ctx=default_ctx) ?backlog ?password ~certfile ~keyfile sa =
    Lwt.fail_with "Ssl not available"

  let init ?(ctx=default_ctx) ?backlog ?password ~certfile ~keyfile ?stop
      ?timeout sa cb =
    Lwt.fail_with "Ssl not available"
end

let available = false

Fix some warnings with the dummy lwt unix ssl module

(*
 * Copyright (c) 2012-2014 Anil Madhavapeddy <anil@recoil.org>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *
 *)

module Client = struct
  let default_ctx = `Ssl_not_available

  let connect ?(ctx=default_ctx) ?src:_ _sa =
    ignore ctx;
    Lwt.fail_with "Ssl not available"
end

module Server = struct

  let default_ctx = `Ssl_not_available

  let init ?(ctx=default_ctx) ?backlog:_ ?password:_ ~certfile:_ ~keyfile:_ ?stop:_
      ?timeout:_ _sa _cb =
    ignore ctx;
    Lwt.fail_with "Ssl not available"
end

let available = false


open Lib
open Git.Model
open Git.Backend

let () =
  let t = Git.Store.create (File.Dirname.of_string ".git") in
  Git.Store.dump t;
  Git.View.to_dot t (File.Name.of_string "graph.dot")

Fix the compilation of test.

open GitTypes

let () =
  let t = GitLocal.create () in
  GitLocal.dump t;
  GitGraph.to_dot t "graph.dot"


#!/usr/bin/env ocaml
#use "topfind"
#require "topkg"
open Topkg

let () =
  Pkg.describe "mirage_ci" @@ fun c ->
  Ok [
    Pkg.lib "src/mirage-ci.mllib";
    Pkg.bin "src-bin/mirageCI";
    Pkg.bin "src-bin/avsmCI";
    Pkg.bin "src-bin/datakitToml";
  ]

Fix the install file generation so pinning this repo works

#!/usr/bin/env ocaml
#use "topfind"
#require "topkg"
open Topkg

let () =
  Pkg.describe "mirage-ci" @@ fun c ->
  Ok [
    Pkg.lib "src/mirage-ci.mllib";
    Pkg.bin "src-bin/mirageCI";
    Pkg.bin "src-bin/avsmCI";
    Pkg.bin "src-bin/datakitToml";
  ]


(* Auxiliary types *)
type type_name = string
type type_binders = type_name list

(* Kind definition *)

(* An atom cannot be parametrized by types. *)
(* kind List: type -> type *)
(* kind Variable: atom *)
type kind =
  | Type of type_binders
  | Atom

(* Type application *)
(* A type application is the process to apply a type to another. *)
(* Example: forall(A).List<A> *)
type type_application = type_name * type_name list

(* Constant definition *)

type constant = type_binders * type_application

(* Operator definition *)

(* A binder is: "Variable" in [Variable].Term * Term -> Term.
 (Note the '.' that delimitates the binder). *)
type binder = type_name option
type operator_args = type_application list
type operator_result = type_name

type operator = type_binders * binder * operator_args * operator_result

(* Rule definition *)

type pattern =
  | POperator of string * pattern list
  | PPlaceholder of string
  | PConstant of string
  | PAny

type effect =
  | EOperator of string * effect list
  | EPlaceholder of string
  | EConstant of string

type rule = pattern * effect

(* rewriting system *)
type info = Lexing.position
type 'a symbol_table = (string, 'a * info) Hashtbl.t
type rewriting_system =
  kind symbol_table *
  constant symbol_table *
  operator symbol_table *
  rule symbol_table

Add constructors for operator, constant and rule.

(* Auxiliary types *)
type type_name = string
type type_binders = type_name list

(* Kind definition *)

(* An atom cannot be parametrized by types. *)
(* kind List: type -> type *)
(* kind Variable: atom *)
type kind =
  | Type of type_binders
  | Atom

(* Type application *)
(* A type application is the process to apply a type to another. *)
(* Example: forall(A).List<A> *)
type type_application = type_name * type_name list

(* Constant definition *)

type constant = Constant of type_binders * type_application

(* Operator definition *)

(* A binder is: "Variable" in [Variable].Term * Term -> Term.
 (Note the '.' that delimitates the binder). *)
type binder = type_name option
type operator_args = type_application list
type operator_result = type_name

type operator = Operator of type_binders * binder * operator_args * operator_result

(* Rule definition *)

type pattern =
  | POperator of string * pattern list
  | PPlaceholder of string
  | PConstant of string
  | PAny

type effect =
  | EOperator of string * effect list
  | EPlaceholder of string
  | EConstant of string

type rule = Rule of pattern * effect

(* rewriting system *)
type info = Lexing.position
type 'a symbol_table = (string, 'a * info) Hashtbl.t
type rewriting_system =
  kind symbol_table *
  constant symbol_table *
  operator symbol_table *
  rule symbol_table


(*
 * Copyright (c) 2013 Thomas Gazagnaire <thomas@gazagnaire.org>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

let () =
  let suite k = [
    `Quick, Test_memory.suite k;
    `Quick, Test_fs.suite k;
    `Quick, Test_git.suite k `Disk;
    `Quick, Test_git.suite k `Memory;
    `Quick, Test_dispatch.suite k [|
      Test_git.suite k `Disk;
      Test_memory.suite k;
    |];
    `Slow , Test_crud.suite k (Test_memory.suite k);
    `Slow , Test_crud.suite k (Test_fs.suite k);
    `Slow , Test_crud.suite k (Test_git.suite k `Disk);
  ] in
  Test_store.run "irminsule" (suite `String @ suite `JSON)

Add an other dispatch backend

(*
 * Copyright (c) 2013 Thomas Gazagnaire <thomas@gazagnaire.org>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

let () =
  let suite k = [
    `Quick, Test_memory.suite k;
    `Quick, Test_fs.suite k;
    `Quick, Test_git.suite k `Disk;
    `Quick, Test_git.suite k `Memory;
    `Quick, Test_dispatch.suite k [|
      Test_git.suite k `Disk;
      Test_memory.suite k;
      Test_fs.suite k;
    |];
    `Slow , Test_crud.suite k (Test_memory.suite k);
    `Slow , Test_crud.suite k (Test_fs.suite k);
    `Slow , Test_crud.suite k (Test_git.suite k `Disk);
  ] in
  Test_store.run "irminsule" (suite `String @ suite `JSON)


(* TEST

include dynlink
files = "host.ml plugin.ml"
libraries = ""

flags += " -g "
ocamldebug_script = "${test_source_directory}/input_script"

* debugger
** shared-libraries
** setup-ocamlc.byte-build-env
*** ocamlc.byte
module = "host.ml"
**** ocamlc.byte
module = "plugin.ml"
***** ocamlc.byte
module = ""
all_modules = "host.cmo"
program = "${test_build_directory}/host.byte"
libraries = "dynlink"

****** run
output = "host.output"
******* check-program-output
reference = "${test_source_directory}/host.reference"

******* ocamldebug
output = "host.debug.output"
******** check-program-output
reference = "${test_source_directory}/host.debug.reference"

*)

let () = print_endline "hello host"; Dynlink.loadfile "plugin.cmo"

Fix debugger dynlink test on non-shared platforms

(* TEST

include dynlink
files = "host.ml plugin.ml"
libraries = ""

flags += " -g "
ocamldebug_script = "${test_source_directory}/input_script"

* debugger
** shared-libraries
*** setup-ocamlc.byte-build-env
**** ocamlc.byte
module = "host.ml"
***** ocamlc.byte
module = "plugin.ml"
****** ocamlc.byte
module = ""
all_modules = "host.cmo"
program = "${test_build_directory}/host.byte"
libraries = "dynlink"

******* run
output = "host.output"
******** check-program-output
reference = "${test_source_directory}/host.reference"

******** ocamldebug
output = "host.debug.output"
********* check-program-output
reference = "${test_source_directory}/host.debug.reference"

*)

let () = print_endline "hello host"; Dynlink.loadfile "plugin.cmo"


(**
 * Copyright (c) 2015, Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the BSD-style license found in the
 * LICENSE file in the "hack" directory of this source tree. An additional grant
 * of patent rights can be found in the PATENTS file in the same directory.
 *
 *)

module type S = MyMap_sig.S
module Make(Ord: Map.OrderedType) : S with type key = Ord.t = struct
  include Map.Make(Ord)
  let get x t =
    try Some (find x t) with Not_found -> None

  let find_unsafe = find

  let union x y =
    fold add x y

  let compare x y = compare Pervasives.compare x y
  let equal x y = compare x y = 0

  let keys m = fold (fun k _ acc -> k :: acc) m []
  let values m = fold (fun _ v acc -> v :: acc) m []
  let elements m = fold (fun k v acc -> (k,v)::acc) m []

  let map_env f env m =
    fold (
      fun x y (env, acc) ->
        let env, y = f env y in
        env, add x y acc
    ) m (env, empty)

  let choose x =
    try Some (choose x) with Not_found -> None

  let from_keys keys f =
    List.fold_left begin fun acc key ->
      add key (f key) acc
    end empty keys

end

Use built-in union to implement MyMap.union

(**
 * Copyright (c) 2015, Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the BSD-style license found in the
 * LICENSE file in the "hack" directory of this source tree. An additional grant
 * of patent rights can be found in the PATENTS file in the same directory.
 *
 *)

module type S = MyMap_sig.S
module Make(Ord: Map.OrderedType) : S with type key = Ord.t = struct
  include Map.Make(Ord)
  let get x t =
    try Some (find x t) with Not_found -> None

  let find_unsafe = find

  let union x y =
    union (fun _ fst _ -> Some fst) x y

  let compare x y = compare Pervasives.compare x y
  let equal x y = compare x y = 0

  let keys m = fold (fun k _ acc -> k :: acc) m []
  let values m = fold (fun _ v acc -> v :: acc) m []
  let elements m = fold (fun k v acc -> (k,v)::acc) m []

  let map_env f env m =
    fold (
      fun x y (env, acc) ->
        let env, y = f env y in
        env, add x y acc
    ) m (env, empty)

  let choose x =
    try Some (choose x) with Not_found -> None

  let from_keys keys f =
    List.fold_left begin fun acc key ->
      add key (f key) acc
    end empty keys

end


(**
 * Copyright (c) 2013-present, Facebook, Inc.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the root directory of this source tree.
 *)

type t = {
  null_loc: Loc.t option;
  bool_loc: Loc.t option;
  string_loc: Loc.t option;
  number_loc: Loc.t option;
  mixed_loc: Loc.t option;
}

let empty = {
  null_loc = None;
  bool_loc = None;
  string_loc = None;
  number_loc = None;
  mixed_loc = None;
}

let to_string t =
  let string_of_loc_option = function
    | None -> "None"
    | Some loc -> Loc.to_string ~include_source:true loc
  in
  [
    ("null_loc", t.null_loc);
    ("bool_loc", t.bool_loc);
    ("string_loc", t.string_loc);
    ("number_loc", t.number_loc);
    ("mixed_loc", t.mixed_loc);
  ]
  |> List.map (fun (name, loc_opt) -> (name, string_of_loc_option loc_opt))
  |> List.map (fun (name, loc) -> Printf.sprintf "  %s: %s;\n" name loc)
  |> String.concat ""
  |> Printf.sprintf "{\n%s}"

Rename `ExistsCheck.to_string` to reflect its intent as a debugging utility

(**
 * Copyright (c) 2013-present, Facebook, Inc.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the root directory of this source tree.
 *)

type t = {
  null_loc: Loc.t option;
  bool_loc: Loc.t option;
  string_loc: Loc.t option;
  number_loc: Loc.t option;
  mixed_loc: Loc.t option;
}

let empty = {
  null_loc = None;
  bool_loc = None;
  string_loc = None;
  number_loc = None;
  mixed_loc = None;
}

let debug_to_string t =
  let string_of_loc_option = function
    | None -> "None"
    | Some loc -> Loc.to_string ~include_source:true loc
  in
  [
    ("null_loc", t.null_loc);
    ("bool_loc", t.bool_loc);
    ("string_loc", t.string_loc);
    ("number_loc", t.number_loc);
    ("mixed_loc", t.mixed_loc);
  ]
  |> List.map (fun (name, loc_opt) -> (name, string_of_loc_option loc_opt))
  |> List.map (fun (name, loc) -> Printf.sprintf "  %s: %s;\n" name loc)
  |> String.concat ""
  |> Printf.sprintf "{\n%s}"


val find : ('a -> bool) -> 'a list -> 'a option
val remove : ('a -> bool) -> 'a list -> 'a list
val replace : ('a -> bool) -> 'a -> 'a list -> 'a list

Add insert_before and insert_after to the Vylist signature.

val find : ('a -> bool) -> 'a list -> 'a option
val remove : ('a -> bool) -> 'a list -> 'a list
val replace : ('a -> bool) -> 'a -> 'a list -> 'a list
val insert_before : ('a -> bool) -> 'a -> 'a list -> 'a list
val insert_after : ('a -> bool) -> 'a -> 'a list -> 'a	list


open Subscribe_sync
open Subscribe_lwt

let host = ref "127.0.0.1"
let port = ref 6379
let n = ref 100_000

let names = [
  "subscribe_sync", (fun () -> subscribe_sync !host !port);
  "subscribe_lwt", (fun () -> subscribe_lwt !host !port);
  "bench_merge_sort", (fun () -> Bench_merge_sort.run ~n:!n !host !port);
]

let () =
  let name = ref (fst @@ List.hd names) in
  let opts = [
    "--name", Arg.Symbol (List.map fst names, (fun s -> name := s)), " pick example to run";
    "--host", Arg.Set_string host, " host to connect to";
    "--port", Arg.Set_int port, " port to connect to";
    "-n", Arg.Set_int n, " size (for benchmarks)";
  ] |> Arg.align in
  Arg.parse opts (fun _ -> ()) "Example of usage ocaml-redis";
  match List.assoc !name names with
  | f -> f()
  | exception _ ->
    failwith @@ "no such example: " ^ !name

Fix example which was using old port

open Subscribe_sync
open Subscribe_lwt

let host = ref "127.0.0.1"
let port = ref 63791
let n = ref 100_000

let names = [
  "subscribe_sync", (fun () -> subscribe_sync !host !port);
  "subscribe_lwt", (fun () -> subscribe_lwt !host !port);
  "bench_merge_sort", (fun () -> Bench_merge_sort.run ~n:!n !host !port);
]

let () =
  let name = ref (fst @@ List.hd names) in
  let opts = [
    "--name", Arg.Symbol (List.map fst names, (fun s -> name := s)), " pick example to run";
    "--host", Arg.Set_string host, " host to connect to";
    "--port", Arg.Set_int port, " port to connect to";
    "-n", Arg.Set_int n, " size (for benchmarks)";
  ] |> Arg.align in
  Arg.parse opts (fun _ -> ()) "Example of usage ocaml-redis";
  match List.assoc !name names with
  | f -> f()
  | exception _ ->
    failwith @@ "no such example: " ^ !name


open Prelude.Ana

type t =
  | Lock of LockDomain.Addr.t
  | Unlock of LockDomain.Addr.t
  | Escape of EscapeDomain.EscapedVars.t
  | EnterMultiThreaded
  | SplitBranch of exp * bool (** Used to simulate old branch-based split. *)
  | AssignSpawnedThread of lval * ThreadIdDomain.Thread.t (** Assign spawned thread's ID to lval. *)

let pretty () = function
  | Lock m -> dprintf "Lock %a" LockDomain.Addr.pretty m (* This is only emitted if the mutex was not previously held *)
  | Unlock m -> dprintf "Unock %a" LockDomain.Addr.pretty m
  | Escape escaped -> dprintf "Escape %a" EscapeDomain.EscapedVars.pretty escaped
  | EnterMultiThreaded -> text "EnterMultiThreaded"
  | SplitBranch (exp, tv) -> dprintf "SplitBranch (%a, %B)" d_exp exp tv
  | AssignSpawnedThread (lval, tid) -> dprintf "AssignSpawnedThread (%a, %a)" d_lval lval ThreadIdDomain.Thread.pretty tid

Move comment for Events.Lock to proper place

open Prelude.Ana

type t =
  | Lock of LockDomain.Addr.t  (** This is only emitted if the mutex was not previously held *)
  | Unlock of LockDomain.Addr.t
  | Escape of EscapeDomain.EscapedVars.t
  | EnterMultiThreaded
  | SplitBranch of exp * bool (** Used to simulate old branch-based split. *)
  | AssignSpawnedThread of lval * ThreadIdDomain.Thread.t (** Assign spawned thread's ID to lval. *)

let pretty () = function
  | Lock m -> dprintf "Lock %a" LockDomain.Addr.pretty m
  | Unlock m -> dprintf "Unock %a" LockDomain.Addr.pretty m
  | Escape escaped -> dprintf "Escape %a" EscapeDomain.EscapedVars.pretty escaped
  | EnterMultiThreaded -> text "EnterMultiThreaded"
  | SplitBranch (exp, tv) -> dprintf "SplitBranch (%a, %B)" d_exp exp tv
  | AssignSpawnedThread (lval, tid) -> dprintf "AssignSpawnedThread (%a, %a)" d_lval lval ThreadIdDomain.Thread.pretty tid


(* Copyright (c) 2013-2017 The Cervoise developers. *)
(* See the LICENSE file at the top-level directory. *)

(** NOTE: the unused id field is needed to avoid optimization by
    the ocaml compiler *)
type t = {name : string; id : unit ref}

let create name = {name; id = ref ()}

let raw_ptr (x : t) =
  Nativeint.shift_left (Nativeint.of_int (Obj.magic x)) 1

let equal = (==)
let compare x y = Nativeint.compare (raw_ptr x) (raw_ptr y)

let to_string x = x.name

type tmp = t

module Map = Utils.EqMap (struct
    type t = tmp
    let equal = equal
  end)

module Set = Utils.EqSet (struct
    type t = tmp
    let equal = equal
  end)

module MSet = CCMultiSet.Make (struct
    type t = tmp
    let compare = compare
  end)

Fix LIdent.compare / Remove all calls to Obj.magic

(* Copyright (c) 2013-2017 The Cervoise developers. *)
(* See the LICENSE file at the top-level directory. *)

type t = < name : string >

let create name = object
  method name = name
end

let equal = (==)
let compare x y = Int.compare (Oo.id x) (Oo.id y)

let to_string x = x#name

type tmp = t

module Map = Utils.EqMap (struct
    type t = tmp
    let equal = equal
  end)

module Set = Utils.EqSet (struct
    type t = tmp
    let equal = equal
  end)

module MSet = CCMultiSet.Make (struct
    type t = tmp
    let compare = compare
  end)


(**
 * Copyright (c) 2014, Facebook, Inc.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the root directory of this source tree.
 *)

type 'a change' =
  | Replace of 'a * 'a

type 'a change = (Loc.t * 'a change')

type node =
  | Statement of Loc.t Ast.Statement.t
  | Program of Loc.t Ast.program
  | Expression of Loc.t Ast.Expression.t

val program: Loc.t Ast.program -> Loc.t Ast.program -> node change list

Add comment explaining that it uses referential equality

(**
 * Copyright (c) 2014, Facebook, Inc.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the root directory of this source tree.
 *)

type 'a change' =
  | Replace of 'a * 'a

type 'a change = (Loc.t * 'a change')

type node =
  | Statement of Loc.t Ast.Statement.t
  | Program of Loc.t Ast.program
  | Expression of Loc.t Ast.Expression.t

(* Diffs the given ASTs using referential equality to determine whether two nodes are different.
 * This works well for transformations based on Flow_ast_mapper, which preserves identity, but it
 * does not work well for e.g. parsing two programs and determining their differences. *)
val program: Loc.t Ast.program -> Loc.t Ast.program -> node change list