let salsa_core count i =
  let len = 64 in
  if Cstruct.len i <> len then invalid_arg "input must be 16 blocks of 32 bits"
  else
    let combine y0 y1 y2 shift =
      let r a b =
        let rs = 32 - b in
        let open Nocrypto.Numeric.Int32 in (a lsl b) lor (a lsr rs) in
      let open Nocrypto.Numeric.Int32 in (r (y1 + y2) shift) lxor y0
    and x = Array.init 16 (fun j -> Cstruct.LE.get_uint32 i (j * 4)) in
    let quarterround y0 y1 y2 y3 =
      x.(y1) <- combine x.(y1) x.(y0) x.(y3) 7;
      x.(y2) <- combine x.(y2) x.(y1) x.(y0) 9;
      x.(y3) <- combine x.(y3) x.(y2) x.(y1) 13;
      x.(y0) <- combine x.(y0) x.(y3) x.(y2) 18 in
    for _ = 1 to count do
      quarterround 0 4 8 12;
      quarterround 5 9 13 1;
      quarterround 10 14 2 6;
      quarterround 15 3 7 11;

      quarterround 0 1 2 3;
      quarterround 5 6 7 4;
      quarterround 10 11 8 9;
      quarterround 15 12 13 14;
    done;
    let o = Cstruct.create len in
    for j = 0 to 15 do
      let xj = x.(j)
      and ij = Cstruct.LE.get_uint32 i (j * 4) in
      let open Nocrypto.Numeric.Int32 in
      Cstruct.LE.set_uint32 o (j * 4) (xj + ij)
    done;
    o

let salsa20_8_core i =
  salsa_core 4 i

let salsa20_12_core i =
  salsa_core 6 i

let salsa20_20_core i =
  salsa_core 10 i

Remove salsa_core OCaml function and use C function instead

open Cstruct

module Salsa_Core = struct
  external salsa_core : int -> buffer -> buffer -> unit = "caml_salsa_core" [@@noalloc]
end

let salsa20_core count i =
  let l = 64 in
  if len i <> l then invalid_arg "input must be 16 blocks of 32 bits"
  else
    let o = create l in
    Salsa_Core.salsa_core count (to_bigarray i) (to_bigarray o);
    o

let salsa20_8_core i =
  salsa20_core 4 i

let salsa20_12_core i =
  salsa20_core 6 i

let salsa20_20_core i =
  salsa20_core 10 i


let _ =
  let branch = String.sub Sys.ocaml_version 0 (String.rindex Sys.ocaml_version '.') ^ ".X" in
  if not (List.mem branch ["4.02.X"; "4.04.X"; "4.05.X"; "4.06.X"; "4.07.X"]) then
    failwith ("Unsupported version of OCaml:" ^ Sys.ocaml_version);
  print_endline branch

Fix how OCaml version is checked

let starts_with (input: string) (prefix: string) =
  let len_prefix = String.length prefix in
  String.length input >= len_prefix &&
  String.sub input 0 len_prefix = prefix

let _ =
  let version = Sys.ocaml_version in
  let check_version x = starts_with (version ^ ".") (x ^ ".") in
  let rec find_branch = function
    | [] -> failwith ("Unsupported version of OCaml:" ^ version)
    | v :: q -> if check_version v then v ^ ".X" else find_branch q
  in
  let branch = find_branch ["4.02"; "4.04"; "4.05"; "4.06"; "4.07"] in
  print_endline branch


open Core.Std

let all = List.map ~f:Option.some

let add_gradient ~self:_ ~gradient =
  let gradient = Node.P gradient in
  all [ gradient; gradient ]

let sub_gradient ~self:_ ~gradient =
  let minus_gradient = Node.P (Ops.neg gradient) in
  let gradient = Node.P gradient in
  all [ gradient; minus_gradient ]

let abs_gradient (type a) ~self ~(gradient : a Node.t) =
  let Node.P input = List.hd_exn self.Node.inputs in
  let output =
    match input.output_type, gradient.Node.output_type with
    | Node.Type.Double, Node.Type.Double -> Node.P (Ops.mul gradient (Ops.sign input))
    | Node.Type.Float, Node.Type.Float -> Node.P (Ops.mul gradient (Ops.sign input))
    | _ -> assert false
  in
  all [ output ]

let register_all () =
  Gradients.register_gradient (Node.Op_name.of_string "Add") { f = add_gradient };
  Gradients.register_gradient (Node.Op_name.of_string "Sub") { f = sub_gradient };
  Gradients.register_gradient (Node.Op_name.of_string "Abs") { f = abs_gradient }

Add a helper for unary functions.

open Core.Std

type unary =
  { f1 : 'a .
          (  [< `float | `double] as 'a) Node.t
          -> gradient:'a Node.t
          -> 'a Node.t
  }

let all = List.map ~f:Option.some

let unary_exn (type a) ~self ~(gradient : a Node.t) ~t =
  let Node.P input =
    match self.Node.inputs with
    | [] | _ :: _ :: _ -> failwith "Not a unary function"
    | [ node ] -> node
  in
  let output =
    match input.output_type, gradient.Node.output_type with
    | Node.Type.Double, Node.Type.Double -> Node.P (t.f1 input ~gradient)
    | Node.Type.Float, Node.Type.Float -> Node.P (t.f1 input ~gradient)
    | _ -> failwith "Inconsistent types"
  in
  all [ output ]

let add_gradient ~self:_ ~gradient =
  let gradient = Node.P gradient in
  all [ gradient; gradient ]

let sub_gradient ~self:_ ~gradient =
  let minus_gradient = Node.P (Ops.neg gradient) in
  let gradient = Node.P gradient in
  all [ gradient; minus_gradient ]

let abs_gradient (type a) ~self ~(gradient : a Node.t) =
  let t = { f1 = fun input ~gradient -> Ops.mul gradient (Ops.sign input) } in
  unary_exn ~self ~gradient ~t

let register_all () =
  Gradients.register_gradient (Node.Op_name.of_string "Add") { f = add_gradient };
  Gradients.register_gradient (Node.Op_name.of_string "Sub") { f = sub_gradient };
  Gradients.register_gradient (Node.Op_name.of_string "Abs") { f = abs_gradient }


open Lwt

let store = "/tmp/irmin/test"
module Store = (val IrminGit.local ~bare:false store)

let main () =
  Store.create () >>= fun t ->
  Store.update   t ["root";"misc";"1.txt"] "Hello world!" >>= fun () ->
  Store.update   t ["root";"misc";"2.txt"] "Hi!" >>= fun () ->
  Store.update   t ["root";"misc";"3.txt"] "Really ?" >>= fun () ->
  Store.read_exn t ["root";"misc";"2.txt"] >>= fun file ->
  Printf.printf "I've just read: %s\n%!" file;
  return_unit

let () =
  Lwt_unix.run (main ())

Add some comments in the Git store example

(*

  Simple example showing how to create and use a Git store.

  $ make                               # Compile
  $ ./git_store                        # Run
  $ cd /tmp/irmin/test && git log      # Show the Git history

*)

open Lwt

(* Enable debug outputs if DEBUG is set *)
let () =
  try match Sys.getenv "DEBUG" with
    | "" -> ()
    | _  -> Log.set_log_level Log.DEBUG
  with Not_found -> ()

let store = "/tmp/irmin/test"
module Store = (val IrminGit.local ~bare:false store)

let main () =
  Store.create () >>= fun t ->
  Store.update   t ["root";"misc";"1.txt"] "Hello world!" >>= fun () ->
  Store.update   t ["root";"misc";"2.txt"] "Hi!" >>= fun () ->
  Store.update   t ["root";"misc";"3.txt"] "Really ?" >>= fun () ->
  Store.read_exn t ["root";"misc";"2.txt"] >>= fun file ->
  Printf.printf "I've just read: %s\n%!" file;
  return_unit

let () =
  Lwt_unix.run (main ())


(**
 * 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.
 *
 *)

external get_build_revision : unit -> string = "hh_get_build_revision"
external get_build_commit_time : unit -> int = "hh_get_build_commit_time"
external get_build_commit_time_string : unit -> string =
  "hh_get_build_commit_time_string"

let build_revision = get_build_revision ()

let build_id_ohai = build_revision ^ " " ^ get_build_commit_time_string ()

let build_commit_time = get_build_commit_time ()

(* Monotonically increasing identifier that can be used when we introduce
 * backward incompatible changes in hh_client commands *)
let build_api_version = 2

Split failed_naming set from failed_parsing and update it during lazy incremental check

(**
 * 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.
 *
 *)

external get_build_revision : unit -> string = "hh_get_build_revision"
external get_build_commit_time : unit -> int = "hh_get_build_commit_time"
external get_build_commit_time_string : unit -> string =
  "hh_get_build_commit_time_string"

let build_revision = get_build_revision ()

let build_id_ohai = build_revision ^ " " ^ get_build_commit_time_string ()

let build_commit_time = get_build_commit_time ()

(* Monotonically increasing identifier that can be used when we introduce
 * backward incompatible changes in hh_client commands *)
let build_api_version = 3


(* open Deriving.Cil *)
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 * varinfo (** 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 d_varinfo tid

Remove commented out open in Events


{
  open JsonParser
}

let nl = '\r'?'\n'
let endlinecomment = "//" [^'\n']* nl
let multlinecomment = "/*"([^'*']|('*'+[^'*''/'])|nl)*'*'+'/'
let comments = endlinecomment|multlinecomment

rule token = parse
  | ['\t' '\n' '\r' ' '   ] { token lexbuf }
  | comments		            { token lexbuf }
  | "true"                  { TRUE   }
  | "false"                 { FALSE  }
  | "null"                  { NULL   }
  | ","                     { COMMA  }
  | ":"                     { COLON  }
  | "{"                     { LCURL  }
  | "}"                     { RCURL  }
  | "["                     { LBRACK }
  | "]"                     { RBRACK }
  | ('\"'[^'\"']*'\"') | ('\''[^'\'']*'\'')
    { let str = Lexing.lexeme lexbuf in
      let sl  = String.length str in
      STRING (String.sub str 1 (sl-2))
    }
  | ['0'-'9']+'.'?['0'-'9']*(('e'|'E')('+'|'-')?['0'-'9']+)?
                { NUMBER (Num.num_of_string (Lexing.lexeme lexbuf)) }
  | _ as c { Printf.printf "Unrecognized character: %C\n" c; raise (Failure "") }

Remove fallback printing case from JsonLexer


(*
 * 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
    XMLRPC_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
    XMLRPC_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)


module Make(T: Streaming.Transformers) = struct
  module Arguments = LocalFacts.CollectArguments(T)
  module Closures = LocalFacts.CollectClosures(T)
  module NameBindings = CalculateNameBindings.Make(T)
  module Versions = CalculateVersions.Make(T)
  module PointsTo = CalculatePointsTo.Make(T)
  module Prototypes = CalculatePrototypes.Make(T)
  let collect initials trace =
    trace
      |> Arguments.collect
      |> Closures.collect
      |> NameBindings.collect initials
      |> Prototypes.collect initials
      |> Versions.collect initials
      |> PointsTo.collect initials
end

Insert a step to calculate actual bases.

module Make(T: Streaming.Transformers) = struct
  module Arguments = LocalFacts.CollectArguments(T)
  module Closures = LocalFacts.CollectClosures(T)
  module NameBindings = CalculateNameBindings.Make(T)
  module Versions = CalculateVersions.Make(T)
  module PointsTo = CalculatePointsTo.Make(T)
  module Prototypes = CalculatePrototypes.Make(T)
  module ActualBase = CalculateActualBase.Make(T)
  let collect initials trace =
    trace
      |> Arguments.collect
      |> Closures.collect
      |> NameBindings.collect initials
      |> Prototypes.collect initials
      |> ActualBase.collect initials
      |> Versions.collect initials
      |> PointsTo.collect initials
end


(*
 * Copyright (c) 2013 Jeremy Yallop.
 *
 * This file is distributed under the terms of the MIT License.
 * See the file LICENSE for details.
 *)

open Ctypes
open OUnit2
open Foreign
open Functions

(*
  Ensure that passing ~release_runtime_lock releases the runtime lock.
*)
let test_release_runtime_lock _ =
  begin
    initialize_waiters ();
    let t1 = Thread.create post1_wait2 () in
    let t2 = Thread.create post2_wait1 () in
    Thread.join t1;
    Thread.join t2;
  end

(*
  Ensure that passing ~runtime_lock to funptr causes a callbacks to acquire
  the runtime lock.
*)
let test_acquire_runtime_lock _ =
  begin
    let f x y = let _ = Gc.major () in !@x + !@y in
    let t1 = Thread.create Gc.major () in
    assert (callback_with_pointers f = 7);
    Thread.join t1
  end

let suite = "Thread tests" >:::
  ["test_release_runtime_lock (foreign)"
   >:: test_release_runtime_lock;

   "test_acquire_runtime_lock (foreign)"
   >:: test_acquire_runtime_lock;
  ]

let _ =
  run_test_tt_main suite

Fix a typo in a test comment.

(*
 * Copyright (c) 2013 Jeremy Yallop.
 *
 * This file is distributed under the terms of the MIT License.
 * See the file LICENSE for details.
 *)

open Ctypes
open OUnit2
open Foreign
open Functions

(*
  Ensure that passing ~release_runtime_lock releases the runtime lock.
*)
let test_release_runtime_lock _ =
  begin
    initialize_waiters ();
    let t1 = Thread.create post1_wait2 () in
    let t2 = Thread.create post2_wait1 () in
    Thread.join t1;
    Thread.join t2;
  end

(*
  Ensure that passing ~runtime_lock to funptr causes a callback to acquire
  the runtime lock.
*)
let test_acquire_runtime_lock _ =
  begin
    let f x y = let _ = Gc.major () in !@x + !@y in
    let t1 = Thread.create Gc.major () in
    assert (callback_with_pointers f = 7);
    Thread.join t1
  end

let suite = "Thread tests" >:::
  ["test_release_runtime_lock (foreign)"
   >:: test_release_runtime_lock;

   "test_acquire_runtime_lock (foreign)"
   >:: test_acquire_runtime_lock;
  ]

let _ =
  run_test_tt_main suite


(*
Author : AlexLusitania
Version : 1.0
Date : 07/01/2014
Description : In a given 20x20 grid, what is the greatest product of four adjacent numbers in the same direction (up, down, left, right or diagonally) in the 20x20 grid ?
*)

(* First step : reading the file given containing the 20x20 grid and make a matrix out of it *)
let file = open_in "grid.txt";;

(* Create a list according to a given line of numbers (of size x) separated by a space *)
let createList line x =
	let rec local acc i = match i with
	| i when i>=(String.length line) -> acc
	| _ -> local (List.append acc [int_of_string(String.sub line i x)]) (i+x+1)
	in local [] 0;;

(* Create a matrix xy from the given data (file) with numbers of size n *)
let createMatrix data x y n_size =
	let rec local acc i = match i with
	| i when i>=y -> acc
	| _ -> local ( (createList (input_line data) n_size)) (i+1)
	in local [] 0;;

Use arrays instead of lists

(*
Author : AlexLusitania
Version : 1.0
Date : 07/01/2014
Description : In a given 20x20 grid, what is the greatest product of four adjacent numbers in the same direction (up, down, left, right or diagonally) in the 20x20 grid ?
*)

(* First step : reading the file given containing the 20x20 grid and make a matrix out of it *)
let file = open_in "grid.txt";;

(* Create a array according to a given line of numbers (of size s) separated by a space *)
let createArray line s =
	let rec local acc i = match i with
	| i when i>=(String.length line) -> acc
	| _ -> local (Array.append acc [|int_of_string(String.sub line i s)|]) (i+s+1)
	in local [||] 0;;

(* Create a matrix xy from the given data (file) with numbers of size n *)
let createMatrix data x y n_size =
	let rec local acc i = match i with
	| i when i>=y -> acc
	| _ -> local (createArray (input_line data) n_size) (i+1)
	in local [||] 0;;


open Import

module Id : sig
  type 'a t

  val eq : 'a t -> 'b t -> ('a, 'b) eq option
end

module type S = sig
  type t

  val id : t Id.t

  val load : Path.t -> t
  val to_string : Path.t -> t -> string
end

type 'a t = (module S with type t = 'a)

val eq : 'a t -> 'b t -> ('a, 'b) eq option

module Make
    (T : sig type t end)
    (F : functor (C : Sexp.Combinators) -> sig val t : T.t C.t end)
  : S with type t = T.t

module Make_full
    (T : sig type t end)
    (To_sexp : sig val t : Path.t -> T.t -> Sexp.t end)
    (Of_sexp : sig val t : Path.t -> Sexp.Ast.t -> T.t end)
  : S with type t = T.t

Remove Make_full from file_kind signature since it's unused


(* Portions Copyright (c) 2015-present, Facebook, Inc. All rights reserved. *)

(* No String.split in stdlib... *)
let split str ~by =
  let rec split' str ~by idx accum =
    try
      let foundIdx = String.index_from str idx by in
      split' str ~by (foundIdx + 1) ((String.sub str idx foundIdx) :: accum)
    with Not_found ->
      let lastStrPiece = String.sub str idx (String.length str - idx) in
      List.rev (lastStrPiece :: accum)
  in
  split' str ~by 0 []

let () =
  if Array.length Sys.argv <> 2 then
    print_endline @@ "Please provide a single, quoted string of all the " ^
      "types you want transformed, separated by the escaped double quote \\\""
  else
    try
      Sys.argv.(1)
      |> split ~by:'"'
      |> List.map (fun input ->
        Reason_type_of_ocaml_type.convert input |> String.trim
      )
      |> List.iter print_endline
    with Syntaxerr.Error a ->
      prerr_endline "Failed to parse the input type(s)."

Fix reson_format_type string split bug

(* Portions Copyright (c) 2015-present, Facebook, Inc. All rights reserved. *)

(* No String.split in stdlib... *)
let split str ~by =
  let rec split' str ~by accum =
    try
      let foundIdx = String.index_from str 0 by in
      let subStr = String.sub str 0 foundIdx in
      split'
        (String.sub str (foundIdx + 1) (String.length str - foundIdx - 1))
        ~by
        (subStr :: accum)
    with Not_found ->
      List.rev (str :: accum)
  in
  split' str ~by []

let () =
  if Array.length Sys.argv <> 2 then
    print_endline @@ "Please provide a single, quoted string of all the " ^
      "types you want transformed, separated by the escaped double quote \\\""
  else
    try
      Sys.argv.(1)
      |> split ~by:'"'
      |> List.map (fun input ->
        Reason_type_of_ocaml_type.convert input |> String.trim
      )
      |> List.iter print_endline
    with Syntaxerr.Error a ->
      prerr_endline "Failed to parse the input type(s)."


(*
 * Copyright (c) 2016 Jeremy Yallop <yallop@docker.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.
 *
 *)

val opendir : string -> Lwt_unix.dir_handle Lwt.t

val readdir : Unix.dir_handle -> Dirent.Dirent.t Lwt.t

val closedir : Unix.dir_handle -> unit Lwt.t

Use only Lwt_unix.dir_handle in the lwt interface

(*
 * Copyright (c) 2016 Jeremy Yallop <yallop@docker.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.
 *
 *)

val opendir : string -> Lwt_unix.dir_handle Lwt.t

val readdir : Lwt_unix.dir_handle -> Dirent.Dirent.t Lwt.t

val closedir : Lwt_unix.dir_handle -> unit Lwt.t


type t = Foo of int

let fail _ = failwith "not implemented"

module Biniou =
struct
  type def = t
  let def_tag = 0
  let write_untagged_def = fail
  let write_def = fail
  let string_of_def = fail
  let get_def_reader = fail
  let read_def = fail
  let def_of_string = fail
end

module Json =
struct
  type def = t
  let write_def = fail
  let string_of_def = fail
  let read_def = fail
  let def_of_string = fail
end

module Natural :
sig
  type t = private int
  val wrap : int -> t
  val unwrap : t -> int
end =
struct
  type t = int
  let wrap x =
    if x < 0 then
      failwith ("Out of bounds number " ^ string_of_int x)
    else
      x
  let unwrap x = x
end

module Even_natural :
sig
  type t = private Natural.t
  val wrap : Natural.t -> t
  val unwrap : t -> Natural.t
end =
struct
  type t = Natural.t
  let wrap (x : Natural.t) =
    if (x :> int) mod 2 <> 0 then
      failwith ("Odd number " ^ string_of_int (x :> int))
    else
      x
  let unwrap x = x
end

Fix test warnings due to Test_lib types

type t = Foo of int

let fail _ = failwith "not implemented"

module Biniou =
struct
  type def = t
  let def_tag = 0
  let write_untagged_def _ : 'a -> unit = fail
  let write_def _ : 'a -> unit = fail
  let string_of_def = fail
  let get_def_reader _ = fail
  let read_def = fail
  let def_of_string = fail
end

module Json =
struct
  type def = t
  let write_def _ : 'a -> unit = fail
  let string_of_def = fail
  let read_def _ = fail
  let def_of_string = fail
end

module Natural :
sig
  type t = private int
  val wrap : int -> t
  val unwrap : t -> int
end =
struct
  type t = int
  let wrap x =
    if x < 0 then
      failwith ("Out of bounds number " ^ string_of_int x)
    else
      x
  let unwrap x = x
end

module Even_natural :
sig
  type t = private Natural.t
  val wrap : Natural.t -> t
  val unwrap : t -> Natural.t
end =
struct
  type t = Natural.t
  let wrap (x : Natural.t) =
    if (x :> int) mod 2 <> 0 then
      failwith ("Odd number " ^ string_of_int (x :> int))
    else
      x
  let unwrap x = x
end


(**
 * 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 Reordered_argument_map (S : MyMap.S) = struct
  include S
  let add m ~key ~data = add key data m
  let filter m ~f = filter f m
  let fold m ~init ~f = fold f m init
  let get m k = get k m
  let find_unsafe m k = find_unsafe k m
  let iter m ~f = iter f m
  let map m ~f = map f m
  let mem m v = mem v m
  let remove m v = remove v m
  let exists m ~f = exists f m
  let merge m1 m2 ~f = merge f m1 m2
end

module Reordered_argument_set (S : Set.S) = struct
  include S
  let add s v = add v s
  let filter s ~f = filter f s
  let fold s ~init ~f = fold f s init
  let iter s ~f = iter f s
  let mem s v = mem v s
  let remove s v = remove v s
  let exists s ~f = exists f s
  let of_list l = List.fold_left add S.empty l
end

module SSet = Reordered_argument_set(SSet)
module SMap = Reordered_argument_map(SMap)

Make live global errors a bit less live, but more performant

(**
 * 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 Reordered_argument_map (S : MyMap.S) = struct
  include S
  let add m ~key ~data = add key data m
  let filter m ~f = filter f m
  let fold m ~init ~f = fold f m init
  let get m k = get k m
  let find_unsafe m k = find_unsafe k m
  let iter m ~f = iter f m
  let map m ~f = map f m
  let mem m v = mem v m
  let remove m v = remove v m
  let exists m ~f = exists f m
  let merge m1 m2 ~f = merge f m1 m2
  let filter m ~f = filter m f
  let partition m ~f = partition f m
end

module Reordered_argument_set (S : Set.S) = struct
  include S
  let add s v = add v s
  let filter s ~f = filter f s
  let fold s ~init ~f = fold f s init
  let iter s ~f = iter f s
  let mem s v = mem v s
  let remove s v = remove v s
  let exists s ~f = exists f s
  let of_list l = List.fold_left add S.empty l
end

module SSet = Reordered_argument_set(SSet)
module SMap = Reordered_argument_map(SMap)


(* TEST
   exit_status = "2"
*)

open Gc.Memprof

let alloc_tracker on_alloc =
  { null_tracker with
    alloc_minor = (fun info -> on_alloc info; None);
    alloc_major = (fun info -> on_alloc info; None);
  }

(* We don't want to print the backtrace. We just want to make sure the
   exception is printed.
   This also makes sure [Printexc] is loaded, otherwise we don't use
   its uncaught exception handler. *)
let _ = Printexc.record_backtrace false

let _ =
  start ~callstack_size:10 ~sampling_rate:1.
    (alloc_tracker (fun _ -> failwith "callback failed"));
  ignore (Sys.opaque_identity (Array.make 200 0));
  stop ()

Add a test for Memprof.stop within a Memprof callback

(* TEST
   exit_status = "2"
*)

open Gc.Memprof

let alloc_tracker on_alloc =
  { null_tracker with
    alloc_minor = (fun info -> on_alloc info; None);
    alloc_major = (fun info -> on_alloc info; None);
  }

(* We don't want to print the backtrace. We just want to make sure the
   exception is printed.
   This also makes sure [Printexc] is loaded, otherwise we don't use
   its uncaught exception handler. *)
let _ = Printexc.record_backtrace false

let () =
  start ~callstack_size:10 ~sampling_rate:1.
    (alloc_tracker (fun _ -> stop ()));
  ignore (Sys.opaque_identity (Array.make 200 0))

let _ =
  start ~callstack_size:10 ~sampling_rate:1.
    (alloc_tracker (fun _ -> failwith "callback failed"));
  ignore (Sys.opaque_identity (Array.make 200 0));
  stop ()


type t =
  | Any
  | AS of Site.t list
  | None

let compare = compare

let equal = (=)

let bot = None

let join a1 a2 =
  match (a1, a2) with
  | (_, None) -> a1
  | (None, _) -> a2
  | (AS al1, AS al2) ->
    if equal al1 al2 then
      a1
    else
      Any
  | (Any, _) | (_, Any) -> Any

let push a s =
  match a with
  | Any -> Any
  | AS al -> AS (s :: al)
  | None -> AS [s]

let from_list l =
  AS l

let to_string a =
  match a with
  | Any -> "Any"
  | AS al ->
    let al_str = List.fold_left
        (fun s o -> s ^ (if s = "" then "" else "; ") ^ (Site.to_string o))
        "" al in
    "[" ^ al_str ^ "]"
  | None -> "None"

Fix analyzer loop due to infinite activity stacks

type t =
  | Any
  | AS of Site.t list
  | None

let compare = compare

let equal = (=)

let bot = None

let join a1 a2 =
  match (a1, a2) with
  | (_, None) -> a1
  | (None, _) -> a2
  | (AS al1, AS al2) ->
    if equal al1 al2 then
      a1
    else
      Any
  | (Any, _) | (_, Any) -> Any

let push a s =
  match a with
  | Any -> Any
  | AS al ->
      if List.mem s al then
        Any (* potentially infinite stack *)
      else
        AS (s :: al)
  | None -> AS [s]

let from_list = List.fold_left push None

let to_string a =
  match a with
  | Any -> "Any"
  | AS al ->
    let al_str = List.fold_left
        (fun s o -> s ^ (if s = "" then "" else "; ") ^ (Site.to_string o))
        "" al in
    "[" ^ al_str ^ "]"
  | None -> "None"


(** Helpers around Menhir generated definitions *)

type token = Raw_parser.token

type annotation =
  [ `Shift of int
  | `Shift_token of int * token
  | `Cost of int
  | `Indent of int
  | `Unclosed of string | `Close
  | `Item of string
  ]

type 'a token_class = 'a Raw_parser.token_class
type 'a nonterminal_class = 'a Raw_parser.nonterminal_class

type symbol_class = Raw_parser.symbol_class =
  | CT_ : 'a token_class * annotation list -> symbol_class
  | CN_ : 'a nonterminal_class  * annotation list -> symbol_class

type symbol = Raw_parser.symbol =
  | T_ : 'a token_class * 'a -> symbol
  | N_ : 'a nonterminal_class * 'a -> symbol
  | Bottom

val class_of_symbol: symbol -> symbol_class

val string_of_class: symbol_class -> string

val symbol_of_token: token -> symbol

val default_symbol: symbol_class -> int * symbol

val selection_priority: symbol_class -> int

val token_of_symbol: 'a token_class -> 'a -> token

Add "friendly names" to grammar construct

(** Helpers around Menhir generated definitions *)

type token = Raw_parser.token

type annotation =
  [ `Shift of int
  | `Shift_token of int * token
  | `Cost of int
  | `Indent of int
  | `Unclosed of string | `Close
  | `Item of string
  ]

type 'a token_class = 'a Raw_parser.token_class
type 'a nonterminal_class = 'a Raw_parser.nonterminal_class

type symbol_class = Raw_parser.symbol_class =
  | CT_ : 'a token_class * annotation list -> symbol_class
  | CN_ : 'a nonterminal_class  * annotation list -> symbol_class

type symbol = Raw_parser.symbol =
  | T_ : 'a token_class * 'a -> symbol
  | N_ : 'a nonterminal_class * 'a -> symbol
  | Bottom

val class_of_symbol: symbol -> symbol_class

val string_of_class: symbol_class -> string

val symbol_of_token: token -> symbol

val default_symbol: symbol_class -> int * symbol

val selection_priority: symbol_class -> int

val token_of_symbol: 'a token_class -> 'a -> token

val friendly_name : symbol_class -> string option


include Import0
include Sexplib0.Sexp_conv
include Sexp.Private.Raw_grammar.Builtin
include Hash.Builtin
include Ppx_compare_lib.Builtin
include Int_replace_polymorphic_compare

exception Not_found_s = Sexp.Not_found_s

Remove duplicate include of Int_replace_polymorphic_compare

include Import0
include Sexplib0.Sexp_conv
include Sexp.Private.Raw_grammar.Builtin
include Hash.Builtin
include Ppx_compare_lib.Builtin

exception Not_found_s = Sexp.Not_found_s


open QCheck

module DomainProperties (D: Lattice.S) =
struct
  let arb = D.arbitrary ()

  let leq_refl = Test.make ~name:"leq refl" (arb) (fun x -> D.leq x x)
  let leq_trans = Test.make ~name:"leq trans" (triple arb arb arb) (fun (a, b, c) -> (D.leq a b && D.leq b c) ==> D.leq a c)

  let tests = [
    leq_refl;
    leq_trans
  ]
end

module DP = DomainProperties (IntDomain.Flattened)
let testsuite = DP.tests

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

Add domain name to test names

open QCheck

module DomainProperties (D: Lattice.S) =
struct
  (* Wrapper for Test.make: prepends domain name to required name *)
  let make ?count ?long_factor ?max_gen ?max_fail ?small ~name arb law =
    let full_name = D.name () ^ " " ^ name in
    Test.make ?count ?long_factor ?max_gen ?max_fail ?small ~name:full_name arb law

  let arb = D.arbitrary ()

  let leq_refl = make ~name:"leq refl" (arb) (fun x -> D.leq x x)
  let leq_trans = make ~name:"leq trans" (triple arb arb arb) (fun (a, b, c) -> (D.leq a b && D.leq b c) ==> D.leq a c)

  let tests = [
    leq_refl;
    leq_trans
  ]
end

module DP = DomainProperties (IntDomain.Flattened)
let testsuite = DP.tests

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


Add testcase (insertion sort using array)

let rec get_min ary i n =
  let rec gmsub ary i n m = if i >= n then m
    else gmsub ary i n (if ary.(m) > ary.(i) then i else m)
  in gmsub ary i n 0
in
let rec insertion_sort ary n =
  let rec is_sub a i n =
    if i >= n then ()
    else
      let j = get_min a i n in
      let t = a.(j) in
      a.(j) <- a.(i);
      a.(i) <- t;
      is_sub ary (i + 1) n
  in is_sub ary 0 n
in
let ary = Array.create 10 0 in
insertion_sort ary 10


(* TEST
   flags = " -w A "
   * expect
*)

module type U = sig end
[%%expect {|
module type U = sig end
|}]

module M : sig
  module F2 (_ : U) : U
end = struct
  module X = struct
    let x = 13
  end

  module F1 (_ : U) = X
  module F2 (M : U) = F1 (M)
end
[%%expect {|
Line 5, characters 8-9:
5 |     let x = 13
            ^
Warning 32: unused value x.
module M : sig module F2 : U -> U end
|}]

module N : sig
  module F2 (_ : U) : U
end = struct
  module X = struct
    let x = 13
  end

  module F1 (_ : U) = X
  module F2 (_ : U) = F1 (struct end)
end
[%%expect {|
module N : sig module F2 : U -> U end
|}]

module F (X : sig type t type s end) = struct type t = X.t end
[%%expect {|
module F : functor (X : sig type t type s end) -> sig type t = X.t end
|}]


Isolate a few types of Goptions in a pure .mli, solving a dep issue with ocamlbuild

(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** Some types used in the generic option mechanism (Goption) *)

(** Placing them here in a pure interface avoid some dependency issues
    when compiling CoqIDE *)

type option_name = string list

type option_value =
  | BoolValue   of bool
  | IntValue    of int option
  | StringValue of string

type option_state = {
  opt_sync  : bool;
  opt_depr  : bool;
  opt_name  : string;
  opt_value : option_value;
}


(**
 * 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.
 *)

val print: source_maps:Source_map_config.t option -> Layout.layout_node -> Source.t


Add a script to automate build-depisation

#!/usr/bin/env opam-admin.top

#directory "+../opam";;
open Opam_admin_top;;

(* Add the "build" dependency flag to all ocamlfind depends *)

let to_build = List.map OpamPackage.Name.of_string ["ocamlfind"]

let addbuild (pkg, (flags, cstr) as atom) =
  if List.mem pkg to_build && not (List.mem OpamTypes.Depflag_Build flags) then
    OpamFormula.Atom (pkg, (OpamTypes.Depflag_Build::flags, cstr))
  else
    OpamFormula.Atom atom
;;

map_packages ~opam:(fun opam ->
    let open OpamFile.OPAM in
    let opam = with_depends opam @@ OpamFormula.map addbuild @@ depends opam in
    let opam = with_depopts opam @@ OpamFormula.map addbuild @@ depopts opam in
    opam)
  ()


Add basic signatures for initial interface

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 new module to manage Docs API requests

open Utils.Infix
open GapiLens.Infix
open GapiMonad.SessionM.Infix
open GdataDocumentsV3Model
open GdataDocumentsV3Service

let do_request
      initial_context
      interact =
  let rec try_request context =
    try
      let state = context |. Context.state_lens in
      let config = context.Context.gapi_config in
      let curl_state = context.Context.curl_state in
      let auth_context =
        GapiConversation.Session.OAuth2
          { GapiConversation.Session.oauth2_token =
              state.State.last_access_token;
            refresh_token = state.State.refresh_token }
      in
        GapiConversation.with_session
          ~auth_context
          config
          curl_state
          interact
    with
        Failure message as e ->
          if ExtString.String.exists
               message "CURLE_OPERATION_TIMEOUTED" then
            (* Retry on timeout *)
            try_request context
          else begin
            Utils.log_message "Failure %s\n%!" message;
            raise e
          end
      | GapiRequest.RefreshTokenFailed _ ->
          let updated_context =
            try
              GaeProxy.refresh_access_token context
            with e ->
              Utils.log_message "Exception: %s\n%!" (Printexc.to_string e);
              raise e
          in
            Utils.log_message "done.\n%!";
            Context.StateFileStore.save updated_context.Context.state_store;
            (* Retry with refreshed token *)
            try_request updated_context
      | GapiService.ServiceError e ->
          Utils.log_message "ServiceError\n%!";
          let message =
            e |> GapiError.RequestError.to_data_model
              |> GapiJson.data_model_to_json
              |> Json_io.string_of_json
          in
            failwith message
  in
    try_request initial_context

let get_dir_list context =
    do_request
      context
      (fun session ->
         let parameters = QueryParameters.default
           |> QueryParameters.showfolders ^= true in
         let (feed, session) =
           query_folder_contents
             ~parameters
             root_folder_id
             session
         in
           List.map
             (fun entry ->
                entry |. Document.Entry.title |. GdataAtom.Title.value)
             feed.Document.Feed.entries)


(**
 * Copyright (c) 2017, 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.
 *
 *)

module Marshal_tools_lwt = Marshal_tools.MarshalToolsFunctor (struct
  type 'a result = 'a Lwt.t
  type fd = Lwt_unix.file_descr

  let return = Lwt.return
  let fail = Lwt.fail
  let (>>=) = Lwt.(>>=)

  let write ?timeout fd ~buffer ~offset ~size =
    if timeout <> None
    then raise (Invalid_argument "Use Lwt timeouts directly");
    Lwt_unix.write fd buffer offset size

  let read ?timeout fd ~buffer ~offset ~size =
    if timeout <> None
    then raise (Invalid_argument "Use lwt timeouts directly");
    Lwt_unix.read fd buffer offset size

  let log str = Lwt_log_core.ign_error str
end)

include Marshal_tools_lwt

(* The Timeout module probably doesn't work terribly well with Lwt. Luckily, timeouts are super easy
 * to write in Lwt, so we don't **really** need them *)
let to_fd_with_preamble ?flags fd obj = to_fd_with_preamble ?flags fd obj
let from_fd_with_preamble fd = from_fd_with_preamble fd

Work around non-blocking fd issue on Windows.

(**
 * Copyright (c) 2017, 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.
 *
 *)

module Marshal_tools_lwt = Marshal_tools.MarshalToolsFunctor (struct
  type 'a result = 'a Lwt.t
  type fd = Lwt_unix.file_descr

  let return = Lwt.return
  let fail = Lwt.fail
  let (>>=) = Lwt.(>>=)

  let write ?timeout fd ~buffer ~offset ~size =
    if timeout <> None
    then raise (Invalid_argument "Use Lwt timeouts directly");
    Lwt_unix.wait_write fd
    >>= (fun () -> Lwt_unix.write fd buffer offset size)

  let read ?timeout fd ~buffer ~offset ~size =
    if timeout <> None
    then raise (Invalid_argument "Use lwt timeouts directly");
    Lwt_unix.wait_read fd
    >>= (fun () -> Lwt_unix.read fd buffer offset size)

  let log str = Lwt_log_core.ign_error str
end)

include Marshal_tools_lwt

(* The Timeout module probably doesn't work terribly well with Lwt. Luckily, timeouts are super easy
 * to write in Lwt, so we don't **really** need them *)
let to_fd_with_preamble ?flags fd obj = to_fd_with_preamble ?flags fd obj
let from_fd_with_preamble fd = from_fd_with_preamble fd


Add AST mapper to convert `Loc.t`s contained in the AST to `ALoc.t`

(**
 * 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.
 *)

(* Provides utilities for converting AST locations between ALoc.t and Loc.t *)

let abstractify_mapper: (Loc.t, Loc.t, ALoc.t, ALoc.t) Flow_polymorphic_ast_mapper.mapper =
  object
    inherit [Loc.t, Loc.t, ALoc.t, ALoc.t] Flow_polymorphic_ast_mapper.mapper
    method on_loc_annot = ALoc.of_loc
    method on_type_annot = ALoc.of_loc
  end


Add version with tuples instead of names types

open Core
open Option.Monad_infix
open In_channel

(*------------------------------------------------------------------------------
 *  Replaced named types with tuples
 *  Replaced succ calls with +1
 *-----------------------------------------------------------------------------*)

let read_cases (count : int) =
  let rec read_cases' n acc =
    match n with
    | 0 -> if List.length acc > 0 then Some(acc) else None
    | n ->
      let __days = input_line In_channel.stdin in
      input_line ~fix_win_eol:true In_channel.stdin
      >>| String.split_on_chars ~on:[' ']
      >>| List.map ~f:int_of_string
      >>| List.mapi ~f:(fun i x -> (x, i))
      >>| (fun x -> [x])
      >>| List.append acc
      >>= read_cases' (n-1)
  in
  read_cases' count []

let max_price (x, i) (y, j) = if x > y then -1 else 1

let trade acc price = match (List.last acc) with
  | None -> []
  | Some x -> match x with
    | (_, (day), (shares), (net_worth), (max_price::rest)) ->
      List.append acc [
        if price < max_price then
          (
            price,
            (day + 1),
            (shares + 1),
            (net_worth - price),
            (max_price::rest))
        else
          (
            price,
            (day + 1),
            (0),
            (net_worth + (shares * max_price)),
            rest)
      ]
    | _ -> acc

let process_case case =
  let sorted = List.sort ~cmp:max_price case in
  let no_price_raise =
    match (List.hd sorted >>| snd >>| phys_same 0) with
    | Some x -> x
    | None -> false
  in
  let prices = List.map ~f:fst in
  if no_price_raise
  then [((0), (0), (0), (0), (prices sorted))]
  else
    prices case
    |> List.fold_left
      ~f:trade
      ~init:[((0), (0), (0), (0), (prices sorted))]

let get_worth = function (_, _, _, (w), _) -> w

let print_results steps =
  steps
  |> List.map ~f:(List.last)
  |> List.map ~f:(fun x -> match x with
      | Some x -> get_worth x
      | None -> 0)
  |> List.iter ~f:(Printf.printf "%d\n")

let res =
  input_line ~fix_win_eol:true In_channel.stdin
  >>| Int.of_string
  >>= read_cases
  >>| List.map ~f:process_case

let () = match res with
  | Some x -> print_results x
  | None -> Printf.printf "No results available"


(* Gpumon CLI *)

module Cmds = Gpumon_interface.RPC_API(Cmdlinergen.Gen ())

let version_str description =
  let maj,min,mic = description.Idl.Interface.version in
  Printf.sprintf "%d.%d.%d" maj min mic

let default_cmd =
  let doc = String.concat "" [
      "A CLI for the GPU monitoring API. This allows scripting of the gpumon daemon ";
      "for testing and debugging. This tool is not intended to be used as an ";
      "end user tool"] in
  Cmdliner.Term.(ret (const (fun _ -> `Help (`Pager, None)) $ const ())),
  Cmdliner.Term.info "gpumon_cli" ~version:(version_str Cmds.description) ~doc

let cli () =
  let rpc = Gpumon_client.rpc in
  Cmdliner.Term.eval_choice default_cmd (List.map (fun t -> t rpc) (Cmds.implementation ()))

let _ = cli ()


(**
 * 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 'a t = 'a * 'a list

val to_list: 'a t -> 'a list
val one: 'a -> 'a t
val cons: 'a -> 'a t -> 'a t
val iter: ('a -> unit) -> 'a t -> unit
val map: ('a -> 'b) -> 'a t -> 'b t
val ident_map: ('a -> 'a) -> 'a t -> 'a t
val concat: 'a t t -> 'a t
val map_concat: ('a -> 'b t) -> 'a t -> 'b t
val rev: 'a t -> 'a t
val rev_map: ('a -> 'b) -> 'a t -> 'b t
val rev_append: 'a t -> 'a t -> 'a t
val length: 'a t -> int
val fold_left: ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
val hd: 'a t -> 'a


open Core

module Foo = struct
  type t =
    { x: string
    ; y: int
    }
  [@@deriving sexp]

  let params =
    let%map_open.Command x = flag "-x" ~doc:"" (required string)
    and y = flag "-y" ~doc:"" (required int) in
    { x ; y }

  let api ~x ~y =
    { x; y }
end

let main ({ x; y } : Foo.t) =
  printf "%s %d" x y

let flags =
  let%map_open.Command foo = Foo.params in
  fun () ->
    main foo
;;

let sexp =
  let%map_open.Command foo = flag "-sexp" ~doc:"" (required (Arg_type.create (fun str -> str |> Sexp.of_string |> Foo.t_of_sexp))) in
  fun () ->
    main foo
;;

let () = Command.run (Command.group ~summary:"" [ "flags", Command.basic ~summary:"" flags ; "sexp", Command.basic ~summary:"" sexp ])


Add another application of the FreeVars module

#default_quotation "expr";

open Camlp4.PreCast;
open Format;

module FV = Camlp4.Struct.FreeVars.Make Ast;
module PP = Camlp4.Printers.OCaml.Make Syntax;
module S = FV.S;

value _loc = Loc.ghost;

value pervasives =
  let list =
    [ "+"; "-"; "/"; "*" (* ... *) ]
  in List.fold_right S.add list S.empty;

value f e =
  let fv = FV.free_vars pervasives e in
  S.fold (fun x acc -> << fun ~ $x$ -> $acc$ >>) fv e;

value print_expr = (new PP.printer ())#expr;

printf "%a@." print_expr (f <<let z = x + 2 in x + 2 * y * x * z>>);


Add test that should fail when a vhist is not defined

open Amqp_thread
open Amqp

let log fmt = Printf.printf (fmt ^^ "\n%!")

let test =
  Deferred.try_with (fun () -> Connection.connect ~id:"ocaml-amqp-tests" ~virtual_host:"/not_there" "localhost") >>= function
  | `Ok _ -> failwith "No exception raised"
  | `Error _ ->
      log "Got expected exception";
      Scheduler.shutdown 0;
      return ()

let _ =
    Scheduler.go ()


Add .mli file for module Parser.Reference

(* TODO Remove; this is needed for testing in the meantime. *)
exception InvalidReference of string

module Paths = Model.Paths

val read_reference : string -> Paths.Reference.any
val read_path_longident : string -> [< Paths.Path.kind > `Module ] Paths.Path.t
val read_mod_longident : string -> Paths.Reference.module_


(* TEST
   * expect
*)
let foo ?x = ()
[%%expect{|
Line 1, characters 9-10:
1 | let foo ?x = ()
             ^
Warning 16 [unerasable-optional-argument]: this optional argument cannot be erased.
val foo : ?x:'a -> unit = <fun>
|}]

let foo ?x ~y = ()
[%%expect{|
val foo : ?x:'a -> y:'b -> unit = <fun>
|}]

let foo ?x () = ()
[%%expect{|
val foo : ?x:'a -> unit -> unit = <fun>
|}]

let foo ?x ~y () = ()
[%%expect{|
val foo : ?x:'a -> y:'b -> unit -> unit = <fun>
|}]

class bar ?x = object end
[%%expect{|
Line 1, characters 11-12:
1 | class bar ?x = object end
               ^
Warning 16 [unerasable-optional-argument]: this optional argument cannot be erased.
class bar : ?x:'a -> object  end
|}]

class bar ?x ~y = object end
[%%expect{|
class bar : ?x:'a -> y:'b -> object  end
|}]

class bar ?x () = object end
[%%expect{|
class bar : ?x:'a -> unit -> object  end
|}]

class foo ?x ~y () = object end
[%%expect{|
class foo : ?x:'a -> y:'b -> unit -> object  end
|}]


(* Renamed from http://www.codecodex.com/wiki/Generate_a_random_password_or_random_string#OCaml *)
let gen_boundary length =
    let gen() = match Random.int(26+26+10) with
        n when n < 26 -> int_of_char 'a' + n
      | n when n < 26 + 26 -> int_of_char 'A' + n - 26
      | n -> int_of_char '0' + n - 26 - 26 in
    let gen _ = String.make 1 (char_of_int(gen())) in
    String.concat "" (Array.to_list (Array.init length gen))

let send ~domain ~api_key params =
  let open Cohttp in
  let open Cohttp_lwt_unix in
  let authorization = "Basic " ^ (B64.encode ("api:" ^ api_key)) in
  let _boundary = gen_boundary 24 in
  let header_boundary = "------------------------" ^ _boundary in
  let boundary = "--------------------------" ^ _boundary in
  let content_type = "multipart/form-data; boundary=" ^ header_boundary in
  let form_value = List.fold_left (fun run (key, value) ->
      run ^ (Printf.sprintf "%s\r\nContent-Disposition: form-data; name=\"%s\"\r\n\r\n%s\r\n" boundary key value)) "" params in
  let headers = Header.of_list [
      ("Content-Type", content_type);
      ("Authorization", authorization)] in
  let uri = (Printf.sprintf "https://api.mailgun.net/v3/%s/messages" domain) in
  let body = Cohttp_lwt_body.of_string (Printf.sprintf "%s\r\n%s--" form_value boundary) in
  Client.post ~headers ~body (Uri.of_string uri)


Add an user-friendly implementation of SHA1 from Digestif

include Helper.BaseBytes

type ctx = Digestif.SHA1.Bytes.ctx
type buffer = Cstruct.t

let init        = Digestif.SHA1.Bytes.init
let feed ctx cs = Digestif.SHA1.Bytes.feed ctx (Cstruct.to_string cs |> Bytes.unsafe_of_string)
let get         = Digestif.SHA1.Bytes.get
let digestv l   = Digestif.SHA1.Bytes.digestv (List.map Cstruct.to_string l |> List.map Bytes.unsafe_of_string)

let length      = Digestif.SHA1.digest_size

let of_string   = Bytes.of_string


open Globals

type bin =
  Parsetree.bin

type llvm_type =
  | Tint of int
  | Tarray of int * llvm_type
  | Tpointer of llvm_type
  | Tstruct of llvm_type array
  | Tnamedstruct of string

type signature = {
  sig_args : llvm_type array;
  sig_rtyp : llvm_type option
}

type value =
  | VUNDEF
  | VINT of int * int
  | VNULL of llvm_type
  | VVAR of Id.t
  | VLOAD of Id.t

type cexp =
  | VAL of value
  | ALLOCA of bool * llvm_type
  | MALLOC of llvm_type
  | ARRAY_MALLOC of value * value
  | LOAD of value
  | STORE of value * value
  | BINOP of value * bin * value
  | CALL of Id.t * value list
  | EXT_CALL of string * value list
  | GEP of value * value list

type exp =
  | DIE of string
  | LET of Id.t * llvm_type * cexp * exp
  | IF of value * exp * exp
  | RETURN of cexp
  | LET_BLOCK of Id.t * (Id.t * llvm_type) list * exp * exp
  | GOTO of Id.t * value list
  | LET_REC of (Id.t, llvm_type, exp) fundef list * exp

type prog = {
  prog_named : (string * llvm_type list) list;
  prog_strings : (Id.t * string) list;
  prog_body : exp
}


Add test case contributed by Robert Atkey to test a bug in Unzip module.

(*
 * ExtLib Testing Suite
 * Copyright (C) 2004, 2007 Janne Hellsten
 *
 * This library 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; either
 * version 2.1 of the License, or (at your option) any later version,
 * with the special exception on linking described in file LICENSE.
 *
 * This library 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.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *)

(* test_unzip_bug1 test case was contributed by Robert Atkey on
   ocaml-lib-devel@lists.sourceforge.net on Nov 26, 2007.
   Thanks Rob! *)

let test_unzip_bug1 () =
  (* This string represents an uncompressed block.
     0x80 : bit 8 is set to indicate the last block,
            bits 6 and 7 are 00 to indicate an uncompressed block
            all other bits are ignored
     0x02
     0x00 : length of data (2) in little endian
     0xfd
     0xff : one's complement of data length (little endian)
     X
     Y    : the data

     The bug is that the Unzip module incorrectly checked that the
     one's complement representation of the length matched the
     original length. *)
  let block    = "\x80\x02\x00\xfd\xffXY" in
  let input    = IO.input_string block in
  let unzipped = Unzip.inflate ~header:false input in
    try
      let str      = IO.really_nread unzipped 2 in
      assert (str = "XY")
    with Unzip.Error Unzip.Invalid_data ->
      assert false

let test () =
  Util.run_test ~test_name:"jh_Unzip.unzip_bug1" test_unzip_bug1


Add a file which triggers a weird type-conv error message.

(*pp camlp4o -I ../lib -I `ocamlfind query type-conv` pa_type_conv.cmo pa_orm.cma *)

type t = { int: x } with orm ()

(*
make -f Makefile.debug p_bug
camlp4orf -I/Users/user/thomasga/godi/lib/ocaml/pkg-lib/type-conv -I/Users/user/thomasga/godi/lib/ocaml/site-lib/sqlite3 -I ../lib pa_type_conv.cmo -parser ../lib/pa_orm.cma -printer o bug.ml
File "bug.ml", line 3, characters 25-28:
Failure: "Pa_type_conv: 'orm' is not a supported type generator."
make[1]: *** [p_bug] Error 2
make: *** [p_bug] Error 2
*)


(*
 * Copyright (C) 2011-2013 Citrix 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.
 *)

type buf = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t

val alloc_bigarray: int -> buf
(** [alloc_bigarray min] allocates a page-aligned bigarray of size
    at least [min] bytes. *)

val alloc: int -> Cstruct.t
(** [alloc size] allocates a page-aligned Cstruct.t of size exactly [size]
    bytes *)


Add a dummy filter that remove the Camlp4FiltersTrash module.

(* camlp4r *)
(****************************************************************************)
(*                                                                          *)
(*                              Objective Caml                              *)
(*                                                                          *)
(*                            INRIA Rocquencourt                            *)
(*                                                                          *)
(*  Copyright   2006    Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed under   *)
(*  the terms of the GNU Library General Public License, with the special   *)
(*  exception on linking described in LICENSE at the top of the Objective   *)
(*  Caml source tree.                                                       *)
(*                                                                          *)
(****************************************************************************)

(* Authors:
 * - Nicolas Pouillard: initial version
 *)

open Camlp4;

module Id = struct
  value name    = "Camlp4Filters.RemoveTrashModule";
  value version = "$Id$";
end;

module Make (AstFilters : Camlp4.Sig.AstFilters.S) = struct
  open AstFilters;
  open Ast;

  register_str_item_filter
    (new Ast.c_str_item
      (fun
       [ <:str_item@_loc< module Camlp4FiltersTrash = $_$ >> ->
            <:str_item<>>
       | st -> st ]));

end;

let module M = Camlp4.Register.AstFilter Id Make in ();


(* solver's code *)

type options =
  {number: int option;
   memory : int option;
   phrase_of_power : string option}

let solve filename options =
  let lexer = Yojson.init_lexer () in
  let channel = Pervasives.open_in filename in
  let lexbuf = Lexing.from_channel channel in
  let input = Formats_j.read_input lexer lexbuf in
  close_in channel;
  input

let main filenames number memory phrase_of_power =
  let options = {number; memory; phrase_of_power} in
  List.iter (fun f -> ignore (solve f options)) filenames;

(* Cmdliner code *)
open Cmdliner

let filenames =
  let doc = "File containing JSON encoded input." in
  Arg.(value & opt_all (file) [] & info ["f"]  ~doc)

let number =
  let doc = "Time limit, in seconds, to produce output." in
  Arg.(value & opt (some int) None & info ["t"] ~doc)

let memory =
  let doc = "Memory limit, in megabytes, to produce output." in
  Arg.(value & opt (some int) None & info ["m"] ~doc)

let phrase_of_power =
  let doc = "Phrase of power, as quoted string." in
  Arg.(value & opt (some string) None & info ["p"] ~doc)

let main_t =
  Term.(pure main $ filenames $ number $ memory $ phrase_of_power)

let main_info =
  let doc = "Our mighty solver" in
  Term.info "main" ~doc

let () = match Term.eval (main_t, main_info) with `Error _ -> exit 1 | _ -> exit 0


Add admin-script to automatically split build and install

#!/usr/bin/env opam-admin.top

#directory "+../opam-lib";;
#directory "+../re";;
open Opam_admin_top;;
open OpamTypes;;

iter_packages ~opam:(fun _ opam ->
    let module O = OpamFile.OPAM in
    if O.install opam <> [] then opam else
      let rec rev_split_while acc cond = function
        | [] -> acc, []
        | x::r when cond x -> rev_split_while (x::acc) cond r
        | l -> acc, List.rev l
      in
      let condition = function
        | (CString "install",_)::_, _ -> true
        | (CString "cp",_)::r, _ ->
          (try
             let dest =
               match List.filter (function
                   | CString s, _ -> not (OpamStd.String.starts_with ~prefix:"-" s)
                   | CIdent _, _ -> true)
                   (List.rev r)
               with
               | (d, _)::_ -> d
               | _ -> raise Not_found
             in
             let dests = ["prefix";"bin";"sbin";"lib";"man";"doc";"share";"etc";
                          "toplevel";"stublibs";"doc"] in
             match dest with
             | CIdent i -> List.mem i dests
             | CString s ->
               Re.(execp (compile (seq [alt (List.map str dests); str "}%"])) s)
           with Not_found -> false)
        | l, _ -> List.exists (fun (arg,_) -> arg =CString "install") l
      in
      let install, build =
        rev_split_while [] condition (List.rev (O.build opam))
      in
      opam |>
      OpamFile.OPAM.with_build build |>
      OpamFile.OPAM.with_install install)
  ()
;;


open Printf
open NSString
open NSError

let ns_of_string (s : string) = new native_NSString (class_NSString#stringWithCString s)
let string_of_ns (ns : NSString.native_NSString) = ns#cStringUsingEncoding _NSUTF8StringEncoding

let _ = Objc.debug_invoke true

let f s =
  try
    let fname = ns_of_string s in
    let ns = class_NSString#stringWithContentsOfFile ~encoding:_NSUTF8StringEncoding ~error:true (fname :> [`NSString] Objc.t) in
    let fs = new native_NSString ns in
      printf "Length of %s: %d\n" s fs#length;
      let (l1, l2) = fs#lineRangeForRange (1, 10) in
	printf "%d, %d\n" l1 l2
  with
    | Objc.NSError e ->
	let e = new native_NSError e in
	  Debug.f "Error code: %d description: %s"
	    e#code
	    (string_of_ns (new native_NSString e#localizedDescription))

let _ =
  Arg.parse [] f "Load files in string, calculate length"


Add test for usage warnings of recursive modules

(* TEST
   * expect
*)

[@@@ocaml.warning "+a"]

module M : sig end = struct
  module rec Foo : sig
    type t
    val create : Bar.t -> t
  end = struct
    type t = unit

    let create _ = ()
  end

  and Bar : sig
    type t
  end = struct
    type t = unit
  end

  let _ = Foo.create
end;;
[%%expect{|
Line 14, characters 4-10:
14 |     type t
         ^^^^^^
Warning 34: unused type t.
Lines 13-17, characters 2-5:
13 | ..and Bar : sig
14 |     type t
15 |   end = struct
16 |     type t = unit
17 |   end
Warning 60: unused module Bar.
module M : sig end
|}];;


(**
 * 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.
 *
 *)

open Hh_core

(*****************************************************************************)
(* The file extensions we are interested in *)
(*****************************************************************************)

let extensions = [
  ".php"  ; (* normal php file *)
  ".hh"   ; (* Hack extension some open source code is starting to use *)
  ".phpt" ; (* our php template files *)
  ".hhi"  ; (* interface files only visible to the type checker *)
  ".xhp"  ; (* XHP extensions *)
]

let is_dot_file path =
  let filename = Filename.basename path in
  String.length filename > 0 && filename.[0] = '.'

let is_php path =
  not (is_dot_file path) &&
  List.exists extensions (Filename.check_suffix path)

(** Returns whether one of the ancestral directories of path has the given
 * name. *)
let rec has_ancestor path ancestor_name =
  let dirname = Filename.dirname path in
  if dirname = path then
    (** Terminal condition *)
    false
  else if (Filename.basename dirname) = ancestor_name then
    true
  else
    has_ancestor dirname ancestor_name

Support `.hack` as a file extension

(**
 * 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.
 *
 *)

open Hh_core

(*****************************************************************************)
(* The file extensions we are interested in *)
(*****************************************************************************)

let extensions = [
  ".php"  ; (* normal php file *)
  ".hh"   ; (* Hack extension some open source code is starting to use *)
  ".hack" ; (* Hack extension some open source code is starting to use *)
  ".phpt" ; (* our php template files *)
  ".hhi"  ; (* interface files only visible to the type checker *)
  ".xhp"  ; (* XHP extensions *)
]

let is_dot_file path =
  let filename = Filename.basename path in
  String.length filename > 0 && filename.[0] = '.'

let is_php path =
  not (is_dot_file path) &&
  List.exists extensions (Filename.check_suffix path)

(** Returns whether one of the ancestral directories of path has the given
 * name. *)
let rec has_ancestor path ancestor_name =
  let dirname = Filename.dirname path in
  if dirname = path then
    (** Terminal condition *)
    false
  else if (Filename.basename dirname) = ancestor_name then
    true
  else
    has_ancestor dirname ancestor_name


open Printf
open Xhtml.M

let href uri =
  a_href (uri_of_string uri)

let a_link url text =
  a ~a:[a_href (uri_of_string url)] [pcdata text]

let page ~title ~subtitle ~headers ~body ~footer =
  let headers =
    (meta
      ~content:"text/html;charset=utf-8"
      ~a:[a_http_equiv "Content-Type"]
      ())
    ::
    (link ~a:[a_rel [`Stylesheet]; a_href "media/revamp.css"] ())
    ::
    (link ~a:[a_rel [`Stylesheet]; a_href "media/styles.css"] ())
    ::
    headers in
  html ~a:[a_xmlns `W3_org_1999_xhtml]
    (head
       (Xhtml.M.title (pcdata title))
       headers
    )
    (Xhtml.M.body ~a:[a_class ["debian"]] [
      h1 ~a:[a_id "title"]
        [a_link "http://qa.debian.org/transitions/" "Tanglu QA"];
      h2 ~a:[a_id "subtitle"] subtitle;
      div ~a:[a_id "body"] body;
      div ~a:[a_id "footer"] footer
    ])

open Template

let () =
  Benl_templates.register_template {
    name = "Tanglu";
    page;
    intro = [
      b [ a_link
            "http://wiki.debian.org/Teams/ReleaseTeam/Transitions"
            "Transition documentation"
        ];
      br ();
      b [ a_link
            "http://bugs.debian.org/cgi-bin/pkgreport.cgi?users=release.debian.org@packages.debian.org;tag=transition"
            "Bugs tagged \"transition\""
        ];
      br ();
      br ();
    ];
    pts = (fun ~src -> sprintf "http://packages.qa.debian.org/%s" src);
    changelog = (fun ~letter ~src ~ver -> sprintf "http://packages.debian.org/changelog:%s" src);
    buildd = (fun ~src ~ver -> sprintf "https://buildd.debian.org/status/package.php?p=%s" src);
    buildds = (fun ~srcs ->
      let srcs = String.concat "," srcs in
      Some (sprintf "https://buildd.debian.org/status/package.php?p=%s&compact=compact" srcs));
    bugs = (fun ~src -> sprintf "http://bugs.debian.org/%s" src);
    critical_bugs = (fun ~srcs ->
      let srcs = String.concat ";src=" srcs in
      Some (sprintf "http://bugs.debian.org/cgi-bin/pkgreport.cgi?sev-inc=serious;sev-inc=grave;sev-inc=critical;src=%s" srcs));
    msg_id = (fun ~mid -> sprintf "http://lists.debian.org/%s" mid);
  }


open Core.Std
open Collections

exception RuntimeError of Error.t
exception HitRecursionLimit

val eval : ?recursion_limit:int -> Value.t Ctx.t -> Expr.t -> Value.t

val partial_eval :
  ?recursion_limit:int
  -> ?ctx:ExprValue.t Ctx.t
  -> ExprValue.t
  -> ExprValue.t


open Util

let _ =
  let lt a b =
  if (a mod 3 = b mod 3) then
    Some (a <= b)
  else
    None
  in
  let l = [87;24;1;6;3;7;2;4;8;1;23;5] in
  let sorted = partial_sort lt l in
  Printf.printf "%s\n" (String.concat ", " (List.map string_of_int sorted));


(**
 * 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.
 *)

type t =
  | Classic of Utils_js.FilenameSet.t Utils_js.FilenameMap.t
  | TypesFirst of (Utils_js.FilenameSet.t * Utils_js.FilenameSet.t) Utils_js.FilenameMap.t

val implementation_dependency_graph : t -> Utils_js.FilenameSet.t Utils_js.FilenameMap.t

val sig_dependency_graph : t -> Utils_js.FilenameSet.t Utils_js.FilenameMap.t

val debug_to_string : t -> string


Add small utility to test connection stalls and other stuff

open Amqp_thread
open Amqp

let log fmt = Printf.printf (fmt ^^ "\n%!")

let rec repeat channel queue =
  log "rep";
  Queue.publish channel queue (Message.make "Test") >>= function
  | `Ok ->
      begin
        Queue.get ~no_ack:true channel queue >>= function
        | Some _ ->
            after 1000.0 >>= fun () ->
            repeat channel queue
        | None -> failwith "No message"
      end
  | _ -> failwith "Cannot publish"

let test =
  Connection.connect ~id:"fugmann" "localhost" >>= fun connection ->
  log "Connection started";
  Connection.open_channel ~id:"test.repeat" Channel.no_confirm connection >>= fun channel ->
  Queue.declare channel ~auto_delete:true "test.repeat" >>= fun queue ->
  repeat channel queue >>= fun () ->
  Connection.close connection >>= fun () ->
  Scheduler.shutdown 0 |> return

let _ =
  Scheduler.go ()


(* Test for "include <module-expr>" inside structures *)

module A =
  struct
    type t = int
    let x = (1 : t)
    let y = (2 : t)
    let f (z : t) = (x + z : t)
  end

module B =
  struct
    include A
    type u = t * t
    let p = ((x, y) : u)
    let g ((x, y) : u) = ((f x, f y) : u)
  end

let _ =
  let print_pair (x,y) =
    print_int x; print_string ", "; print_int y; print_newline() in
  print_pair B.p;
  print_pair (B.g B.p);
  print_pair (B.g (123, 456))

module H =
  struct
    include A
    let f (z : t) = (x - 1 : t)
  end

let _ =
  print_int (H.f H.x); print_newline()

module C =
  struct
    include (A : sig type t val f : t -> int val x : t end)
    let z = f x
  end

let _ =
  print_int C.z; print_newline();
  print_int (C.f C.x); print_newline()

(* Toplevel inclusion *)

include A

let _ =
  print_int x; print_newline();
  print_int (f y); print_newline()

(* With a functor *)

module F(X: sig end) =
  struct
    let _ = print_string "F is called"; print_newline()
    type t = A | B of int
    let print_t = function A -> print_string "A"
                         | B x -> print_int x
  end

module D =
  struct
    include F(struct end)
    let test() = print_t A; print_newline(); print_t (B 42); print_newline()
  end

let _ =
  D.test();
  D.print_t D.A; print_newline(); D.print_t (D.B 42); print_newline()

(* Exceptions and classes *)

module E =
  struct
    exception Exn of string
    class c = object method m = 1 end
  end

module G =
  struct
    include E
    let _ =
      begin try raise (Exn "foo") with Exn s -> print_string s end;
      print_int ((new c)#m); print_newline()
  end

let _ =
  begin try raise (G.Exn "foo") with G.Exn s -> print_string s end;
  print_int ((new G.c)#m); print_newline()


Add a unit test for the xenstore watch code

(*
 * Copyright (C) 2006-2009 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 Watch
open Xenstore

module Tests = struct
  let title name =
    Printf.printf "Waiting for %s: " name;
    flush stdout

  let all ~xs =
    title "key /test/one to appear";
    Printf.printf "read %s\n" (wait_for ~xs (value_to_appear "/test/one"));
    title "key /test/one to disappear";
    wait_for ~xs (key_to_disappear "/test/one");
    Printf.printf "OK\n";

    title "both /test/one and /test/two to appear";
    begin
      match wait_for ~xs (all_of [ value_to_appear "/test/one"; value_to_appear "/test/two" ]) with
      | [ a; b ] ->
	  Printf.printf "values %s and %s\n" a b
      | _ -> failwith "arity mismatch"
    end;
    title "either of /test/one or /test/two to disappear";
    begin
      match fst (wait_for ~xs (any_of [ `One, key_to_disappear "/test/one"; `Two, key_to_disappear "/test/two" ])) with
      | `One -> Printf.printf "/test/one\n"
      | `Two -> Printf.printf "/test/two\n"
    end
  let go () =
    let xs = Xs.daemon_open () in
    finally
      (fun () -> all ~xs)
      (fun () -> Xs.close xs)
end

let _ = Tests.go ()


Gather all remora-nvvm unit tests together in one program

(******************************************************************************)
(* Copyright (c) 2015, NVIDIA CORPORATION. All rights reserved.               *)
(*                                                                            *)
(* Redistribution and use in source and binary forms, with or without         *)
(* modification, are permitted provided that the following conditions         *)
(* are met:                                                                   *)
(*  * Redistributions of source code must retain the above copyright          *)
(*    notice, this list of conditions and the following disclaimer.           *)
(*  * Redistributions in binary form must reproduce the above copyright       *)
(*    notice, this list of conditions and the following disclaimer in the     *)
(*    documentation and/or other materials provided with the distribution.    *)
(*  * Neither the name of NVIDIA CORPORATION nor the names of its             *)
(*    contributors may be used to endorse or promote products derived         *)
(*    from this software without specific prior written permission.           *)
(*                                                                            *)
(* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY       *)
(* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE          *)
(* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR         *)
(* PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT OWNER OR          *)
(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,      *)
(* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,        *)
(* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR         *)
(* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY        *)
(* OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT               *)
(* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE      *)
(* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.       *)
(******************************************************************************)

module AST = Test_basic_ast.UnitTests;;
open OUnit2

let () =
  run_test_tt_main AST.suite_init_drop
;;


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* An undoable view class *)

class undoable_view : [> Gtk.text_view] Gtk.obj ->
object
  inherit GText.view
  method undo : bool
  method redo : bool
  method clear_undo : unit
end

val undoable_view :
    ?buffer:GText.buffer ->
    ?editable:bool ->
    ?cursor_visible:bool ->
    ?justification:GtkEnums.justification ->
    ?wrap_mode:GtkEnums.wrap_mode ->
    ?accepts_tab:bool ->
    ?border_width:int ->
    ?width:int ->
    ?height:int ->
    ?packing:(GObj.widget -> unit) ->
    ?show:bool ->
    unit ->
  undoable_view

Fix build with OCaml 3.12

(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* An undoable view class *)

class undoable_view : ([> Gtk.text_view] as 'a) Gtk.obj ->
object
  inherit GText.view
  val obj : 'a Gtk.obj
  method undo : bool
  method redo : bool
  method clear_undo : unit
end

val undoable_view :
    ?buffer:GText.buffer ->
    ?editable:bool ->
    ?cursor_visible:bool ->
    ?justification:GtkEnums.justification ->
    ?wrap_mode:GtkEnums.wrap_mode ->
    ?accepts_tab:bool ->
    ?border_width:int ->
    ?width:int ->
    ?height:int ->
    ?packing:(GObj.widget -> unit) ->
    ?show:bool ->
    unit ->
  undoable_view


Add Input module to the library. Subject to packing into Dom_react later

module E = Dom_react.E
module H = Dom_html

module Value = struct

  let int value =
    let w = H.createInput ~_type:(Js.string "text") Dom_html.document in
    w ## value <- Js.string (string_of_int value);
    let e = E.create w E.onchar in
    let validate = E.map
      (fun char_code ->
          let input = Js.to_string w ## value in
          let selectionStart = w ## selectionStart in
          let selectionEnd = w ## selectionEnd in
          let left = String.sub input 0 selectionStart in
          let right = String.sub input selectionStart
            (String.length input - selectionStart) in
          try
            let input = Printf.sprintf "%s%c%s" left (Char.chr char_code) right in
            int_of_string input;
            w ## value <- Js.string input;
            w ## selectionStart <- selectionStart+1;
            w ## selectionEnd <- selectionStart+1;
            input
          with _ -> input
      ) e
    in
    w, E.map int_of_string validate

end


Add ConcurrentGlobal to handle multithreading

module Make
  (M : sig type u val label : string end) =
struct
  type t = M.u

  let global : t Global.t = Global.empty M.label
  let mutex = Mutex.create ()

  let with_lock f =
    try
      let () = Mutex.lock mutex in
      let result = f () in
        Mutex.unlock mutex;
        result
    with e ->
      Mutex.unlock mutex;
      raise e

  let get_no_lock () =
    Global.get global

  let set_no_lock value =
    Global.set global value

  let get () =
    with_lock get_no_lock

  let set value =
    with_lock (fun () -> set_no_lock value)

  let clear () =
    with_lock (fun () -> Global.undef global)

  let update f =
    with_lock
      (fun () ->
         let value = get_no_lock () in
         let updated_value = f value in
           set_no_lock updated_value)

end


Add utility for combining files with cilly

open Unix

let buff_size = 1024

let exec_program (program: string) (callArray : string array) =
  let in_channel = openfile "/dev/null" [O_RDONLY] 0o640 in
  let (fd_in, fd_out) = pipe () in
  let args = callArray in
  (* git should output to fdin *)
  let _ = create_process program args in_channel fd_out fd_out in
  close fd_out;
  let input = in_channel_of_descr fd_in in
  let output = Buffer.create buff_size in
  (* Read file until end *)
  try
    while true do
      let line = input_char input in
      Buffer.add_char output line
    done;
    assert false;
  with End_of_file ->
    Buffer.contents output

let run_make (args: string array) =
    exec_program "make" args

let run_cilly (path: string) =
    if Sys.file_exists path && Sys.is_directory path then (
        Unix.chdir path;
        let output = run_make [|"make"; "CC=cilly --gcc=/usr/bin/gcc-6 --merge"; "LD=cilly --gcc=/usr/bin/gcc-6 --merge --keepmerged"|] in
        print_endline output;
    )

let () =
    if Array.length Sys.argv > 1 then (
        run_cilly Sys.argv.(1);
    )


Add primitive test that sexp actually works

open Sexplib.Std

let my_record = Test_type_conv_t.({ fst=123; snd="testing" })

let cmrs : (float Test_type_conv_t.contains_my_record) list =
  let open Test_type_conv_t in
  [ `C1 123
  ; `C2 123.0
  ; `C3 my_record ]

let sexps =
  [my_record |> Test_type_conv_t.sexp_of_my_record] @
  (List.map (Test_type_conv_t.sexp_of_contains_my_record sexp_of_float) cmrs)

let () =
  sexps
  |> sexp_of_list (fun x -> x)
  |> Sexplib.Sexp.to_string
  |> print_endline


Add script to compare small epsilon values.

let dx = 2.22044e-16

let () =
  Printf.printf "add eps to 1.0 %b\n" (1.0 +. epsilon_float = 1.0);
  Printf.printf "sub eps from 1.0 %b\n" (1.0 -. epsilon_float = 1.0);
  Printf.printf "add dx to 1.0 %b\n" (1.0 +. dx = 1.0);
  Printf.printf "sub dx from 1.0 %b\n" (1.0 -. dx = 1.0);
  Printf.printf "dx is less %b\n" (dx < epsilon_float)


type ('ok, 'err) t =
  | Ok of 'ok
  | Error of 'err

let return x = Ok x

let bind m f = match m with
  | Ok x -> f x
  | Error x -> Error x

let (>>=) = bind

let fail x = Error x


Add OCaml solution for p406m reconstruct queue

(**
 * @param people: int*int list
 * @return int*int list
 *)
let reconstruct_queue people =
  let sorted = List.stable_sort (fun (h_a,k_a) (h_b,k_b) ->
    if (h_a = h_b) then
      (k_a - k_b) (* increasing k *)
    else
      (h_b - h_a) (* decreasing h *)
  ) people in
  List.fold_left (fun queue (h,k) ->
    (* insert into the position using k value *)
    let rec insert_by_k (h,k) n = function
      | [] -> [(h,k)]
      | hd :: tl as l -> if n = 0 then (h, k) :: l
                         else hd :: insert_by_k (h,k) (n-1) tl in
    insert_by_k (h,k) k queue
  ) [] sorted

(* TEST *)
open Printf
let () =
  let tests = [
    [];
    [(7,0)];
    [(7,0); (4,4); (7,1); (5,0); (6,1); (5,2)]
  ] in
  List.iter (fun test ->
    print_string "After reconstructing queue -> [ ";
    List.iter (fun (h,k) ->
      printf "(%d,%d) " h k
    ) @@ reconstruct_queue @@ test;
    print_endline "]";
  ) tests;
  print_newline ();


Add benchmark of some string searching algorithms

open Bigarray

let stride = 8 (* bytes *)
let ba_cat = int64

let blit_string_to_ba s =
  let ba = Array1.create ba_cat c_layout ((String.length s + stride - 1) / stride) in
  let s' = (Obj.magic (Obj.field (Obj.repr ba) 1) : string) in
  for i = 0 to String.length s - 1 do
    String.unsafe_set s' i (String.unsafe_get s i);
  done;
  ba

let build_srch_ht n_ba =
  let len = Array1.dim n_ba in
  let ht = Hashtbl.create len in
  for i = 0 to len - 1 do
    Hashtbl.add ht (Array1.get n_ba i) i
  done;
  ht

let volnit ~n_ba =
  let ht = build_srch_ht n_ba in
  let ret = ref [] in
  fun ~hs_ba verify ->
  for i = 0 to Array1.dim hs_ba - 1 do
    try
      let off = Hashtbl.find ht (Array1.unsafe_get hs_ba i) in
      let srch_off = i * stride - off in
      if verify ~off:srch_off then
	ret := srch_off :: !ret
    with
	Not_found -> ()
  done;
  !ret

let vol n =
  let s = volnit ~n_ba:(blit_string_to_ba n) in
  fun hs -> s ~hs_ba:(blit_string_to_ba hs) (fun ~off -> String.sub hs off (String.length n) = n)

open Batteries

let rec find_all_aux n hs last acc =
  match
    try Some (String.find_from hs (last+1) n) with Not_found -> None
  with
    | Some i -> find_all_aux n hs i (last::acc)
    | None -> List.rev (last::acc)

let find_all n hs =
  try
    let i0 = String.find hs n in
    find_all_aux n hs i0 []
  with Not_found -> []

let n1 = "abcde"
let hs1 = "abcabcabdeabcdeabbaab"

let na1 = blit_string_to_ba n1
let hsa1 = blit_string_to_ba hs1

let test_vol =
  let v = vol n1 in
  fun () -> v hs1

let test_vol_ba =
  let v = volnit ~n_ba:na1 in
  fun () -> v ~hs_ba:hsa1 (fun ~off -> String.sub hs1 off (String.length n1) = n1)

let test_bf () = find_all n1 hs1

let tests =
  [ "vol", test_vol , ();
    "vol_ba", test_vol_ba, ();
    "batfind", test_bf, ();
  ]

open Benchmark

let () =
  latencyN 1_000_000L tests |> tabulate


Test for linking archives with no modules

(* TEST

* setup-ocamlc.byte-build-env
** ocamlc.byte
module = "empty.ml"
*** ocamlc.byte
module = ""
flags = "-a"
all_modules = ""
program = "empty.cma"
**** ocamlc.byte
flags = ""
program = "${test_build_directory}/empty.byte"
all_modules = "empty.cma empty.cmo"
***** check-ocamlc.byte-output
* setup-ocamlopt.byte-build-env
** ocamlopt.byte
module = "empty.ml"
*** ocamlopt.byte
module = ""
flags = "-a"
all_modules = ""
program = "empty.cmxa"
**** ocamlopt.byte
flags = ""
program = "${test_build_directory}/empty.native"
all_modules = "empty.cmxa empty.cmx"
***** check-ocamlopt.byte-output
*)


Add Os_types.eliomi for the documentation generation

(* Ocsigen-start
 * http://www.ocsigen.org/ocsigen-start
 *
 * Copyright (C) Université Paris Diderot, CNRS, INRIA, Be Sport.
 *
 * 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, with linking exception;
 * either version 2.1 of the License, or (at your option) any later version.
 *
 * 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.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)

(** Data types

    This module defines types used in ocsigen-start in multiple files. It
    gives a more readable interface (for example by using [Os_types.userid]
    instead of [int64]). Put all most used types in this file avoids to have
    dependencies between different modules for only one type.
 **)

[%%shared.start]

(** Type representing a user ID *)
type userid = int64 [@@deriving json]

(** Type representing a user. See <<a_api | module Os_user >>. *)
type user = {
    userid : userid;
    fn : string;
    ln : string;
    avatar : string option;
  } [@@deriving json]

(** Action links *)
type actionlinkkey_info = {
  userid        : userid;
  email         : string;
  validity      : int64;
  autoconnect   : bool;
  action        : [ `AccountActivation | `PasswordReset | `Custom of string ];
  data          : string;
}

(** Type representing a group ID *)
type groupid = int64 [@@deriving json]

(** Type representing a group. See <<a_api | module Os_group >> *)
type group = {
  id    : groupid;
  name  : string;
  desc  : string option;
}


(**
 * Copyright (c) 2017, 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.
 *
 *)

val grab : string -> bool
val release : string -> bool
val blocking_grab_then_release : string -> unit
val fd_of : string -> int
val check : string -> bool


open Bigarray

let program_source = "
__kernel
void vecadd(__global int *A,
            __global int *B,
            __global int *C)
{
  int idx = get_global_id(0);
  C[idx] = A[idx] + B[idx];
}
"

let () =
  try
    let elements = 2048 in
    let a = Array1.create int c_layout elements in
    let b = Array1.create int c_layout elements in
    let c = Array1.create int c_layout elements in
    for i = 0 to elements - 1 do
      a.{i} <- i;
      b.{i} <- i
    done;

    let platforms = Cl.get_platform_ids () in
    let devices = Cl.get_device_ids (List.hd platforms) [Cl.Device_type.ALL] in
    let context = Cl.create_context [] devices (fun _ _ _ -> ()) in
    let cmd_queue = Cl.create_command_queue context (List.hd devices) [] in
    let buffer_a = Cl.create_buffer context [Cl.Mem_flags.READ_ONLY]
      (Cl.Buffer_contents.SIZE (int, elements))
    in
    let buffer_b = Cl.create_buffer context [Cl.Mem_flags.READ_ONLY]
      (Cl.Buffer_contents.SIZE (int, elements))
    in
    let buffer_c = Cl.create_buffer context [Cl.Mem_flags.WRITE_ONLY]
      (Cl.Buffer_contents.SIZE (int, elements))
    in
    let _ =
      Cl.enqueue_write_buffer cmd_queue buffer_a true (Cl.Host_mem.ARRAY1 a) []
    in
    let _ =
      Cl.enqueue_write_buffer cmd_queue buffer_b true (Cl.Host_mem.ARRAY1 b) []
    in
    let program = Cl.create_program_with_source context [program_source] in
    Cl.build_program program devices "" (fun _ -> ());
    let kernel = Cl.create_kernel program "vecadd" in
    Cl.set_kernel_arg kernel 0 (Cl.Arg_value.MEM buffer_a);
    Cl.set_kernel_arg kernel 1 (Cl.Arg_value.MEM buffer_b);
    Cl.set_kernel_arg kernel 2 (Cl.Arg_value.MEM buffer_c);

    let _ = Cl.enqueue_nd_range_kernel cmd_queue kernel None [elements] None []
    in
    let _ =
      Cl.enqueue_read_buffer cmd_queue buffer_c true (Cl.Host_mem.ARRAY1 c) []
    in

    for i = 0 to elements - 1 do
      if c.{i} <> i + i then
        failwith "Output is incorrect"
    done;
    Printf.printf "Output is correct\n"

  with Cl.Cl_error cl_error ->
    Printf.printf "error %s.\n" (Cl.Cl_error.to_string cl_error)


(*
 * 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 Xenstore

val request: Protocol.Request.t -> bool Lwt.t
(** [request r] is true if we should log the request [r] *)

val response: Protocol.Response.t -> bool Lwt.t
(** [response r] is true if we should log the response [r] *)


type 'a expr = (Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.mapping
type 'a def = (Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.def
type 'a grouped_defs = (bool * 'a def list) list

val get_full_type_name : (_, _) Ag_mapping.def -> string

val is_exportable : (_, _) Ag_mapping.def -> bool

val make_record_creator
  : ((Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.mapping
     -> (Ag_ocaml.atd_ocaml_repr, 'b) Ag_mapping.mapping)
  -> (Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.def
  -> string * string

val opt_annot : string option -> string -> string

val opt_annot_def : string option -> string -> string

val insert_annot : string option -> string

val get_type_constraint
  : original_types:(string, string * int) Hashtbl.t
  -> ('a, 'b) Ag_mapping.def
  -> string

val is_function : Ag_indent.t list -> bool

val needs_type_annot : _ expr -> bool

val check : _ grouped_defs -> unit

val write_ocaml : [< `Files of string | `Stdout ] -> string -> string -> unit


Copy threadflag analysis to threadid analysis

(** A stand-alone multi-threadedness aanlysis. *)

module GU = Goblintutil
module LF = LibraryFunctions

open Prelude.Ana
open Analyses

module Spec =
struct
  include Analyses.DefaultSpec

  module Flag = BaseDomain.Flag
  module D = Flag
  module C = Flag
  module G = Lattice.Unit

  let name () = "threadid"

  let startstate v = Flag.bot ()
  let exitstate  v = Flag.start_main v

  let morphstate v _ = Flag.start_single v

  let create_tid v =
    let loc = !Tracing.current_loc in
    Flag.spawn_thread loc v

  let body ctx f = ctx.local

  let branch ctx exp tv = ctx.local

  let return ctx exp fundec  =
    match fundec.svar.vname with
    | "__goblint_dummy_init" ->
      Flag.make_main ctx.local
    | "StartupHook" ->
      Flag.get_multi ()
    | _ ->
      ctx.local

  let assign ctx (lval:lval) (rval:exp) : D.t  =
    ctx.local

  let enter ctx lval f args =
    [ctx.local,ctx.local]

  let combine ctx lval fexp f args fc st2 = st2

  let special ctx lval f args =
    ctx.local

  let query ctx x =
    match x with
    | Queries.SingleThreaded -> `Bool (Queries.BD.of_bool (not (Flag.is_multi ctx.local)))
    | _ -> `Top

  let is_unique ctx fl =
    not (BaseDomain.Flag.is_bad fl) ||
    match ctx.ask Queries.IsNotUnique with
    | `Bool false -> true
    | _ -> false

  let part_access ctx e v w =
    let es = Access.LSSet.empty () in
    let fl = ctx.local in
    if BaseDomain.Flag.is_multi fl then begin
      if is_unique ctx fl then
        let tid = BaseDomain.Flag.short 20 fl in
        (Access.LSSSet.singleton es, Access.LSSet.add ("thread",tid) es)
      else
        (Access.LSSSet.singleton es, es)
    end else
      Access.LSSSet.empty (), es

  let threadenter ctx f args =
    create_tid f

  let threadcombine ctx f args fd =
    Flag.make_main ctx.local
end

let _ =
  MCP.register_analysis (module Spec : Spec)


(*
 * Copyright (c) 2013-2014 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.
 *)

(** Functions to manipulate the graph of Git objects. *)

module K: Graph.Sig.I with type V.t = SHA1.t
(** The graph of Git keys. *)

module Make (S: Store.S): sig

  val of_keys: S.t -> K.t Lwt.t
  (** Return the graph of keys of the given Git store. *)

  val closure: S.t -> min:SHA1.Set.t -> SHA1.Set.t -> K.t Lwt.t
  (** Return a consistent cut of the graph of keys, where no elements
      are lesser than the ones in [min] and none are bigger than the
      ones in [max]. *)

  val pack: S.t -> min:SHA1.Set.t -> SHA1.Set.t -> Pack.t Lwt.t
  (** Return a packed (closed) collection of objects. *)

  val to_dot: S.t -> string -> unit Lwt.t
  (** Create a `.dot` file describing the Git graph. *)

end


(**
 * 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.
 *)

type t =
  | Classic of Utils_js.FilenameSet.t Utils_js.FilenameMap.t
  | TypesFirst of (Utils_js.FilenameSet.t * Utils_js.FilenameSet.t) Utils_js.FilenameMap.t

val implementation_dependency_graph : t -> Utils_js.FilenameSet.t Utils_js.FilenameMap.t

val sig_dependency_graph : t -> Utils_js.FilenameSet.t Utils_js.FilenameMap.t

val debug_to_string : t -> string


(** If any element is mapped to [Some x], return the first such one. Otherwise return [None]. *)
val first_some : ('a -> 'b option) -> 'a list -> 'b option

(** If any element is mapped to [Some x], replace the first such element with [x].  Otherwise, return [None] *)
val change_first : ('a -> 'a option) -> 'a list -> 'a list option


open Bigarray

let gen ?(u=1e3) n m l =
  let native =
    Array.init n (fun _ ->
      Array.init m (fun _ ->
        Array.init l (fun _ ->
          2.0 *. (Random.float u) -. u)))
  in
  let fl64for = Array3.of_array Float64 Fortran_layout native in
  let fl64c   = Array3.of_array Float64 C_layout native in
  native, fl64for, fl64c


open Lwt
open Cohttp
open Cohttp_lwt_unix

let pp_uri = Uri.pp_hum
let pp_method pp meth = Format.pp_print_string pp (Code.string_of_method meth)
let handler conn req body =
  let%lwt body_string = Cohttp_lwt_body.to_string body in
    Format.printf "Got request on %a using %a with body @[<hov 2>%s@]@."
      pp_uri (Request.uri req)
      pp_method (Request.meth req)
      body_string;
    if Uri.path (Request.uri req) = "/new" then
      Server.respond_string ~status:`OK ~body:"key" ()
    else
      Server.respond_string ~status:`Accepted ~body:"" ()

let test_server () =
  let server = Server.make ~callback:handler () in
    Server.create ~mode:(`TCP (`Port 8080)) server

let _ = Lwt_main.run (test_server ())


Add most basic sanity test using test framework

open Lwt
open OUnit
open Cohttp_lwt_unix
open Cohttp_lwt_unix_test

let message = "Hello sanity!"

let server _req _body = Server.respond_string ~status:`OK ~body:message ()

let ts =
  Cohttp_lwt_unix_test.test_server server begin fun uri ->
    let t () =
      Client.get uri >>= fun (_, body) ->
      body |> Cohttp_lwt_body.to_string >>= fun body ->
      return (assert_equal body message) in
    ["sanity test", t]
  end

let _ = run_async_tests ts


Replace Core_kernel with Hh_prelude to forbid polymorphic equal in decl and typing

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

include Core_kernel

(** The equality function in Pervasives is backed by compiler magic (called
    compare_val), which operates on the memory representation of values to
    perform a comparison between values of any type. This is convenient, but it
    has the wrong semantics for stdlib sets and maps (since the same value may
    be represented with trees of differing structure), will not compare on-heap
    values with off-heap values (unless the compiler was configured with the
    -no-naked-pointers option), and is slower than monomorphic comparison
    functions. As a result, we forbid the use of the = operator from Pervasives
    here.

    Instead of using polymorphic equality, use ppx_deriving to derive eq for
    your data type and use the derived `equal` function.

    If you are performing many comparisons of the same kind, consider binding
    the = operator locally with something like `let ( = ) = Int.equal`.

    If your module only compares values of a single builtin type (e.g., int or
    string), you can add `open Int.Replace_polymorphic_compare` to the top of
    the file. *)
let ( = ) : [ `Do_not_use_polymorphic_compare ] =
  `Do_not_use_polymorphic_compare

(** The nonequal function in Pervasives is backed by compiler magic (called
    compare_val), which operates on the memory representation of values to
    perform a comparison between values of any type. This is convenient, but it
    has the wrong semantics for stdlib sets and maps (since the same value may
    be represented with trees of differing structure), will not compare on-heap
    values with off-heap values (unless the compiler was configured with the
    -no-naked-pointers option), and is slower than monomorphic comparison
    functions. As a result, we forbid the use of the <> operator from Pervasives
    here.

    Instead of using polymorphic equality, use ppx_deriving to derive eq for
    your data type and use the derived `equal` function.

    If you are performing many comparisons of the same kind, consider binding
    the <> operator locally with something like `let ( <> ) = Int.( <> )`.

    If your module only compares values of a single builtin type (e.g., int or
    string), you can add `open Int.Replace_polymorphic_compare` to the top of
    the file. *)
let ( <> ) : [ `Do_not_use_polymorphic_compare ] =
  `Do_not_use_polymorphic_compare