jyapayne/flitter
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add poc files

Browse source
This commit is contained in:
Joey Yakimowich-Payne 2018-05-26 10:55:38 +09:00
commit fa600b98f7
220 changed files with 45679 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

26
commons/.depend Normal file
View file

@ -0,0 +1,26 @@
common.cmo : common.cmi
common.cmx : common.cmi
common.cmi :
common2.cmo : common.cmi common2.cmi
common2.cmx : common.cmx common2.cmi
common2.cmi : common.cmi
dumper.cmo : dumper.cmi
dumper.cmx : dumper.cmi
dumper.cmi :
features.cmo :
features.cmx :
file_type.cmo : common2.cmi common.cmi file_type.cmi
file_type.cmx : common2.cmx common.cmx file_type.cmi
file_type.cmi : common.cmi
map_.cmo : map_.cmi
map_.cmx : map_.cmi
map_.cmi :
oUnit.cmo : dumper.cmi oUnit.cmi
oUnit.cmx : dumper.cmx oUnit.cmi
oUnit.cmi :
ocaml.cmo : common2.cmi common.cmi ocaml.cmi
ocaml.cmx : common2.cmx common.cmx ocaml.cmi
ocaml.cmi : common.cmi
set_.cmo : set_.cmi
set_.cmx : set_.cmi
set_.cmi :

4
commons/META Normal file
View file

@ -0,0 +1,4 @@
description = "Generic functions from pfff. Yet another extended stdlib."
requires = "unix num"
archive(byte) = "commons.cma"
archive(native) = "commons.cmxa"

57
commons/Makefile Normal file
View file

@ -0,0 +1,57 @@
##############################################################################
# Variables
##############################################################################
# if part of pfff/ or other programs with a Makefile.config
-include ../Makefile.config
LIBNAME=commons
# note: if you add a file (a .mli or .ml), dont forget to redo a 'make depend'
SRC=common.ml common2.ml \
ocaml.ml\
file_type.ml\
set_.ml map_.ml \
dumper.ml oUnit.ml
EXPORTSRC=$(SRC:%.ml=%.mli)
OCAMLMKLIB=ocamlc -a
OCAMLMKLIBOPT=ocamlopt -a
#ocamlmklib, does some weird things when you actually dont have C code
SYSLIBS=unix.cma str.cma
-include Makefile.common
# too many code in pfff assume commons/lib.cma
all:: lib.cma
all.opt: lib.cmxa lib.a
lib.cma: $(LIBNAME).cma
cp $^ $@
lib.cmxa: $(LIBNAME).cmxa
cp $^ $@
lib.a: $(LIBNAME).a
cp $^ $@
##############################################################################
# Developer rules
##############################################################################
clean::
rm -f gmon.out
forprofiling:
$(MAKE) OPTFLAGS="-p -inline 0 " opt
# obsolete, use codegraph instead!
dependencygraph:
ocamldep *.mli *.ml > /tmp/dependfull.depend
ocamldot -fullgraph /tmp/dependfull.depend > /tmp/dependfull.dot
dot -Tps /tmp/dependfull.dot > /tmp/dependfull.ps
dependencygraph2:
find -name "*.ml" |grep -v "scripts" | xargs ocamldep -I commons -I globals -I ctl -I parsing_cocci -I parsing_c -I engine -I popl -I extra > /tmp/dependfull.depend
ocamldot -fullgraph /tmp/dependfull.depend > /tmp/dependfull.dot
dot -Tps /tmp/dependfull.dot > /tmp/dependfull.ps

118
commons/Makefile.common Normal file
View file

@ -0,0 +1,118 @@
# -*- Makefile -*-
##############################################################################
# Generic variables
##############################################################################
OBJS = $(SRC:.ml=.cmo)
OPTOBJS = $(SRC:.ml=.cmx)
INCLUDES=$(INCLUDEDIRS:%=-I %) $(INCLUDESEXTRA)
LIB=$(LIBNAME).cma
OPTLIB=$(LIB:.cma=.cmxa)
##############################################################################
# Generic OCaml variables
##############################################################################
# This flag can also be used in subdirectories so don't change its name here.
# For profiling use: -p -inline 0
OPTFLAGS=-thread
# The OPTBIN variable is here to allow to use ocamlc.opt instead of
# ocaml, when it is available, which speeds up compilation. So
# if you want the fast version of the ocaml chain tools, set this var
# or setenv it to ".opt" in your startup script.
OPTBIN ?= #.opt
# coupling: ../Makefile.common, but want independent commons/
OCAMLCFLAGS ?= -g -dtypes $(OCAMLCFLAGS_EXTRA) -thread -w +9
# The OCaml tools.
OCAMLC =ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES)
OCAMLOPT=ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES)
OCAMLLEX = ocamllex$(OPTBIN)
OCAMLYACC= ocamlyacc -v
OCAMLDEP = ocamldep$(OPTBIN) $(INCLUDES)
OCAMLMKTOP=ocamlmktop -g -custom $(INCLUDES)
OCAMLMKLIB ?= ocamlmklib
CC=gcc
##############################################################################
# Top rules
##############################################################################
all:: $(LIB)
all.opt: $(OPTLIB)
opt: all.opt
top: $(LIBNAME).top
$(LIB): $(OBJS) $(COBJS)
$(OCAMLMKLIB) -o $(LIBNAME).cma $(BUILTINLIBS) $^
$(OPTLIB): $(OPTOBJS) $(COBJS)
$(OCAMLMKLIBOPT) -o $(LIBNAME).cmxa $(BUILTINLIBSOPT) $^
$(LIBNAME).top: $(OBJS)
$(OCAMLMKTOP) -o $@ $(SYSLIBS) $^
clean::
rm -f $(LIBNAME).top
##############################################################################
# Generic rules
##############################################################################
.SUFFIXES:
.SUFFIXES: .ml .mli .cmo .cmi .cmx
.ml.cmo:
$(OCAMLC) -c $<
.mli.cmi:
$(OCAMLC) -c $<
.ml.cmx:
$(OCAMLOPT) -c $<
clean::
rm -f *.cm[iox] *.o *.a *.cma *.cmxa *.annot *.cmt *.cmti *.so
rm -f *~ .*~ #*#
clean::
for i in $(SUBDIRS); do (cd $$i; \
rm -f *.cm[iox] *.cmt* *.o *.a *.cma *.cmxa *.annot *~ .*~ ; \
cd ..; ) \
done
depend:
$(OCAMLDEP) *.mli *.ml > .depend
for i in $(SUBDIRS); do $(OCAMLDEP) $$i/*.ml $$i/*.mli >> .depend; done
distclean::
rm -f .depend
-include .depend
##############################################################################
# install
##############################################################################
OCAMLSTDLIB=`ocamlc -where`
install: all all.opt
mkdir -p $(OCAMLSTDLIB)/$(LIBNAME)
cp $(LIBNAME).cma $(LIBNAME).cmxa \
common.mli ocaml.mli \
$(OCAMLSTDLIB)/$(LIBNAME)
install-findlib: all all.opt
ocamlfind install $(LIBNAME) META \
$(LIBNAME).cma $(LIBNAME).cmxa $(LIBNAME).a *.cmi $(EXPORTSRC)
uninstall-findlib:
ocamlfind remove $(LIBNAME)
# note that the dlllib.so will be added in lib/stublibs/
# dlllib.so lib.a liblib.a \
# dlllib.so liblib.a\
#todo: $(EXPORTSRC:%.mli=%.cmt) but must be guarded by having bin-annot

6
commons/authors.txt Normal file
View file

@ -0,0 +1,6 @@
Yoann Padioleau <yoann.padioleau@gmail.com>
Maybe some code was borrowed from Pixel (Pascal Rigaux)
and Julia Lawall may have written a few helper functions.
See also credits.txt.

1324
commons/common.ml Normal file
View file

File diff suppressed because it is too large Load diff

245
commons/common.mli Normal file
View file

@ -0,0 +1,245 @@
val (+>) : 'a -> ('a -> 'b) -> 'b
val (=|=) : int -> int -> bool
val (=<=) : char -> char -> bool
val (=$=) : string -> string -> bool
val (=:=) : bool -> bool -> bool
val (=*=): 'a -> 'a -> bool
val pr : string -> unit
val pr2 : string -> unit
(* forbid pr2_once to do the once "optimisation" *)
val _already_printed : (string, bool) Hashtbl.t
val disable_pr2_once : bool ref
val pr2_once : string -> unit
val pr2_gen: 'a -> unit
val dump: 'a -> string
exception Todo
exception Impossible
exception Multi_found
val exn_to_s : exn -> string
val i_to_s : int -> string
val s_to_i : string -> int
val null_string : string -> bool
val (=~) : string -> string -> bool
val matched1 : string -> string
val matched2 : string -> string * string
val matched3 : string -> string * string * string
val matched4 : string -> string * string * string * string
val matched5 : string -> string * string * string * string * string
val matched6 : string -> string * string * string * string * string * string
val matched7 : string -> string * string * string * string * string * string * string
val spf : ('a, unit, string) format -> 'a
val join : string (* sep *) -> string list -> string
val split : string (* sep regexp *) -> string -> string list
type filename = string
type dirname = string
type path = string
val cat : filename -> string list
val write_file : file:filename -> string -> unit
val read_file : filename -> string
val with_open_outfile :
filename -> ((string -> unit) * out_channel -> 'a) -> 'a
val with_open_infile :
filename -> (in_channel -> 'a) -> 'a
exception CmdError of Unix.process_status * string
val command2 : string -> unit
val cmd_to_list : ?verbose:bool -> string -> string list (* alias *)
val cmd_to_list_and_status:
?verbose:bool -> string -> string list * Unix.process_status
val null : 'a list -> bool
val exclude : ('a -> bool) -> 'a list -> 'a list
val sort : 'a list -> 'a list
val map_filter : ('a -> 'b option) -> 'a list -> 'b list
val find_opt: ('a -> bool) -> 'a list -> 'a option
val find_some : ('a -> 'b option) -> 'a list -> 'b
val find_some_opt : ('a -> 'b option) -> 'a list -> 'b option
val filter_some: 'a option list -> 'a list
val take : int -> 'a list -> 'a list
val take_safe : int -> 'a list -> 'a list
val drop : int -> 'a list -> 'a list
val span : ('a -> bool) -> 'a list -> 'a list * 'a list
val index_list : 'a list -> ('a * int) list
val index_list_0 : 'a list -> ('a * int) list
val index_list_1 : 'a list -> ('a * int) list
type ('a, 'b) assoc = ('a * 'b) list
val sort_by_val_lowfirst: ('a,'b) assoc -> ('a * 'b) list
val sort_by_val_highfirst: ('a,'b) assoc -> ('a * 'b) list
val sort_by_key_lowfirst: ('a,'b) assoc -> ('a * 'b) list
val sort_by_key_highfirst: ('a,'b) assoc -> ('a * 'b) list
val group_by: ('a -> 'b) -> 'a list -> ('b * 'a list) list
val group_assoc_bykey_eff : ('a * 'b) list -> ('a * 'b list) list
val group_by_mapped_key: ('a -> 'b) -> 'a list -> ('b * 'a list) list
val group_by_multi: ('a -> 'b list) -> 'a list -> ('b * 'a list) list
type 'a stack = 'a list
val push : 'a -> 'a stack ref -> unit
val hash_of_list : ('a * 'b) list -> ('a, 'b) Hashtbl.t
val hash_to_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list
type 'a hashset = ('a, bool) Hashtbl.t
val hashset_of_list : 'a list -> 'a hashset
val hashset_to_list : 'a hashset -> 'a list
val map_opt: ('a -> 'b) -> 'a option -> 'b option
val opt: ('a -> unit) -> 'a option -> unit
val do_option : ('a -> unit) -> 'a option -> unit
val (>>=): 'a option -> ('a -> 'b option) -> 'b option
val (|||): 'a option -> 'a -> 'a
type ('a, 'b) either = Left of 'a | Right of 'b
type ('a, 'b, 'c) either3 = Left3 of 'a | Middle3 of 'b | Right3 of 'c
val partition_either :
('a -> ('b, 'c) either) -> 'a list -> 'b list * 'c list
val partition_either3 :
('a -> ('b, 'c, 'd) either3) -> 'a list -> 'b list * 'c list * 'd list
type arg_spec_full = Arg.key * Arg.spec * Arg.doc
type cmdline_options = arg_spec_full list
type options_with_title = string * string * arg_spec_full list
type cmdline_sections = options_with_title list
(* A wrapper around Arg modules that have more logical argument order,
* and returns the remaining args.
*)
val parse_options :
cmdline_options -> Arg.usage_msg -> string array -> string list
(* Another wrapper that does Arg.align automatically *)
val usage : Arg.usage_msg -> cmdline_options -> unit
(* Work with the options_with_title type way to organize a long
* list of command line switches.
*)
val short_usage :
Arg.usage_msg -> short_opt:cmdline_options -> unit
val long_usage :
Arg.usage_msg -> short_opt:cmdline_options -> long_opt:cmdline_sections ->
unit
(* With the options_with_title way, we don't want the default -help and --help
* so need adapter of Arg module, not just wrapper.
*)
val arg_align2 : cmdline_options -> cmdline_options
val arg_parse2 :
cmdline_options -> Arg.usage_msg -> (unit -> unit) (* short_usage func *) ->
string list
(* The action lib. Useful to debug supart of your system. cf some of
* my main.ml for example of use. *)
type flag_spec = Arg.key * Arg.spec * Arg.doc
type action_spec = Arg.key * Arg.doc * action_func
and action_func = (string list -> unit)
type cmdline_actions = action_spec list
exception WrongNumberOfArguments
val mk_action_0_arg : (unit -> unit) -> action_func
val mk_action_1_arg : (string -> unit) -> action_func
val mk_action_2_arg : (string -> string -> unit) -> action_func
val mk_action_3_arg : (string -> string -> string -> unit) -> action_func
val mk_action_4_arg : (string -> string -> string -> string -> unit) ->
action_func
val mk_action_n_arg : (string list -> unit) -> action_func
val options_of_actions:
string ref (* the action ref *) -> cmdline_actions -> cmdline_options
val do_action:
Arg.key -> string list (* args *) -> cmdline_actions -> unit
val action_list:
cmdline_actions -> Arg.key list
(* if set then will not do certain finalize so faster to go back in replay *)
val debugger : bool ref
(* emacs spirit *)
val unwind_protect : (unit -> 'a) -> (exn -> 'b) -> 'a
(* java spirit *)
val finalize : (unit -> 'a) -> (unit -> 'b) -> 'a
val save_excursion : 'a ref -> 'a -> (unit -> 'b) -> 'b
val memoized :
?use_cache:bool -> ('a, 'b) Hashtbl.t -> 'a -> (unit -> 'b) -> 'b
exception UnixExit of int
exception Timeout
val timeout_function :
?verbose:bool ->
int -> (unit -> 'a) -> 'a
type prof = ProfAll | ProfNone | ProfSome of string list
val profile : prof ref
val show_trace_profile : bool ref
val _profile_table : (string, (float ref * int ref)) Hashtbl.t ref
val profile_code : string -> (unit -> 'a) -> 'a
val profile_diagnostic : unit -> string
val profile_code_exclusif : string -> (unit -> 'a) -> 'a
val profile_code_inside_exclusif_ok : string -> (unit -> 'a) -> 'a
val report_if_take_time : int -> string -> (unit -> 'a) -> 'a
(* similar to profile_code but print some information during execution too *)
val profile_code2 : string -> (unit -> 'a) -> 'a
(* creation of /tmp files, a la gcc
* ex: new_temp_file "cocci" ".c" will give "/tmp/cocci-3252-434465.c"
*)
val _temp_files_created : string list ref
val save_tmp_files : bool ref
val new_temp_file : string (* prefix *) -> string (* suffix *) -> filename
val erase_temp_files : unit -> unit
val erase_this_temp_file : filename -> unit
(* val realpath: filename -> filename *)
val fullpath: filename -> filename
val cache_computation :
?verbose:bool -> ?use_cache:bool -> filename -> string (* extension *) ->
(unit -> 'a) -> 'a
val filename_without_leading_path : string -> filename -> filename
val readable: root:string -> filename -> filename
val follow_symlinks: bool ref
val files_of_dir_or_files_no_vcs_nofilter:
string list -> filename list
(* do some finalize, signal handling, unix exit conversion, etc *)
val main_boilerplate : (unit -> unit) -> unit
(* type of maps from string to `a *)
module SMap : Map.S with type key = String.t
type 'a smap = 'a SMap.t

6186
commons/common2.ml Normal file
View file

File diff suppressed because it is too large Load diff

2049
commons/common2.mli Normal file
View file

File diff suppressed because it is too large Load diff

17
commons/copyright.txt Normal file
View file

@ -0,0 +1,17 @@
Copyright (C) 1998-2018 Yoann Padioleau
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public License (LGPL)
version 2.1 as published by the Free Software Foundation, with the
special exception on linking described in file license.txt.
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 file
license.txt for more details.
The contents of some files in this directory was derived from external
sources with compatible licenses. The original copyright and license
notice was preserved in the affected files.

12
commons/credits.txt Normal file
View file

@ -0,0 +1,12 @@
Thanks to
- Richard Jones for his dumper.ml module (public domain?)
- Jane Street for the backtrace module and lib-sexp/ (LGPL)
- Martin Jambon, Mika Illouz and Gert Stolpmann for lib-json/ (BSD-like)
- Nicolas Canasse for lib-xml/ (LGPL)
- Thomas Gazagnaire for dynType (BSD-like)
- Maas-Maarten Zeeman for OUnit (BSD-like)
- Thorsten Ohl for xHTML.ml (GPL)
- Brian Hurt and Nicolas Cannasse for their dynArray module (LGPL)
- Christophe Troestler for his ANSITerminal.ml module (LGPL)
- Sebastien ferre for his suffix tree module (public domain?)
- Anil Madhavapeddy for pretty_print_ident.ml (BSD-like)

24
commons/deprecated/Makefile.old Normal file
View file

@ -0,0 +1,24 @@
#-----------------------------------------------------------------------------
# Other stuff
#-----------------------------------------------------------------------------
#backtrace
MYBACKTRACESRC=backtrace.ml
BACKTRACEINCLUDES=-I $(shell ocamlc -where)
backtrace: commons_backtrace.cma
backtrace.opt: commons_backtrace.cmxa
backtrace_c.o: backtrace_c.c
$(CC) $(BACKTRACEINCLUDES) -c $^
commons_backtrace.cma: $(MYBACKTRACESRC:.ml=.cmo) backtrace_c.o
$(OCAMLMKLIB) -o commons_backtrace $^
commons_backtrace.cmxa: $(MYBACKTRACESRC:.ml=.cmx) backtrace_c.o
$(OCAMLMKLIB) -o commons_backtrace $^
clean::
rm -f dllcommons_backtrace.so

39
commons/deprecated/backtrace.ml Normal file
View file

@ -0,0 +1,39 @@
open Common
(*
* src: Jane Street Core library.
* update: Normally no more needed in OCaml 3.11 as part of the
* default runtime.
*)
external print : unit -> unit = "print_exception_backtrace_stub" "noalloc"
(* ---------------------------------------------------------------------- *)
(* testing *)
(* ---------------------------------------------------------------------- *)
exception MyNot_Found
let foo1 () =
if 1=1
then raise MyNot_Found
else 2
let foo2 () =
foo1 () + 2
let test_backtrace () =
(try ignore(foo2 ())
with exn ->
pr2 (Common.exn_to_s exn);
print();
failwith "other exn"
);
print_string "ok cool\n";
()
let actions () =
[
"-test_backtrace", " ",
Common.mk_action_0_arg test_backtrace;
]

9
commons/deprecated/backtrace_c.c Normal file
View file

@ -0,0 +1,9 @@
#include "caml/mlvalues.h"
CAMLextern void caml_print_exception_backtrace(void);
CAMLprim value print_exception_backtrace_stub(value /*__unused*/ unit)
{
caml_print_exception_backtrace();
return Val_unit;
}

48
commons/deprecated/sexp_common.ml Normal file
View file

@ -0,0 +1,48 @@
(* automatically generated by ocamltarzan *)
open Common
let sexp_of_either _of_a _of_b =
function
| Left v1 -> let v1 = _of_a v1 in Sexp.List [ Sexp.Atom "Left"; v1 ]
| Right v1 -> let v1 = _of_b v1 in Sexp.List [ Sexp.Atom "Right"; v1 ]
let sexp_of_either3 _of_a _of_b _of_c =
function
| Left3 v1 -> let v1 = _of_a v1 in Sexp.List [ Sexp.Atom "Left3"; v1 ]
| Middle3 v1 -> let v1 = _of_b v1 in Sexp.List [ Sexp.Atom "Middle3"; v1 ]
| Right3 v1 -> let v1 = _of_c v1 in Sexp.List [ Sexp.Atom "Right3"; v1 ]
let sexp_of_filename v = Conv.sexp_of_string v
let sexp_of_dirname v = Conv.sexp_of_string v
let sexp_of_set _of_a = Conv.sexp_of_list _of_a
let sexp_of_assoc _of_a _of_b =
Conv.sexp_of_list
(fun (v1, v2) ->
let v1 = _of_a v1 and v2 = _of_b v2 in Sexp.List [ v1; v2 ])
let sexp_of_hashset _of_a = Conv.sexp_of_hashtbl _of_a Conv.sexp_of_bool
let sexp_of_stack _of_a = Conv.sexp_of_list _of_a
let sexp_of_score_result =
function
| Common2.Ok -> Sexp.Atom "Ok"
| Common2.Pb v1 ->
let v1 = Conv.sexp_of_string v1 in Sexp.List [ Sexp.Atom "Pb"; v1 ]
let sexp_of_score v =
Conv.sexp_of_hashtbl Conv.sexp_of_string sexp_of_score_result v
let sexp_of_score_list v =
Conv.sexp_of_list
(fun (v1, v2) ->
let v1 = Conv.sexp_of_string v1
and v2 = sexp_of_score_result v2
in Sexp.List [ v1; v2 ])
v

85
commons/dumper.ml Normal file
View file

@ -0,0 +1,85 @@
(* Dump an OCaml value into a printable string.
* By Richard W.M. Jones (rich@annexia.org).
* dumper.ml 1.2 2005/02/06 12:38:21 rich Exp
*)
open Printf
open Obj
let rec dump r =
if is_int r then
string_of_int (magic r : int)
else ( (* Block. *)
let rec get_fields acc = function
| 0 -> acc
| n -> let n = n-1 in get_fields (field r n :: acc) n
in
let rec is_list r =
if is_int r then (
if (magic r : int) = 0 then true (* [] *)
else false
) else (
let s = size r and t = tag r in
if t = 0 && s = 2 then is_list (field r 1) (* h :: t *)
else false
)
in
let rec get_list r =
if is_int r then []
else let h = field r 0 and t = get_list (field r 1) in h :: t
in
let opaque name =
(* XXX In future, print the address of value 'r'. Not possible in
* pure OCaml at the moment.
*)
"<" ^ name ^ ">"
in
let s = size r and t = tag r in
(* From the tag, determine the type of block. *)
if is_list r then ( (* List. *)
let fields = get_list r in
"[" ^ String.concat "; " (List.map dump fields) ^ "]"
)
else if t = 0 then ( (* Tuple, array, record. *)
let fields = get_fields [] s in
"(" ^ String.concat ", " (List.map dump fields) ^ ")"
)
(* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not
* clear if very large constructed values could have the same
* tag. XXX *)
else if t = lazy_tag then opaque "lazy"
else if t = closure_tag then opaque "closure"
else if t = object_tag then ( (* Object. *)
let fields = get_fields [] s in
let clasz, id, slots =
match fields with h::h'::t -> h, h', t | _ -> assert false in
(* No information on decoding the class (first field). So just print
* out the ID and the slots.
*)
"Object #" ^ dump id ^
" (" ^ String.concat ", " (List.map dump slots) ^ ")"
)
else if t = infix_tag then opaque "infix"
else if t = forward_tag then opaque "forward"
else if t < no_scan_tag then ( (* Constructed value. *)
let fields = get_fields [] s in
"Tag" ^ string_of_int t ^
" (" ^ String.concat ", " (List.map dump fields) ^ ")"
)
else if t = string_tag then (
"\"" ^ String.escaped (magic r : string) ^ "\""
)
else if t = double_tag then (
string_of_float (magic r : float)
)
else if t = abstract_tag then opaque "abstract"
else if t = custom_tag then opaque "custom"
else if t = final_tag then opaque "final"
else failwith ("dump: impossible tag (" ^ string_of_int t ^ ")")
)
let dump v = dump (repr v)

6
commons/dumper.mli Normal file
View file

@ -0,0 +1,6 @@
(* Dump an OCaml value into a printable string.
* By Richard W.M. Jones (rich@annexia.org).
* dumper.mli 1.1 2005/02/03 23:07:47 rich Exp
*)
val dump : 'a -> string

0
commons/features.ml Normal file
View file

323
commons/file_type.ml Normal file
View file

@ -0,0 +1,323 @@
(* Yoann Padioleau
*
* Copyright (C) 2010-2013 Facebook
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* version 2.1 as published by the Free Software Foundation, with the
* special exception on linking described in file license.txt.
*
* 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 file
* license.txt for more details.
*)
open Common
(*****************************************************************************)
(* Prelude *)
(*****************************************************************************)
(*****************************************************************************)
(* Types *)
(*****************************************************************************)
(* see also dircolors.el and LFS *)
type file_type =
| PL of pl_type
| Obj of string (* .o, .a, .aux, .bak, etc *)
| Binary of string
| Text of string (* tex, txt, readme, noweb, org, etc *)
| Doc of string (* ps, pdf *)
| Media of media_type
| Archive of string (* tgz, rpm, etc *)
| Other of string
and pl_type =
| ML of string (* mli, ml, mly, mll *)
| Haskell of string
| Lisp of lisp_type
| Prolog of string
| Makefile
| Script of string (* sh, csh, awk, sed, etc *)
| C of string | Cplusplus of string | ObjectiveC of string
| Java | Csharp
| Perl | Python | Ruby | Lua
| Erlang | Go | Rust
| Beta
| Pascal
| Haxe | Opa | Flash
| Web of webpl_type
| Bytecode of string
| Asm
| Thrift
| MiscPL of string
and lisp_type = CommonLisp | Elisp | Scheme
and webpl_type =
| Php of string (* php or phpt or script *)
| Js | Coffee
| Css
| Html | Xml | Json
| Sql
and media_type =
| Sound of string
| Picture of string
| Video of string
(*****************************************************************************)
(* Main entry point *)
(*****************************************************************************)
(* this function is used by codemap and archi_parse and called for each
* filenames, so it has to be fast!
*)
let file_type_of_file2 file =
let (d,b,e) = Common2.dbe_of_filename_noext_ok file in
match e with
| "ml" | "mli"
| "mly" | "mll"
-> PL (ML e)
| "mlb" (* mlburg *)
| "mlp" (* used in some source *)
| "eliom" (* ocsigen, obviously *)
-> PL (ML e)
| "sml" -> PL (ML e)
(* fsharp *)
| "fsi" | "fsx" | "fs" -> PL (ML e)
(* linear ML *)
| "lml" -> PL (ML e)
| "hs" | "lhs" -> PL (Haskell e)
| "erl" | "hrl" -> PL Erlang
| "hx" | "hxp" | "hxml" -> PL Haxe
| "opa" -> PL Opa
| "as" -> PL Flash
| "bet" -> PL Beta
(* todo detect false C file, look for "Mode: Objective-C++" string in file ?
* can also be a c++, use Parser_cplusplus.is_problably_cplusplus_file
*)
| "c" -> PL (C e)
| "h" -> PL (C e)
(* todo? have a PL of xxx_kind * pl_kind ? *)
| "y" | "l" -> PL (C e)
| "hpp" -> PL (Cplusplus e) | "hxx" -> PL (Cplusplus e)
| "hh" -> PL (Cplusplus e)
| "cpp" -> PL (Cplusplus e) | "C" -> PL (Cplusplus e)
| "cc" -> PL (Cplusplus e) | "cxx" -> PL (Cplusplus e)
(* used in libstdc++ *)
| "tcc" -> PL (Cplusplus e)
| "m" | "mm" -> PL (ObjectiveC e)
| "java" -> PL Java
| "cs" -> PL Csharp
| "p" -> PL Pascal
| "thrift" -> PL Thrift
| "scm" | "rkt" | "ss" | "lsp" -> PL (Lisp Scheme)
| "lisp" -> PL (Lisp CommonLisp)
| "el" -> PL (Lisp Elisp)
(* Perl or Prolog ... I made my choice *)
| "pl" -> PL (Prolog "pl")
| "logic" -> PL (Prolog "logic") (* datalog of logicblox *)
| "dtl" -> PL (Prolog "dtl") (* bddbddb *)
| "dl" -> PL (Prolog "dl") (* datalog *)
| "perl" -> PL Perl
| "py" -> PL Python
| "rb" -> PL Ruby
| "clp" -> PL (Prolog e)
| "s" | "S" | "asm" -> PL Asm
| "c--" -> PL (MiscPL e)
| "oz" -> PL (MiscPL e)
| "R" | "Rd" -> PL (MiscPL e)
| "scala" -> PL (MiscPL e)
| "groovy" -> PL (MiscPL e)
| "sh" | "rc" | "csh" | "bash" -> PL (Script e)
| "m4" -> PL (MiscPL e)
| "conf" -> PL (MiscPL e)
(* Andrew Appel's Tiger toy language *)
| "tig" -> PL (MiscPL e)
(* merd *)
| "me" -> PL (MiscPL "me")
| "vim" -> PL (MiscPL "vim")
| "nanorc" -> PL (MiscPL "nanorc")
(* from hex to bcc *)
| "he" -> PL (MiscPL "he")
| "bc" -> PL (MiscPL "bc")
| "php" | "phpt" -> PL (Web (Php e))
| "css" -> PL (Web Css)
(* "javascript" | "es" | ? *)
| "js" -> PL (Web Js)
| "coffee" -> PL (Web Coffee)
| "html" | "htm" -> PL (Web Html)
| "xml" -> PL (Web Xml)
| "json" -> PL (Web Json)
| "sql" -> PL (Web Sql)
| "sqlite" -> PL (Web Sql)
(* apple stuff ? *)
| "xib" -> PL (Web Xml)
(* xml i18n stuff for apple *)
| "nib" -> Obj e
(* facebook: sqlshim files *)
| "sql3" -> PL (Web Sql)
| "fbobj" -> PL (MiscPL "fbobj")
| "png" | "jpg" | "JPG" | "gif" | "tiff" -> Media (Picture e)
| "xcf" | "xpm" -> Media (Picture e)
| "icns" | "icon" | "ico" -> Media (Picture e)
| "ppm" -> Media (Picture e)
| "tga" -> Media (Picture e)
| "ttf" | "font" -> Media (Picture e)
| "wav" -> Media (Sound e)
| "swf" -> Media (Picture e)
| "ps" | "pdf" -> Doc e
| "ppt" -> Doc e
| "tex" | "texi" -> Text e
| "txt" | "doc" -> Text e
| "nw" | "web" -> Text e
| "ms" -> Text e
| "org"
| "md" | "rest" | "textile" | "wiki" | "rst"
-> Text e
| "rtf" -> Text e
| "cmi" | "cmo" | "cmx" | "cma" | "cmxa"
| "annot" | "cmt" | "cmti"
| "o" | "a"
| "pyc"
| "log"
| "toc" | "brf"
| "out" | "output"
| "hi"
| "msi"
-> Obj e
(* pad: I use it to store marshalled data *)
| "db" -> Obj e
| "po" | "pot" | "gmo" -> Obj e
(* facebook fbcode stuff *)
| "apcarc" | "serialized" | "wsdl" | "dat" | "train" -> Obj e
| "facts" -> Obj e (* logicblox *)
(* pad specific, cached git blame info *)
| "git_annot" -> Obj e
(* pad specific, codegraph cached data *)
| "marshall" | "matrix" -> Obj e
| "byte" | "top" -> Binary e
| "tar" -> Archive e
| "tgz" -> Archive e
(* was PL Bytecode, but more accurate as an Obj *)
| "class" -> Obj e
(* pad specific, clang ast dump *)
| "clang" | "c.clang2" | "h.clang2" | "clang2" -> Obj e
(* was Archive *)
| "jar" -> Archive e
| "bz2" -> Archive e
| "gz" -> Archive e
| "rar" -> Archive e
| "zip" -> Archive e
| "exe" -> Binary e
| "mk" -> PL Makefile
| "rs" -> PL Rust
| "go" -> PL Go
| "lua" -> PL Lua
| _ when Common2.is_executable file -> Binary e
| _ when b = "Makefile" || b = "mkfile" || b = "Imakefile" -> PL Makefile
| _ when b = "README" -> Text "txt"
| _ when b = "TAGS" -> Binary e
| _ when b = "TARGETS" -> PL Makefile
| _ when b = ".depend" -> Obj "depend"
| _ when b = ".emacs" -> PL (Lisp (Elisp))
| _ when Common2.filesize file > 300_000 -> Obj e
| _ -> Other e
let file_type_of_file a =
Common.profile_code "file_type_of_file" (fun () -> file_type_of_file2 a)
(*****************************************************************************)
(* Misc *)
(*****************************************************************************)
let is_textual_file file =
match file_type_of_file file with
(* if this contains weird code then pfff_visual crash *)
| PL (Web Sql) -> false
| PL _
| Text _ -> true
| _ -> false
let webpl_type_of_file file =
match file_type_of_file file with
| PL (Web x) -> Some x
| _ -> None
(*
let detect_pl_of_file file =
raise Todo
let string_of_pl x =
raise Todo
| C -> "c"
| Cplusplus -> "c++"
| Java -> "java"
| Web _ -> raise Todo
*)
let is_syncweb_obj_file file =
file =~ ".*md5sum_"
let is_json_filename filename =
filename =~ ".*\\.json$"
(*
match File_type.file_type_of_file filename with
| File_type.PL (File_type.Web (File_type.Json)) -> true
| _ -> false
*)

58
commons/file_type.mli Normal file
View file

@ -0,0 +1,58 @@
type file_type =
| PL of pl_type
| Obj of string
| Binary of string
| Text of string
| Doc of string
| Media of media_type
| Archive of string
| Other of string
and pl_type =
| ML of string | Haskell of string | Lisp of lisp_type
| Prolog of string
| Makefile
| Script of string
| C of string | Cplusplus of string | ObjectiveC of string | Java | Csharp
| Perl | Python | Ruby | Lua
| Erlang | Go | Rust
| Beta
| Pascal
| Haxe | Opa | Flash
| Web of webpl_type
| Bytecode of string
| Asm
| Thrift
| MiscPL of string
and lisp_type = CommonLisp | Elisp | Scheme
and webpl_type =
| Php of string
| Js | Coffee
| Css
| Html | Xml | Json
| Sql
and media_type =
| Sound of string
| Picture of string
| Video of string
val file_type_of_file:
Common.filename -> file_type
val is_textual_file:
Common.filename -> bool
val is_syncweb_obj_file:
Common.filename -> bool
val is_json_filename:
Common.filename -> bool
(* specialisations *)
val webpl_type_of_file:
Common.filename -> webpl_type option
(* val string_of_pl: pl_kind -> string *)

520
commons/license.txt Normal file
View file

@ -0,0 +1,520 @@
The Library is distributed under the terms of the GNU Lesser General
Public License version 2.1 (included below).
As a special exception to the GNU Lesser General Public License, you
may link, statically or dynamically, a "work that uses the Library"
with a publicly distributed version of the Library to produce an
executable file containing portions of the Library, and distribute that
executable file under terms of your choice, without any of the additional
requirements listed in clause 6 of the GNU Lesser General Public License.
By "a publicly distributed version of the Library", we mean either the
unmodified Library as distributed by the authors, or a modified version
of the Library that is distributed under the conditions defined in clause
3 of the GNU Lesser General Public License. This exception does not
however invalidate any other reasons why the executable file might be
covered by the GNU Lesser General Public License.
---------------------------------------------------------------------------
GNU LESSER GENERAL PUBLIC LICENSE
Version 2.1, February 1999
Copyright (C) 1991, 1999 Free Software Foundation, Inc.
59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
[This is the first released version of the Lesser GPL. It also counts
as the successor of the GNU Library Public License, version 2, hence
the version number 2.1.]
Preamble
The licenses for most software are designed to take away your
freedom to share and change it. By contrast, the GNU General Public
Licenses are intended to guarantee your freedom to share and change
free software--to make sure the software is free for all its users.
This license, the Lesser General Public License, applies to some
specially designated software packages--typically libraries--of the
Free Software Foundation and other authors who decide to use it. You
can use it too, but we suggest you first think carefully about whether
this license or the ordinary General Public License is the better
strategy to use in any particular case, based on the explanations below.
When we speak of free software, we are referring to freedom of use,
not price. Our General Public Licenses are designed to make sure that
you have the freedom to distribute copies of free software (and charge
for this service if you wish); that you receive source code or can get
it if you want it; that you can change the software and use pieces of
it in new free programs; and that you are informed that you can do
these things.
To protect your rights, we need to make restrictions that forbid
distributors to deny you these rights or to ask you to surrender these
rights. These restrictions translate to certain responsibilities for
you if you distribute copies of the library or if you modify it.
For example, if you distribute copies of the library, whether gratis
or for a fee, you must give the recipients all the rights that we gave
you. You must make sure that they, too, receive or can get the source
code. If you link other code with the library, you must provide
complete object files to the recipients, so that they can relink them
with the library after making changes to the library and recompiling
it. And you must show them these terms so they know their rights.
We protect your rights with a two-step method: (1) we copyright the
library, and (2) we offer you this license, which gives you legal
permission to copy, distribute and/or modify the library.
To protect each distributor, we want to make it very clear that
there is no warranty for the free library. Also, if the library is
modified by someone else and passed on, the recipients should know
that what they have is not the original version, so that the original
author's reputation will not be affected by problems that might be
introduced by others.
Finally, software patents pose a constant threat to the existence of
any free program. We wish to make sure that a company cannot
effectively restrict the users of a free program by obtaining a
restrictive license from a patent holder. Therefore, we insist that
any patent license obtained for a version of the library must be
consistent with the full freedom of use specified in this license.
Most GNU software, including some libraries, is covered by the
ordinary GNU General Public License. This license, the GNU Lesser
General Public License, applies to certain designated libraries, and
is quite different from the ordinary General Public License. We use
this license for certain libraries in order to permit linking those
libraries into non-free programs.
When a program is linked with a library, whether statically or using
a shared library, the combination of the two is legally speaking a
combined work, a derivative of the original library. The ordinary
General Public License therefore permits such linking only if the
entire combination fits its criteria of freedom. The Lesser General
Public License permits more lax criteria for linking other code with
the library.
We call this license the "Lesser" General Public License because it
does Less to protect the user's freedom than the ordinary General
Public License. It also provides other free software developers Less
of an advantage over competing non-free programs. These disadvantages
are the reason we use the ordinary General Public License for many
libraries. However, the Lesser license provides advantages in certain
special circumstances.
For example, on rare occasions, there may be a special need to
encourage the widest possible use of a certain library, so that it becomes
a de-facto standard. To achieve this, non-free programs must be
allowed to use the library. A more frequent case is that a free
library does the same job as widely used non-free libraries. In this
case, there is little to gain by limiting the free library to free
software only, so we use the Lesser General Public License.
In other cases, permission to use a particular library in non-free
programs enables a greater number of people to use a large body of
free software. For example, permission to use the GNU C Library in
non-free programs enables many more people to use the whole GNU
operating system, as well as its variant, the GNU/Linux operating
system.
Although the Lesser General Public License is Less protective of the
users' freedom, it does ensure that the user of a program that is
linked with the Library has the freedom and the wherewithal to run
that program using a modified version of the Library.
The precise terms and conditions for copying, distribution and
modification follow. Pay close attention to the difference between a
"work based on the library" and a "work that uses the library". The
former contains code derived from the library, whereas the latter must
be combined with the library in order to run.
GNU LESSER GENERAL PUBLIC LICENSE
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License Agreement applies to any software library or other
program which contains a notice placed by the copyright holder or
other authorized party saying it may be distributed under the terms of
this Lesser General Public License (also called "this License").
Each licensee is addressed as "you".
A "library" means a collection of software functions and/or data
prepared so as to be conveniently linked with application programs
(which use some of those functions and data) to form executables.
The "Library", below, refers to any such software library or work
which has been distributed under these terms. A "work based on the
Library" means either the Library or any derivative work under
copyright law: that is to say, a work containing the Library or a
portion of it, either verbatim or with modifications and/or translated
straightforwardly into another language. (Hereinafter, translation is
included without limitation in the term "modification".)
"Source code" for a work means the preferred form of the work for
making modifications to it. For a library, complete source code means
all the source code for all modules it contains, plus any associated
interface definition files, plus the scripts used to control compilation
and installation of the library.
Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope. The act of
running a program using the Library is not restricted, and output from
such a program is covered only if its contents constitute a work based
on the Library (independent of the use of the Library in a tool for
writing it). Whether that is true depends on what the Library does
and what the program that uses the Library does.
1. You may copy and distribute verbatim copies of the Library's
complete source code as you receive it, in any medium, provided that
you conspicuously and appropriately publish on each copy an
appropriate copyright notice and disclaimer of warranty; keep intact
all the notices that refer to this License and to the absence of any
warranty; and distribute a copy of this License along with the
Library.
You may charge a fee for the physical act of transferring a copy,
and you may at your option offer warranty protection in exchange for a
fee.
2. You may modify your copy or copies of the Library or any portion
of it, thus forming a work based on the Library, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:
a) The modified work must itself be a software library.
b) You must cause the files modified to carry prominent notices
stating that you changed the files and the date of any change.
c) You must cause the whole of the work to be licensed at no
charge to all third parties under the terms of this License.
d) If a facility in the modified Library refers to a function or a
table of data to be supplied by an application program that uses
the facility, other than as an argument passed when the facility
is invoked, then you must make a good faith effort to ensure that,
in the event an application does not supply such function or
table, the facility still operates, and performs whatever part of
its purpose remains meaningful.
(For example, a function in a library to compute square roots has
a purpose that is entirely well-defined independent of the
application. Therefore, Subsection 2d requires that any
application-supplied function or table used by this function must
be optional: if the application does not supply it, the square
root function must still compute square roots.)
These requirements apply to the modified work as a whole. If
identifiable sections of that work are not derived from the Library,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works. But when you
distribute the same sections as part of a whole which is a work based
on the Library, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote
it.
Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Library.
In addition, mere aggregation of another work not based on the Library
with the Library (or with a work based on the Library) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.
3. You may opt to apply the terms of the ordinary GNU General Public
License instead of this License to a given copy of the Library. To do
this, you must alter all the notices that refer to this License, so
that they refer to the ordinary GNU General Public License, version 2,
instead of to this License. (If a newer version than version 2 of the
ordinary GNU General Public License has appeared, then you can specify
that version instead if you wish.) Do not make any other change in
these notices.
Once this change is made in a given copy, it is irreversible for
that copy, so the ordinary GNU General Public License applies to all
subsequent copies and derivative works made from that copy.
This option is useful when you wish to copy part of the code of
the Library into a program that is not a library.
4. You may copy and distribute the Library (or a portion or
derivative of it, under Section 2) in object code or executable form
under the terms of Sections 1 and 2 above provided that you accompany
it with the complete corresponding machine-readable source code, which
must be distributed under the terms of Sections 1 and 2 above on a
medium customarily used for software interchange.
If distribution of object code is made by offering access to copy
from a designated place, then offering equivalent access to copy the
source code from the same place satisfies the requirement to
distribute the source code, even though third parties are not
compelled to copy the source along with the object code.
5. A program that contains no derivative of any portion of the
Library, but is designed to work with the Library by being compiled or
linked with it, is called a "work that uses the Library". Such a
work, in isolation, is not a derivative work of the Library, and
therefore falls outside the scope of this License.
However, linking a "work that uses the Library" with the Library
creates an executable that is a derivative of the Library (because it
contains portions of the Library), rather than a "work that uses the
library". The executable is therefore covered by this License.
Section 6 states terms for distribution of such executables.
When a "work that uses the Library" uses material from a header file
that is part of the Library, the object code for the work may be a
derivative work of the Library even though the source code is not.
Whether this is true is especially significant if the work can be
linked without the Library, or if the work is itself a library. The
threshold for this to be true is not precisely defined by law.
If such an object file uses only numerical parameters, data
structure layouts and accessors, and small macros and small inline
functions (ten lines or less in length), then the use of the object
file is unrestricted, regardless of whether it is legally a derivative
work. (Executables containing this object code plus portions of the
Library will still fall under Section 6.)
Otherwise, if the work is a derivative of the Library, you may
distribute the object code for the work under the terms of Section 6.
Any executables containing that work also fall under Section 6,
whether or not they are linked directly with the Library itself.
6. As an exception to the Sections above, you may also combine or
link a "work that uses the Library" with the Library to produce a
work containing portions of the Library, and distribute that work
under terms of your choice, provided that the terms permit
modification of the work for the customer's own use and reverse
engineering for debugging such modifications.
You must give prominent notice with each copy of the work that the
Library is used in it and that the Library and its use are covered by
this License. You must supply a copy of this License. If the work
during execution displays copyright notices, you must include the
copyright notice for the Library among them, as well as a reference
directing the user to the copy of this License. Also, you must do one
of these things:
a) Accompany the work with the complete corresponding
machine-readable source code for the Library including whatever
changes were used in the work (which must be distributed under
Sections 1 and 2 above); and, if the work is an executable linked
with the Library, with the complete machine-readable "work that
uses the Library", as object code and/or source code, so that the
user can modify the Library and then relink to produce a modified
executable containing the modified Library. (It is understood
that the user who changes the contents of definitions files in the
Library will not necessarily be able to recompile the application
to use the modified definitions.)
b) Use a suitable shared library mechanism for linking with the
Library. A suitable mechanism is one that (1) uses at run time a
copy of the library already present on the user's computer system,
rather than copying library functions into the executable, and (2)
will operate properly with a modified version of the library, if
the user installs one, as long as the modified version is
interface-compatible with the version that the work was made with.
c) Accompany the work with a written offer, valid for at
least three years, to give the same user the materials
specified in Subsection 6a, above, for a charge no more
than the cost of performing this distribution.
d) If distribution of the work is made by offering access to copy
from a designated place, offer equivalent access to copy the above
specified materials from the same place.
e) Verify that the user has already received a copy of these
materials or that you have already sent this user a copy.
For an executable, the required form of the "work that uses the
Library" must include any data and utility programs needed for
reproducing the executable from it. However, as a special exception,
the materials to be distributed need not include anything that is
normally distributed (in either source or binary form) with the major
components (compiler, kernel, and so on) of the operating system on
which the executable runs, unless that component itself accompanies
the executable.
It may happen that this requirement contradicts the license
restrictions of other proprietary libraries that do not normally
accompany the operating system. Such a contradiction means you cannot
use both them and the Library together in an executable that you
distribute.
7. You may place library facilities that are a work based on the
Library side-by-side in a single library together with other library
facilities not covered by this License, and distribute such a combined
library, provided that the separate distribution of the work based on
the Library and of the other library facilities is otherwise
permitted, and provided that you do these two things:
a) Accompany the combined library with a copy of the same work
based on the Library, uncombined with any other library
facilities. This must be distributed under the terms of the
Sections above.
b) Give prominent notice with the combined library of the fact
that part of it is a work based on the Library, and explaining
where to find the accompanying uncombined form of the same work.
8. You may not copy, modify, sublicense, link with, or distribute
the Library except as expressly provided under this License. Any
attempt otherwise to copy, modify, sublicense, link with, or
distribute the Library is void, and will automatically terminate your
rights under this License. However, parties who have received copies,
or rights, from you under this License will not have their licenses
terminated so long as such parties remain in full compliance.
9. You are not required to accept this License, since you have not
signed it. However, nothing else grants you permission to modify or
distribute the Library or its derivative works. These actions are
prohibited by law if you do not accept this License. Therefore, by
modifying or distributing the Library (or any work based on the
Library), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Library or works based on it.
10. Each time you redistribute the Library (or any work based on the
Library), the recipient automatically receives a license from the
original licensor to copy, distribute, link with or modify the Library
subject to these terms and conditions. You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties with
this License.
11. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Library at all. For example, if a patent
license would not permit royalty-free redistribution of the Library by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Library.
If any portion of this section is held invalid or unenforceable under any
particular circumstance, the balance of the section is intended to apply,
and the section as a whole is intended to apply in other circumstances.
It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system which is
implemented by public license practices. Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.
This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.
12. If the distribution and/or use of the Library is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Library under this License may add
an explicit geographical distribution limitation excluding those countries,
so that distribution is permitted only in or among countries not thus
excluded. In such case, this License incorporates the limitation as if
written in the body of this License.
13. The Free Software Foundation may publish revised and/or new
versions of the Lesser General Public License from time to time.
Such new versions will be similar in spirit to the present version,
but may differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the Library
specifies a version number of this License which applies to it and
"any later version", you have the option of following the terms and
conditions either of that version or of any later version published by
the Free Software Foundation. If the Library does not specify a
license version number, you may choose any version ever published by
the Free Software Foundation.
14. If you wish to incorporate parts of the Library into other free
programs whose distribution conditions are incompatible with these,
write to the author to ask for permission. For software which is
copyrighted by the Free Software Foundation, write to the Free
Software Foundation; we sometimes make exceptions for this. Our
decision will be guided by the two goals of preserving the free status
of all derivatives of our free software and of promoting the sharing
and reuse of software generally.
NO WARRANTY
15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
DAMAGES.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Libraries
If you develop a new library, and you want it to be of the greatest
possible use to the public, we recommend making it free software that
everyone can redistribute and change. You can do so by permitting
redistribution under these terms (or, alternatively, under the terms of the
ordinary General Public License).
To apply these terms, attach the following notices to the library. It is
safest to attach them to the start of each source file to most effectively
convey the exclusion of warranty; and each file should have at least the
"copyright" line and a pointer to where the full notice is found.
<one line to give the library's name and a brief idea of what it does.>
Copyright (C) <year> <name of author>
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.
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
Also add information on how to contact you by electronic and paper mail.
You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the library, if
necessary. Here is a sample; alter the names:
Yoyodyne, Inc., hereby disclaims all copyright interest in the
library `Frob' (a library for tweaking knobs) written by James Random Hacker.
<signature of Ty Coon>, 1 April 1990
Ty Coon, President of Vice
That's all there is to it!

152
commons/map_.ml Normal file
View file

@ -0,0 +1,152 @@
(*pad: same than for Setb, module Make(Ord: OrderedType) = struct *)
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 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 file ../LICENSE. *)
(* *)
(***********************************************************************)
(* map.ml 1.15 2004/04/23 10:01:33 xleroy Exp *)
(*
type key = Ord.t
type 'a t =
Empty
| Node of 'a t * key * 'a * 'a t * int
*)
type ('key, 'v) t =
Empty
| Node of ('key, 'v) t * 'key * 'v * ('key, 'v) t * int
let empty = Empty
let is_empty = function Empty -> true | _ -> false
let height = function
Empty -> 0
| Node(_,_,_,_,h) -> h
let create l x d r =
let hl = height l and hr = height r in
Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
let bal l x d r =
let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
if hl > hr + 2 then begin
match l with
Empty -> invalid_arg "Map.bal"
| Node(ll, lv, ld, lr, _) ->
if height ll >= height lr then
create ll lv ld (create lr x d r)
else begin
match lr with
Empty -> invalid_arg "Map.bal"
| Node(lrl, lrv, lrd, lrr, _)->
create (create ll lv ld lrl) lrv lrd (create lrr x d r)
end
end else if hr > hl + 2 then begin
match r with
Empty -> invalid_arg "Map.bal"
| Node(rl, rv, rd, rr, _) ->
if height rr >= height rl then
create (create l x d rl) rv rd rr
else begin
match rl with
Empty -> invalid_arg "Map.bal"
| Node(rll, rlv, rld, rlr, _) ->
create (create l x d rll) rlv rld (create rlr rv rd rr)
end
end else
Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
let rec add x data = function
Empty ->
Node(Empty, x, data, Empty, 1)
| Node(l, v, d, r, h) ->
let c = compare x v in
if c = 0 then
Node(l, x, data, r, h)
else if c < 0 then
bal (add x data l) v d r
else
bal l v d (add x data r)
let rec find x = function
Empty ->
raise Not_found
| Node(l, v, d, r, _) ->
let c = compare x v in
if c = 0 then d
else find x (if c < 0 then l else r)
let rec mem x = function
Empty ->
false
| Node(l, v, d, r, _) ->
let c = compare x v in
c = 0 || mem x (if c < 0 then l else r)
let rec min_binding = function
Empty -> raise Not_found
| Node(Empty, x, d, r, _) -> (x, d)
| Node(l, x, d, r, _) -> min_binding l
let rec remove_min_binding = function
Empty -> invalid_arg "Map.remove_min_elt"
| Node(Empty, x, d, r, _) -> r
| Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
let merge t1 t2 =
match (t1, t2) with
(Empty, t) -> t
| (t, Empty) -> t
| (_, _) ->
let (x, d) = min_binding t2 in
bal t1 x d (remove_min_binding t2)
let rec remove x = function
Empty ->
Empty
| Node(l, v, d, r, h) ->
let c = compare x v in
if c = 0 then
merge l r
else if c < 0 then
bal (remove x l) v d r
else
bal l v d (remove x r)
let rec iter f = function
Empty -> ()
| Node(l, v, d, r, _) ->
iter f l; f v d; iter f r
let rec map f = function
Empty -> Empty
| Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h)
let rec mapi f = function
Empty -> Empty
| Node(l, v, d, r, h) -> Node(mapi f l, v, f v d, mapi f r, h)
let rec fold f m accu =
match m with
Empty -> accu
| Node(l, v, d, r, _) ->
fold f l (f v d (fold f r accu))
(* addons pad *)
let of_list xs =
List.fold_left (fun acc (k, v) -> add k v acc) empty xs
let to_list t =
fold (fun k v acc -> (k,v)::acc) t []

123
commons/map_.mli Normal file
View file

@ -0,0 +1,123 @@
(*pad: taken from map.ml from stdlib ocaml, functor sux: module Make(Ord: OrderedType) = *)
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 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 file ../LICENSE. *)
(* *)
(***********************************************************************)
(* $Id: map.mli,v 1.33.18.1 2009/03/21 16:35:48 xleroy Exp $ *)
(** Association tables over ordered types.
This module implements applicative association tables, also known as
finite maps or dictionaries, given a total ordering function
over the keys.
All operations over maps are purely applicative (no side-effects).
The implementation uses balanced binary trees, and therefore searching
and insertion take time logarithmic in the size of the map.
*)
(* pad:
module type OrderedType =
sig
type t
(** The type of the map keys. *)
val compare : t -> t -> int
(** A total ordering function over the keys.
This is a two-argument function [f] such that
[f e1 e2] is zero if the keys [e1] and [e2] are equal,
[f e1 e2] is strictly negative if [e1] is smaller than [e2],
and [f e1 e2] is strictly positive if [e1] is greater than [e2].
Example: a suitable ordering function is the generic structural
comparison function {!Pervasives.compare}. *)
end
(** Input signature of the functor {!Map.Make}. *)
*)
(*
module type S =
sig
*)
(* type key *)
(** The type of the map keys. *)
(*type (+'a) t *)
type ('key, 'a) t
(** The type of maps from type [key] to type ['a]. *)
val empty: ('key, 'a) t
(** The empty map. *)
val is_empty: ('key, 'a) t -> bool
(** Test whether a map is empty or not. *)
val add: 'key -> 'a -> ('key, 'a) t -> ('key, 'a) t
(** [add x y m] returns a map containing the same bindings as
[m], plus a binding of [x] to [y]. If [x] was already bound
in [m], its previous binding disappears. *)
val find: 'key -> ('key, 'a) t -> 'a
(** [find x m] returns the current binding of [x] in [m],
or raises [Not_found] if no such binding exists. *)
val remove: 'key -> ('key, 'a) t -> ('key, 'a) t
(** [remove x m] returns a map containing the same bindings as
[m], except for [x] which is unbound in the returned map. *)
val mem: 'key -> ('key, 'a) t -> bool
(** [mem x m] returns [true] if [m] contains a binding for [x],
and [false] otherwise. *)
val iter: ('key -> 'a -> unit) -> ('key, 'a) t -> unit
(** [iter f m] applies [f] to all bindings in map [m].
[f] receives the key as first argument, and the associated value
as second argument. The bindings are passed to [f] in increasing
order with respect to the ordering over the type of the keys. *)
val map: ('a -> 'b) -> ('key, 'a) t -> ('key, 'b) t
(** [map f m] returns a map with same domain as [m], where the
associated value [a] of all bindings of [m] has been
replaced by the result of the application of [f] to [a].
The bindings are passed to [f] in increasing order
with respect to the ordering over the type of the keys. *)
val mapi: ('key -> 'a -> 'b) -> ('key, 'a) t -> ('key, 'b) t
(** Same as {!Map.S.map}, but the function receives as arguments both the
key and the associated value for each binding of the map. *)
val fold: ('key -> 'a -> 'b -> 'b) -> ('key, 'a) t -> 'b -> 'b
(** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)],
where [k1 ... kN] are the keys of all bindings in [m]
(in increasing order), and [d1 ... dN] are the associated data. *)
(*
val compare: ('a -> 'a -> int) -> ('key, 'a) t -> ('key, 'a) t -> int
(** Total ordering between maps. The first argument is a total ordering
used to compare data associated with equal keys in the two maps. *)
val equal: ('a -> 'a -> bool) -> ('key, 'a) t -> ('key, 'a) t -> bool
(** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are
equal, that is, contain equal keys and associate them with
equal data. [cmp] is the equality predicate used to compare
the data associated with the keys. *)
*)
(*
end
(** Output signature of the functor {!Map.Make}. *)
module Make (Ord : OrderedType) : S with type key = Ord.t
(** Functor building an implementation of the map structure
given a totally ordered type. *)
*)
(* addons pad *)
val of_list: ('key * 'a) list -> ('key, 'a) t
val to_list: ('key, 'a) t -> ('key * 'a) list

462
commons/oUnit.ml Normal file
View file

@ -0,0 +1,462 @@
(***********************************************************************)
(* The OUnit library *)
(* *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 *)
(* Maas-Maarten Zeeman. *)
(*
The package OUnit is copyright by Maas-Maarten Zeeman.
Permission is hereby granted, free of charge, to any person obtaining
a copy of this document and the OUnit software ("the Software"), to
deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute,
sublicense, and/or sell copies of the Software, and to permit persons
to whom the Software is furnished to do so, subject to the following
conditions:
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
The Software is provided ``as is'', without warranty of any kind,
express or implied, including but not limited to the warranties of
merchantability, fitness for a particular purpose and noninfringement.
In no event shall Maas-Maarten Zeeman be liable for any claim, damages
or other liability, whether in an action of contract, tort or
otherwise, arising from, out of or in connection with the Software or
the use or other dealings in the software.
*)
(***********************************************************************)
(* pad: just harmonized some APIs regarding the 'msg' label *)
let bracket set_up f tear_down () =
let fixture = set_up () in
try
f fixture;
tear_down fixture
with
e ->
tear_down fixture;
raise e
exception Skip of string
let skip_if b msg =
if b then
raise (Skip msg)
exception Todo of string
let todo msg =
raise (Todo msg)
let assert_failure msg =
failwith ("OUnit: " ^ msg)
let assert_bool ~msg b =
if not b then assert_failure msg
let assert_string str =
if not (str = "") then assert_failure str
let assert_equal ?(cmp = ( = )) ?printer ?msg expected actual =
(* pad: better to use dump by default *)
let p = Dumper.dump in
let get_error_string _ =
match printer, msg with
None, None ->
(Format.sprintf "expected: %s but got: %s"
(p expected) (p actual))
| None, Some s ->
(Format.sprintf "%s\nnot equal, expected: %s but got: %s" s
(p expected) (p actual))
| Some p, None -> (Format.sprintf "expected: %s but got: %s"
(p expected) (p actual))
| Some p, Some s -> (Format.sprintf "%s\nexpected: %s but got: %s"
s (p expected) (p actual))
in
if not (cmp expected actual) then
assert_failure (get_error_string ())
let raises f =
try
f ();
None
with
e -> Some e
let assert_raises ?msg exn (f: unit -> 'a) =
let pexn = Printexc.to_string in
let get_error_string _ =
let str = Format.sprintf
"expected exception %s, but no exception was raised." (pexn exn)
in
match msg with
None -> assert_failure str
| Some s -> assert_failure (Format.sprintf "%s\n%s" s str)
in
match raises f with
None -> assert_failure (get_error_string ())
| Some e -> assert_equal ?msg ~printer:pexn exn e
(* Compare floats up to a given relative error *)
let cmp_float ?(epsilon = 0.00001) a b =
abs_float (a -. b) <= epsilon *. (abs_float a) ||
abs_float (a -. b) <= epsilon *. (abs_float b)
(* Now some handy shorthands *)
let (@?) msg a = assert_bool msg a
(* The type of test function *)
type test_fun = unit -> unit
(* The type of tests *)
type test =
TestCase of test_fun
| TestList of test list
| TestLabel of string * test
(* Some shorthands which allows easy test construction *)
let (>:) s t = TestLabel(s, t) (* infix *)
let (>::) s f = TestLabel(s, TestCase(f)) (* infix *)
let (>:::) s l = TestLabel(s, TestList(l)) (* infix *)
(* Utility function to manipulate test *)
let rec test_decorate g tst =
match tst with
| TestCase f ->
TestCase (g f)
| TestList tst_lst ->
TestList (List.map (test_decorate g) tst_lst)
| TestLabel (str, tst) ->
TestLabel (str, test_decorate g tst)
(* Return the number of available tests *)
let rec test_case_count test =
match test with
TestCase _ -> 1
| TestLabel (_, t) -> test_case_count t
| TestList l -> List.fold_left (fun c t -> c + test_case_count t) 0 l
type node = ListItem of int | Label of string
type path = node list
let string_of_node node =
match node with
ListItem n -> (string_of_int n)
| Label s -> s
let string_of_path path =
List.fold_left
(fun a l ->
if a = "" then
l
else
l ^ ":" ^ a) "" (List.map string_of_node path)
(* Some helper function, they are generally applicable *)
(* Applies function f in turn to each element in list. Function f takes
one element, and integer indicating its location in the list *)
let mapi f l =
let rec rmapi cnt l =
match l with
[] -> []
| h::t -> (f h cnt)::(rmapi (cnt + 1) t)
in
rmapi 0 l
let fold_lefti f accu l =
let rec rfold_lefti cnt accup l =
match l with
[] -> accup
| h::t -> rfold_lefti (cnt + 1) (f accup h cnt) t
in
rfold_lefti 0 accu l
(* Returns all possible paths in the test. The order is from test case
to root
*)
let test_case_paths test =
let rec tcps path test =
match test with
TestCase _ -> [path]
| TestList tests ->
List.concat (mapi (fun t i -> tcps ((ListItem i)::path) t) tests)
| TestLabel (l, t) -> tcps ((Label l)::path) t
in
tcps [] test
(* Test filtering with their path *)
module SetTestPath = Set.Make(String)
let test_filter only test =
let set_test =
List.fold_left
(fun st str -> SetTestPath.add str st)
SetTestPath.empty
only
in
let foldi f acc lst =
List.fold_left
(fun (i, acc) e ->
let nacc =
f i acc e
in
(i + 1), nacc
)
acc
lst
in
let rec filter_test path tst =
if SetTestPath.mem (string_of_path path) set_test then
(
Some tst
)
else
(
match tst with
| TestCase _ ->
None
| TestList tst_lst ->
let (_, ntst_lst) =
foldi
(fun i ntst_lst tst ->
let nntst_lst =
match filter_test ((ListItem i) :: path) tst with
| Some tst ->
tst :: ntst_lst
| None ->
ntst_lst
in
nntst_lst
)
(0, [])
tst_lst
in
if ntst_lst = [] then
None
else
Some (TestList ntst_lst)
| TestLabel (lbl, tst) ->
let ntst =
filter_test
((Label lbl) :: path)
tst
in
match ntst with
| Some tst ->
Some (TestLabel (lbl, tst))
| None ->
None
)
in
filter_test [] test
(* The possible test results *)
type test_result =
RSuccess of path
| RFailure of path * string
| RError of path * string
| RSkip of path * string
| RTodo of path * string
let is_success = function
RSuccess _ -> true
| RFailure _ | RError _ | RSkip _ | RTodo _ -> false
let is_failure = function
RFailure _ -> true
| RSuccess _ | RError _ | RSkip _ | RTodo _ -> false
let is_error = function
RError _ -> true
| RSuccess _ | RFailure _ | RSkip _ | RTodo _ -> false
let is_skip = function
RSkip _ -> true
| RSuccess _ | RFailure _ | RError _ | RTodo _ -> false
let is_todo = function
RTodo _ -> true
| RSuccess _ | RFailure _ | RError _ | RSkip _ -> false
let result_flavour = function
RError _ -> "Error"
| RFailure _ -> "Failure"
| RSuccess _ -> "Success"
| RSkip _ -> "Skip"
| RTodo _ -> "Todo"
let result_path = function
RSuccess path
| RError (path, _)
| RFailure (path, _)
| RSkip (path, _)
| RTodo (path, _) -> path
let result_msg = function
RSuccess _ -> "Success"
| RError (_, msg)
| RFailure (_, msg)
| RSkip (_, msg)
| RTodo (_, msg) -> msg
(* Returns true if the result list contains successes only *)
let rec was_successful results =
match results with
[] -> true
| RSuccess _::t
| RSkip _::t -> was_successful t
| RFailure _::_
| RError _::_
| RTodo _::_ -> false
(* Events which can happen during testing *)
type test_event =
EStart of path
| EEnd of path
| EResult of test_result
(* Run all tests, report starts, errors, failures, and return the results *)
let perform_test report test =
let run_test_case f path =
try
f ();
RSuccess path
with
Failure s -> RFailure (path, s)
| Skip s -> RSkip (path, s)
| Todo s -> RTodo (path, s)
| s -> RError (path, (Printexc.to_string s ^ " " ^
Printexc.get_backtrace ()))
in
let rec run_test path results test =
match test with
TestCase(f) ->
report (EStart path);
let result = run_test_case f path in
report (EResult result);
report (EEnd path);
result::results
| TestList (tests) ->
fold_lefti
(fun results t cnt -> run_test ((ListItem cnt)::path) results t)
results tests
| TestLabel (label, t) ->
run_test ((Label label)::path) results t
in
run_test [] [] test
(* Function which runs the given function and returns the running time
of the function, and the original result in a tuple *)
let time_fun f x y =
let begin_time = Unix.gettimeofday () in
(Unix.gettimeofday () -. begin_time, f x y)
(* A simple (currently too simple) text based test runner *)
let run_test_tt ?(verbose=false) test =
let printf = Format.printf in
let separator1 =
"======================================================================" in
let separator2 =
"----------------------------------------------------------------------" in
let string_of_result = function
RSuccess _ ->
if verbose then "ok\n" else "."
| RFailure (_, _) ->
if verbose then "FAIL\n" else "F"
| RError (_, _) ->
if verbose then "ERROR\n" else "E"
| RSkip (_, _) ->
if verbose then "SKIP\n" else "S"
| RTodo (_, _) ->
if verbose then "TODO\n" else "T"
in
let report_event = function
EStart p ->
if verbose then printf "%s ... " (string_of_path p)
| EEnd _ -> ()
| EResult result ->
printf "%s@?" (string_of_result result);
in
let print_result_list results =
List.iter
(fun result -> printf "%s\n%s: %s\n\n%s\n%s\n"
separator1
(result_flavour result)
(string_of_path (result_path result))
(result_msg result)
separator2)
results
in
(* Now start the test *)
let running_time, results = time_fun perform_test report_event test in
let errors = List.filter is_error results in
let failures = List.filter is_failure results in
let skips = List.filter is_skip results in
let todos = List.filter is_todo results in
if not verbose then printf "\n";
(* Print test report *)
print_result_list errors;
print_result_list failures;
printf "Ran: %d tests in: %.2f seconds.\n"
(List.length results) running_time;
(* Print final verdict *)
if was_successful results then
(
if skips = [] then
printf "OK"
else
printf "OK: Cases: %d Skip: %d\n"
(test_case_count test) (List.length skips)
)
else
printf "FAILED: Cases: %d Tried: %d Errors: %d Failures: %d Skip:%d Todo:%d\n"
(test_case_count test) (List.length results)
(List.length errors) (List.length failures)
(List.length skips) (List.length todos);
(* Return the results possibly for further processing *)
results
(* Call this one from you test suites *)
let run_test_tt_main suite =
let verbose = ref false in
let only_test = ref [] in
Arg.parse
(Arg.align
[("-verbose", Arg.Set verbose, " Run the test in verbose mode.");
("-only-test", Arg.String (fun str -> only_test := str :: !only_test),
"path Run only the selected test");
]
)
(fun x -> raise (Arg.Bad ("Bad argument : " ^ x)))
("usage: " ^ Sys.argv.(0) ^ " [-verbose] [-only-test path]*");
let nsuite =
if !only_test = [] then
(
suite
)
else
(
match test_filter !only_test suite with
| Some tst ->
tst
| None ->
failwith ("Filtering test "^
(String.concat ", " !only_test)^
" lead to no test")
)
in
let result = run_test_tt ~verbose:!verbose nsuite in
if not (was_successful result) then
exit 1
else
result

202
commons/oUnit.mli Normal file
View file

@ -0,0 +1,202 @@
(***********************************************************************)
(* The OUnit library *)
(* *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 *)
(* Maas-Maarten Zeeman. *)
(*
The package OUnit is copyright by Maas-Maarten Zeeman.
Permission is hereby granted, free of charge, to any person obtaining
a copy of this document and the OUnit software ("the Software"), to
deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute,
sublicense, and/or sell copies of the Software, and to permit persons
to whom the Software is furnished to do so, subject to the following
conditions:
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
The Software is provided ``as is'', without warranty of any kind,
express or implied, including but not limited to the warranties of
merchantability, fitness for a particular purpose and noninfringement.
In no event shall Maas-Maarten Zeeman be liable for any claim, damages
or other liability, whether in an action of contract, tort or
otherwise, arising from, out of or in connection with the Software or
the use or other dealings in the software.
*)
(***********************************************************************)
(** The OUnit library can be used to implement unittests
To uses this library link with
[ocamlc oUnit.cmo]
or
[ocamlopt oUnit.cmx]
@author Maas-Maarten Zeeman
*)
(** {5 Assertions}
Assertions are the basic building blocks of unittests. *)
(** Signals a failure. This will raise an exception with the specified
string.
@raise Failure to signal a failure *)
val assert_failure : string -> 'a
(** Signals a failure when bool is false. The string identifies the
failure.
@raise Failure to signal a failure *)
val assert_bool : msg:string -> bool -> unit
(** Shorthand for assert_bool
@raise Failure to signal a failure *)
val ( @? ) : string -> bool -> unit
(** Signals a failure when the string is non-empty. The string identifies the
failure.
@raise Failure to signal a failure *)
val assert_string : string -> unit
(** Compares two values, when they are not equal a failure is signaled.
The cmp parameter can be used to pass a different compare function.
This parameter defaults to ( = ). The optional printer can be used
to convert the value to string, so a nice error message can be
formatted. When msg is also set it can be used to identify the failure.
@raise Failure description *)
val assert_equal : ?cmp:('a -> 'a -> bool) -> ?printer:('a -> string) ->
?msg:string -> 'a -> 'a -> unit
(** Asserts if the expected exception was raised. When msg is set it can
be used to identify the failure
@raise Failure description *)
val assert_raises : ?msg:string -> exn -> (unit -> 'a) -> unit
(** {5 Skipping tests }
In certain condition test can be written but there is no point running it, because they
are not significant (missing OS features for example). In this case this is not a failure
nor a success. Following function allow you to escape test, just as assertion but without
the same error status.
A test skipped is counted as success. A test todo is counted as failure. *)
(** [skip cond msg] If [cond] is true, skip the test for the reason explain in [msg].
* For example [skip_if (Sys.os_type = "Win32") "Test a doesn't run on windows"].
*)
val skip_if : bool -> string -> unit
(** The associated test is still to be done, for the reason given.
*)
val todo : string -> unit
(** {5 Compare Functions} *)
(** Compare floats up to a given relative error. *)
val cmp_float : ?epsilon: float -> float -> float -> bool
(** {5 Bracket}
A bracket is a functional implementation of the commonly used
setUp and tearDown feature in unittests. It can be used like this:
"MyTestCase" >:: (bracket test_set_up test_fun test_tear_down) *)
(** *)
val bracket : (unit -> 'a) -> ('a -> 'b) -> ('a -> 'c) -> unit -> 'c
(** {5 Constructing Tests} *)
(** The type of test function *)
type test_fun = unit -> unit
(** The type of tests *)
type test =
TestCase of test_fun
| TestList of test list
| TestLabel of string * test
(** Create a TestLabel for a test *)
val (>:) : string -> test -> test
(** Create a TestLabel for a TestCase *)
val (>::) : string -> test_fun -> test
(** Create a TestLabel for a TestList *)
val (>:::) : string -> test list -> test
(** Some shorthands which allows easy test construction.
Examples:
- ["test1" >: TestCase((fun _ -> ()))] =>
[TestLabel("test2", TestCase((fun _ -> ())))]
- ["test2" >:: (fun _ -> ())] =>
[TestLabel("test2", TestCase((fun _ -> ())))]
- ["test-suite" >::: ["test2" >:: (fun _ -> ());]] =>
[TestLabel("test-suite", TestSuite([TestLabel("test2", TestCase((fun _ -> ())))]))]
*)
(** [test_decorate g tst] Apply [g] to test function contains in [tst] tree. *)
val test_decorate : (test_fun -> test_fun) -> test -> test
(** [test_filter paths tst] Filter test based on their path string representation. *)
val test_filter : string list -> test -> test option
(** {5 Retrieve Information from Tests} *)
(** Returns the number of available test cases *)
val test_case_count : test -> int
(** Types which represent the path of a test *)
type node = ListItem of int | Label of string
type path = node list (** The path to the test (in reverse order). *)
(** Make a string from a node *)
val string_of_node : node -> string
(** Make a string from a path. The path will be reversed before it is
tranlated into a string *)
val string_of_path : path -> string
(** Returns a list with paths of the test *)
val test_case_paths : test -> path list
(** {5 Performing Tests} *)
(** The possible results of a test *)
type test_result =
RSuccess of path
| RFailure of path * string
| RError of path * string
| RSkip of path * string
| RTodo of path * string
(** Events which occur during a test run *)
type test_event =
EStart of path
| EEnd of path
| EResult of test_result
(** Perform the test, allows you to build your own test runner *)
val perform_test : (test_event -> 'a) -> test -> test_result list
(** A simple text based test runner. It prints out information
during the test. *)
val run_test_tt : ?verbose:bool -> test -> test_result list
(** Main version of the text based test runner. It reads the supplied command
line arguments to set the verbose level and limit the number of test to run
*)
val run_test_tt_main : test -> test_result list

498
commons/ocaml.ml Normal file
View file

@ -0,0 +1,498 @@
(*
* Yoann Padioleau
*
* Copyright (C) 2009-2012 Facebook
*
* Most of the code in this file was inspired by code by Gazagnaire.
* Here is the original copyright:
*
* Copyright (c) 2009 Thomas Gazagnaire <thomas@gazagnaire.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.
*)
open Common
(*****************************************************************************)
(* Purpose *)
(*****************************************************************************)
(*
* OCaml hacks to support reflection.
*
* OCaml does not support reflection, and it's a good thing: we love
* strong type-checking that forbids too clever hacks like 'eval', or
* run-time reflection; it's too much power for you, you will misuse
* it. At the same time it's sometimes useful. So at least we could make
* it possible to still reflect on the type definitions or values in
* OCaml source code. We can do it by processing ML source code and
* emitting ML source code containing under the form of regular ML
* value or functions meta-information about information in other
* source code files. It's a little bit a poor's man reflection mechanism,
* because it's more manual, but it's for the best. Metaprogramming had
* to be painful, because it is dangerous!
*
* Example:
*
* TODO
*
* In some sense we reimplement what is in the OCaml compiler, which
* contains the full AST of OCaml source code. But the OCaml compiler
* and its AST are too big, too scary for many tasks that would be satisfied
* by a restricted but simpler AST.
*
* Camlp4 is obviously also a solution to this problem, but it has a
* learning curve, and it's a slightly different world than the pure
* regular OCaml world. So this module, and ocamltarzan together can
* reduce the problem by taking the best of camlp4, while still
* avoiding it.
*
*
*
* The support is partial. We support only the OCaml constructions
* we found the most useful for programming stuff like
* stub generators.
*
* less? not all OCaml so call it miniml.ml ? or reflection.ml ?
*
*
* Notes: 2 worlds
* - the type level world,
* - the data level world
*
* Then there is whether the code is generated on the fly, or output somewhere
* to be compiled and linked again (so 2 steps process, more manual, but
* arguably less complicated magic)
*
* different level of (meta)programming:
*
* - programming in OCaml on OCaml values (classic)
* - programming in OCaml on Sexp.t value of value
* - programming in OCaml on Sexp.t value of type description
* - programming in OCaml on OCaml.v value of value
* - programming in OCaml on OCaml.t value of type description
*
* Depending on what you have to do, some levels are more suited than other.
* For instance to do a show, to pretty print value, then sexp is good,
* because really you just want to write code that handle 2 cases,
* atoms and list. That's really what pretty printing is all about. You
* could write a pretty printer for Ocaml.v, but it will need to handle
* 10 cases. Now if you want to write a code generator for python, or an ORM,
* then Ocaml.v is better than sexp, because in sexp you lost some valuable
* information (that you may have to reverse engineer, like whether
* a Sexp.List corresponds to a field, or a sum, or wether something is
* null or an empty list, or wether it's an int or float, etc).
*
* Another way to do (meta)programming is:
* - programming in Camlp4 on OCaml ast
* - writing camlmix code to generate code.
*
* notes:
* - sexp value or sexp of type description, not as precise, but easier to
* write really generic code that do not need to have more information
* about the sexp nodes (such as wether it's a field, a constuctor, etc)
* - miniml value or type, not as precise that the regular type,
* but more precise than sexp, and allow write some generic code.
* - ocaml value (not type as you cant program at type level),
* precise type checking, but can be tedious to write generic
* code like generic visitors or pickler/unpicklers
*
* This file is working with ocamltarzan/pa/pa_type.ml (and so indirectly
* it is working with camlp4).
*
* Note that can even generate sexp_of_x for miniML :) really
* reflexive tower here
*
* Note that even if this module helps a programmer to avoid
* using directly camlp4 to auto generate some code, it can
* not solve all the tasks.
*
* history:
* - Thought about it when wanting to do the ast_php.ml to be
* transformed into a .adsl declaration to be able to generate
* corresponding python classes using astgen.py.
* - Thought about a miniMLType and miniMLValue, and then realize
* that that was maybe what code in the ocaml-orm-sqlite
* was doing (type-of et value-of), except I wanted the
* ocamltarzan style of meta-programming instead of the camlp4 one.
*
*
* Alternatives:
* - camlp4
* obviously camlp4 has access to the full AST of OCaml, but
* that is one pb, that's too much. We often want only to do
* analysis on the type
* - type-conv
* good, but force to use camlp4. Can use the generic sexplib
* and then work on the generated sexp, but as explained below,
* is will be on the value.
* - use lib-sexp (just the sexp library part, not the camlp4 support part)
* but not enough info. Even if usually
* can reverse engineer the sexp to rediscover the type,
* you will reverse engineer a value; what you want
* is the sexp representation of the type! not a value of this type.
* Also lib-sexp autogenerated code can be hard to understand, especially
* if the type definition is complex. A good side effect of ocaml.ml
* is that it provides an intermediate step :) So even if you
* could pretty print value from your def to sexp directly, you could
* also use transform your value into a Ocaml.v, then use
* the somehow more readable function that translate a v into a sexp,
* and same when wanting to read a value from a sexp, by using
* again Ocaml.v as an intermediate. It's nevertheless obviously
* less efficient.
*
* - zephyr, or thrift ?
* - F# ?
* - Lisp/Scheme ?
* - .Net interoperability
*
*)
(*****************************************************************************)
(* Types *)
(*****************************************************************************)
(* src:
* - orm-sqlite/value/value.ml
* (itself a fork of http://xenbits.xen.org/xapi/xen-api-libs.hg?file/7a17b2ab5cfc/rpc-light/rpc.ml)
* - orm-sqlite/type-of/type.ml
*
* update: Gazagnaire made a paper about that.
*
* modifications:
* - slightly renamed the types and rearrange order of constructors. Could
* have use nested modules to allow to reuse Int in different contexts,
* but I actually prefer to prefix the values with the V, so when debugging
* stuff, it's clearer that what you are looking are values, not types
* (even if the ocaml toplevel would prefix the value with a V. or T.,
* but sexp would not)
* - Changed Int of int option
* - Introduced List, Apply, Poly
* - debugging support (using sexp :) )
*)
(* OCaml type definitions *)
type t =
| Unit
| Bool | Float | Char | String | Int
| Tuple of t list
| Dict of (string * [`RW|`RO] * t) list
| Sum of (string * t list) list
| Var of string
| Poly of string
| Arrow of t * t
| Apply of string * t
(* special cases of Apply *)
| Option of t
| List of t
(* todo? split in another type, because here it's the left part,
* whereas before is the right part of a type definition. Also
* have not the polymorphic args to some defs like ('a, 'b) Hashbtbl
* | Rec of string * t
* | Ext of string * t
*
* | Enum of t (* ??? *)
*)
| TTODO of string
(* with tarzan *)
(* OCaml values (a restricted form of expressions) *)
type v =
| VUnit
| VBool of bool | VFloat of float | VInt of int (* was int64 *)
| VChar of char | VString of string
| VTuple of v list
| VDict of (string * v) list
| VSum of string * v list
| VVar of (string * int64)
| VArrow of string
(* special cases *)
| VNone | VSome of v
| VList of v list
| VRef of v
(*
| VEnum of v list (* ??? *)
| VRec of (string * int64) * v
| VExt of (string * int64) * v
*)
| VTODO of string
(* with tarzan *)
(*****************************************************************************)
(* Helpers *)
(*****************************************************************************)
(* the generated code can use that if he wants *)
let (_htype: (string, t) Hashtbl.t) =
Hashtbl.create 101
let (add_new_type: string -> t -> unit) = fun s t ->
Hashtbl.add _htype s t
let (get_type: string -> t) = fun s ->
Hashtbl.find _htype s
(* for generated code that want to transform and in and out of a v or t *)
let vof_unit () =
VUnit
let vof_int x =
VInt ((*Int64.of_int*) x)
let vof_float x =
VFloat ((*Int64.of_int*) x)
let vof_string x =
VString x
let vof_bool b =
VBool b
let vof_list ofa x =
VList (List.map ofa x)
let vof_option ofa x =
match x with
| None -> VNone
| Some x -> VSome (ofa x)
let vof_ref ofa x =
match x with
| {contents = x } -> VRef (ofa x)
let vof_either _of_a _of_b =
function
| Left v1 -> let v1 = _of_a v1 in VSum (("Left", [ v1 ]))
| Right v1 -> let v1 = _of_b v1 in VSum (("Right", [ v1 ]))
let vof_either3 _of_a _of_b _of_c =
function
| Left3 v1 -> let v1 = _of_a v1 in VSum (("Left3", [ v1 ]))
| Middle3 v1 -> let v1 = _of_b v1 in VSum (("Middle3", [ v1 ]))
| Right3 v1 -> let v1 = _of_c v1 in VSum (("Right3", [ v1 ]))
let int_ofv = function
| VInt x -> x
| _ -> failwith "ofv: was expecting a VInt"
let float_ofv = function
| VFloat x -> x
| _ -> failwith "ofv: was expecting a VFloat"
let string_ofv = function
| VString x -> x
| _ -> failwith "ofv: was expecting a VString"
let unit_ofv = function
| VUnit -> ()
| _ -> failwith "ofv: was expecting a VUnit"
let list_ofv a__of_sexp sexp = match sexp with
| VList lst ->
let rev_lst = List.rev_map a__of_sexp lst in
List.rev rev_lst
| _ -> failwith "list_ofv: VLlist needed"
let option_ofv a__of_sexp sexp = match sexp with
| VNone -> None
| VSome x -> Some (a__of_sexp x)
| _ -> failwith "option_ofv: VNone or VSome needed"
(*****************************************************************************)
(* Format pretty printers *)
(*****************************************************************************)
let add_sep xs =
xs +> List.map (fun x -> Right x) +> Common2.join_gen (Left ())
(*
* OCaml value pretty printer. A similar functionnality is provided by
* the OCaml toplevel interpreter ('/usr/bin/ocaml') but
* sometimes it is useful to print values from a regular command
* line program. You don't always want to run the ocaml interpreter (or
* customized interpreter built by ocamlmktop), and type an expression
* in to get the printed value.
*
* The v_of_xxx generated code by ocamltarzan is
* the first part to make this possible. The function below
* is the second part.
*
* The '@[', '@,', etc are Format printf tags. See the doc of the Format
* module in the OCaml manual to understand their meaning. Mainly,
* @[ and @] open and close a pretty print box, and '@ ' and '@,'
* are to give breaking hints to the pretty printer.
*
* The output can be copy pasted in ML code directly, which can be
* useful when you want to pattern match over complex ocaml value.
*)
let string_of_v v =
Common2.format_to_string (fun () ->
let ppf = Format.printf in
let rec aux v =
match v with
| VUnit -> ppf "()"
| VBool v1 ->
if v1
then ppf "true"
else ppf "false"
| VFloat v1 -> ppf "%f" v1
| VChar v1 -> ppf "'%c'" v1
| VString v1 -> ppf "\"%s\"" v1
| VInt i -> ppf "%d" i
| VTuple xs ->
ppf "(@[";
xs +> add_sep +> List.iter (function
| Left _ -> ppf ",@ ";
| Right v -> aux v
);
ppf "@])";
| VDict xs ->
ppf "{@[";
xs +> List.iter (fun (s, v) ->
(* less: could open a box there too? *)
ppf "@,%s=" s;
aux v;
ppf ";@ ";
);
ppf "@]}";
| VSum ((s, xs)) ->
(match xs with
| [] -> ppf "%s" s
| y::ys ->
ppf "@[<hov 2>%s(@," s;
xs +> add_sep +> List.iter (function
| Left _ -> ppf ",@ ";
| Right v -> aux v
);
ppf "@])";
)
| VVar (s, i64) -> ppf "%s_%d" s (Int64.to_int i64)
| VArrow v1 -> failwith "Arrow TODO"
| VNone -> ppf "None";
| VSome v -> ppf "Some(@["; aux v; ppf "@])";
| VRef v -> ppf "Ref(@["; aux v; ppf "@])";
| VList xs ->
ppf "[@[<hov>";
xs +> add_sep +> List.iter (function
| Left _ -> ppf ";@ ";
| Right v -> aux v
);
ppf "@]]";
| VTODO v1 -> ppf "VTODO"
in
aux v
)
(*****************************************************************************)
(* Mapper Visitor *)
(*****************************************************************************)
let map_of_unit x = ()
let map_of_bool x = x
let map_of_float x = x
let map_of_char x = x
let map_of_string (s:string) = s
let map_of_ref aref x = x (* dont go into ref *)
let map_of_option v_of_a v =
match v with
| None -> None
| Some x -> Some (v_of_a x)
let map_of_list of_a xs =
List.map of_a xs
let map_of_int x = x
let map_of_int64 x = x
let map_of_either _of_a _of_b =
function
| Left v1 -> let v1 = _of_a v1 in Left ((v1))
| Right v1 -> let v1 = _of_b v1 in Right ((v1))
let map_of_either3 _of_a _of_b _of_c =
function
| Left3 v1 -> let v1 = _of_a v1 in Left3 ((v1))
| Middle3 v1 -> let v1 = _of_b v1 in Middle3 ((v1))
| Right3 v1 -> let v1 = _of_c v1 in Right3 ((v1))
(* this is subtle ... *)
let rec (map_v: f:( k:(v -> v) -> v -> v) -> v -> v) =
fun ~f x ->
let rec map_v v =
(* generated by ocamltarzan with: camlp4o -o /tmp/yyy.ml -I pa/ pa_type_conv.cmo pa_map.cmo pr_o.cmo /tmp/xxx.ml *)
let rec k x =
match x with
| VUnit -> VUnit
| VBool v1 -> let v1 = map_of_bool v1 in VBool ((v1))
| VFloat v1 -> let v1 = map_of_float v1 in VFloat ((v1))
| VChar v1 -> let v1 = map_of_char v1 in VChar ((v1))
| VString v1 -> let v1 = map_of_string v1 in VString ((v1))
| VInt v1 -> let v1 = map_of_int v1 in VInt ((v1))
| VTuple v1 -> let v1 = map_of_list map_v v1 in VTuple ((v1))
| VDict v1 ->
let v1 =
map_of_list
(fun (v1, v2) ->
let v1 = map_of_string v1 and v2 = map_v v2 in (v1, v2))
v1
in VDict ((v1))
| VSum ((v1, v2)) ->
let v1 = map_of_string v1
and v2 = map_of_list map_v v2
in VSum ((v1, v2))
| VVar v1 ->
let v1 =
(match v1 with
| (v1, v2) ->
let v1 = map_of_string v1 and v2 = map_of_int64 v2 in (v1, v2))
in VVar ((v1))
| VArrow v1 -> let v1 = map_of_string v1 in VArrow ((v1))
| VNone -> VNone
| VSome v1 -> let v1 = map_v v1 in VSome ((v1))
| VRef v1 -> let v1 = map_v v1 in VRef ((v1))
| VList v1 -> let v1 = map_of_list map_v v1 in VList ((v1))
| VTODO v1 -> let v1 = map_of_string v1 in VTODO ((v1))
in
f ~k v
in
map_v x
(*****************************************************************************)
(* Iterator Visitor *)
(*****************************************************************************)
let v_unit x = ()
let v_bool x = ()
let v_int x = ()
let v_string (s:string) = ()
let v_ref aref x = () (* dont go into ref *)
let v_option v_of_a v =
match v with
| None -> ()
| Some x -> v_of_a x
let v_list of_a xs =
List.iter of_a xs
let v_either of_a of_b x =
match x with
| Left a -> of_a a
| Right b -> of_b b
let v_either3 of_a of_b of_c x =
match x with
| Left3 a -> of_a a
| Middle3 b -> of_b b
| Right3 c -> of_c c

130
commons/ocaml.mli Normal file
View file

@ -0,0 +1,130 @@
(*
* OCaml hacks to support reflection (works with ocamltarzan).
*
* See also sexp.ml, json.ml, and xml.ml for other "reflective" techniques.
*)
(* OCaml core type definitions (no objects, no modules) *)
type t =
| Unit
| Bool | Float | Char | String | Int
| Tuple of t list
| Dict of (string * [`RW|`RO] * t) list (* aka record *)
| Sum of (string * t list) list (* aka variants *)
| Var of string
| Poly of string
| Arrow of t * t
| Apply of string * t
(* special cases of Apply *)
| Option of t
| List of t
| TTODO of string
val add_new_type: string -> t -> unit
val get_type: string -> t
(* OCaml values (a restricted form of expressions) *)
type v =
| VUnit
| VBool of bool | VFloat of float | VInt of int
| VChar of char | VString of string
| VTuple of v list
| VDict of (string * v) list
| VSum of string * v list
| VVar of (string * int64)
| VArrow of string
(* special cases *)
| VNone | VSome of v
| VList of v list
| VRef of v
| VTODO of string
(* building blocks, used by code generated using ocamltarzan *)
val vof_unit : unit -> v
val vof_bool : bool -> v
val vof_int : int -> v
val vof_float : float -> v
val vof_string : string -> v
val vof_list : ('a -> v) -> 'a list -> v
val vof_option : ('a -> v) -> 'a option -> v
val vof_ref : ('a -> v) -> 'a ref -> v
val vof_either : ('a -> v) -> ('b -> v) -> ('a, 'b) Common.either -> v
val vof_either3 : ('a -> v) -> ('b -> v) -> ('c -> v) ->
('a, 'b, 'c) Common.either3 -> v
val int_ofv: v -> int
val float_ofv: v -> float
val unit_ofv: v -> unit
val string_ofv: v -> string
val list_ofv: (v -> 'a) -> v -> 'a list
val option_ofv: (v -> 'a) -> v -> 'a option
(* regular pretty printer (not via sexp, but using Format) *)
val string_of_v: v -> string
(* sexp converters *)
(*
val sexp_of_t: t -> Sexp.t
val t_of_sexp: Sexp.t -> t
val sexp_of_v: v -> Sexp.t
val v_of_sexp: Sexp.t -> v
val string_sexp_of_t: t -> string
val t_of_string_sexp: string -> t
val string_sexp_of_v: v -> string
val v_of_string_sexp: string -> v
*)
(* json converters *)
(*
val v_of_json: Json_type.json_type -> v
val json_of_v: v -> Json_type.json_type
val save_json: Common.filename -> Json_type.json_type -> unit
val load_json: Common.filename -> Json_type.json_type
*)
(* mapper/visitor *)
val map_v:
f:( k:(v -> v) -> v -> v) ->
v ->
v
(* other building blocks, used by code generated using ocamltarzan *)
val map_of_unit: unit -> unit
val map_of_bool: bool -> bool
val map_of_int: int -> int
val map_of_float: float -> float
val map_of_char: char -> char
val map_of_string: string -> string
val map_of_ref: 'a -> 'b -> 'b
val map_of_option: ('a -> 'b) -> 'a option -> 'b option
val map_of_list: ('a -> 'a) -> 'a list -> 'a list
val map_of_either:
('a -> 'b) -> ('c -> 'd) -> ('a, 'c) Common.either -> ('b, 'd) Common.either
val map_of_either3:
('a -> 'b) -> ('c -> 'd) -> ('e -> 'f) ->
('a, 'c, 'e) Common.either3 -> ('b, 'd, 'f) Common.either3
(* pure visitor building blocks, used by code generated using ocamltarzan *)
val v_unit: unit -> unit
val v_bool: bool -> unit
val v_int: int -> unit
val v_string: string -> unit
val v_option: ('a -> unit) -> 'a option -> unit
val v_list: ('a -> unit) -> 'a list -> unit
val v_ref: ('a -> unit) -> 'a ref -> unit
val v_either:
('a -> unit) -> ('b -> unit) ->
('a, 'b) Common.either -> unit
val v_either3:
('a -> unit) -> ('b -> unit) -> ('c -> unit) ->
('a, 'b, 'c) Common.either3 -> unit

29
commons/readme.txt Normal file
View file

@ -0,0 +1,29 @@
This directory builds a common.cma library and also optionally
multiple commons_xxx.cma small libraries. The reason not to just build
a single one is that some functionnalities require external libraries
(like Berkeley DB, MPI, etc) or special version of OCaml (like for the
backtrace support) and I don't want to penalize the user by forcing
him to install all those libs before being able to use some of my
common helper functions. So, common.ml and other files offer
convenient helpers that do not require to install anything. In some
cases I have directly included the code of those external libs when
there are simple such as for ANSITerminal in ocamlextra/, and for
dumper.ml I have even be further by inlining its code in common.ml so
one can just do a open Common and have everything. Then if the user
wants to, he can also leverage the other commons_xxx libraries by
explicitely building them after he has installed the necessary
external files.
For many configurable things we can use some flags in ml files,
and have some -xxx command line argument to set them or not,
but for other things flags are not enough as they will not remove
the header and linker dependencies in Makefiles. A solution is
to use cpp and pre-process many files that have such configuration
issue. Another solution is to centralize all the cpp issue in one
file, features.ml.in, that acts as a generic wrapper for other
librairies and depending on the configuration actually call
the external library or provide a fake empty services indicating
that the service is not present.
So you should have a ../configure that call cpp on features.ml.in
to set those linking-related configuration settings.

302
commons/set_.ml Normal file
View file

@ -0,0 +1,302 @@
(*pad: taken from set.ml from stdlib ocaml, functor sux: module Make(Ord: OrderedType) = *)
(* with some addons such as from list *)
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 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 file ../LICENSE. *)
(* *)
(***********************************************************************)
(* set.ml 1.18.4.1 2004/11/03 21:19:49 doligez Exp *)
(* Sets over ordered types *)
(* pad:
type elt = Ord.t
type t = Empty | Node of t * elt * t * int
and subst all Ord.compare with just compare
*)
type 'elt t = Empty | Node of 'elt t * 'elt * 'elt t * int
(* Sets are represented by balanced binary trees (the heights of the
children differ by at most 2 *)
let height = function
Empty -> 0
| Node(_, _, _, h) -> h
(* Creates a new node with left son l, value v and right son r.
We must have all elements of l < v < all elements of r.
l and r must be balanced and | height l - height r | <= 2.
Inline expansion of height for better speed. *)
let create l v r =
let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1))
(* Same as create, but performs one step of rebalancing if necessary.
Assumes l and r balanced and | height l - height r | <= 3.
Inline expansion of create for better speed in the most frequent case
where no rebalancing is required. *)
let bal l v r =
let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
if hl > hr + 2 then begin
match l with
Empty -> invalid_arg "Set.bal"
| Node(ll, lv, lr, _) ->
if height ll >= height lr then
create ll lv (create lr v r)
else begin
match lr with
Empty -> invalid_arg "Set.bal"
| Node(lrl, lrv, lrr, _)->
create (create ll lv lrl) lrv (create lrr v r)
end
end else if hr > hl + 2 then begin
match r with
Empty -> invalid_arg "Set.bal"
| Node(rl, rv, rr, _) ->
if height rr >= height rl then
create (create l v rl) rv rr
else begin
match rl with
Empty -> invalid_arg "Set.bal"
| Node(rll, rlv, rlr, _) ->
create (create l v rll) rlv (create rlr rv rr)
end
end else
Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1))
(* Insertion of one element *)
let rec add x = function
Empty -> Node(Empty, x, Empty, 1)
| Node(l, v, r, _) as t ->
let c = compare x v in
if c = 0 then t else
if c < 0 then bal (add x l) v r else bal l v (add x r)
(* Same as create and bal, but no assumptions are made on the
relative heights of l and r. *)
let rec join l v r =
match (l, r) with
(Empty, _) -> add v r
| (_, Empty) -> add v l
| (Node(ll, lv, lr, lh), Node(rl, rv, rr, rh)) ->
if lh > rh + 2 then bal ll lv (join lr v r) else
if rh > lh + 2 then bal (join l v rl) rv rr else
create l v r
(* Smallest and greatest element of a set *)
let rec min_elt = function
Empty -> raise Not_found
| Node(Empty, v, r, _) -> v
| Node(l, v, r, _) -> min_elt l
let rec max_elt = function
Empty -> raise Not_found
| Node(l, v, Empty, _) -> v
| Node(l, v, r, _) -> max_elt r
(* Remove the smallest element of the given set *)
let rec remove_min_elt = function
Empty -> invalid_arg "Set.remove_min_elt"
| Node(Empty, v, r, _) -> r
| Node(l, v, r, _) -> bal (remove_min_elt l) v r
(* Merge two trees l and r into one.
All elements of l must precede the elements of r.
Assume | height l - height r | <= 2. *)
let merge t1 t2 =
match (t1, t2) with
(Empty, t) -> t
| (t, Empty) -> t
| (_, _) -> bal t1 (min_elt t2) (remove_min_elt t2)
(* Merge two trees l and r into one.
All elements of l must precede the elements of r.
No assumption on the heights of l and r. *)
let concat t1 t2 =
match (t1, t2) with
(Empty, t) -> t
| (t, Empty) -> t
| (_, _) -> join t1 (min_elt t2) (remove_min_elt t2)
(* Splitting. split x s returns a triple (l, present, r) where
- l is the set of elements of s that are < x
- r is the set of elements of s that are > x
- present is false if s contains no element equal to x,
or true if s contains an element equal to x. *)
let rec split x = function
Empty ->
(Empty, false, Empty)
| Node(l, v, r, _) ->
let c = compare x v in
if c = 0 then (l, true, r)
else if c < 0 then
let (ll, pres, rl) = split x l in (ll, pres, join rl v r)
else
let (lr, pres, rr) = split x r in (join l v lr, pres, rr)
(* Implementation of the set operations *)
let empty = Empty
let is_empty = function Empty -> true | _ -> false
let rec mem x = function
Empty -> false
| Node(l, v, r, _) ->
let c = compare x v in
c = 0 || mem x (if c < 0 then l else r)
let singleton x = Node(Empty, x, Empty, 1)
let rec remove x = function
Empty -> Empty
| Node(l, v, r, _) ->
let c = compare x v in
if c = 0 then merge l r else
if c < 0 then bal (remove x l) v r else bal l v (remove x r)
let rec union s1 s2 =
match (s1, s2) with
(Empty, t2) -> t2
| (t1, Empty) -> t1
| (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
if h1 >= h2 then
if h2 = 1 then add v2 s1 else begin
let (l2, _, r2) = split v1 s2 in
join (union l1 l2) v1 (union r1 r2)
end
else
if h1 = 1 then add v1 s2 else begin
let (l1, _, r1) = split v2 s1 in
join (union l1 l2) v2 (union r1 r2)
end
let rec inter s1 s2 =
match (s1, s2) with
(Empty, t2) -> Empty
| (t1, Empty) -> Empty
| (Node(l1, v1, r1, _), t2) ->
match split v1 t2 with
(l2, false, r2) ->
concat (inter l1 l2) (inter r1 r2)
| (l2, true, r2) ->
join (inter l1 l2) v1 (inter r1 r2)
let rec diff s1 s2 =
match (s1, s2) with
(Empty, t2) -> Empty
| (t1, Empty) -> t1
| (Node(l1, v1, r1, _), t2) ->
match split v1 t2 with
(l2, false, r2) ->
join (diff l1 l2) v1 (diff r1 r2)
| (l2, true, r2) ->
concat (diff l1 l2) (diff r1 r2)
let rec compare_aux l1 l2 =
match (l1, l2) with
([], []) -> 0
| ([], _) -> -1
| (_, []) -> 1
| (Empty :: t1, Empty :: t2) ->
compare_aux t1 t2
| (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) ->
let c = compare v1 v2 in
if c <> 0 then c else compare_aux (r1::t1) (r2::t2)
| (Node(l1, v1, r1, _) :: t1, t2) ->
compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2
| (t1, Node(l2, v2, r2, _) :: t2) ->
compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2)
let compare s1 s2 =
compare_aux [s1] [s2]
let equal s1 s2 =
compare s1 s2 = 0
let rec subset s1 s2 =
match (s1, s2) with
Empty, _ ->
true
| _, Empty ->
false
| Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) ->
let c = Pervasives.compare v1 v2 in
if c = 0 then
subset l1 l2 && subset r1 r2
else if c < 0 then
subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2
else
subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2
let rec iter f = function
Empty -> ()
| Node(l, v, r, _) -> iter f l; f v; iter f r
let rec fold f s accu =
match s with
Empty -> accu
| Node(l, v, r, _) -> fold f l (f v (fold f r accu))
let rec for_all p = function
Empty -> true
| Node(l, v, r, _) -> p v && for_all p l && for_all p r
let rec exists p = function
Empty -> false
| Node(l, v, r, _) -> p v || exists p l || exists p r
let filter p s =
let rec filt accu = function
| Empty -> accu
| Node(l, v, r, _) ->
filt (filt (if p v then add v accu else accu) l) r in
filt Empty s
let partition p s =
let rec part (t, f as accu) = function
| Empty -> accu
| Node(l, v, r, _) ->
part (part (if p v then (add v t, f) else (t, add v f)) l) r in
part (Empty, Empty) s
let rec cardinal = function
Empty -> 0
| Node(l, v, r, _) -> cardinal l + 1 + cardinal r
let rec elements_aux accu = function
Empty -> accu
| Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l
let elements s =
elements_aux [] s
let choose = min_elt
(* pad: *)
let (of_list: 'a list -> 'a t) = fun xs ->
List.fold_left (fun a e -> add e a) empty xs

161
commons/set_.mli Normal file
View file

@ -0,0 +1,161 @@
(*pad: taken from set.ml from stdlib ocaml, functor sux: module Make(Ord: OrderedType) = *)
(* with some addons such as from list *)
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 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 file ../LICENSE. *)
(* *)
(***********************************************************************)
(* set.mli 1.32 2004/04/23 10:01:54 xleroy Exp $ *)
(** Sets over ordered types.
This module implements the set data structure, given a total ordering
function over the set elements. All operations over sets
are purely applicative (no side-effects).
The implementation uses balanced binary trees, and is therefore
reasonably efficient: insertion and membership take time
logarithmic in the size of the set, for instance.
*)
(* pad:
module type OrderedType =
sig
type t
(** The type of the set elements. *)
val compare : t -> t -> int
(** A total ordering function over the set elements.
This is a two-argument function [f] such that
[f e1 e2] is zero if the elements [e1] and [e2] are equal,
[f e1 e2] is strictly negative if [e1] is smaller than [e2],
and [f e1 e2] is strictly positive if [e1] is greater than [e2].
Example: a suitable ordering function is the generic structural
comparison function {!Pervasives.compare}. *)
end
(** Input signature of the functor {!Set.Make}. *)
*)
(*
module type S =
sig
*)
(* type elt *)
(** The type of the set elements. *)
type 'elt t
(** The type of sets. *)
val empty: 'elt t
(** The empty set. *)
val is_empty: 'elt t -> bool
(** Test whether a set is empty or not. *)
val mem: 'elt -> 'elt t -> bool
(** [mem x s] tests whether [x] belongs to the set [s]. *)
val add: 'elt -> 'elt t -> 'elt t
(** [add x s] returns a set containing all elements of [s],
plus [x]. If [x] was already in [s], [s] is returned unchanged. *)
val singleton: 'elt -> 'elt t
(** [singleton x] returns the one-element set containing only [x]. *)
val remove: 'elt -> 'elt t -> 'elt t
(** [remove x s] returns a set containing all elements of [s],
except [x]. If [x] was not in [s], [s] is returned unchanged. *)
val union: 'elt t -> 'elt t -> 'elt t
(** Set union. *)
val inter: 'elt t -> 'elt t -> 'elt t
(** Set intersection. *)
(** Set difference. *)
val diff: 'elt t -> 'elt t -> 'elt t
val compare: 'elt t -> 'elt t -> int
(** Total ordering between sets. Can be used as the ordering function
for doing sets of sets. *)
val equal: 'elt t -> 'elt t -> bool
(** [equal s1 s2] tests whether the sets [s1] and [s2] are
equal, that is, contain equal elements. *)
val subset: 'elt t -> 'elt t -> bool
(** [subset s1 s2] tests whether the set [s1] is a subset of
the set [s2]. *)
val iter: ('elt -> unit) -> 'elt t -> unit
(** [iter f s] applies [f] in turn to all elements of [s].
The elements of [s] are presented to [f] in increasing order
with respect to the ordering over the type of the elements. *)
val fold: ('elt -> 'a -> 'a) -> 'elt t -> 'a -> 'a
(** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)],
where [x1 ... xN] are the elements of [s], in increasing order. *)
val for_all: ('elt -> bool) -> 'elt t -> bool
(** [for_all p s] checks if all elements of the set
satisfy the predicate [p]. *)
val exists: ('elt -> bool) -> 'elt t -> bool
(** [exists p s] checks if at least one element of
the set satisfies the predicate [p]. *)
val filter: ('elt -> bool) -> 'elt t -> 'elt t
(** [filter p s] returns the set of all elements in [s]
that satisfy predicate [p]. *)
val partition: ('elt -> bool) -> 'elt t -> 'elt t * 'elt t
(** [partition p s] returns a pair of sets [(s1, s2)], where
[s1] is the set of all the elements of [s] that satisfy the
predicate [p], and [s2] is the set of all the elements of
[s] that do not satisfy [p]. *)
val cardinal: 'elt t -> int
(** Return the number of elements of a set. *)
val elements: 'elt t -> 'elt list
(** Return the list of all elements of the given set.
The returned list is sorted in increasing order with respect
to the ordering [Ord.compare], where [Ord] is the argument
given to {!Set.Make}. *)
val min_elt: 'elt t -> 'elt
(** Return the smallest element of the given set
(with respect to the [Ord.compare] ordering), or raise
[Not_found] if the set is empty. *)
val max_elt: 'elt t -> 'elt
(** Same as {!Set.S.min_elt}, but returns the largest element of the
given set. *)
val choose: 'elt t -> 'elt
(** Return one element of the given set, or raise [Not_found] if
the set is empty. Which element is chosen is unspecified,
but equal elements will be chosen for equal sets. *)
val split: 'elt -> 'elt t -> 'elt t * bool * 'elt t
(** [split x s] returns a triple [(l, present, r)], where
[l] is the set of elements of [s] that are
strictly less than [x];
[r] is the set of elements of [s] that are
strictly greater than [x];
[present] is [false] if [s] contains no element equal to [x],
or [true] if [s] contains an element equal to [x]. *)
val of_list: 'elt list -> 'elt t
(*
end
(** Output signature of the functor {!Set.Make}. *)
module Make (Ord : OrderedType) : S with type elt = Ord.t
(** Functor building an implementation of the set structure
given a totally ordered type. *)
*)