Add poc files

Makefile

@@ -0,0 +1,262 @@
+#############################################################################
+# Configuration section
+#############################################################################
+
+-include Makefile.config
+
+##############################################################################
+# Variables
+##############################################################################
+TOP:=$(shell pwd)
+
+SRC=find_source.ml
+
+TARGET=pfff
+
+#------------------------------------------------------------------------------
+# Program related variables
+#------------------------------------------------------------------------------
+
+PROGS=pfff
+
+#PROGS+=pfff_test
+
+OPTPROGS= $(PROGS:=.opt)
+
+#------------------------------------------------------------------------------
+#package dependencies
+#------------------------------------------------------------------------------
+
+#format: XXXDIR, XXXCMD, XXXCMDOPT, XXXINCLUDE (if different XXXDIR), XXXCMA
+#template:
+#  ifeq ($(FEATURE_XXX), 1)
+#  XXXDIR=xxx
+#  XXXCMD= $(MAKE) -C xxx &&  $(MAKE) xxx -C commons
+#  XXXCMDOPT= $(MAKE) -C xxx &&  $(MAKE) xxx.opt -C commons
+#  XXXCMA=xxx/xxx.cma  commons/commons_xxx.cma
+#  XXXSYSCMA=xxx.cma
+#  XXXINCLUDE=xxx
+#  else
+#  XXXCMD=
+#  XXXCMDOPT=
+#  endif
+
+
+# should be FEATURE_OCAMLGRAPH, or should give dependencies between features
+
+JSONDIR=external/jsonwheel
+JSONCMA=external/jsonwheel/jsonwheel.cma
+#------------------------------------------------------------------------------
+# Main variables
+#------------------------------------------------------------------------------
+BASICSYSLIBS=nums.cma bigarray.cma str.cma unix.cma
+
+# used for sgrep and other small utilities which I dont want to depend
+# on too much things
+BASICLIBS=commons/commons.cma \
+ commons_core/commons_core.cma \
+ $(JSONCMA) \
+ globals/lib.cma \
+ h_program-lang/lib.cma \
+ lang_cpp/parsing/lib.cma \
+ lang_c/parsing/lib.cma
+
+#       commons/commons_features.cma \
+
+SYSLIBS=nums.cma bigarray.cma str.cma unix.cma
+SYSLIBS+=$(OCAMLCOMPILERCMA)
+
+# use for the other programs
+LIBS= commons/commons.cma \
+    commons_core/commons_core.cma \
+	$(JSONCMA) \
+    globals/lib.cma \
+	h_files-format/lib.cma \
+	h_program-lang/lib.cma \
+    lang_cpp/parsing/lib.cma \
+    lang_c/parsing/lib.cma \
+
+MAKESUBDIRS=commons commons_core \
+  $(JSONDIR) \
+  globals \
+  h_files-format \
+  h_program-lang \
+  lang_cpp/parsing \
+  lang_c/parsing \
+
+INCLUDEDIRS=$(MAKESUBDIRS)
+
+PP=-pp "cpp $(CLANG_HACK) -DFEATURE_BYTECODE=$(FEATURE_BYTECODE) -DFEATURE_CMT=$(FEATURE_CMT)"
+
+##############################################################################
+# Generic
+##############################################################################
+-include $(TOP)/Makefile.common
+
+##############################################################################
+# Top rules
+##############################################################################
+
+.PHONY:: all clean distclean
+
+#note: old: was before all: rec $(EXEC) ... but can not do that cos make -j20
+#could try to compile $(EXEC) before rec. So here force sequentiality.
+
+all:: Makefile.config
+	$(MAKE) rec
+	$(MAKE) $(PROGS)
+
+opt:
+	$(MAKE) rec.opt
+	$(MAKE) $(OPTPROGS)
+all.opt: opt
+
+
+#	$(MAKE) features -C commons
+#	$(MAKE) features.opt -C commons
+
+rec:
+	$(MAKE) -C commons
+	set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i all || exit 1; done
+
+rec.opt:
+	$(MAKE) all.opt -C commons
+	set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i all.opt || exit 1; done
+
+$(TARGET): $(BASICLIBS) $(OBJS) main.cmo
+	$(OCAMLC) $(BYTECODE_STATIC) -o $@ $(SYSLIBS) $^
+
+$(TARGET).opt: $(BASICLIBS:.cma=.cmxa) $(OPTOBJS) main.cmx
+	$(OCAMLOPT) $(STATIC) -o $@ $(SYSLIBS:.cma=.cmxa)  $^
+
+
+$(TARGET).top: $(LIBS) $(OBJS)
+	$(OCAMLMKTOP) -o $@ $(SYSLIBS) threads.cma $^
+
+
+clean::
+	rm -f $(TARGET)
+clean::
+	rm -f $(TARGET).top
+clean::
+	set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i clean; done
+clean::
+	rm -f *.opt
+
+depend::
+	set -e; for i in $(MAKESUBDIRS); do echo $$i; $(MAKE) -C $$i depend; done
+
+Makefile.config:
+	@echo "Makefile.config is missing. Have you run ./configure?"
+	@exit 1
+
+
+distclean:: clean
+	set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i $@; done
+	rm -f .depend
+	rm -f Makefile.config
+	rm -f globals/config_pfff.ml
+	rm -f TAGS
+#	find -name ".#*1.*" | xargs rm -f
+
+# add -custom so dont need add e.g. ocamlbdb/ in LD_LIBRARY_PATH
+CUSTOM=-custom
+
+static:
+	rm -f $(EXEC).opt $(EXEC)
+	$(MAKE) STATIC="-ccopt -static" $(EXEC).opt
+	cp $(EXEC).opt $(EXEC)
+
+purebytecode:
+	rm -f $(EXEC).opt $(EXEC)
+	$(MAKE) BYTECODE_STATIC="" $(EXEC)
+
+#------------------------------------------------------------------------------
+# codegraph (was pm_depend)
+#------------------------------------------------------------------------------
+
+pfff_test: $(LIBS) $(OBJS) main_test.cmo
+	$(OCAMLC) $(CUSTOM) -o $@ $(SYSLIBS) $^
+pfff_test.opt: $(LIBS:.cma=.cmxa) $(OPTOBJS) main_test.cmx
+	$(OCAMLOPT) $(STATIC) -o $@ $(SYSLIBS:.cma=.cmxa) $^
+clean::
+	rm -f pfff_test
+
+tests:
+	$(MAKE) rec && $(MAKE) pfff_test
+	./pfff_test -verbose all
+test:
+	make tests
+
+##############################################################################
+# Build documentation
+##############################################################################
+.PHONY:: docs
+
+##############################################################################
+# Install
+##############################################################################
+
+VERSION=$(shell cat globals/config_pfff.ml.in |grep version |perl -p -e 's/.*"(.*)".*/$$1/;')
+
+# note: don't remove DESTDIR, it can be set by package build system like ebuild
+install: all
+	mkdir -p $(DESTDIR)$(BINDIR)
+	mkdir -p $(DESTDIR)$(SHAREDIR)
+	cp -a $(PROGS) $(DESTDIR)$(BINDIR)
+	cp -a data $(DESTDIR)$(SHAREDIR)
+	@echo ""
+	@echo "You can also install pfff by copying the programs"
+	@echo "available in this directory anywhere you want and"
+	@echo "give it the right options to find its configuration files."
+
+uninstall:
+	rm -rf $(DESTDIR)$(SHAREDIR)/data
+
+
+INSTALL_SUBDIRS= \
+  commons \
+  lang_cpp/parsing
+
+LIBNAME=pfff
+install-findlib:: all all.opt
+	ocamlfind install $(LIBNAME) META
+	set -e; for i in $(INSTALL_SUBDIRS); do echo $$i; $(MAKE) -C $$i install-findlib; done
+
+uninstall-findlib::
+	set -e; for i in $(INSTALL_SUBDIRS); do echo $$i; $(MAKE) -C $$i uninstall-findlib; done
+
+version:
+	@echo $(VERSION)
+
+
+install-bin:
+	cp $(PROGS) ../pfff-binaries/mac
+
+##############################################################################
+# Package rules
+##############################################################################
+
+PACKAGE=$(TARGET)-$(VERSION)
+TMP=/tmp
+
+package:
+	make srctar
+
+srctar:
+	make clean
+	cp -a .  $(TMP)/$(PACKAGE)
+	cd $(TMP); tar cvfz $(PACKAGE).tgz  --exclude=CVS --exclude=_darcs  $(PACKAGE)
+	rm -rf  $(TMP)/$(PACKAGE)
+
+#todo? automatically build binaries for Linux, Windows, etc?
+#http://stackoverflow.com/questions/2689813/cross-compile-windows-64-bit-exe-from-linux
+
+# making an OPAM package:
+# - git push from pfff to github
+# - make a new release on github: https://github.com/facebook/pfff/releases
+# - get md5sum of new archive
+# - update opam file in opam-repository/pfff-xxx/
+# - test locally?
+# - commit, git push
+# - do pull request on github

Makefile.common

@@ -0,0 +1,170 @@
+# -*- makefile -*-
+
+##############################################################################
+# Prelude 
+##############################################################################
+
+# This file assumes the "includer" has set a few variables and then has done a
+# include Makefile.common. Here are those variables:
+#  - TOP
+#  - SRC
+#  - INCLUDEDIRS
+
+# For literate programming, it also assumes a few variables:
+#  - SRCNW
+#  - TEXMAIN
+#  - TEX
+
+# For (un)installation, it assumes:
+#  - LIBNAME
+
+# this can set extra flags like -bin-annot that we want to be everywhere
+-include $(TOP)/Makefile.config
+# this can set extra flags like -warn-error
+-include $(TOP)/Makefile.user
+
+##############################################################################
+# Generic variables
+##############################################################################
+
+INCLUDES?=$(INCLUDEDIRS:%=-I %) $(SYSINCLUDES)
+
+OBJS?=    $(SRC:.ml=.cmo)
+OPTOBJS?= $(SRC:.ml=.cmx)
+
+
+##############################################################################
+# Generic ocaml variables
+##############################################################################
+
+#dont use -custom, it makes the bytecode unportable.
+
+#-4  allow | _ patterns in match
+#-6  allow omit labels
+#-29 alow multiline strings
+#-45 allow shadowing open (TODO: fix them though)
+#-41 allow ambiguous constructor in 2 opned modules (TODO: fix them though)
+#-44 allow shadow module identifier (TODO: fix them)
+#-48 allow eliminating optional arguments, unclear how to fix without wide
+#    changes
+ifeq "$(wildcard $(TOP)/.git)" ""
+WARNING_FLAGS?=-w +A-4-29-6-45-41-44-48
+else
+WARNING_FLAGS?=-w +A-4-29-6-45-41-44-48
+endif
+
+OCAMLCFLAGS=-g -thread -dtypes $(WARNING_FLAGS) $(OCAMLCFLAGS_EXTRA) 
+
+# This flag is also used in subdirectories so don't change its name here
+# the -w y is to silence errors on the visitor_xxx files with the unused
+# variable false positive
+OPTFLAGS?=-thread -g -w y
+
+OCAMLC=ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(PP) $(INCLUDES)
+OCAMLOPT=ocamlopt$(OPTBIN) $(OPTFLAGS) $(PP) $(INCLUDES)
+OCAMLLEX=ocamllex #-ml # -ml for debugging lexer, but slightly slower
+OCAMLYACC=ocamlyacc -v
+OCAMLDEP=ocamldep $(PP) $(INCLUDES)
+OCAMLMKTOP=ocamlmktop -g -custom $(INCLUDES) -thread
+
+# can also be set via 'make static'
+STATIC= #-ccopt -static
+
+# can also be unset via 'make purebytecode'
+BYTECODE_STATIC=-custom
+
+##############################################################################
+# Top rules
+##############################################################################
+all::
+
+##############################################################################
+# Generic Literate programming variables
+##############################################################################
+
+SYNCFLAGS=-md5sum_in_auxfile -less_marks
+
+SYNCWEB=~/github/syncweb/syncweb $(SYNCFLAGS)
+NOWEB=~/github/syncweb/scripts/noweblatex
+OCAMLDOC=ocamldoc $(INCLUDES)
+
+PDFLATEX=pdflatex --shell-escape 
+
+lpclean::
+	rm -f *.aux *.toc *.log *.brf *.out
+
+##############################################################################
+# Developer rules
+##############################################################################
+
+#old: otags -no-mli-tags -r  .  but does not work very well
+# better to use my own tagger :)
+otags:
+	echo "you should use pfff_tags"
+
+ovisual:
+	echo "you should use pfff_visual"
+
+distclean::
+	rm -f TAGS
+
+DOTCOLORS=green,darkgoldenrod2,cyan,red,magenta,yellow,burlywood1,aquamarine,purple,lightpink,salmon,mediumturquoise,black,slategray3
+
+dot:
+	$(OCAMLDOC) -I +threads $(SRC) -dot -dot-reduce \
+	   -dot-colors $(DOTCOLORS)
+	dot -Tps ocamldoc.out > dot.ps
+	mv dot.ps Fig_graph_ml.ps
+	ps2pdf Fig_graph_ml.ps
+	rm -f Fig_graph_ml.ps
+
+doti:
+	$(OCAMLDOC) -I +threads $(SRC:.ml=.mli) -dot
+	dot -Tps ocamldoc.out > dot.ps
+	mv dot.ps Fig_graph_mli.ps
+	ps2pdf Fig_graph_mli.ps
+	rm -f Fig_graph_mli.ps
+
+##############################################################################
+# Install
+##############################################################################
+
+uninstall-findlib::
+	ocamlfind remove $(LIBNAME)
+
+reinstall-findlib:
+	$(MAKE) uninstall-findlib
+	$(MAKE) install-findlib
+
+##############################################################################
+# Generic ocaml rules
+##############################################################################
+
+.SUFFIXES: .ml .mli .cmo .cmi .cmx .cmt
+
+.ml.cmo:
+	$(OCAMLC)  -c $<
+.mli.cmi:
+	$(OCAMLC)  -c $<
+.ml.cmx:
+	$(OCAMLOPT)  -c $<
+
+.ml.mldepend: 
+	$(OCAMLC) -i $<
+
+clean::
+	rm -f *.cm[ioxa] *.cmt* *.o *.a *.cmxa *.annot
+	rm -f *~ .*~ *.exe gmon.out #*#
+
+clean::
+	rm -f *.aux *.toc *.log *.brf *.out
+
+distclean::
+	rm -f .depend
+
+beforedepend::
+
+depend:: beforedepend
+	$(OCAMLDEP) *.mli *.ml > .depend
+
+-include .depend

Makefile.config

@@ -0,0 +1,24 @@
+# autogenerated by configure
+
+# Where to install the binary
+BINDIR=/usr/local/bin
+
+# Where to install the man pages
+MANDIR=/usr/local/man
+
+# Where to install the lib
+LIBDIR=/usr/local/lib
+
+# Where to install the configuration files
+SHAREDIR=/usr/local/share/pfff
+
+# Features
+FEATURE_VISUAL=1
+FEATURE_FACEBOOK=0
+
+FEATURE_BYTECODE=1
+FEATURE_CMT=0
+
+OPTBIN=.opt
+OCAMLCFLAGS_EXTRA=-bin-annot -absname
+OCAMLVERSION=4050

commons/.depend

@@ -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 :

commons/META

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

commons/Makefile

@@ -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

commons/Makefile.common

@@ -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

commons/authors.txt

@@ -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.

commons/common.mli

@@ -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
+

commons/copyright.txt

@@ -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.
+

commons/credits.txt

@@ -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)

commons/deprecated/Makefile.old

@@ -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
+

commons/deprecated/backtrace.ml

@@ -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;
+  ]

commons/deprecated/backtrace_c.c

@@ -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;
+}

commons/deprecated/sexp_common.ml

@@ -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

commons/dumper.ml

@@ -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)

commons/dumper.mli

@@ -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

commons/file_type.ml

@@ -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
+  *)

commons/file_type.mli

@@ -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 *)

commons/license.txt

@@ -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!

commons/map_.ml

@@ -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 []

commons/map_.mli

@@ -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

commons/oUnit.ml

@@ -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

commons/oUnit.mli

@@ -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

commons/ocaml.ml

@@ -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

commons/ocaml.mli

@@ -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

commons/readme.txt

@@ -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.
+

commons/set_.ml

@@ -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
+
+
+

commons/set_.mli

@@ -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. *)
+*)

commons_core/.depend

@@ -0,0 +1,8 @@
+ANSITerminal.cmo : ANSITerminal.cmi
+ANSITerminal.cmx : ANSITerminal.cmi
+ANSITerminal.cmi :
+console.cmo : ../commons/common2.cmi ../commons/common.cmi ANSITerminal.cmi \
+    console.cmi
+console.cmx : ../commons/common2.cmx ../commons/common.cmx ANSITerminal.cmx \
+    console.cmi
+console.cmi :

commons_core/ANSITerminal.ml

@@ -0,0 +1,219 @@
+(* File: ANSITerminal.ml
+   Allow colors, cursor movements, erasing,... under Unix and DOS shells.
+   *********************************************************************
+
+   Copyright 2004 by Troestler Christophe
+   Christophe.Troestler(at)umh.ac.be
+
+   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.
+
+   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 for more details.
+*)
+(** See the file ctlseqs.html (unix)
+    and (for DOS) http://www.ka.net/jmenees/Dos/Ansi.htm
+ *)
+
+
+open Printf
+
+(* Erasing *)
+
+type loc = Above | Below | Screen
+
+let erase = function
+  | Above -> print_string "\027[1J"
+  | Below -> print_string "\027[0J"
+  | Screen -> print_string "\027[2J"
+
+
+(* Cursor *)
+
+let set_cursor x y =
+  if x <= 0 then (if y > 0 then printf "\027[%id" y)
+  else (* x > 0 *) if y <= 0 then printf "\027[%iG" x
+  else printf "\027[%i;%iH" y x
+
+let move_cursor x y =
+  if x > 0 then printf "\027[%iC" x
+  else if x < 0 then printf "\027[%iD" (-x);
+  if y > 0 then printf "\027[%iB" y
+  else if y < 0 then printf "\027[%iA" (-y)
+
+let save_cursor () = print_string "\027[s"
+let restore_cursor () = print_string "\027[u"
+
+(* Scrolling *)
+
+let scroll lines =
+  if lines > 0 then printf "\027[%iS" lines
+  else if lines < 0 then printf "\027[%iT" (- lines)
+
+(* Colors *)
+
+let autoreset = ref true
+
+let set_autoreset b = autoreset := b
+
+
+type color =
+    Black | Red | Green | Yellow | Blue | Magenta | Cyan | White | Default
+
+type style =
+  | Reset | Bold | Underlined | Blink | Inverse | Hidden
+  | Foreground of color
+  | Background of color
+
+let black = Foreground Black
+let red = Foreground Red
+let green = Foreground Green
+let yellow = Foreground Yellow
+let blue = Foreground Blue
+let magenta = Foreground Magenta
+let cyan = Foreground Cyan
+let white = Foreground White
+let default = Foreground Default
+
+let on_black = Background Black
+let on_red = Background Red
+let on_green = Background Green
+let on_yellow = Background Yellow
+let on_blue = Background Blue
+let on_magenta = Background Magenta
+let on_cyan = Background Cyan
+let on_white = Background White
+let on_default = Background Default
+
+let style_to_string = function
+  | Reset -> "0"
+  | Bold -> "1"
+  | Underlined -> "4"
+  | Blink -> "5"
+  | Inverse -> "7"
+  | Hidden -> "8"
+  | Foreground Black -> "30"
+  | Foreground Red -> "31"
+  | Foreground Green -> "32"
+  | Foreground Yellow -> "33"
+  | Foreground Blue -> "34"
+  | Foreground Magenta -> "35"
+  | Foreground Cyan -> "36"
+  | Foreground White -> "37"
+  | Foreground Default -> "39"
+  | Background Black -> "40"
+  | Background Red -> "41"
+  | Background Green -> "42"
+  | Background Yellow -> "43"
+  | Background Blue -> "44"
+  | Background Magenta -> "45"
+  | Background Cyan -> "46"
+  | Background White -> "47"
+  | Background Default -> "49"
+
+
+let print_string style txt =
+  print_string "\027[";
+  let s = String.concat ";" (List.map style_to_string style) in
+  print_string s;
+  print_string "m";
+  print_string txt;
+  if !autoreset then print_string "\027[0m"
+
+
+let printf style = kprintf (print_string style)
+
+
+
+(* On DOS & windows, to enable the ANSI sequences, ANSI.SYS should be
+   loaded in C:\CONFIG.SYS with a line of the type
+
+   DEVICE = C:\DOS\ANSI.SYS
+   DEVICEHIGH=C:\WINDOWS\COMMAND\ANSI.SYS
+
+   This routine checks whether the line is present and, if not, it
+   inserts it and tells the user to reboot.
+
+   On WINNT, one will create a ANSI.NT in the user dir and a
+   command.com link on the desktop (with Configfilename = our ANSI.NT)
+   and tell the user to use it.
+
+   REM: that does NOT work under winxp because OCaml programs are not
+   considered to run in DOS mode only...
+
+   http://support.microsoft.com/default.aspx?scid=kb;en-us;816179
+   http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dllproc/base/console_functions.asp
+*)
+
+
+(* let is_readable file = *)
+(*   try close_in(open_in file); true *)
+(*   with Sys_error _ -> false *)
+
+(* let config_sys = "C:\\CONFIG.SYS" *)
+(* exception OK *)
+
+(* let win9x () = *)
+(*   (\* Locate ANSI.SYS *\) *)
+(*   let ansi_sys = List.find is_readable [ *)
+(*     "C:\\DOS\\ANSI.SYS"; *)
+(*     "C:\\WINDOWS\\COMMAND\\ANSI.SYS"; ] in *)
+(*   (\* Parse CONFIG.SYS to see wether it has the right line *\) *)
+(*   try *)
+(*     let re = Str.regexp_case_fold *)
+(*                ("^DEVICE\\(HIGH\\)?[ \t]*=[ \t]*" ^ ansi_sys ^ "[ \t]*$") in *)
+(*     let fh = open_in config_sys in *)
+(*     begin try *)
+(*       while true do *)
+(*         if Str.string_match re (input_line fh) 0 then raise OK *)
+(*       done *)
+(*     with *)
+(*     | End_of_file -> *)
+(*         (\* Correct line not found: add it *\) *)
+(*         close_in fh; *)
+(*         raise(Sys_error "win9x") *)
+(*     | OK -> close_in fh (\* Correct line found, keep going *\) *)
+(*     end *)
+(*   with Sys_error _ -> *)
+(*     (\* config_sys not does not exists or does not contain the right line. *\) *)
+(*     let fh = open_out_gen [Open_wronly; Open_append; Open_creat; Open_text] *)
+(*                0x777 config_sys in *)
+(*     output_string fh ("DEVICEHIGH=" ^ ansi_sys ^ "\n"); *)
+(*     close_out fh; *)
+(*     prerr_endline "Please restart your computer and rerun the program."; *)
+(*     exit 1 *)
+
+
+
+(* let winnt home = *)
+(*   (\* Locate ANSI.SYS *\) *)
+(*   let system = *)
+(*     try Sys.getenv "SystemRoot" *)
+(*     with Not_found -> "C:\\WINDOWS" in *)
+(*   let ansi_sys = *)
+(*     List.find is_readable (List.map (fun s -> Filename.concat system s) *)
+(*                              [ "SYSTEM32\\ANSI.SYS"; ]) in *)
+(*   (\* Create an ANSI.SYS file in the user dir *\) *)
+(*   let ansi_nt = Filename.concat home "ANSI.NT" in *)
+(*   let fh = open_out ansi_nt in *)
+(*   output_string fh "dosonly\ndevice="; *)
+(*   output_string fh ansi_sys; *)
+(*   output_string fh "\ndevice=%SystemRoot%\\system32\\himem.sys *)
+(* files=40 *)
+(* dos=high, umb *)
+(* " ; *)
+(*   close_out fh; *)
+(*   (\* Make a command.com link on the desktop *\) *)
+(*   let fh = open_out (Filename.concat home "command.lnk") in *)
+(*   close_out fh *)
+
+
+(* let () = *)
+(*   if Sys.os_type = "Win32" then begin *)
+(*     try  winnt(Sys.getenv "USERPROFILE")  (\* WinNT, Win2000, WinXP *\) *)
+(*     with Not_found -> win9x() (\* Win9x *\) *)
+(*   end *)

commons_core/ANSITerminal.mli

@@ -0,0 +1,107 @@
+(* File: ANSITerminal.mli
+
+   Copyright 2004 Troestler Christophe
+   Christophe.Troestler(at)umh.ac.be
+
+   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.
+
+   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 for more details.
+*)
+(** This module offers basic control of ANSI compliant terminals.
+
+  @author Christophe Troestler
+  @version 0.3
+*)
+
+(** {2 Color} *)
+
+type color =
+  | Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
+  | Default (** Default color of the terminal *)
+
+(** Various styles for the text.  [Blink] and [Hidden] may not work on
+    every terminal. *)
+type style =
+  | Reset
+  | Bold | Underlined | Blink | Inverse | Hidden
+  | Foreground of color
+  | Background of color
+
+val black : style	(** Shortcut for [Foreground Black] *)
+val red : style 	(** Shortcut for [Foreground Red] *)
+val green : style	(** Shortcut for [Foreground Green] *)
+val yellow : style	(** Shortcut for [Foreground Yellow] *)
+val blue : style	(** Shortcut for [Foreground Blue] *)
+val magenta : style	(** Shortcut for [Foreground Magenta] *)
+val cyan : style	(** Shortcut for [Foreground Cyan] *)
+val white : style	(** Shortcut for [Foreground White] *)
+val default : style	(** Shortcut for [Foreground Default] *)
+
+val on_black : style	(** Shortcut for [Background Black] *)
+val on_red : style 	(** Shortcut for [Background Red] *)
+val on_green : style	(** Shortcut for [Background Green] *)
+val on_yellow : style	(** Shortcut for [Background Yellow] *)
+val on_blue : style	(** Shortcut for [Background Blue] *)
+val on_magenta : style	(** Shortcut for [Background Magenta] *)
+val on_cyan : style	(** Shortcut for [Background Cyan] *)
+val on_white : style	(** Shortcut for [Background White] *)
+val on_default : style	(** Shortcut for [Background Default] *)
+
+val set_autoreset : bool -> unit
+  (** Turns the autoreset feature on and off.  It defaults to on. *)
+
+val print_string : style list -> string -> unit
+  (** [print_string attr txt] prints the string [txt] with the
+    attibutes [attr].  After printing, the attributes are
+    automatically reseted to the defaults, unless autoreset is turned
+    off. *)
+
+val printf : style list -> ('a, unit, string, unit) format4 -> 'a
+  (** [printf attr format arg1 ... argN] prints the arguments
+    [arg1],...,[argN] according to [format] with the attibutes [attr].
+    After printing, the attributes are automatically reseted to the
+    defaults, unless autoreset is turned off. *)
+
+
+(** {2 Erasing} *)
+
+type loc = Above | Below | Screen
+
+val erase : loc -> unit
+  (** [erase Above] erases everything before the position of the cursor.
+    [erase Below] erases everything after the position of the cursor.
+    [erase Screen] erases the whole screen.
+  *)
+
+
+(** {2 Cursor} *)
+
+val set_cursor : int -> int -> unit
+  (** [set_cursor x y] puts the cursor at position [(x,y)], [x]
+    indicating the column (the leftmost one being 1) and [y] being the
+    line (the topmost one being 1).  If [x <= 0], the [x] coordinate
+    is unchanged; if [y <= 0], the [y] coordinate is unchanged.  *)
+
+val move_cursor : int -> int -> unit
+  (** [move_cursor x y] moves the cursor by [x] columns (to the right
+    if [x > 0], to the left if [x < 0]) and by [y] lines (downwards if
+    [y > 0] and upwards if [y < 0]). *)
+
+val save_cursor : unit -> unit
+  (** [save_cursor()] saves the current position of the cursor. *)
+val restore_cursor : unit -> unit
+  (** [restore_cursor()] replaces the cursor to the position saved
+    with [save_cursor()]. *)
+
+
+(** {2 Scrolling} *)
+
+val scroll : int -> unit
+  (** [scroll n] scrolls the terminal by [n] lines, up (creating new
+    lines at the bottom) if [n > 0] and down if [n < 0]. *)

commons_core/META

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

commons_core/Makefile

@@ -0,0 +1,19 @@
+##############################################################################
+# Variables
+##############################################################################
+
+-include ../Makefile.config
+
+INCLUDEDIRS=../commons
+
+LIBNAME=commons_core
+
+SRC=ANSITerminal.ml console.ml
+
+
+EXPORTSRC=$(SRC:%.ml=%.mli)
+
+OCAMLMKLIB=ocamlc -a
+OCAMLMKLIBOPT=ocamlopt -a
+
+-include ../commons/Makefile.common

commons_core/console.ml

@@ -0,0 +1,93 @@
+(* used to be called common_extra.ml *)
+
+(* 
+ * How to use it ? ex in LFS:
+ *  Console.progress (w.prop_iprop#length) (fun k ->
+ *  w.prop_iprop#iter (fun (p, ip) -> 
+ *     k ();
+ *     ...
+ *  ));
+ * 
+ * todo: Unix.isatty, and the spinner trick of jason \ | / -
+ *)
+
+let execute_and_show_progress ~show len f = 
+  let _count = ref 0 in
+  (* kind of continuation passed to f *)
+  let continue_pourcentage () = 
+    incr _count;
+    ANSITerminal.set_cursor 1 (-1);
+    ANSITerminal.printf [] "%d / %d" !_count len; flush stdout;
+  in
+  let nothing () = () in 
+
+  (* ANSITerminal.printf [] "0 / %d" len; flush stdout; *)
+  (if !Common2._batch_mode || not show
+  then f nothing
+  else f continue_pourcentage
+  );
+  Common.pr2 ""
+
+
+let execute_and_show_progress2 ?(show=true) len f = 
+  let _count = ref 0 in
+  (* kind of continuation passed to f *)
+  let continue_pourcentage () = 
+    incr _count;
+    ANSITerminal.set_cursor 1 (-1);
+    ANSITerminal.printf [] "%d / %d" !_count len; flush stdout;
+  in
+  let nothing () = () in 
+
+  (* ANSITerminal.printf [] "0 / %d" len; flush stdout; *)
+  if !Common2._batch_mode || not show
+  then f nothing
+  else f continue_pourcentage
+
+let with_progress_list_metter ?show fk xs =
+  let len = List.length xs in
+  execute_and_show_progress2 ?show len 
+    (fun k -> fk k xs)
+
+let progress ?show fk xs = 
+  with_progress_list_metter ?show fk xs
+
+
+(*
+(* old code
+let ansi_terminal = ref true *)
+
+let (_execute_and_show_progress_func:
+   (show:bool ->
+    int (* length *) -> ((unit -> unit) -> 'a) -> 'a) ref)
+ = ref
+  (fun ~show a b ->
+    failwith "no execute  yet, have you included common_extra.cmo?"
+  )
+
+let execute_and_show_progress ?(show=true) len f =
+    !_execute_and_show_progress_func ~show len f
+
+(* don't forget to call Common_extra.set_link () *)
+
+val _execute_and_show_progress_func :
+  (show:bool -> int (* length *) -> ((unit -> unit) -> unit) -> unit)
+  ref 
+val execute_and_show_progress : 
+ ?show:bool -> int (* length *) -> ((unit -> unit) -> unit) -> unit
+
+let set_link () = 
+  Common2._execute_and_show_progress_func := execute_and_show_progress
+
+
+let _init_execute = 
+  set_link ()
+
+
+*)
+
+(* now in common_extra.ml:
+ * let execute_and_show_progress len f = ...
+ *)
+
+

commons_core/console.mli

@@ -0,0 +1,14 @@
+(* to be used as in 
+ *  xs +> Common_extra.progress (fun k -> List.iter (fun x -> k(); ...))
+ *)
+val progress:
+  ?show:bool -> ((unit -> unit) -> 'a list -> 'b) -> 'a list -> 'b
+
+
+val execute_and_show_progress:
+  show:bool -> int -> ((unit -> unit) -> 'a) -> unit
+val execute_and_show_progress2:
+  ?show:bool -> int -> ((unit -> unit) -> 'a) -> 'a
+
+val with_progress_list_metter:
+  ?show:bool -> ((unit -> unit) -> 'a list -> 'b) -> 'a list -> 'b

commons_core/features.ml.in

@@ -0,0 +1,81 @@
+(* yes sometimes cpp is useful *)
+
+(* old:
+note: in addition to Makefile.config, globals/config.ml is also modified
+by configure
+features.ml: features.ml.cpp Makefile.config
+	cpp -DFEATURE_GUI=$(FEATURE_GUI) \
+            -DFEATURE_MPI=$(FEATURE_MPI) \
+	    -DFEATURE_PCRE=$(FEATURE_PCRE) \
+	   features.ml.cpp > features.ml
+
+clean::
+	rm -f features.ml
+
+beforedepend:: features.ml
+*)
+
+#if FEATURE_MPI==1
+
+module Distribution = struct
+  let map_reduce ?timeout ~fmap ~freduce c xs = 
+    Distribution.map_reduce ?timeout ~fmap ~freduce c xs
+
+  let map_reduce_lazy ?timeout ~fmap ~freduce c fxs = 
+    Distribution.map_reduce_lazy ?timeout ~fmap ~freduce c fxs
+
+
+  let under_mpirun () = 
+    Distribution.under_mpirun()
+
+  let set_debug_mpi () = 
+    Distribution.debug_mpi := true
+
+(* was only when use mpich and the ch4 module. with openmpi, no need.
+  let mpi_adjust_argv argv = 
+    Distribution.mpi_adjust_argv argv
+*)
+
+end
+
+#else 
+
+module Distribution = struct
+  let map_reduce ?timeout ~fmap:map_ex ~freduce:reduce_ex acc xs = 
+    let not_done = [] in
+    List.fold_left reduce_ex acc (List.map map_ex xs), not_done
+
+  let map_reduce_lazy ?timeout ~fmap:map_ex ~freduce:reduce_ex acc fxs = 
+    let xs = fxs() in (* changed code *)
+    let not_done = [] in
+    List.fold_left reduce_ex acc (List.map map_ex xs), not_done
+
+
+  let under_mpirun () = 
+    false
+      
+  let set_debug_mpi () = 
+    ()
+
+end
+
+#endif
+
+
+#if FEATURE_REGEXP_PCRE==1
+#else
+#endif
+
+#if FEATURE_BACKTRACE==1
+module Backtrace = struct
+ let print () = 
+   Backtrace.print ()
+end
+#else
+
+module Backtrace = struct
+ let print () = 
+   print_string "no backtrace support, use configure --with-backtrace\n"
+end
+
+#endif

commons_core/macro.ml4

@@ -0,0 +1,894 @@
+(******************************************************************************)
+(* TODO *)
+(******************************************************************************)
+
+(*
+ macro Or a la merd (try or_left with -> or_right)
+
+  Pcaml.str_item:
+    [ [ "type"; LIDENT "nogen"; tdl = LIST1 type_declaration SEP "and" ->
+          <:str_item< type $list:tdl$ >>
+      | "type"; tdl = LIST1 type_declaration SEP "and" ->
+          let sil = gen_ioxml_impl loc tdl in
+  Pcaml.sig_item:
+    [ [ "type"; LIDENT "nogen"; tdl = LIST1 type_declaration SEP "and" ->
+          <:sig_item< type $list:tdl$ >>
+      | "type"; tdl = LIST1 type_declaration SEP "and" ->
+need put too in sig_item ? 
+
+look in common.* to do more macro (and also in my docs/langage)
+   
+put the tricks i have in perl
+ aspect ==> need fix_caml ? or can do with camlp4 (i think yes, but complicated)
+ profiling mem/cpu/overhead/....
+ pr pr2 ....
+emacs tricks (C-M-1, ...)
+au moins pour le debug
+
+generalise my stuff so that it is easy to add functionnality
+ (kind of tools a la haskell je_sais_plus_lenom)
+
+
+faire meilleur lang
+ where
+ comprehension
+ [.. syntax (just from ...) do the desugar as in haskell)
+
+ `...` perhaps with help of lexer (can extend the lexer easily ?)
+ type class ?
+ layout ?
+ section
+ joly syntax pour les types ([], ())
+ autogenerated accessor function
+
+ \x -> ... NON visuellement dur a voir
+ my stuff with self fun ?
+ suppr let rec
+
+
+class Show par exemple, peut etre fait
+en passant en param a la function genere automatiquement 2 3 foncs
+ (genre string_of_var, connection_between, ...) ?
+can we make class stuff with my fix_caml ?
+ just need pass around the dictionnary
+
+pb let obj' = f obj
+ mieux obj = f obj
+ encore mieux macro, that "modify" obj
+  comme let obj ||= f
+  (ex ++ s'ecrirait let i ||= (+1)
+*)
+
+(******************************************************************************)
+(*
+   design interactivly: (=~ design and call macroexpand of lisp)
+     $~> ocaml
+     #load "camlp4o.cma";;
+     #load "pa_extend.cmo";;
+    add Extend rule, copy paste in interpreter
+    Grammar.Entry.parse expr (Stream.of_string "2 + 3");;
+      expr is already binded with the expr for caml
+    can use the exception tricks to display (as in exception Print of type_decl)
+
+   using p4 in p4 (with pattern that are quotation) is confusing
+    => better to do a violent match over the real Ast type
+
+   good example in pa_o.ml (defintion of caml grammar in p4)
+*)
+(******************************************************************************)
+(* 
+   compile it:
+    ocamlc -c -pp 'camlp4o pa_extend.cmo q_MLast.cmo -impl' -I +camlp4 -impl macro.ml4
+
+   test output:
+    camlp4o ./macro.cmo pr_o.cmo common.ml
+
+   use in file (handled by OcamlMakefile):
+    put at start of your file (*pp camlp4o ./macro.cmo *)
+    or manually compile with ocamlc -c -pp "camlp4o ./macro.cmo" -g my_file.ml
+*) 
+(******************************************************************************)
+
+open Pcaml
+open MLast
+
+
+(* same as in common *)
+let (+>) o f = f o
+
+let rec zip xs ys = 
+  match (xs,ys) with
+  | ([],_) -> []
+  | (_,[]) -> []
+  | (x::xs,y::ys) -> (x,y)::zip xs ys
+
+let foldl1 p = function x::xs -> List.fold_left p x xs | _ -> failwith "foldl1"
+
+let rec join_gen a = function
+  | [] -> []
+  | [x] -> [x]
+  | x::xs -> x::a::(join_gen a xs)
+
+let _counter = ref 0
+let counter () = (_counter := !_counter +1; !_counter)
+
+
+(* just cos dont want care about location and pass it around to each func *)
+(* old: let l = (1,1) *)
+let l = (Lexing.dummy_pos, Lexing.dummy_pos)
+
+(******************************************************************************)
+
+(* inspired by an example in the camlp4 tutorial
+   NEED recent version of camlp4 > 3.06+6 (available in the cvs only)
+
+   update=tywith do better ? ioXml do better ?
+   update: I made this a long time ago, maybe in 2001, long before
+   tywith, or typeconf, or sexplib, json-static. It was working but limited
+   to not too complex type, it has no object or module support I think. So
+   tywith/typeconf were definitely better (and generic).
+
+   It auto-genarate string_of_<name_type> and print_<name_type> function.
+   After defining a type, you can normally use the corresponding string_of function.
+   For polymorphic type, you need to pass as a parameter the string_of function
+    of the corresponding polymorphic variable
+
+   ex: 
+    from "type t = int * int"
+    it generates
+	let rec string_of_t a0 =
+	   match a0 with
+	    a24, a25 -> ((("(" ^ string_of_int a24) ^ ",") ^ string_of_int a25) ^ ")"
+	and print_t a = print_string (string_of_t a)
+
+    from "type ('a, 'b) either = Left of 'a | Right of 'b"
+    it generates
+	let rec string_of_either (str__of_a, str__of_b) a0 =
+	  match a0 with
+	    Left a24 -> (("Left" ^ "(") ^ str__of_a a24) ^ ")"
+	  | Right a26 -> (("Right" ^ "(") ^ str__of_b a26) ^ ")"
+	and print_either funs a = print_string (string_of_either funs a)
+
+
+
+  as i have not access to the source file of caml, you certainly have to put
+    in one of your source file those definitions: 
+
+         let string_of_list f xs = 
+           "[" ^ (xs +> List.map f +> String.concat ";" ) ^ "]"
+
+         let string_of_array f xs =
+           "[|" ^ (xs +> Array.to_list +> List.map f +> String.concat ";") ^ "|]"
+         
+         let string_of_option f = function
+           | None -> "None "
+           | Some x -> "Some " ^ (f x)
+         
+         let print_bool x = print_string (if x then  "True" else "False")
+         
+         let print_list pr xs = 
+           do { print_string "["; List.iter (fun x -> pr x; print_string ",") xs; print_string "]" }
+         
+         let print_option pr = function
+           | None -> print_string "None"
+           | Some x -> print_string "Some ("; pr x; print_string ")"
+
+
+
+*)
+
+(* COMMENT START
+let _ =
+  DELETE_RULE
+    Pcaml.str_item: "type"; LIST1 Pcaml.type_declaration SEP "and"
+  END;
+
+EXTEND
+      Pcaml.str_item:
+      [ [ "type"; tdl = LIST1 Pcaml.type_declaration SEP "and" ->
+
+	let name () = "a" ^ string_of_int (counter ()) in
+
+	(* subtil bug, when we have only one param, we cant construct a tuple with one param,
+	   we should think that (1) and 1 are treated the same way, but seems this work
+	   is done in caml in the parser, which mean that we must not give to caml an Ast with
+	   a 1-uple
+	*)
+	let ex_tuple = function
+	  | [] -> failwith "pb"
+	  | [x] -> x
+	  | xs -> ExTup (l,xs)
+	in
+	let pa_tuple = function
+	  | [] -> failwith "pb"
+	  | [x] -> x
+	  | xs -> PaTup (l,xs)
+	in
+
+	let funcs = tdl +> List.map (fun ((l,str), param_polymorphs, ctyp, z) -> 
+	  let join_app  xs = xs +> foldl1 (fun a e -> <:expr< $a$ ^ $e$>>) in
+	  let join_virg xs = xs +> join_gen (ExStr (l, ",")) in
+
+	  let name_module_func = function
+	    | TyLid (l, s)                           -> ExLid(l, "string_of_" ^ s)
+	    | TyAcc (_, TyUid (_,file), TyLid (_,s)) -> 
+              (*  Module.string_of ....
+		 ExAcc(l, ExUid (l,file), ExLid(l, "string_of_" ^ s)) 
+		but dont work that much cos builtin lib or modules have not those function
+	      *)
+		ExLid(l, String.lowercase file ^ "_" ^ "string_of_" ^ s)
+	    | _ -> failwith "pb"
+	  in
+	  (* TODOSTYLE? function fmatch id patt expr who put the None, ... *)
+	  let rec body_ctyp id = function
+	    | (TyLid (_) | TyAcc (_)) as c -> ExApp (l,name_module_func c, ExLid (l,id))
+              (* | TyUid of loc and string *)
+
+	    | TyQuo (l, s) -> ExApp (l, ExLid(l, "str__of_" ^ s), ExLid (l,id))
+	    | TySum (l,_bool, xs) ->
+		ExMat(l, ExLid (l, id),
+		      xs +> List.map (fun (l, s, ctyps) -> 
+			let newids = xs +> List.map (fun _ -> name ()) in
+			match ctyps, newids with
+			| ([],_) -> (PaUid(l, s), None, ExStr (l,s))
+			| (x::xs,id::ids) -> 
+			    let patt = zip xs ids +> 
+			      List.fold_left 
+				(fun a (e,id) -> PaApp (l, a, PaLid (l,id))) 
+				(PaApp (l, PaUid(l, s), PaLid(l, id))) in
+			    (patt, None,
+			     zip (x::xs) (id::ids) +> List.map (fun (e,id) -> body_ctyp id e) +> join_virg +> 
+			     (fun xs -> [ExStr (l,s); ExStr (l,"(")] @ xs @ [ExStr (l,")")]) +> join_app
+			    )
+			| _ -> failwith "pb"
+				     )	
+		     )
+	    | TyTup (l, xs) -> 
+		let newids = xs +> List.map (fun _ -> name ()) in
+		ExMat(l, ExLid (l,id), 
+		      [PaTup(l, newids +> List.map (fun id -> PaLid (l,id))),
+		      None, 
+		      zip xs newids +> List.map (fun (e,id) -> body_ctyp id e) +> join_virg +> 
+			(fun xs -> [ExStr (l,"(")] @ xs @ [ExStr (l,")")]) +> join_app
+		      ]	
+		     )
+	    | TyArr (l,c1,c2) -> ExStr(l, "<fun>")
+	    | TyApp (l,c1,c2) -> 
+		let rec extract_all_params acc = function
+		  | TyApp (l,c1', c2') -> extract_all_params (acc @ [c2']) c1'
+		  | x -> (x, acc) in
+		let (type_parameted, params) = extract_all_params [] (TyApp (l, c1, c2)) in
+		let funcs = params +> List.map (fun c -> 
+		  let id = name () in
+		  let f = body_ctyp id c in
+		  ExFun (l, [PaLid(l, id), None, f]))
+		in 
+		  (match type_parameted with
+		  |  (TyLid (_) | TyAcc (_)) as c -> 
+		      ExApp (l, ExApp (l, name_module_func c, ex_tuple funcs), ExLid (l,id))
+		  | _ -> ExStr (l,"<illegal syntax in type, should be a typeconst>")
+		  )
+	    | TyRec (l, _bool, xs) -> 
+		let newids = xs +> List.map (fun _ -> name ()) in
+		ExMat(l, ExLid (l, id),
+		      [ PaRec (l, zip xs newids +> List.map (fun ((_,e,_,_), id) -> PaLid(l, e), PaLid(l, id))),
+			None, 
+			zip xs newids 
+			  +> List.map 
+			    (fun ((l,s,_b,e),id) -> [ExStr(l,s); ExStr(l," = ");body_ctyp id e] +> join_app)
+			  +> join_virg 
+			  +> (fun xs -> [ExStr (l,"{")] @ xs @ [ExStr (l,"}")]) +> join_app
+		      ])
+
+	      (* TODO when needed
+	    | TyAli of loc and ctyp and ctyp
+	    | TyAny of loc
+	    | TyCls of loc and list string
+	    | TyLab of loc and string and ctyp
+	    | TyMan of loc and ctyp and ctyp
+	    | TyOlb of loc and string and ctyp
+	    | TyPol of loc and list string and ctyp
+	    | TyObj of loc and list (string * ctyp) and bool
+	    | TyVrn of loc and list row_field and option (option (list string)) 
+	      and row_field =
+	      | RfTag of string and bool and list ctyp
+	      | RfInh of ctyp 
+	      *)
+	    | _ -> (ExStr (l, "<not yet implemnted>"))
+
+	  in
+	  let f_str_func_params body = 
+	    (* currifie:
+	    param_polymorphs +> List.rev +> List.fold_left (fun acc (str_poly, (_,_)) -> 
+	      ExFun(l, [(PaLid (l, name_f_str_params str_poly),None, acc)]))
+	      body
+	    *)
+	    if  param_polymorphs = [] then body
+	    else ExFun (l, [pa_tuple 
+			       (param_polymorphs +> List.map (fun (str_poly,(_,_)) -> 
+				 PaLid (l, "str__of_" ^ str_poly))),
+			     None, body])
+	  in
+	  
+	  [(PaLid (l, "string_of_" ^ str), (* let string_of... *)
+	   f_str_func_params     (*  str__a str__b ... *)
+	      (ExFun(l, [(PaLid (l,"a0"), None,  (* a0 = .... *)
+			 (body_ctyp "a0" ctyp))])))    (*  match a with .... *)
+	      
+	   ;(PaLid (l, "print_" ^ str),
+	     (if param_polymorphs = [] 
+	     then fun e -> e
+	     else fun e -> (ExFun (l, [PaLid (l, "funs"), None, e]))
+	     )
+	       (ExFun (l, [(PaLid (l,"a")), None,
+			    ExApp (l, ExLid (l, "print_string"),
+				   if param_polymorphs = [] 
+				   then ExApp(l, ExLid (l, "string_of_" ^ str), ExLid (l, "a"))
+				   else ExApp (l, 
+					       ExApp (l, ExLid (l, "string_of_" ^ str), 
+						      ExLid (l, "funs")),
+					       ExLid (l, "a")))])))
+	  ])  
+	in
+	let recursif = true in
+	(StDcl (loc, [(StTyp (loc, tdl));StVal (loc, recursif, funcs +> List.flatten)]))
+]]
+      ;
+    END
+;;
+
+END COMMENT *)
+(*
+let x = Grammar.Entry.parse str_item (Stream.of_string "type synon = int * int")
+let x = Grammar.Entry.parse str_item (Stream.of_string "type 'a numdict =  C of ('a -> 'a)")
+let x = Grammar.Entry.parse str_item (Stream.of_string "type test = C1 of string * string | C2 and t2 = C3 | C4")
+let x = Grammar.Entry.parse str_item (Stream.of_string "type ('a,'b) test = C1 of 'a | C2 of 'b")
+let x = Grammar.Entry.parse str_item (Stream.of_string "type point = {x: int; y:int}")
+let x = Grammar.Entry.parse str_item (Stream.of_string "type ('a,'b) assoc  = ('a * 'b) list")
+let x = Grammar.Entry.parse str_item (Stream.of_string "type ('a,'b) vec  = ('a , 'b) assoc")
+let x = Grammar.Entry.parse str_item (Stream.of_string "type robot_list = robot IntMap.t")
+
+let x = Grammar.Entry.parse expr (Stream.of_string "match a with {x = a; y = b} -> a + b")
+let x = Grammar.Entry.parse expr (Stream.of_string "match a with (a,b,c,d) -> a + b + c + d")
+let x = Grammar.Entry.parse expr (Stream.of_string "match a with C1 (s, s2) -> s | C2 s -> s | C3 -> s")
+let x = Grammar.Entry.parse str_item (Stream.of_string "let rec fact x = if x = 0 then 1 else x * fact (x -1);; ")
+let x = Grammar.Entry.parse str_item (Stream.of_string "let print_toto f a  = function () -> ();; ")
+let x = Grammar.Entry.parse str_item (Stream.of_string "let print_toto f1 f2 a  = function () -> ();; ")
+let x = Grammar.Entry.parse str_item (Stream.of_string "let print_toto (f1,f2) a  = function () -> ();; ")
+let x = Grammar.Entry.parse str_item (Stream.of_string "let print_assoc (f1,f2) a0  = print_list (fun a -> function () -> ());; ")
+let x = Grammar.Entry.parse str_item (Stream.of_string "let print_assoc (f1,f2) a0  = IntMap.print_list (fun a -> function () -> ());; ")
+
+
+let x = Grammar.Entry.parse expr (Stream.of_string "1 + 1")
+let x = Grammar.Entry.parse expr (Stream.of_string "\"tptp\" ^ string_of a")
+let x = Grammar.Entry.parse expr (Stream.of_string "print_string (string_of a)")
+
+let t   = macro_expand "type t = int * int;;"    
+let t   = macro_expand "type test = C1 of string * string | C2 and t2 = C3 | C4"
+let t   = macro_expand "type 'a test = C1 of string * string | C2 | C3 of 'a and t2 = C3 | C4"
+let t   = macro_expand "type ('a,'b) either = Left of 'a | Right of 'b"
+let t   = macro_expand "type color_test = Red | Yellow"
+let t   = macro_expand "type ('a,'b) assoc  = ('a * 'b) list" 
+let t = macro_expand "type 'a numdict =  C of ('a -> 'a)"
+let t = macro_expand "type 'a numdict =  NumDict of (('a-> 'a -> 'a) * ('a-> 'a -> 'a) * ('a-> 'a -> 'a) * 	('a -> 'a))"
+let t = macro_expand "type 'a bintree = Leaf of 'a | Branch of ('a bintree * 'a bintree)"
+let t = macro_expand "type ('a,'b) assoc  = ('a * 'b) list"
+let t = macro_expand "type ('a,'b) vec  = ('a , 'b) assoc"
+let t = macro_expand "type vector = (float * float * float)"
+let t = macro_expand "type point = {x: int; y:int}"
+let t = macro_expand "type robot_list = robot IntMap.t"
+let t = macro_expand "type robot_list = IntMap.t"
+*)
+(******************************************************************************)
+(*
+map
+fold
+fold_some
+apres pourra faire facilement des trucs du genre get_all_vars,
+ ...
+
+ facto code ?
+
+'a 'b --> 'c 'd pour map
+
+intmap fold = ?
+les fold des libs de caml = ?
+
+*)
+
+
+(******************************************************************************)
+
+(*
+EXTEND
+      expr: BEFORE "simple"
+           [[ "do"; "{";  e1 = expr; "}" -> 
+	     <:expr<  do {  $e1$ }  >> ]];
+END;;
+*)
+(*  can also do                <:expr<  let _ =  $e1$ in ()  >> ]]; *)
+
+EXTEND
+      expr: BEFORE "simple"
+           [[ "do"; "{";  e1 = expr; "}" -> 
+	      ExSeq ((Lexing.dummy_pos,Lexing.dummy_pos),[e1]) 
+	    ]];
+END;;
+
+
+(******************************************************************************)
+(* use:
+   let g = (x + y) 
+     where x = 1 
+       and y = 1
+*)
+
+EXTEND
+      expr: 
+           [[ e2 = expr; "where"; rest = LIST1 Pcaml.let_binding SEP "and" ->
+	     rest +> List.rev +> List.fold_left (fun acc (patt, expr) -> 
+	       ExLet(l, false, [patt,expr], acc)) e2
+	    ]];
+END;;
+
+(*
+let x = Grammar.Entry.parse expr (Stream.of_string "let x = 1 in let y a = 1 in x + y");;
+let t = macro_expand "let2 x = 1 in 1"
+let t = macro_expand "x where x = 1"
+let t = macro_expand "x + y where x = 1 and y = 1"
+*)
+
+(******************************************************************************)
+(*
+use: 
+ { x + y | (x,y) <- [(1,1);(2,2);(3,3)] and x > 2 and y < 3}
+  TODO support only one generator for the moment
+*)
+(*
+EXTEND
+    expr: 
+           [[ 
+             "{{"; e1 = expr; "|"; p1 = patt; "<-"; e2 = expr; "}}" -> 
+	       let maps = (ExAcc (l, ExUid (l, "List"), ExLid (l,"map"))) in
+	       ExApp (l, ExApp(l, maps,
+			       ExFun (l, [p1, None, e1])
+			      ), e2)
+            | "{{"; e1 = expr; "|"; p1 = patt; "<-"; e2 = expr; "and"; e3s = LIST1 expr SEP "and"; "}}" -> 
+	       let maps    = (ExAcc (l, ExUid (l, "List"), ExLid (l,"map"))) in
+	       let filters =(ExAcc (l, ExUid (l, "List"), ExLid (l,"filter"))) in
+	       
+	       ExApp (l, 
+		      ExApp(l, maps,ExFun (l, [p1, None, e1])), 
+		      e3s +> List.fold_left (fun acc expr -> 
+			ExApp (l,
+			       ExApp(l, filters, ExFun(l, [p1, None, expr])),
+			       acc)
+					    )
+			e2)
+	    ]];
+END;;
+*)
+(*
+   [ expr1 | x <- expr2]        ----> expr2 +> List.map (fun x -> expr1)
+   [ expr1 | x <- expr2, x > 2] ----> expr2 +> List.filter (fun x -> x > 2) +> List.map (fun x -> expr1)
+ TODO better than | to separate filter
+*)
+
+(******************************************************************************)
+(*
+use: 
+   let x = {1 .. 10} +> List.map (fun i -> i)
+   you need space between token (dont know really why)
+   you need the enum function: let rec enum x n = if x = n then [n] else x::enum (x+1)  n
+
+*)
+(*
+EXTEND
+    expr: 
+           [[ 
+             "{{"; e1 = expr; ".."; e2 = expr; "}}" -> 
+	       <:expr<enum $e1$ $e2$>>
+	    ]];
+END;;
+*)
+(******************************************************************************)
+
+(*
+EXTEND
+    expr: BEFORE "simple"
+           [[ 
+             e1 = expr; "to"; e2 = expr; "to"; e3 = expr -> 
+	       <:expr<e2 $e1$ $e3$>>
+	    ]];
+END;;
+*)
+
+
+(******************************************************************************)
+(*
+ let add_update_plan w e = w.update_plan <- e::w.update_plan
+ sucks cos no first class field
+ perhaps need a preprocessor over record to let the field be first class
+ indeed :) camlp4
+*)
+
+EXTEND
+  expr:BEFORE "simple"
+  [ [  
+    "modify"; record = NEXT; "."; field = LIDENT ; f = NEXT ->
+      <:expr< $record$.$lid:field$ := $f$ $record$.$lid:field$>>
+  ]];
+END;;
+
+(* 
+   #  type point  = {mutable x:int; mutable y:int};;
+   # let o = { x= 0; y = 0};;
+   # modify o.y succ;;
+
+   I haven't tested this extension any further, but the main issue I can see is
+   that "modify" becomes a keyword, which can be a problem if there are some 
+   variables with that name in your code.
+
+   -- Virgile Prevosto <virgile.prevosto@lip6.fr>
+*)
+
+(******************************************************************************)
+(*
+Original version, without quotation
+let _ =
+  DELETE_RULE
+    Pcaml.str_item: "type"; LIST1 Pcaml.type_declaration SEP "and"
+  END;
+
+EXTEND
+      Pcaml.str_item:
+      [ [ "type"; tdl = LIST1 Pcaml.type_declaration SEP "and" ->
+
+	let name () = "a" ^ string_of_int (counter ()) in
+
+	(* subtil bug, when we have only one param, we cant construct a tuple with one param,
+	   we should think that (1) and 1 are treated the same way, but seems this work
+	   is done in caml in the parser, which mean that we must not give to caml an Ast with
+	   a 1-uple
+	*)
+	let ex_tuple = function
+	  | [] -> failwith "pb"
+	  | [x] -> x
+	  | xs -> ExTup (l,xs)
+	in
+	let pa_tuple = function
+	  | [] -> failwith "pb"
+	  | [x] -> x
+	  | xs -> PaTup (l,xs)
+	in
+
+	let funcs = tdl +> List.map (fun ((l,str), param_polymorphs, ctyp, z) -> 
+	  let join_app  xs = xs +> foldl1 (fun a e -> ExApp(l, ExApp (l, ExLid (l, "^"), a), e)) in
+	  let join_virg xs = xs +> join_gen (ExStr (l, ",")) in
+
+	  let name_module_func = function
+	    | TyLid (l, s)                           -> ExLid(l, "string_of_" ^ s)
+	    | TyAcc (_, TyUid (_,file), TyLid (_,s)) -> ExAcc(l, ExUid (l,file), ExLid(l, "string_of_" ^ s))
+	    | _ -> failwith "pb"
+	  in
+	  (* TODOSTYLE? function fmatch id patt expr who put the None, ... *)
+	  let rec body_ctyp id = function
+	    | (TyLid (_) | TyAcc (_)) as c -> ExApp (l,name_module_func c, ExLid (l,id))
+              (* | TyUid of loc and string *)
+
+	    | TyQuo (l, s) -> ExApp (l, ExLid(l, "str__of_" ^ s), ExLid (l,id))
+	    | TySum (l, xs) ->
+		ExMat(l, ExLid (l, id),
+		      xs +> List.map (fun (l, s, ctyps) -> 
+			let newids = xs +> List.map (fun _ -> name ()) in
+			match ctyps, newids with
+			| ([],_) -> (PaUid(l, s), None, ExStr (l,s))
+			| (x::xs,id::ids) -> 
+			    let patt = zip xs ids +> List.fold_left 
+				(fun a (e,id) -> PaApp (l, a, PaLid (l,id))
+				) (PaApp (l, PaUid(l, s), PaLid(l, id))) in
+			    (patt, None,
+			     zip (x::xs) (id::ids) +> List.map (fun (e,id) -> body_ctyp id e) +> join_virg +> 
+			     (fun xs -> [ExStr (l,s); ExStr (l,"(")] @ xs @ [ExStr (l,")")]) +> join_app
+			    )
+			| _ -> failwith "pb"
+				     )	
+		     )
+	    | TyTup (l, xs) -> 
+		let newids = xs +> List.map (fun _ -> name ()) in
+		ExMat(l, ExLid (l,id), 
+		      [PaTup(l, newids +> List.map (fun id -> PaLid (l,id))),
+		      None, 
+		      zip xs newids +> List.map (fun (e,id) -> body_ctyp id e) +> join_virg +> 
+			(fun xs -> [ExStr (l,"(")] @ xs @ [ExStr (l,")")]) +> join_app
+		      ]	
+		     )
+	    | TyArr (l,c1,c2) -> ExStr(l, "<fun>")
+	    | TyApp (l,c1,c2) -> 
+		let rec extract_all_params acc = function
+		  | TyApp (l,c1', c2') -> extract_all_params (acc @ [c2']) c1'
+		  | x -> (x, acc) in
+		let (type_parameted, params) = extract_all_params [] (TyApp (l, c1, c2)) in
+		let funcs = params +> List.map (fun c -> 
+		  let id = name () in
+		  let f = body_ctyp id c in
+		  ExFun (l, [PaLid(l, id), None, f]))
+		in 
+		  (match type_parameted with
+		  |  (TyLid (_) | TyAcc (_)) as c -> 
+		      ExApp (l, ExApp (l, name_module_func c, ex_tuple funcs), ExLid (l,id))
+		  | _ -> ExStr (l,"<illegal syntax in type, should be a typeconst>")
+		  )
+	    | TyRec (l, xs) -> 
+		let newids = xs +> List.map (fun _ -> name ()) in
+		ExMat(l, ExLid (l, id),
+		      [ PaRec (l, zip xs newids +> List.map (fun ((_,e,_,_), id) -> PaLid(l, e), PaLid(l, id))),
+			None, 
+			zip xs newids 
+			  +> List.map 
+			    (fun ((l,s,_b,e),id) -> [ExStr(l,s); ExStr(l," = ");body_ctyp id e] +> join_app)
+			  +> join_virg 
+			  +> (fun xs -> [ExStr (l,"{")] @ xs @ [ExStr (l,"}")]) +> join_app
+		      ])
+
+	      (* TODO when needed
+	    | TyAli of loc and ctyp and ctyp
+	    | TyAny of loc
+	    | TyCls of loc and list string
+	    | TyLab of loc and string and ctyp
+	    | TyMan of loc and ctyp and ctyp
+	    | TyOlb of loc and string and ctyp
+	    | TyPol of loc and list string and ctyp
+	    | TyObj of loc and list (string * ctyp) and bool
+	    | TyVrn of loc and list row_field and option (option (list string)) 
+	      and row_field =
+	      | RfTag of string and bool and list ctyp
+	      | RfInh of ctyp 
+	      *)
+	    | _ -> (ExStr (l, "<not yet implemnted>"))
+
+	  in
+	  let f_str_func_params body = 
+	    (* currifie:
+	    param_polymorphs +> List.rev +> List.fold_left (fun acc (str_poly, (_,_)) -> 
+	      ExFun(l, [(PaLid (l, name_f_str_params str_poly),None, acc)]))
+	      body
+	    *)
+	    if  param_polymorphs = [] then body
+	    else ExFun (l, [pa_tuple 
+			       (param_polymorphs +> List.map (fun (str_poly,(_,_)) -> 
+				 PaLid (l, "str__of_" ^ str_poly))),
+			     None, body])
+	  in
+	  
+	  [(PaLid (l, "string_of_" ^ str), (* let string_of... *)
+	   f_str_func_params     (*  str__a str__b ... *)
+	      (ExFun(l, [(PaLid (l,"a0"), None,  (* a0 = .... *)
+			 (body_ctyp "a0" ctyp))])))    (*  match a with .... *)
+	      
+	   ;(PaLid (l, "print_" ^ str),
+	     (if param_polymorphs = [] 
+	     then fun e -> e
+	     else fun e -> (ExFun (l, [PaLid (l, "funs"), None, e]))
+	     )
+	       (ExFun (l, [(PaLid (l,"a")), None,
+			    ExApp (l, ExLid (l, "print_string"),
+				   if param_polymorphs = [] 
+				   then ExApp(l, ExLid (l, "string_of_" ^ str), ExLid (l, "a"))
+				   else ExApp (l, 
+					       ExApp (l, ExLid (l, "string_of_" ^ str), 
+						      ExLid (l, "funs")),
+					       ExLid (l, "a")))])))
+	  ])  
+	in
+	let recursif = true in
+	(StDcl (loc, [(StTyp (loc, tdl));StVal (loc, recursif, funcs +> List.flatten)]))
+]]
+      ;
+    END
+;;
+
+*)
+(******************************************************************************)
+
+(*
+let gen_print_funs loc tdl =
+         <:str_item< not yet implemented >>
+       
+       let _ =
+         EXTEND
+           Pcaml.str_item:
+             [ [ "type"; tdl = LIST1 Pcaml.type_declaration SEP "and" ->
+                   let si1 = <:str_item< type $list:tdl$ >> in
+                   let si2 = gen_print_funs loc tdl in
+                   <:str_item< declare $si1$; $si2$; end >> ] ]
+           ;
+         END
+
+*)
+(*
+let fun_name n = "print_" ^ n
+let fun_param_name n = "pr_" ^ n
+let param_name cnt = "x" ^ string_of_int cnt
+			     
+let list_mapi f l =
+  let rec loop cnt =
+    function
+        x :: l -> f cnt x :: loop (cnt + 1) l
+      | [] -> []
+  in
+  loop 1 l
+    
+let gen_print_type loc t =
+  let rec eot =
+    function
+        <:ctyp< $t1$ $t2$ >> -> <:expr< $eot t1$ $eot t2$ >>
+      | <:ctyp< $lid:s$ >> -> <:expr< $lid:fun_name s$ >>
+      | <:ctyp< '$s$ >> -> <:expr< $lid:fun_param_name s$ >>
+      | _ -> <:expr< fun _ -> print_string "..." >>
+  in
+  eot t
+    
+let gen_call loc n f = <:expr< $f$ $lid:param_name n$ >>
+  
+  let gen_print_cons_patt loc c tl =
+    let pl =
+      list_mapi (fun n _ -> <:patt< $lid:param_name n$ >>)
+        tl
+    in
+    List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>)
+      <:patt< $uid:c$ >> pl
+      
+let gen_print_con_extra_syntax loc el =
+  let rec loop =
+    function
+        [] | [_] as e -> e
+      | e :: el -> e :: <:expr< print_string ", " >> :: loop el
+  in
+  <:expr< print_string " (" >> :: loop el @
+  [<:expr< print_string ")" >>]
+    
+let gen_print_cons_expr loc c tl =
+  let pr_con = <:expr< print_string $str:c$ >> in
+  match tl with
+    [] -> pr_con
+  | _ ->
+      let pr_params =
+        let type_funs = List.map (gen_print_type loc) tl in
+        list_mapi (gen_call loc) type_funs
+      in
+      let pr_all = gen_print_con_extra_syntax loc pr_params in
+      let el = pr_con :: pr_all in
+      <:expr< do { $list:el$ } >>
+      
+      let gen_print_cons (loc, c, tl) =
+        let p = gen_print_cons_patt loc c tl in
+        let e = gen_print_cons_expr loc c tl in
+        p, None, e
+	  
+let gen_print_sum loc cdl =
+  let pwel = List.map gen_print_cons cdl in
+  <:expr< fun [ $list:pwel$ ] >>
+
+let gen_one_print_fun loc ((loc, n), tpl, tk, cl) =
+      let body =
+        match tk with
+          <:ctyp< [ $list:cdl$ ] >> -> gen_print_sum loc cdl
+        | _ -> <:expr< fun _ -> failwith $str:fun_name n$ >>
+      in
+      let body =
+        List.fold_right
+          (fun (v, _) e ->
+            <:expr< fun $lid:fun_param_name v$ -> $e$ >>)
+          tpl body
+      in
+      <:patt< $lid:fun_name n$ >>, body
+
+let gen_print_funs loc tdl =
+  let pel = List.map (gen_one_print_fun loc) tdl in
+  <:str_item< value rec $list:pel$ >>
+
+*)
+(*  
+  let _ =
+    DELETE_RULE
+      Pcaml.str_item: "type"; LIST1 Pcaml.type_declaration SEP "and"
+      END;
+    EXTEND
+      Pcaml.str_item:
+      [ [ "type"; tdl = LIST1 Pcaml.type_declaration SEP "and" ->
+        let si1 = <:str_item< type $list:tdl$ >> in
+        let si2 = gen_print_funs loc tdl in
+        <:str_item< declare $si1$; $si2$; end >> ] ]
+      ;
+    END
+*)
+(* by author of camlp4 *)
+
+(******************************************************************************)
+(*
+     # let expand _ s =                                                                                                   
+          match s with                                                                                                     
+            "PI" -> "3.14159"                                                                                              
+          | "goban" -> "19*19"                                                                                             
+          | "chess" -> "8*8"                                                                                               
+          | "ZERO" -> "0"                                                                                                  
+          | "ONE" -> "1"                                                                                                   
+          | _ -> "\"" ^ s ^ "\""                                                                                           
+        ;;                                                                                                                 
+                                                                                                                           
+   Let us call the quotation ``foo''. We can associate the quotation ``foo'' to the above expander ``expand'' by typing:   
+                                                                                                                           
+      # Quotation.add "foo" (Quotation.ExStr expand);;                                                                     
+                                                                                                                           
+   We can experiment the new quotation immediately:                                                                        
+                                                                                                                           
+      # <:foo<PI>>;;                                                                                                       
+      - : float = 3.14159                                    
+*)
+
+(******************************************************************************)
+(*
+let add_infix lev op =                                                                                             
+          EXTEND                                                                                                           
+            expr: LEVEL $lev$                                                                                              
+              [ [ x = expr; $op$; y = expr -> <:expr< $lid:op$ $x$ $y$ >> ] ]                                              
+            ;                                                                                                              
+          END;;                                                                                                            
+*)                  
+
+(******************************************************************************)
+
+(*
+    type term =                                                                                                          
+          Var of string                                                                                                    
+        | Func of string * term                                                                                            
+        | Appl of term * term                                                                                              
+      ;;                                                                                                                   
+                                                                                                                           
+   The first case, Var, represents variables.                                                                              
+                                                                                                                           
+   The second case, Func, represents functions. Its first parameter is the function parameter and its second parameter     
+   the function body. We write that in concrete syntax [parameter]body.                                                    
+                                                                                                                           
+   The third case, App, represents an application of two lambda terms. We write that in concrete syntax (term1 term2).     
+                                                                                                                           
+   But, for the moment, we just defined a type term, and we can just write these terms using the constructors. Here is     
+   an example:                                                                                                             
+                                                                                                                           
+      let id = Func ("x", Var "x")                                                                                         
+      let k = Func ("x", Func ("y", Var "x"))                                                                              
+      let s =                                                                                                              
+        Func ("x", Func ("y", Func ("z",                                                                                   
+          Appl (Appl (Var "x", Var "y"), Appl (Var "x", Var "z")))))                                                       
+      let delta = Func ("x", Appl (Var "x", Var "x"))                                                                      
+      let omega = Appl (delta, delta)                                                                                      
+                                                                                                                           
+   A nice quotation expander would allow us to use concrete syntax. The same piece of program could look like this,        
+   which is more readable:                                                                                                 
+                                                                                                                           
+      let id = << [x]x >>                                                                                                  
+      let k = << [x][y]x >>                                                                                                
+      let s = << [x][y][z]((x y) (x z)) >>                                                                                 
+      let delta = << [x](x x) >>                                                                                           
+      let omega = << (^delta ^delta) >>         
+
+     
+let gram = Grammar.gcreate (Plexer.gmake ());;                                                                       
+      let term_eoi = Grammar.Entry.create gram "term";;                                                                    
+      let term = Grammar.Entry.create gram "term";;                                                                        
+      EXTEND                                                                                                               
+         term_eoi: [ [ x = term; EOI -> x ] ];                                                                             
+         term:                                                                                                             
+            [ [ "["; x = LIDENT; "]"; t = term -> <:expr< Func $str:x$ $t$ >>                                              
+              | "("; t1 = term; t2 = term; ")" -> <:expr< Appl $t1$ $t2$ >>                                                
+              | x = LIDENT -> <:expr< Var $str:x$ >> ] ]                                                                   
+         ;                                                                                                                 
+      END;;                                                                                                                
+      let term_exp s = Grammar.Entry.parse term_eoi (Stream.of_string s);;                                                 
+      let term_pat s = failwith "not implemented term_pat";;                                                               
+      Quotation.add "term" (Quotation.ExAst (term_exp, term_pat));;                                                        
+      Quotation.default := "term";;                  
+*)
+
+(******************************************************************************)

external/Makefile

@@ -0,0 +1,5 @@
+
+# alternatives: godi, opam
+
+install:
+	echo TODO

external/dependencies.txt

@@ -0,0 +1,16 @@
+stdlib/: used by everthing
+
+ocamlcairo/: used by codemap/codegraph, core graphics library.
+ocamlgtk/:   used by codemap/codegraph, mostly for interactive menus and basic
+ UI chrome.
+
+ocamlgraph/: used by commons/graph.ml and so graph_code, also a bit by
+ lang_html/? TODO why dependencies to codegraph is now shown in cg?
+
+javalib/: used by lang_bytecode/
+ocamlzip/: used by externals/javalib (used itself by lang_bytecode/)
+extlib/: used by externals/javalib (used itself by lang_bytecode/)
+ptrees/: used by javalib/ (TODO: deps not in codegraph because functor)
+
+bddbddb/: used by codequery -datalog (actually not ocaml code!)
+swiprolog/: used by codequery (also not ocaml code)

external/jsonwheel/.depend

@@ -0,0 +1,17 @@
+json_in.cmo : json_type.cmi json_parser.cmi json_lexer.cmo
+json_in.cmx : json_type.cmx json_parser.cmx json_lexer.cmx
+json_io.cmo : json_type.cmi json_parser.cmi json_lexer.cmo json_io.cmi
+json_io.cmx : json_type.cmx json_parser.cmx json_lexer.cmx json_io.cmi
+json_io.cmi : json_type.cmi
+json_lexer.cmo : netconversion2.cmo json_type.cmi json_parser.cmi
+json_lexer.cmx : netconversion2.cmx json_type.cmx json_parser.cmx
+json_out.cmo : json_type.cmi
+json_out.cmx : json_type.cmx
+json_parser.cmo : json_type.cmi json_parser.cmi
+json_parser.cmx : json_type.cmx json_parser.cmi
+json_parser.cmi : json_type.cmi
+json_type.cmo : json_type.cmi
+json_type.cmx : json_type.cmi
+json_type.cmi :
+netconversion2.cmo :
+netconversion2.cmx :

external/jsonwheel/META

@@ -0,0 +1,4 @@
+description = "jsonwheel"
+requires = "unix num str bigarray"
+archive(byte) = "jsonwheel.cma"
+archive(native) = "jsonwheel.cmxa"

external/jsonwheel/Makefile

@@ -0,0 +1,118 @@
+##############################################################################
+# Variables
+##############################################################################
+
+SRC= json_type.ml \
+     json_out.ml \
+     netconversion2.ml \
+     json_parser.ml \
+     json_lexer.ml \
+     json_in.ml \
+     json_io.ml
+
+TARGET=jsonwheel
+
+INCLUDES=
+#-I +camlp4
+SYSLIBS= str.cma unix.cma bigarray.cma num.cma
+
+##############################################################################
+# Generic variables
+##############################################################################
+
+#dont use -custom, it makes the bytecode unportable.
+OCAMLCFLAGS= -g -dtypes $(OCAMLCFLAGS_EXTRA)
+#-for-pack Sexplib
+
+# This flag is also used in subdirectories so don't change its name here.
+OPTFLAGS=
+
+OCAMLC=ocamlc$(OPTBIN) $(OCAMLCFLAGS)  $(INCLUDES)  $(SYSINCLUDES) -thread
+OCAMLOPT=ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES) $(SYSINCLUDES) -thread
+OCAMLLEX=ocamllex #-ml # -ml for debugging lexer, but slightly slower
+OCAMLYACC=ocamlyacc -v
+OCAMLDEP=ocamldep $(INCLUDES)
+OCAMLMKTOP=ocamlmktop -g -custom $(INCLUDES) -thread
+
+#-ccopt -static
+STATIC=
+
+##############################################################################
+# Top rules
+##############################################################################
+
+OBJS = $(SRC:.ml=.cmo)
+OPTOBJS = $(SRC:.ml=.cmx)
+
+all: $(TARGET).cma
+all.opt: $(TARGET).cmxa
+
+$(TARGET).cma: $(OBJS)
+	$(OCAMLC) -a -o $(TARGET).cma $(OBJS)
+
+$(TARGET).cmxa: $(OPTOBJS) $(LIBS:.cma=.cmxa)
+	$(OCAMLOPT) -a -o $(TARGET).cmxa $(OPTOBJS)
+
+$(TARGET).top: $(OBJS) $(LIBS)
+	$(OCAMLMKTOP) -o $(TARGET).top $(SYSLIBS) $(LIBS) $(OBJS)
+
+clean::
+	rm -f $(TARGET).top
+
+#pad: we include in the git repo already the generated file
+#json_lexer.ml: json_lexer.mll
+#	$(OCAMLLEX) $<
+#dist_clean::
+#	rm -f json_lexer.ml
+#beforedepend:: json_lexer.ml
+
+#json_parser.ml json_parser.mli: json_parser.mly
+#	$(OCAMLYACC) $<
+#dist_clean::
+#	rm -f json_parser.ml json_parser.mli json_parser.output
+#beforedepend:: json_parser.ml json_parser.mli
+
+##############################################################################
+# install
+##############################################################################
+LIBNAME=jsonwheel
+EXPORTSRC=json_io.mli json_parser.mli json_type.mli
+
+install-findlib: $(LIBNAME).cma $(LIBNAME).cmxa
+	ocamlfind install $(LIBNAME) META \
+   $(LIBNAME).cma $(LIBNAME).cmxa $(LIBNAME).a *.cmi $(EXPORTSRC)
+
+uninstall-findlib::
+	ocamlfind remove $(LIBNAME)
+
+
+##############################################################################
+# Generic rules
+##############################################################################
+
+.SUFFIXES: .ml .mli .cmo .cmi .cmx
+
+.ml.cmo:
+	$(OCAMLC) -c $<
+.mli.cmi:
+	$(OCAMLC) -c $<
+.ml.cmx:
+	$(OCAMLOPT) -c $<
+
+.ml.mldepend:
+	$(OCAMLC) -i $<
+
+clean::
+	rm -f *.cm[ioxa] *.o *.a *.cmxa *.annot *.cmt *.cmti
+clean::
+	rm -f *~ .*~ gmon.out #*#
+
+beforedepend::
+
+depend:: beforedepend
+	$(OCAMLDEP) *.mli *.ml    > .depend
+
+distclean::
+	rm -f .depend
+
+-include .depend

external/jsonwheel/copyright.txt

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

external/jsonwheel/json_in.ml

@@ -0,0 +1,51 @@
+type t = Json_type.t
+open Json_type
+
+
+let filter_result x =
+  Browse.assert_object_or_array x;
+  x
+
+
+let check_channel_is_utf8 ic =
+  let start = pos_in ic in
+  let encoding =
+    try
+      let c1 = input_char ic in
+      let c2 = input_char ic in
+      let c3 = input_char ic in
+      let c4 = input_char ic in
+      Json_lexer.detect_encoding c1 c2 c3 c4
+    with End_of_file -> `UTF8 in
+  if encoding <> `UTF8 then
+    json_error "Only UTF-8 encoding is supported";
+  (try seek_in ic start
+   with _ -> json_error "Not a regular file")
+
+(* from_channel and from_channel4 work 
+   only on seekable devices (regular files) *)
+let from_channel p recursive file ic = 
+  check_channel_is_utf8 ic;
+  let lexbuf = Lexing.from_channel ic in
+  Json_lexer.set_file_name lexbuf file;
+  let j =
+    Json_parser.main
+      (Json_lexer.token p)
+      lexbuf
+  in
+  if recursive then j
+  else filter_result j
+
+let load_json
+    ?allow_comments ?allow_nan ?big_int_mode ?(recursive = false)
+    file = 
+  let ic = open_in file in
+  let x =
+    let p =
+      Json_lexer.make_param ?allow_comments ?allow_nan ?big_int_mode () in
+    try `Result (from_channel p recursive file ic)
+    with e -> `Exn e in
+  close_in ic;
+  match x with
+      `Result x -> x
+    | `Exn e -> raise e

external/jsonwheel/json_io.ml

@@ -0,0 +1,421 @@
+type t = Json_type.t
+open Json_type
+
+
+(*** Parsing ***)
+
+let check_string_is_utf8 s =
+  let encoding =
+    if String.length s < 4 then `UTF8
+    else Json_lexer.detect_encoding s.[0] s.[1] s.[2] s.[3] in
+  if encoding <> `UTF8 then
+    json_error "Only UTF-8 encoding is supported" 
+
+let filter_result x =
+  Browse.assert_object_or_array x;
+  x
+
+let json_of_string 
+    ?allow_comments
+    ?allow_nan
+    ?big_int_mode
+    ?(recursive = false)
+    s =
+  check_string_is_utf8 s;
+  let p = Json_lexer.make_param ?allow_comments ?allow_nan ?big_int_mode () in
+  let j = 
+    Json_parser.main 
+      (Json_lexer.token p)
+      (Lexing.from_string s)
+  in
+  if not recursive then filter_result j
+  else j
+
+
+let check_channel_is_utf8 ic =
+  let start = pos_in ic in
+  let encoding =
+    try
+      let c1 = input_char ic in
+      let c2 = input_char ic in
+      let c3 = input_char ic in
+      let c4 = input_char ic in
+      Json_lexer.detect_encoding c1 c2 c3 c4
+    with End_of_file -> `UTF8 in
+  if encoding <> `UTF8 then
+    json_error "Only UTF-8 encoding is supported";
+  (try seek_in ic start
+   with _ -> json_error "Not a regular file")
+
+(* from_channel and from_channel4 work 
+   only on seekable devices (regular files) *)
+let from_channel p recursive file ic = 
+  check_channel_is_utf8 ic;
+  let lexbuf = Lexing.from_channel ic in
+  Json_lexer.set_file_name lexbuf file;
+  let j =
+    Json_parser.main
+      (Json_lexer.token p)
+      lexbuf
+  in
+  if recursive then j
+  else filter_result j
+
+
+let load_json
+    ?allow_comments ?allow_nan ?big_int_mode ?(recursive = false)
+    file = 
+  let ic = open_in file in
+  let x =
+    let p =
+      Json_lexer.make_param ?allow_comments ?allow_nan ?big_int_mode () in
+    try `Result (from_channel p recursive file ic)
+    with e -> `Exn e in
+  close_in ic;
+  match x with
+      `Result x -> x
+    | `Exn e -> raise e
+
+
+(*** Printing ***)
+
+(* JSON does not allow rendering floats with a trailing dot: that is,
+   1234. is not allowed, but 1234.0 is ok.  here, we add a '0' if
+   string_of_int result in a trailing dot *)
+let fprint_float allow_nan fmt f =
+  match classify_float f with
+      FP_nan -> 
+	if allow_nan then Format.fprintf fmt "NaN"
+	else json_error "Not allowed to serialize NaN value"
+    | FP_infinite ->
+	if allow_nan then
+	  if f < 0. then Format.fprintf fmt "-Infinity"
+	  else Format.fprintf fmt "Infinity"
+	else json_error "Not allowed to serialize infinite value"
+    | FP_zero
+    | FP_normal
+    | FP_subnormal ->
+	let s = string_of_float f in
+	Format.fprintf fmt "%s" s;
+	let s_len = String.length s in
+	if s.[ s_len - 1 ] = '.' then
+	  Format.fprintf fmt "0"
+
+let escape_json_string buf s =
+  for i = 0 to String.length s - 1 do
+    let c = String.unsafe_get s i in
+    match c with 
+      | '"'    -> Buffer.add_string buf "\\\""
+      | '\t'   -> Buffer.add_string buf "\\t"
+      | '\r'   -> Buffer.add_string buf "\\r"
+      | '\b'   -> Buffer.add_string buf "\\b"
+      | '\n'   -> Buffer.add_string buf "\\n"
+      | '\012' -> Buffer.add_string buf "\\f"
+      | '\\'   -> Buffer.add_string buf "\\\\"
+   (* | '/'    -> "\\/" *) (* Forward slash can be escaped 
+			      but doesn't have to *)
+      | '\x00'..'\x1F' (* Control characters that must be escaped *)
+      | '\x7F' (* DEL *) -> 
+	  Printf.bprintf buf "\\u%04X" (int_of_char c)
+      | _      -> 
+	  (* Don't bother detecting or escaping multibyte chars *)
+	  Buffer.add_char buf c
+  done
+
+let fquote_json_string fmt s =
+  let buf = Buffer.create (String.length s) in
+  escape_json_string buf s;
+  Format.fprintf fmt "\"%s\"" (Buffer.contents buf)
+
+let bquote_json_string buf s =
+  Printf.bprintf buf "\"%a\"" escape_json_string s
+
+module Compact =
+struct
+  open Format
+
+  let rec fprint_json allow_nan fmt = function
+      Object o -> 
+	pp_print_string fmt "{";
+	fprint_object allow_nan fmt o;
+	pp_print_string fmt "}"
+    | Array a -> 
+	pp_print_string fmt "[";
+	fprint_list allow_nan fmt a;
+	pp_print_string fmt "]"
+    | Bool b -> 
+	pp_print_string fmt (if b then "true" else "false")
+    | Null -> 
+	pp_print_string fmt "null"
+    | Int i -> pp_print_string fmt (string_of_int i)
+    | Float f -> pp_print_string fmt (string_of_json_float allow_nan f)
+    | String s -> fquote_json_string fmt s
+	
+  and fprint_list allow_nan fmt = function
+      [] -> ()
+    | [x] -> fprint_json allow_nan fmt x
+    | x :: tl -> 
+	fprint_json allow_nan fmt x;
+	pp_print_string fmt ","; 
+	fprint_list allow_nan fmt tl
+	  
+  and fprint_object allow_nan fmt = function
+      [] -> ()
+    | [x] -> fprint_pair allow_nan fmt x
+    | x :: tl -> 
+	fprint_pair allow_nan fmt x;
+	pp_print_string fmt ","; 
+	fprint_object allow_nan fmt tl
+
+  and fprint_pair allow_nan fmt (key, x) =
+    fquote_json_string fmt key;
+    fprintf fmt ":";
+    fprint_json allow_nan fmt x
+
+  (* json does not allow rendering floats with a trailing dot: that is,
+     1234. is not allowed, but 1234.0 is ok.  here, we add a '0' if
+     string_of_int result in a trailing dot *)
+  and string_of_json_float allow_nan f =
+    let s = string_of_float f in
+    let s_len = String.length s in
+    if s.[ s_len - 1 ] = '.' then
+      s ^ "0"
+    else
+      s
+
+  let print ?(allow_nan = false) ?(recursive = false) fmt x =
+    if not recursive then
+      Browse.assert_object_or_array x;
+    fprint_json allow_nan fmt x
+end
+
+
+module Fast =
+struct
+  open Printf
+  open Buffer
+
+  (* Contiguous sequence of non-escaped characters are copied to the buffer
+     using one call to Buffer.add_substring *)
+  let rec buf_add_json_escstr1 buf s k1 l =
+    if k1 < l then (
+      let k2 = buf_add_json_escstr2 buf s k1 k1 l in
+      if k2 > k1 then
+	Buffer.add_substring buf s k1 (k2 - k1);
+      if k2 < l then (
+	let c = String.unsafe_get s k2 in
+	( match c with 
+	    | '"'    -> Buffer.add_string buf "\\\""
+	    | '\t'   -> Buffer.add_string buf "\\t"
+	    | '\r'   -> Buffer.add_string buf "\\r"
+	    | '\b'   -> Buffer.add_string buf "\\b"
+	    | '\n'   -> Buffer.add_string buf "\\n"
+	    | '\012' -> Buffer.add_string buf "\\f"
+	    | '\\'   -> Buffer.add_string buf "\\\\"
+	 (* | '/'    -> "\\/" *) (* Forward slash can be escaped 
+				    but doesn't have to *)
+	    | '\x00'..'\x1F' (* Control characters that must be escaped *)
+	    | '\x7F' (* DEL *) -> 
+		        Printf.bprintf buf "\\u%04X" (int_of_char c)
+	    | _      -> assert false
+	);
+	buf_add_json_escstr1 buf s (k2+1) l
+      )
+    )
+
+  and buf_add_json_escstr2 buf s k1 k2 l =
+    if k2 < l then (
+      let c = String.unsafe_get s k2 in
+      match c with
+	| '"' | '\t' | '\r' | '\b' | '\n' | '\012' | '\\' (*| '/'*)
+	| '\x00'..'\x1F' | '\x7F' -> k2
+	| _ -> buf_add_json_escstr2 buf s k1 (k2+1) l
+    )
+    else
+      l
+
+  and bquote_json_string buf s =
+    Buffer.add_char buf '"';
+    buf_add_json_escstr1 buf s 0 (String.length s);
+    Buffer.add_char buf '"'
+
+  let rec bprint_json allow_nan buf = function
+      Object o -> 
+	add_string buf "{";
+	bprint_object allow_nan buf o;
+	add_string buf "}"
+    | Array a -> 
+	add_string buf "[";
+	bprint_list allow_nan buf a;
+	add_string buf "]"
+    | Bool b -> 
+	add_string buf (if b then "true" else "false")
+    | Null -> 
+	add_string buf "null"
+    | Int i -> add_string buf (string_of_int i)
+    | Float f -> add_string buf (string_of_json_float allow_nan f)
+    | String s -> bquote_json_string buf s
+	
+  and bprint_list allow_nan buf = function
+      [] -> ()
+    | [x] -> bprint_json allow_nan buf x
+    | x :: tl -> 
+	bprint_json allow_nan buf x;
+	add_string buf ","; 
+	bprint_list allow_nan buf tl
+	  
+  and bprint_object allow_nan buf = function
+      [] -> ()
+    | [x] -> bprint_pair allow_nan buf x
+    | x :: tl -> 
+	bprint_pair allow_nan buf x;
+	add_string buf ","; 
+	bprint_object allow_nan buf tl
+
+  and bprint_pair allow_nan buf (key, x) =
+    bquote_json_string buf key;
+    bprintf buf ":";
+    bprint_json allow_nan buf x
+
+  (* json does not allow rendering floats with a trailing dot: that is,
+     1234. is not allowed, but 1234.0 is ok.  here, we add a '0' if
+     string_of_int result in a trailing dot *)
+  and string_of_json_float allow_nan f =
+    match classify_float f with
+	FP_nan -> 
+	  if allow_nan then "NaN"
+	  else json_error "Not allowed to serialize NaN value"
+    | FP_infinite ->
+	if allow_nan then
+	  if f < 0. then "-Infinity"
+	  else "Infinity"
+	else json_error "Not allowed to serialize infinite value"
+    | FP_zero
+    | FP_normal
+    | FP_subnormal ->
+	let s = string_of_float f in
+	let s_len = String.length s in
+	if s.[ s_len - 1 ] = '.' then
+	  s ^ "0"
+	else
+	  s
+
+  let print ?(allow_nan = false) ?(recursive = false) buf x =
+    if not recursive then
+      Browse.assert_object_or_array x;
+    bprint_json allow_nan buf x
+end
+
+
+
+(*** Pretty printing ***)
+
+module Pretty =
+struct
+  open Format
+    
+  (* Printing anything but a value in a key:value pair.
+
+     Opening and closing brackets in such arrays and objects
+     are aligned vertically if they are not on the same line. 
+  *)
+  let rec fprint_json allow_nan fmt = function
+      Object l -> fprint_object allow_nan fmt l
+    | Array l -> fprint_array allow_nan fmt l
+    | Bool b -> fprintf fmt "%s" (if b then "true" else "false")
+    | Null -> fprintf fmt "null"
+    | Int i -> fprintf fmt "%i" i
+    | Float f -> fprint_float allow_nan fmt f
+    | String s -> fquote_json_string fmt s
+	
+  (* Printing an array which is not the value in a key:value pair *)
+  and fprint_array allow_nan fmt = function
+      [] -> fprintf fmt "[]"
+    | x :: tl -> 
+	fprintf fmt "@[<hv 2>[@ "; 
+	fprint_json allow_nan fmt x;
+	List.iter (fun x -> 
+		     fprintf fmt ",@ ";
+		     fprint_json allow_nan fmt x) tl;
+	fprintf fmt "@;<1 -2>]@]"
+	  
+  (* Printing an object which is not the value in a key:value pair *)
+  and fprint_object allow_nan fmt = function
+      [] -> fprintf fmt "{}"
+    | x :: tl -> 
+	fprintf fmt "@[<hv 2>{@ "; 
+	fprint_pair allow_nan fmt x;
+	List.iter (fun x -> 
+		     fprintf fmt ",@ ";
+		     fprint_pair allow_nan fmt x) tl;
+	fprintf fmt "@;<1 -2>}@]"
+
+  (* Printing a key:value pair.
+
+     The opening bracket stays on the same line as the key, no matter what,
+     and the closing bracket is either on the same line
+     or vertically aligned with the beginning of the key. 
+  *)
+  and fprint_pair allow_nan fmt (key, x) =
+    match x with
+	Object l -> 
+	  (match l with
+	       [] -> fprintf fmt "%a: {}" fquote_json_string key
+	     | x :: tl -> 
+		 fprintf fmt "@[<hv 2>%a: {@ " fquote_json_string key;
+		 fprint_pair allow_nan fmt x;
+		 List.iter (fun x -> 
+			      fprintf fmt ",@ ";
+			      fprint_pair allow_nan fmt x) tl;
+		 fprintf fmt "@;<1 -2>}@]")
+      | Array l ->
+	  (match l with
+	       [] -> fprintf fmt "%a: []" fquote_json_string key
+	     | x :: tl -> 
+		 fprintf fmt "@[<hv 2>%a: [@ " fquote_json_string key;
+		 fprint_json allow_nan fmt x;
+		 List.iter (fun x -> 
+			      fprintf fmt ",@ ";
+			      fprint_json allow_nan fmt x) tl;
+		 fprintf fmt "@;<1 -2>]@]")
+      | _ -> 
+	  (* An atom, perhaps a long string that would go to the next line *)
+	  fprintf fmt "@[%a:@;<1 2>%a@]" 
+	    fquote_json_string key (fprint_json allow_nan) x
+
+  let print ?(allow_nan = false) ?(recursive = false) fmt x =
+    if not recursive then
+      Browse.assert_object_or_array x;
+    fprint_json allow_nan fmt x
+end
+
+
+let string_of_json ?allow_nan ?(compact = false) ?recursive x =
+  let buf = Buffer.create 2000 in
+  if compact then
+    Fast.print ?allow_nan ?recursive buf x
+  else
+    (let fmt = Format.formatter_of_buffer buf in
+     (match recursive with
+	  None
+	| Some false -> Browse.assert_object_or_array x
+	| Some true -> ()
+     );
+     let allow_nan = match allow_nan with None -> false | Some b -> b in
+     Pretty.fprint_json allow_nan fmt x;
+     Format.pp_print_flush fmt ());
+  Buffer.contents buf
+
+let save_json ?allow_nan ?(compact = false) ?recursive file x =
+  let oc = open_out file in
+  let print = 
+    if compact then Compact.print
+    else Pretty.print in
+  let fmt = Format.formatter_of_out_channel oc in
+  try
+    print ?allow_nan ?recursive fmt x;
+    Format.pp_print_flush fmt ();
+    close_out oc
+  with e -> 
+    close_out_noerr oc;
+    raise e

external/jsonwheel/json_io.mli

@@ -0,0 +1,111 @@
+(** Input and output functions for the JSON format 
+  as defined by {{:http://www.json.org/}http://www.json.org/} *)
+
+
+(** [json_of_string s] reads the given JSON string.
+
+  If [allow_comments] is [true], then C++ style comments are allowed, i.e.
+  [/* blabla possibly on several lines */] or 
+  [// blabla until the end of the line]. Comments are not part of the JSON
+  specification and are disabled by default.
+
+  If [allow_nan] is [true], then OCaml [nan], [infinity] and [neg_infinity] 
+  float values are represented using their Javascript counterparts
+  [NaN], [Infinity] and [-Infinity].
+
+  If [big_int_mode] is [true], then JSON ints that cannot be represented
+  using OCaml's int type are represented by strings. 
+  This would happen only for ints that are out of the range defined
+  by [min_int] and [max_int], i.e. \[-1G, +1G\[ on a 32-bit platform.
+  The default is [false] and a [Json_type.Json_error] exception
+  is raised if an int is too big.
+
+  If [recursive] is true, then all JSON values are accepted rather
+  than just arrays and objects as specified by the standard.
+  The default is [false].
+*)
+val json_of_string : 
+  ?allow_comments:bool ->
+  ?allow_nan:bool ->
+  ?big_int_mode:bool ->
+  ?recursive:bool -> 
+  string -> Json_type.t
+
+(** Same as [Json_io.json_of_string] but the argument is a file
+  to read from. *)
+val load_json : 
+  ?allow_comments:bool ->
+  ?allow_nan:bool ->
+  ?big_int_mode:bool ->
+  ?recursive:bool -> 
+  string -> Json_type.t
+
+(** Conversion of JSON data to compact text. *)
+module Compact :
+sig
+  (** Generic printing function without superfluous space. 
+    See the standard [Format] module
+    for how to create and use formatters. 
+
+    In general, {!Json_io.string_of_json} and 
+    {!Json_io.save_json} are more convenient.
+  *)
+  val print : 
+    ?allow_nan: bool ->
+    ?recursive:bool ->
+    Format.formatter -> Json_type.t -> unit
+end
+
+(** Conversion of JSON data to compact text, optimized for speed. *)
+module Fast :
+sig
+  (** This function is faster than the one provided by the
+    {!Json_io.Compact} submodule but it is less generic and is subject to
+    the 16MB size limit of strings on 32-bit architectures. *)
+  val print : 
+    ?allow_nan: bool ->
+    ?recursive:bool ->
+    Buffer.t -> Json_type.t -> unit
+end
+
+
+(** Conversion of JSON data to indented text. *)
+module Pretty :
+sig
+  (** Generic pretty-printing function. 
+    See the standard [Format] module
+    for how to create and use formatters.
+    
+    In general, {!Json_io.string_of_json} and 
+    {!Json_io.save_json} are more convenient.
+  *)
+  val print : 
+    ?allow_nan: bool ->
+    ?recursive:bool ->
+    Format.formatter -> Json_type.t -> unit
+end
+
+(** [string_of_json] converts JSON data to a string.
+
+  By default, the output is indented. If the [compact] flag is set to true,
+  the output will not contain superfluous whitespace and will
+  be produced faster.
+
+  If [allow_nan] is [true], then OCaml [nan], [infinity] and [neg_infinity] 
+  float values are represented using their Javascript counterparts
+  [NaN], [Infinity] and [-Infinity].
+*)
+val string_of_json :
+  ?allow_nan: bool ->
+  ?compact:bool ->
+  ?recursive:bool ->
+  Json_type.t -> string
+
+(** [save_json] works like {!Json_io.string_of_json} but 
+  saves the results directly into the file specified by the
+  argument of type string. *)
+val save_json : 
+  ?allow_nan:bool -> 
+  ?compact:bool -> 
+  ?recursive:bool ->
+  string -> Json_type.t -> unit

external/jsonwheel/json_lexer.ml

@@ -0,0 +1,542 @@
+# 1 "json_lexer.mll"
+ 
+  open Printf
+  open Lexing
+
+  open Json_type
+  open Json_parser
+
+  let loc lexbuf = (lexbuf.lex_start_p, lexbuf.lex_curr_p)
+
+  (* Detection of the encoding from the 4 first characters of the data *)
+  let detect_encoding c1 c2 c3 c4 =
+    match c1, c2, c3, c4 with
+	'\000', '\000', '\000', _ -> `UTF32BE 
+      | '\000', _, '\000', _ -> `UTF16BE
+      | _, '\000', '\000', '\000' -> `UTF32LE 
+      | _, '\000', _, '\000' -> `UTF16LE 
+      | _ -> `UTF8
+
+  let hexval c =
+    match c with
+	'0'..'9' -> int_of_char c - int_of_char '0'
+      | 'a'..'f' -> int_of_char c - int_of_char 'a' + 10
+      | 'A'..'F' -> int_of_char c - int_of_char 'A' + 10
+      | _ -> assert false
+
+  let make_int big_int_mode s =
+    try INT (int_of_string s)
+    with _ -> 
+      if big_int_mode then STRING s
+      else json_error (s ^ " is too large for OCaml's type int, sorry")
+
+  let utf8_of_point i =
+    Netconversion2.ustring_of_uchar `Enc_utf8 i
+
+  let custom_error descr lexbuf =
+    json_error 
+      (sprintf "%s:\n%s"
+	 (string_of_loc (loc lexbuf))
+         descr)
+
+  let lexer_error descr lexbuf =
+    custom_error 
+      (sprintf "%s '%s'" descr (Lexing.lexeme lexbuf))
+      lexbuf
+
+  let set_file_name lexbuf name =
+    lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = name }
+
+  let newline lexbuf =
+    let pos = lexbuf.lex_curr_p in
+    lexbuf.lex_curr_p <- { pos with
+			     pos_lnum = pos.pos_lnum + 1;
+			     pos_bol = pos.pos_cnum }
+
+  type param = {
+    allow_comments : bool;
+    big_int_mode : bool;
+    allow_nan : bool
+  }
+
+# 63 "json_lexer.ml"
+let __ocaml_lex_tables = {
+  Lexing.lex_base = 
+   "\000\000\235\255\236\255\003\000\238\255\000\000\031\000\241\255\
+    \085\000\001\000\000\000\000\000\001\000\000\000\248\255\249\255\
+    \250\255\251\255\252\255\253\255\017\000\254\255\001\000\001\000\
+    \002\000\247\255\000\000\000\000\003\000\246\255\001\000\004\000\
+    \245\255\011\000\244\255\003\000\001\000\003\000\002\000\003\000\
+    \000\000\243\255\010\000\020\000\019\000\016\000\022\000\012\000\
+    \008\000\242\255\100\000\111\000\121\000\143\000\153\000\163\000\
+    \175\000\185\000\002\001\251\255\252\255\037\001\254\255\255\255\
+    \035\001\248\255\056\001\250\255\251\255\252\255\253\255\254\255\
+    \255\255\111\001\134\001\172\001\249\255\089\000\252\255\253\255\
+    \254\255\013\000\255\255";
+  Lexing.lex_backtrk = 
+   "\255\255\255\255\255\255\018\000\255\255\015\000\015\000\255\255\
+    \020\000\020\000\020\000\020\000\020\000\020\000\255\255\255\255\
+    \255\255\255\255\255\255\255\255\020\000\255\255\000\000\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\016\000\255\255\016\000\255\255\
+    \016\000\255\255\255\255\255\255\255\255\002\000\255\255\255\255\
+    \255\255\255\255\007\000\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\003\000\255\255";
+  Lexing.lex_default = 
+   "\001\000\000\000\000\000\255\255\000\000\255\255\255\255\000\000\
+    \255\255\255\255\255\255\255\255\255\255\255\255\000\000\000\000\
+    \000\000\000\000\000\000\000\000\255\255\000\000\022\000\255\255\
+    \255\255\000\000\255\255\255\255\255\255\000\000\255\255\255\255\
+    \000\000\255\255\000\000\255\255\255\255\255\255\255\255\255\255\
+    \255\255\000\000\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\000\000\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\061\000\000\000\000\000\061\000\000\000\000\000\
+    \065\000\000\000\255\255\000\000\000\000\000\000\000\000\000\000\
+    \000\000\255\255\255\255\255\255\000\000\078\000\000\000\000\000\
+    \000\000\255\255\000\000";
+  Lexing.lex_trans = 
+   "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\003\000\004\000\255\255\003\000\003\000\000\000\000\000\
+    \003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \003\000\000\000\007\000\003\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\015\000\008\000\051\000\020\000\
+    \005\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\
+    \006\000\006\000\014\000\021\000\082\000\000\000\000\000\000\000\
+    \022\000\000\000\000\000\000\000\000\000\050\000\000\000\000\000\
+    \000\000\009\000\000\000\000\000\000\000\051\000\010\000\006\000\
+    \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\
+    \006\000\034\000\000\000\017\000\000\000\016\000\000\000\000\000\
+    \000\000\033\000\026\000\079\000\050\000\050\000\012\000\025\000\
+    \029\000\036\000\037\000\039\000\027\000\031\000\011\000\035\000\
+    \032\000\038\000\023\000\028\000\013\000\030\000\024\000\040\000\
+    \043\000\041\000\044\000\019\000\045\000\018\000\046\000\047\000\
+    \048\000\049\000\000\000\081\000\050\000\005\000\006\000\006\000\
+    \006\000\006\000\006\000\006\000\006\000\006\000\006\000\057\000\
+    \000\000\057\000\000\000\000\000\056\000\056\000\056\000\056\000\
+    \056\000\056\000\056\000\056\000\056\000\056\000\042\000\052\000\
+    \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\
+    \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\
+    \052\000\052\000\052\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\055\000\000\000\055\000\000\000\053\000\054\000\
+    \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\
+    \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\
+    \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\
+    \054\000\054\000\054\000\054\000\054\000\000\000\053\000\056\000\
+    \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\
+    \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\
+    \056\000\056\000\056\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \002\000\255\255\060\000\060\000\060\000\060\000\060\000\060\000\
+    \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\
+    \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\
+    \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\
+    \060\000\060\000\000\000\000\000\063\000\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\072\000\000\000\255\255\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\072\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\080\000\000\000\000\000\000\000\000\000\062\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \073\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\
+    \073\000\073\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\073\000\073\000\073\000\073\000\073\000\073\000\072\000\
+    \000\000\255\255\000\000\000\000\000\000\071\000\000\000\000\000\
+    \000\000\070\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\069\000\000\000\000\000\000\000\068\000\000\000\067\000\
+    \066\000\073\000\073\000\073\000\073\000\073\000\073\000\074\000\
+    \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\
+    \074\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \074\000\074\000\074\000\074\000\074\000\074\000\075\000\075\000\
+    \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\075\000\
+    \075\000\075\000\075\000\075\000\075\000\000\000\000\000\000\000\
+    \074\000\074\000\074\000\074\000\074\000\074\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\076\000\076\000\076\000\076\000\
+    \076\000\076\000\076\000\076\000\076\000\076\000\000\000\075\000\
+    \075\000\075\000\075\000\075\000\075\000\076\000\076\000\076\000\
+    \076\000\076\000\076\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\059\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\076\000\076\000\076\000\
+    \076\000\076\000\076\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\255\255\000\000\255\255\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000";
+  Lexing.lex_check = 
+   "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\000\000\000\000\022\000\003\000\000\000\255\255\255\255\
+    \003\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \000\000\255\255\000\000\003\000\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\000\000\000\000\005\000\000\000\
+    \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+    \000\000\000\000\000\000\020\000\081\000\255\255\255\255\255\255\
+    \020\000\255\255\255\255\255\255\255\255\005\000\255\255\255\255\
+    \255\255\000\000\255\255\255\255\255\255\006\000\000\000\006\000\
+    \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\
+    \006\000\033\000\255\255\000\000\255\255\000\000\255\255\255\255\
+    \255\255\010\000\012\000\077\000\006\000\005\000\000\000\024\000\
+    \028\000\035\000\036\000\038\000\026\000\030\000\000\000\009\000\
+    \031\000\037\000\013\000\027\000\000\000\011\000\023\000\039\000\
+    \042\000\040\000\043\000\000\000\044\000\000\000\045\000\046\000\
+    \047\000\048\000\255\255\077\000\006\000\008\000\008\000\008\000\
+    \008\000\008\000\008\000\008\000\008\000\008\000\008\000\050\000\
+    \255\255\050\000\255\255\255\255\050\000\050\000\050\000\050\000\
+    \050\000\050\000\050\000\050\000\050\000\050\000\008\000\051\000\
+    \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\
+    \051\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\
+    \052\000\052\000\052\000\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\053\000\255\255\053\000\255\255\052\000\053\000\
+    \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\
+    \053\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\
+    \054\000\054\000\054\000\055\000\055\000\055\000\055\000\055\000\
+    \055\000\055\000\055\000\055\000\055\000\255\255\052\000\056\000\
+    \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\
+    \056\000\057\000\057\000\057\000\057\000\057\000\057\000\057\000\
+    \057\000\057\000\057\000\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \000\000\022\000\058\000\058\000\058\000\058\000\058\000\058\000\
+    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
+    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
+    \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\
+    \058\000\058\000\255\255\255\255\058\000\061\000\061\000\061\000\
+    \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\
+    \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\
+    \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\
+    \061\000\061\000\061\000\061\000\061\000\064\000\255\255\061\000\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\064\000\255\255\255\255\255\255\255\255\255\255\
+    \255\255\077\000\255\255\255\255\255\255\255\255\058\000\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\
+    \066\000\066\000\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\066\000\066\000\066\000\066\000\066\000\066\000\064\000\
+    \255\255\061\000\255\255\255\255\255\255\064\000\255\255\255\255\
+    \255\255\064\000\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\064\000\255\255\255\255\255\255\064\000\255\255\064\000\
+    \064\000\066\000\066\000\066\000\066\000\066\000\066\000\073\000\
+    \073\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\
+    \073\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \073\000\073\000\073\000\073\000\073\000\073\000\074\000\074\000\
+    \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\074\000\
+    \074\000\074\000\074\000\074\000\074\000\255\255\255\255\255\255\
+    \073\000\073\000\073\000\073\000\073\000\073\000\255\255\255\255\
+    \255\255\255\255\255\255\255\255\075\000\075\000\075\000\075\000\
+    \075\000\075\000\075\000\075\000\075\000\075\000\255\255\074\000\
+    \074\000\074\000\074\000\074\000\074\000\075\000\075\000\075\000\
+    \075\000\075\000\075\000\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\058\000\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\075\000\075\000\075\000\
+    \075\000\075\000\075\000\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\064\000\255\255\061\000\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+    \255\255\255\255\255\255\255\255\255\255";
+  Lexing.lex_base_code = 
+   "";
+  Lexing.lex_backtrk_code = 
+   "";
+  Lexing.lex_default_code = 
+   "";
+  Lexing.lex_trans_code = 
+   "";
+  Lexing.lex_check_code = 
+   "";
+  Lexing.lex_code = 
+   "";
+}
+
+let rec token p lexbuf =
+    __ocaml_lex_token_rec p lexbuf 0
+and __ocaml_lex_token_rec p lexbuf __ocaml_lex_state =
+  match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with
+      | 0 ->
+# 79 "json_lexer.mll"
+                 ( if p.allow_comments then 
+		     token p lexbuf
+		   else lexer_error "Comments are not allowed: " lexbuf )
+# 298 "json_lexer.ml"
+
+  | 1 ->
+# 82 "json_lexer.mll"
+                 ( if p.allow_comments then 
+		     (comment lexbuf; 
+		      token p lexbuf)
+		   else lexer_error "Comments are not allowed: " lexbuf )
+# 306 "json_lexer.ml"
+
+  | 2 ->
+# 86 "json_lexer.mll"
+            ( OBJSTART )
+# 311 "json_lexer.ml"
+
+  | 3 ->
+# 87 "json_lexer.mll"
+            ( OBJEND )
+# 316 "json_lexer.ml"
+
+  | 4 ->
+# 88 "json_lexer.mll"
+            ( ARSTART )
+# 321 "json_lexer.ml"
+
+  | 5 ->
+# 89 "json_lexer.mll"
+            ( AREND )
+# 326 "json_lexer.ml"
+
+  | 6 ->
+# 90 "json_lexer.mll"
+            ( COMMA )
+# 331 "json_lexer.ml"
+
+  | 7 ->
+# 91 "json_lexer.mll"
+            ( COLON )
+# 336 "json_lexer.ml"
+
+  | 8 ->
+# 92 "json_lexer.mll"
+            ( BOOL true )
+# 341 "json_lexer.ml"
+
+  | 9 ->
+# 93 "json_lexer.mll"
+            ( BOOL false )
+# 346 "json_lexer.ml"
+
+  | 10 ->
+# 94 "json_lexer.mll"
+            ( NULL )
+# 351 "json_lexer.ml"
+
+  | 11 ->
+# 95 "json_lexer.mll"
+            ( if p.allow_nan then FLOAT nan
+	      else lexer_error "NaN values are not allowed: " lexbuf )
+# 357 "json_lexer.ml"
+
+  | 12 ->
+# 97 "json_lexer.mll"
+               ( if p.allow_nan then FLOAT infinity
+		 else lexer_error "Infinite values are not allowed: " lexbuf )
+# 363 "json_lexer.ml"
+
+  | 13 ->
+# 99 "json_lexer.mll"
+                ( if p.allow_nan then FLOAT neg_infinity
+		  else lexer_error "Infinite values are not allowed: " lexbuf )
+# 369 "json_lexer.ml"
+
+  | 14 ->
+# 101 "json_lexer.mll"
+            ( STRING (string [] lexbuf) )
+# 374 "json_lexer.ml"
+
+  | 15 ->
+# 102 "json_lexer.mll"
+            ( make_int p.big_int_mode (lexeme lexbuf) )
+# 379 "json_lexer.ml"
+
+  | 16 ->
+# 103 "json_lexer.mll"
+            ( FLOAT (float_of_string (lexeme lexbuf)) )
+# 384 "json_lexer.ml"
+
+  | 17 ->
+# 104 "json_lexer.mll"
+            ( newline lexbuf; token p lexbuf )
+# 389 "json_lexer.ml"
+
+  | 18 ->
+# 105 "json_lexer.mll"
+            ( token p lexbuf )
+# 394 "json_lexer.ml"
+
+  | 19 ->
+# 106 "json_lexer.mll"
+            ( EOF )
+# 399 "json_lexer.ml"
+
+  | 20 ->
+# 107 "json_lexer.mll"
+            ( lexer_error "Invalid token" lexbuf )
+# 404 "json_lexer.ml"
+
+  | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_token_rec p lexbuf __ocaml_lex_state
+
+and string l lexbuf =
+    __ocaml_lex_string_rec l lexbuf 58
+and __ocaml_lex_string_rec l lexbuf __ocaml_lex_state =
+  match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with
+      | 0 ->
+# 111 "json_lexer.mll"
+                ( String.concat "" (List.rev l) )
+# 415 "json_lexer.ml"
+
+  | 1 ->
+# 112 "json_lexer.mll"
+                ( let s = escaped_char lexbuf in
+		    string (s :: l) lexbuf )
+# 421 "json_lexer.ml"
+
+  | 2 ->
+# 114 "json_lexer.mll"
+                ( let s = lexeme lexbuf in
+		       string (s :: l) lexbuf )
+# 427 "json_lexer.ml"
+
+  | 3 ->
+let
+# 116 "json_lexer.mll"
+         c
+# 433 "json_lexer.ml"
+= Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in
+# 116 "json_lexer.mll"
+                ( custom_error 
+		    (sprintf "Unescaped control character \\u%04X or \
+                              unterminated string" (int_of_char c))
+		    lexbuf )
+# 440 "json_lexer.ml"
+
+  | 4 ->
+# 120 "json_lexer.mll"
+                ( custom_error "Unterminated string" lexbuf )
+# 445 "json_lexer.ml"
+
+  | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_string_rec l lexbuf __ocaml_lex_state
+
+and escaped_char lexbuf =
+    __ocaml_lex_escaped_char_rec lexbuf 64
+and __ocaml_lex_escaped_char_rec lexbuf __ocaml_lex_state =
+  match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with
+      | 0 ->
+# 126 "json_lexer.mll"
+         ( lexeme lexbuf )
+# 456 "json_lexer.ml"
+
+  | 1 ->
+# 127 "json_lexer.mll"
+         ( "\b" )
+# 461 "json_lexer.ml"
+
+  | 2 ->
+# 128 "json_lexer.mll"
+         ( "\012" )
+# 466 "json_lexer.ml"
+
+  | 3 ->
+# 129 "json_lexer.mll"
+         ( "\n" )
+# 471 "json_lexer.ml"
+
+  | 4 ->
+# 130 "json_lexer.mll"
+         ( "\r" )
+# 476 "json_lexer.ml"
+
+  | 5 ->
+# 131 "json_lexer.mll"
+         ( "\t" )
+# 481 "json_lexer.ml"
+
+  | 6 ->
+let
+# 132 "json_lexer.mll"
+                            x
+# 487 "json_lexer.ml"
+= Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 1) (lexbuf.Lexing.lex_start_pos + 5) in
+# 132 "json_lexer.mll"
+                               ( let i = 0x1000 * hexval x.[0] +
+					 0x100 * hexval x.[1] +
+					 0x10 * hexval x.[2] + 
+					 hexval x.[3] in
+				 utf8_of_point i )
+# 495 "json_lexer.ml"
+
+  | 7 ->
+# 137 "json_lexer.mll"
+       ( lexer_error "Invalid escape sequence" lexbuf )
+# 500 "json_lexer.ml"
+
+  | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_escaped_char_rec lexbuf __ocaml_lex_state
+
+and comment lexbuf =
+    __ocaml_lex_comment_rec lexbuf 77
+and __ocaml_lex_comment_rec lexbuf __ocaml_lex_state =
+  match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with
+      | 0 ->
+# 140 "json_lexer.mll"
+         ( () )
+# 511 "json_lexer.ml"
+
+  | 1 ->
+# 141 "json_lexer.mll"
+         ( lexer_error "Unterminated comment" lexbuf )
+# 516 "json_lexer.ml"
+
+  | 2 ->
+# 142 "json_lexer.mll"
+         ( newline lexbuf; comment lexbuf )
+# 521 "json_lexer.ml"
+
+  | 3 ->
+# 143 "json_lexer.mll"
+         ( comment lexbuf )
+# 526 "json_lexer.ml"
+
+  | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_comment_rec lexbuf __ocaml_lex_state
+
+;;
+
+# 145 "json_lexer.mll"
+ 
+  let make_param 
+      ?(allow_comments = false)
+      ?(allow_nan = false)
+      ?(big_int_mode = false)
+      () =
+    { allow_comments = allow_comments;
+      big_int_mode = big_int_mode;
+      allow_nan = allow_nan }
+
+# 543 "json_lexer.ml"

external/jsonwheel/json_out.ml

@@ -0,0 +1,163 @@
+type t = Json_type.t
+open Json_type
+
+(* pad: copy paste of printing and pretty printing section of json_io.ml *)
+
+(*** Printing ***)
+
+(* JSON does not allow rendering floats with a trailing dot: that is,
+   1234. is not allowed, but 1234.0 is ok.  here, we add a '0' if
+   string_of_int result in a trailing dot *)
+let fprint_float allow_nan fmt f =
+  match classify_float f with
+      FP_nan -> 
+	if allow_nan then Format.fprintf fmt "NaN"
+	else json_error "Not allowed to serialize NaN value"
+    | FP_infinite ->
+	if allow_nan then
+	  if f < 0. then Format.fprintf fmt "-Infinity"
+	  else Format.fprintf fmt "Infinity"
+	else json_error "Not allowed to serialize infinite value"
+    | FP_zero
+    | FP_normal
+    | FP_subnormal ->
+	let s = string_of_float f in
+	Format.fprintf fmt "%s" s;
+	let s_len = String.length s in
+	if s.[ s_len - 1 ] = '.' then
+	  Format.fprintf fmt "0"
+
+let escape_json_string buf s =
+  for i = 0 to String.length s - 1 do
+    let c = String.unsafe_get s i in
+    match c with 
+      | '"'    -> Buffer.add_string buf "\\\""
+      | '\t'   -> Buffer.add_string buf "\\t"
+      | '\r'   -> Buffer.add_string buf "\\r"
+      | '\b'   -> Buffer.add_string buf "\\b"
+      | '\n'   -> Buffer.add_string buf "\\n"
+      | '\012' -> Buffer.add_string buf "\\f"
+      | '\\'   -> Buffer.add_string buf "\\\\"
+   (* | '/'    -> "\\/" *) (* Forward slash can be escaped 
+			      but doesn't have to *)
+      | '\x00'..'\x1F' (* Control characters that must be escaped *)
+      | '\x7F' (* DEL *) -> 
+	  Printf.bprintf buf "\\u%04X" (int_of_char c)
+      | _      -> 
+	  (* Don't bother detecting or escaping multibyte chars *)
+	  Buffer.add_char buf c
+  done
+
+let fquote_json_string fmt s =
+  let buf = Buffer.create (String.length s) in
+  escape_json_string buf s;
+  Format.fprintf fmt "\"%s\"" (Buffer.contents buf)
+
+let bquote_json_string buf s =
+  Printf.bprintf buf "\"%a\"" escape_json_string s
+
+(*** Pretty printing ***)
+
+module Pretty =
+struct
+  open Format
+    
+  (* Printing anything but a value in a key:value pair.
+
+     Opening and closing brackets in such arrays and objects
+     are aligned vertically if they are not on the same line. 
+  *)
+  let rec fprint_json allow_nan fmt = function
+      Object l -> fprint_object allow_nan fmt l
+    | Array l -> fprint_array allow_nan fmt l
+    | Bool b -> fprintf fmt "%s" (if b then "true" else "false")
+    | Null -> fprintf fmt "null"
+    | Int i -> fprintf fmt "%i" i
+    | Float f -> fprint_float allow_nan fmt f
+    | String s -> fquote_json_string fmt s
+	
+  (* Printing an array which is not the value in a key:value pair *)
+  and fprint_array allow_nan fmt = function
+      [] -> fprintf fmt "[]"
+    | x :: tl -> 
+	fprintf fmt "@[<hv 2>[@ "; 
+	fprint_json allow_nan fmt x;
+	List.iter (fun x -> 
+		     fprintf fmt ",@ ";
+		     fprint_json allow_nan fmt x) tl;
+	fprintf fmt "@;<1 -2>]@]"
+	  
+  (* Printing an object which is not the value in a key:value pair *)
+  and fprint_object allow_nan fmt = function
+      [] -> fprintf fmt "{}"
+    | x :: tl -> 
+	fprintf fmt "@[<hv 2>{@ "; 
+	fprint_pair allow_nan fmt x;
+	List.iter (fun x -> 
+		     fprintf fmt ",@ ";
+		     fprint_pair allow_nan fmt x) tl;
+	fprintf fmt "@;<1 -2>}@]"
+
+  (* Printing a key:value pair.
+
+     The opening bracket stays on the same line as the key, no matter what,
+     and the closing bracket is either on the same line
+     or vertically aligned with the beginning of the key. 
+  *)
+  and fprint_pair allow_nan fmt (key, x) =
+    match x with
+	Object l -> 
+	  (match l with
+	       [] -> fprintf fmt "%a: {}" fquote_json_string key
+	     | x :: tl -> 
+		 fprintf fmt "@[<hv 2>%a: {@ " fquote_json_string key;
+		 fprint_pair allow_nan fmt x;
+		 List.iter (fun x -> 
+			      fprintf fmt ",@ ";
+			      fprint_pair allow_nan fmt x) tl;
+		 fprintf fmt "@;<1 -2>}@]")
+      | Array l ->
+	  (match l with
+	       [] -> fprintf fmt "%a: []" fquote_json_string key
+	     | x :: tl -> 
+		 fprintf fmt "@[<hv 2>%a: [@ " fquote_json_string key;
+		 fprint_json allow_nan fmt x;
+		 List.iter (fun x -> 
+			      fprintf fmt ",@ ";
+			      fprint_json allow_nan fmt x) tl;
+		 fprintf fmt "@;<1 -2>]@]")
+      | _ -> 
+	  (* An atom, perhaps a long string that would go to the next line *)
+	  fprintf fmt "@[%a:@;<1 2>%a@]" 
+	    fquote_json_string key (fprint_json allow_nan) x
+
+  let print ?(allow_nan = false) ?(recursive = false) fmt x =
+    if not recursive then
+      Browse.assert_object_or_array x;
+    fprint_json allow_nan fmt x
+end
+
+
+let string_of_json ?allow_nan (*?(compact = false) ?recursive *) x =
+  let buf = Buffer.create 2000 in
+ (*
+  if compact then
+    Fast.print ?allow_nan ?recursive buf x
+  else
+    (let fmt = Format.formatter_of_buffer buf in
+     (match recursive with
+	  None
+	| Some false -> Browse.assert_object_or_array x
+	| Some true -> ()
+     );
+     let allow_nan = match allow_nan with None -> false | Some b -> b in
+     Pretty.fprint_json allow_nan fmt x;
+     Format.pp_print_flush fmt ());
+ *)
+  let fmt = Format.formatter_of_buffer buf in
+  let allow_nan = match allow_nan with None -> false | Some b -> b in
+  Pretty.fprint_json allow_nan fmt x;
+  Format.pp_print_flush fmt ();
+
+  Buffer.contents buf
+ 

external/jsonwheel/json_parser.ml

@@ -0,0 +1,429 @@
+type token =
+  | STRING of (string)
+  | INT of (int)
+  | FLOAT of (float)
+  | BOOL of (bool)
+  | OBJSTART
+  | OBJEND
+  | ARSTART
+  | AREND
+  | NULL
+  | COMMA
+  | COLON
+  | EOF
+
+open Parsing;;
+# 2 "json_parser.mly"
+  (* 
+     Notes about error messages and error locations in ocamlyacc:
+     
+     1) There is a predefined "error" symbol which can be used as a catch-all,
+     in order to get the location of the token that shouldn't be there.
+     
+     2) Additional rules that match common errors are added, so that when
+     they are matched, a nice, handcrafted error message is produced.
+     
+     3) Token locations are retrieved using functions from the Parsing
+     module, which relies on a global state. If you want your error locations
+     to be reliable, don't run two ocamlyacc parsers simultaneously.
+     
+
+     In the end, the error messages are nicer than the ones that a camlp4
+     parser (extensible grammar) would produce because we write them
+     manually. However camlp4's messages are all automatic, 
+     i.e. they tell you which tokens were expected at a given location.
+
+     For the file/line/char locations to be correct, 
+     the lexbuf must be adjusted by the lexer when the file name
+     changes or a new line is encountered. This is not performed automatically
+     by ocamllex, see file json_lexer.mll.
+  *)
+
+  open Printf
+  open Json_type
+			
+  let rhs_loc n = (Parsing.rhs_start_pos n, Parsing.rhs_end_pos n)
+		    
+  let unclosed opening_name opening_num closing_name closing_num =
+    let msg = 
+      sprintf "%s:\nSyntax error: '%s' expected.\n\
+               %s:\nThis '%s' might be unmatched."
+	(string_of_loc (rhs_loc closing_num)) closing_name
+	(string_of_loc (rhs_loc opening_num)) opening_name in
+    json_error msg
+
+  let syntax_error s num =
+    let msg = sprintf "%s:\n%s" (string_of_loc (rhs_loc num)) s in
+    json_error msg
+
+# 60 "json_parser.ml"
+let yytransl_const = [|
+  261 (* OBJSTART *);
+  262 (* OBJEND *);
+  263 (* ARSTART *);
+  264 (* AREND *);
+  265 (* NULL *);
+  266 (* COMMA *);
+  267 (* COLON *);
+    0 (* EOF *);
+    0|]
+
+let yytransl_block = [|
+  257 (* STRING *);
+  258 (* INT *);
+  259 (* FLOAT *);
+  260 (* BOOL *);
+    0|]
+
+let yylhs = "\255\255\
+\001\000\001\000\001\000\001\000\002\000\002\000\002\000\002\000\
+\002\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\
+\002\000\002\000\002\000\003\000\003\000\003\000\003\000\004\000\
+\004\000\004\000\004\000\000\000"
+
+let yylen = "\002\000\
+\002\000\002\000\001\000\001\000\003\000\002\000\003\000\003\000\
+\002\000\003\000\002\000\003\000\003\000\002\000\001\000\001\000\
+\001\000\001\000\001\000\005\000\005\000\004\000\003\000\003\000\
+\003\000\002\000\001\000\002\000"
+
+let yydefred = "\000\000\
+\000\000\000\000\004\000\015\000\018\000\019\000\016\000\000\000\
+\000\000\017\000\003\000\028\000\000\000\009\000\000\000\006\000\
+\000\000\014\000\011\000\000\000\000\000\002\000\001\000\000\000\
+\008\000\005\000\007\000\000\000\026\000\013\000\010\000\012\000\
+\000\000\025\000\024\000\022\000\000\000\021\000\020\000"
+
+let yydgoto = "\002\000\
+\012\000\020\000\017\000\021\000"
+
+let yysindex = "\003\000\
+\001\000\000\000\000\000\000\000\000\000\000\000\000\000\002\255\
+\024\255\000\000\000\000\000\000\011\000\000\000\251\254\000\000\
+\012\000\000\000\000\000\033\255\007\000\000\000\000\000\052\255\
+\000\000\000\000\000\000\043\255\000\000\000\000\000\000\000\000\
+\004\255\000\000\000\000\000\000\009\255\000\000\000\000"
+
+let yyrindex = "\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\009\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\013\000\000\000\000\000\000\000\000\000\000\000\000\000"
+
+let yygindex = "\000\000\
+\000\000\255\255\235\255\245\255"
+
+let yytablesize = 275
+let yytable = "\013\000\
+\011\000\014\000\015\000\001\000\036\000\024\000\032\000\016\000\
+\027\000\015\000\023\000\027\000\023\000\037\000\038\000\039\000\
+\035\000\000\000\029\000\000\000\000\000\000\000\033\000\018\000\
+\004\000\005\000\006\000\007\000\008\000\000\000\009\000\019\000\
+\010\000\004\000\005\000\006\000\007\000\008\000\000\000\009\000\
+\000\000\010\000\028\000\004\000\005\000\006\000\007\000\008\000\
+\000\000\009\000\034\000\010\000\004\000\005\000\006\000\007\000\
+\008\000\000\000\009\000\000\000\010\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+\003\000\004\000\005\000\006\000\007\000\008\000\030\000\009\000\
+\027\000\010\000\022\000\025\000\023\000\000\000\031\000\000\000\
+\027\000\026\000\023\000"
+
+let yycheck = "\001\000\
+\000\000\000\001\001\001\001\000\001\001\011\001\000\000\006\001\
+\000\000\001\001\000\000\000\000\000\000\010\001\006\001\037\000\
+\028\000\255\255\020\000\255\255\255\255\255\255\024\000\000\001\
+\001\001\002\001\003\001\004\001\005\001\255\255\007\001\008\001\
+\009\001\001\001\002\001\003\001\004\001\005\001\255\255\007\001\
+\255\255\009\001\010\001\001\001\002\001\003\001\004\001\005\001\
+\255\255\007\001\008\001\009\001\001\001\002\001\003\001\004\001\
+\005\001\255\255\007\001\255\255\009\001\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
+\000\001\001\001\002\001\003\001\004\001\005\001\000\001\007\001\
+\000\001\009\001\000\001\000\001\000\001\255\255\008\001\255\255\
+\008\001\006\001\006\001"
+
+let yynames_const = "\
+  OBJSTART\000\
+  OBJEND\000\
+  ARSTART\000\
+  AREND\000\
+  NULL\000\
+  COMMA\000\
+  COLON\000\
+  EOF\000\
+  "
+
+let yynames_block = "\
+  STRING\000\
+  INT\000\
+  FLOAT\000\
+  BOOL\000\
+  "
+
+let yyact = [|
+  (fun _ -> failwith "parser")
+; (fun __caml_parser_env ->
+    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'value) in
+    Obj.repr(
+# 55 "json_parser.mly"
+               ( _1 )
+# 218 "json_parser.ml"
+               : Json_type.t))
+; (fun __caml_parser_env ->
+    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'value) in
+    Obj.repr(
+# 56 "json_parser.mly"
+               ( syntax_error "Junk after end of data" 2 )
+# 225 "json_parser.ml"
+               : Json_type.t))
+; (fun __caml_parser_env ->
+    Obj.repr(
+# 57 "json_parser.mly"
+               ( syntax_error "Empty data" 1 )
+# 231 "json_parser.ml"
+               : Json_type.t))
+; (fun __caml_parser_env ->
+    Obj.repr(
+# 58 "json_parser.mly"
+               ( syntax_error "Syntax error" 1 )
+# 237 "json_parser.ml"
+               : Json_type.t))
+; (fun __caml_parser_env ->
+    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'pair_list) in
+    Obj.repr(
+# 61 "json_parser.mly"
+                            ( Object _2 )
+# 244 "json_parser.ml"
+               : 'value))
+; (fun __caml_parser_env ->
+    Obj.repr(
+# 62 "json_parser.mly"
+                            ( Object [] )
+# 250 "json_parser.ml"
+               : 'value))
+; (fun __caml_parser_env ->
+    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'pair_list) in
+    Obj.repr(
+# 63 "json_parser.mly"
+                            ( unclosed "{" 1 "}" 3 )
+# 257 "json_parser.ml"
+               : 'value))
+; (fun __caml_parser_env ->
+    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'pair_list) in
+    Obj.repr(
+# 64 "json_parser.mly"
+                            ( unclosed "{" 1 "}" 3 )
+# 264 "json_parser.ml"
+               : 'value))
+; (fun __caml_parser_env ->
+    Obj.repr(
+# 65 "json_parser.mly"
+                            ( syntax_error 
+				"Expecting a comma-separated sequence \
+                                 of string:value pairs" 2 )
+# 272 "json_parser.ml"
+               : 'value))
+; (fun __caml_parser_env ->
+    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'value_list) in
+    Obj.repr(
+# 68 "json_parser.mly"
+                            ( Array _2 )
+# 279 "json_parser.ml"
+               : 'value))
+; (fun __caml_parser_env ->
+    Obj.repr(
+# 69 "json_parser.mly"
+                            ( Array [] )
+# 285 "json_parser.ml"
+               : 'value))
+; (fun __caml_parser_env ->
+    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'value_list) in
+    Obj.repr(
+# 70 "json_parser.mly"
+                            ( unclosed "[" 1 "]" 3 )
+# 292 "json_parser.ml"
+               : 'value))
+; (fun __caml_parser_env ->
+    let _2 = (Parsing.peek_val __caml_parser_env 1 : 'value_list) in
+    Obj.repr(
+# 71 "json_parser.mly"
+                            ( unclosed "[" 1 "]" 3 )
+# 299 "json_parser.ml"
+               : 'value))
+; (fun __caml_parser_env ->
+    Obj.repr(
+# 72 "json_parser.mly"
+                            ( syntax_error 
+				"Expecting a comma-separated sequence \
+                                 of values" 2 )
+# 307 "json_parser.ml"
+               : 'value))
+; (fun __caml_parser_env ->
+    let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in
+    Obj.repr(
+# 75 "json_parser.mly"
+         ( String _1 )
+# 314 "json_parser.ml"
+               : 'value))
+; (fun __caml_parser_env ->
+    let _1 = (Parsing.peek_val __caml_parser_env 0 : bool) in
+    Obj.repr(
+# 76 "json_parser.mly"
+       ( Bool _1 )
+# 321 "json_parser.ml"
+               : 'value))
+; (fun __caml_parser_env ->
+    Obj.repr(
+# 77 "json_parser.mly"
+       ( Null )
+# 327 "json_parser.ml"
+               : 'value))
+; (fun __caml_parser_env ->
+    let _1 = (Parsing.peek_val __caml_parser_env 0 : int) in
+    Obj.repr(
+# 78 "json_parser.mly"
+       ( Int _1 )
+# 334 "json_parser.ml"
+               : 'value))
+; (fun __caml_parser_env ->
+    let _1 = (Parsing.peek_val __caml_parser_env 0 : float) in
+    Obj.repr(
+# 79 "json_parser.mly"
+        ( Float _1 )
+# 341 "json_parser.ml"
+               : 'value))
+; (fun __caml_parser_env ->
+    let _1 = (Parsing.peek_val __caml_parser_env 4 : string) in
+    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'value) in
+    let _5 = (Parsing.peek_val __caml_parser_env 0 : 'pair_list) in
+    Obj.repr(
+# 82 "json_parser.mly"
+                                     ( (_1, _3) :: _5 )
+# 350 "json_parser.ml"
+               : 'pair_list))
+; (fun __caml_parser_env ->
+    let _1 = (Parsing.peek_val __caml_parser_env 4 : string) in
+    let _3 = (Parsing.peek_val __caml_parser_env 2 : 'value) in
+    Obj.repr(
+# 84 "json_parser.mly"
+                             ( syntax_error 
+				"End-of-object commas are illegal" 4 )
+# 359 "json_parser.ml"
+               : 'pair_list))
+; (fun __caml_parser_env ->
+    let _1 = (Parsing.peek_val __caml_parser_env 3 : string) in
+    let _3 = (Parsing.peek_val __caml_parser_env 1 : 'value) in
+    let _4 = (Parsing.peek_val __caml_parser_env 0 : string) in
+    Obj.repr(
+# 86 "json_parser.mly"
+                             ( syntax_error "Missing ','" 4 )
+# 368 "json_parser.ml"
+               : 'pair_list))
+; (fun __caml_parser_env ->
+    let _1 = (Parsing.peek_val __caml_parser_env 2 : string) in
+    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'value) in
+    Obj.repr(
+# 87 "json_parser.mly"
+                             ( [ (_1, _3) ] )
+# 376 "json_parser.ml"
+               : 'pair_list))
+; (fun __caml_parser_env ->
+    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'value) in
+    let _3 = (Parsing.peek_val __caml_parser_env 0 : 'value_list) in
+    Obj.repr(
+# 90 "json_parser.mly"
+                         ( _1 :: _3 )
+# 384 "json_parser.ml"
+               : 'value_list))
+; (fun __caml_parser_env ->
+    let _1 = (Parsing.peek_val __caml_parser_env 2 : 'value) in
+    Obj.repr(
+# 91 "json_parser.mly"
+                         ( syntax_error 
+			     "End-of-array commas are illegal" 2 )
+# 392 "json_parser.ml"
+               : 'value_list))
+; (fun __caml_parser_env ->
+    let _1 = (Parsing.peek_val __caml_parser_env 1 : 'value) in
+    let _2 = (Parsing.peek_val __caml_parser_env 0 : 'value) in
+    Obj.repr(
+# 93 "json_parser.mly"
+                         ( syntax_error "Missing ',' before this value" 2 )
+# 400 "json_parser.ml"
+               : 'value_list))
+; (fun __caml_parser_env ->
+    let _1 = (Parsing.peek_val __caml_parser_env 0 : 'value) in
+    Obj.repr(
+# 94 "json_parser.mly"
+                         ( [ _1 ] )
+# 407 "json_parser.ml"
+               : 'value_list))
+(* Entry main *)
+; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0)))
+|]
+let yytables =
+  { Parsing.actions=yyact;
+    Parsing.transl_const=yytransl_const;
+    Parsing.transl_block=yytransl_block;
+    Parsing.lhs=yylhs;
+    Parsing.len=yylen;
+    Parsing.defred=yydefred;
+    Parsing.dgoto=yydgoto;
+    Parsing.sindex=yysindex;
+    Parsing.rindex=yyrindex;
+    Parsing.gindex=yygindex;
+    Parsing.tablesize=yytablesize;
+    Parsing.table=yytable;
+    Parsing.check=yycheck;
+    Parsing.error_function=parse_error;
+    Parsing.names_const=yynames_const;
+    Parsing.names_block=yynames_block }
+let main (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) =
+   (Parsing.yyparse yytables 1 lexfun lexbuf : Json_type.t)

external/jsonwheel/json_parser.mli

@@ -0,0 +1,16 @@
+type token =
+  | STRING of (string)
+  | INT of (int)
+  | FLOAT of (float)
+  | BOOL of (bool)
+  | OBJSTART
+  | OBJEND
+  | ARSTART
+  | AREND
+  | NULL
+  | COMMA
+  | COLON
+  | EOF
+
+val main :
+  (Lexing.lexbuf  -> token) -> Lexing.lexbuf -> Json_type.t

external/jsonwheel/json_type.ml

@@ -0,0 +1,153 @@
+open Printf
+open Lexing
+
+type json_type =
+  | Object of (string * json_type) list
+  | Array of json_type list
+
+  | String of string
+  | Int of int
+  | Float of float
+  | Bool of bool
+
+  | Null
+
+type t = json_type
+
+exception Json_error of string
+
+let json_error s = raise (Json_error s)
+
+
+module Browse =
+struct
+
+  let make_table l = 
+    let tbl = Hashtbl.create (List.length l) in
+    List.iter (fun (key, data) -> Hashtbl.add tbl key data) l;
+    tbl
+
+  let field tbl x =
+    match Hashtbl.find_all tbl x with
+	[y] -> y
+      | [] -> json_error ("Missing field " ^ x)
+      | _ -> json_error ("Only one field " ^ x ^ " is expected")
+
+  let fieldx tbl x =
+    match Hashtbl.find_all tbl x with
+	[y] -> y
+      | [] -> Null
+      | _ -> json_error ("At most one field " ^ x ^ " is expected")
+
+  let optfield tbl x =
+    match Hashtbl.find_all tbl x with
+	[y] -> Some y
+      | [] -> None
+      | _ -> json_error ("At most one field " ^ x ^ " is expected")
+
+  let optfieldx tbl x =
+    match Hashtbl.find_all tbl x with
+	[y] -> 
+	  if y = Null then None
+	  else Some y
+      | [] -> None
+      | _ -> json_error ("At most one field " ^ x ^ " is expected")
+
+  let describe = function
+      Bool true -> "true"
+    | Bool false -> "false"
+    | Int i -> string_of_int i
+    | Float x -> string_of_float x
+    | String s -> sprintf "%S" s
+    | Object _ -> "an object"
+    | Array _ -> "an array"
+    | Null -> "null"
+
+  let type_mismatch expected x =
+    let descr = describe x in
+    json_error (sprintf "Expecting %s, not %s" expected descr)
+
+  let is_null x = x = Null
+  let is_defined x = x <> Null
+
+  let null = function
+      Null -> ()
+    | x -> type_mismatch "a null value" x
+
+  let string = function
+      String s -> s
+    | x -> type_mismatch "a string" x
+
+  let bool = function
+      Bool x -> x
+    | x -> type_mismatch "a bool" x
+	
+  let number = function
+      Float x -> x
+    | Int i -> Pervasives.float i
+    | x -> type_mismatch "a number" x
+	
+  let int = function
+      Int x -> x
+    | x -> type_mismatch "an int" x
+
+  let float = function
+      Float x -> x
+    | x -> type_mismatch "a float" x
+
+  let array = function
+      Array x -> x
+    | x -> type_mismatch "an array" x
+
+  let objekt = function
+      Object x -> x
+    | x -> type_mismatch "an object" x
+
+  let list f x = List.map f (array x)
+
+  let option = function
+      Null -> None
+    | x -> Some x
+
+  let optional f = function
+      Null -> None
+    | x -> Some (f x)
+
+  let assert_object_or_array x =
+    match x with
+	Object _ 
+      | Array _ -> ()
+      | _ -> type_mismatch "an array or an object" x
+end
+
+module Build =
+struct
+  let null = Null
+  let bool x = Bool x
+  let int x = Int x
+  let float x = Float x
+  let string x = String x
+  let objekt l = Object l
+  let array l = Array l
+
+  let list f l = Array (List.map f l)
+
+  let option = function
+      None -> Null
+    | Some x -> x
+
+  let optional f = function
+      None -> Null
+    | Some x -> f x
+end
+
+(* pad: *)
+let json_of_list of_a xs = Array(List.map of_a xs)
+
+let string_of_loc (pos1, pos2) =
+  let line1 = pos1.pos_lnum
+  and start1 = pos1.pos_bol in
+  Printf.sprintf "File %S, line %i, characters %i-%i"
+    pos1.pos_fname line1
+    (pos1.pos_cnum - start1)
+    (pos2.pos_cnum - start1)

external/jsonwheel/json_type.mli

@@ -0,0 +1,224 @@
+(** OCaml representation of JSON data *)
+
+(** A [json_type] is a boolean, integer, real, string, null.  It can 
+  also be lists [Array] or string-keyed maps [Object] of 
+  [json_type]'s.  The JSON payload can only be an [Object] or [Array].
+
+  This type is used by the parsing and printing functions from the
+  {!Json_io} module. Typically, a program would convert such data into
+  a specialized type that uses records, etc. For the purpose of converting
+  from and to other types, two submodules are provided: {!Json_type.Browse} 
+  and  {!Json_type.Build}. 
+  They are meant to be opened using either [open Json_type.Browse] 
+  or [open Json_type.Build]. They provided simple functions for converting
+  JSON data. *)
+type json_type =
+    Object of (string * json_type) list
+  | Array of json_type list
+  | String of string
+  | Int of int
+  | Float of float
+  | Bool of bool
+  | Null
+
+(** [t] is an alias for [json_type]. *)
+type t = json_type
+
+(** Errors that are produced by the json-wheel library are represented
+  using the [Json_error] exception.
+
+  Other exceptions may be raised when calling functions from the library. 
+  Either they come from
+  the failure of external functions or like [Not_found] they
+  are not errors per se, and are specifically documented.
+*)
+exception Json_error of string
+
+(** This submodule provides some simple functions for checking
+  and reading the structure of JSON data.
+
+  Use [open Json_type.Browse] when you want to convert JSON data
+  into another OCaml type. 
+*)
+module Browse :
+  sig
+(** [make_table] creates a hash table from the contents of a JSON [Object].
+  For example, if [x] is a JSON [Object], then the corresponding table
+  can be created by [let tbl = make_table (objekt x)].
+
+  Hash tables are more efficient than lists
+  if several fields must be extracted 
+  and converted into something like an OCaml record.
+
+  The key/value pairs are added from left to right.
+  Therefore if there are several bindings for the same key, the latest
+  to appear in the list will be the first in the list
+  returned by [Hashtbl.find_all]. *)
+    val make_table : (string * t) list -> (string, t) Hashtbl.t
+
+(** [field tbl key] looks for a unique field [key] in hash table [tbl].
+  It raises a [Json_error] if [key] is not found in the table
+  or if it is present multiple times. *)
+    val field : (string, t) Hashtbl.t -> string -> t
+
+(** [fieldx tbl key] works like [field tbl key], but returns [Null] if
+  [key] is not found in the table. This function is convenient when
+  assuming that a field which is set to [Null] is the same
+  as if it were not defined. 
+
+  For instance, [optional int (fieldx tbl "year")] looks in 
+  table [tbl] for a field ["year"]. If this field is set to [Null]
+  or if it is undefined, then [None] is returned, otherwise
+  an [Int] is expected and returned, for example as [Some 2006].
+  If the value is of another JSON type than [Int] or [Null], it causes an
+  error. *)
+    val fieldx : (string, t) Hashtbl.t -> string -> t
+
+(** [optfield tbl key] queries hash table [tbl] for zero or one field [key].
+  The result is returned as [None] or [Some result]. If there are several
+  fields with the same [key], then a [Json_error] is produced.
+  
+  [Null] is returned as [Some Null], not
+  as [None]. For other behaviors see {!Json_type.Browse.fieldx}
+  and {!Json_type.Browse.optfieldx}. *)
+    val optfield : (string, t) Hashtbl.t -> string -> t option
+
+(** [optfieldx] is the same as [optfield] except that it
+  will never return [Some Null]
+  but [None] instead. *)
+    val optfieldx : (string, t) Hashtbl.t -> string -> t option
+
+
+(** [describe x] returns a short description of the given JSON data.
+  Its purpose is to help build error messages. *)
+    val describe : t -> string
+
+(** [type_mismatch expected x] raises the [Json_error msg] exception,
+  where [msg] is a message that describes the error as a type mismatch
+  between the element [x] and what is [expected]. *)
+    val type_mismatch : string -> t -> 'a
+
+(** tells whether the given JSON element is null *)
+    val is_null : t -> bool
+
+(** tells whether the given JSON element is not null *)
+    val is_defined : t -> bool
+
+(** raises a [Json_error] exception if the given JSON value is not [Null]. *)
+    val null : t -> unit
+
+(** reads a JSON element as a string or raises a [Json_error] exception. *)
+    val string : t -> string
+
+(** reads a JSON element as a bool or raises a [Json_error] exception. *)
+    val bool : t -> bool
+
+(** reads a JSON element as an int or a float and returns a float 
+  or raises a [Json_error] exception. *)
+    val number : t -> float
+
+(** reads a JSON element as an int or raises a [Json_error] exception. *)
+    val int : t -> int
+
+(** reads a JSON element as a float or raises a [Json_error] exception. *)
+    val float : t -> float
+
+(** reads a JSON element as a JSON [Array] and returns an OCaml list,
+  or raises a [Json_error] exception. *)
+    val array : t -> t list
+
+(** reads a JSON element as a JSON [Object] and returns an OCaml list,
+  or raises a [Json_error] exception.
+
+  Note the unusual spelling. [object] being
+  a keyword in OCaml, we use [objekt]. [Object] with a capital is still
+  spelled [Object]. *)
+    val objekt : t -> (string * t) list
+
+(** [list f x] maps a JSON [Array x] to an OCaml list, 
+  converting each element
+  of list [x] using [f]. A [Json_error] exception is raised if 
+  the given element is not a JSON [Array]. 
+
+  For example, converting a JSON array that must contain only ints 
+  is performed using [list int x]. Similarly, a list of lists of ints 
+  can be obtained using [list (list int) x]. *)
+    val list : (t -> 'a) -> t -> 'a list
+
+(** [option x] returns [None] is [x] is [Null] and [Some x] otherwise. *)
+    val option : t -> t option
+
+(** [optional f x] maps x using the given function [f] and returns 
+  [Some result], unless [x] is [Null] in which case it returns [None].
+
+  For example, [optional int x] may return something like
+  [Some 123] or [None] or raise a [Json_error] exception in case
+  [x] is neither [Null] nor an [Int].
+
+  See also {!Json_type.Browse.fieldx}. *)
+    val optional : (t -> 'a) -> t -> 'a option
+
+(**/**)
+    val assert_object_or_array : t -> unit
+  end
+
+
+(** This submodule provides some simple functions for building
+  JSON data from other OCaml types.
+
+  Use [open Json_type.Build] when you want to convert JSON data
+  into another OCaml type. 
+*)
+module Build :
+  sig
+    val null : t
+      (** The [Null] value *)
+
+    val bool : bool -> t
+      (** builds a JSON [Bool] *)
+
+    val int : int -> t
+      (** builds a JSON [Int] *)
+
+    val float : float -> t
+      (** builds a JSON [Float] *)
+
+    val string : string -> t
+      (** builds a JSON [String] *)
+
+    val objekt : (string * t) list -> t
+      (** builds a JSON [Object].
+
+	See {!Json_type.Browse.objekt} for an explanation about the unusual
+	spelling. *)
+
+    val array : t list -> t
+      (** builds a JSON [Array]. *)
+
+    val list : ('a -> t) -> 'a list -> t
+      (** [list f l] maps OCaml list [l] to a JSON list using 
+	function [f] to convert the elements into JSON values.
+
+      For example, [list int [1; 2; 3]] is a shortcut for
+      [Array [ Int 1; Int 2; Int 3 ]]. *)
+
+    val option : t option -> t
+      (** [option x] returns [Null] is [x] is [None], or [y] if 
+	[x] is [Some y]. *)
+
+    val optional : ('a -> t) -> 'a option -> t
+      (** [optional f x] returns [Null] if [x] is [None], or [f x]
+	otherwise.
+
+      For example, [list (optional int) [Some 1; Some 2; None]] returns
+      [Array [ Int 1; Int 2; Null ]]. *)
+  end
+
+(**/**)
+
+(* pad: *)
+val json_of_list: ('a -> t) -> 'a list -> t
+ 
+
+val string_of_loc : (Lexing.position * Lexing.position) -> string
+val json_error : string -> 'a

external/jsonwheel/license.txt

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

external/jsonwheel/modif-orig.txt

@@ -0,0 +1,8 @@
+Modified Makefile to not require ocamlfind or netstring
+and created a slice of json_io.ml  in json_out.ml.
+
+Json-wheel is better structured than sexplib. Martin correctly
+realized that people may want to use Json as-is, without the automatic
+converting camlp4 stuff. So he splitted in json-wheel and json-static.
+They should have done that for sexplib too. Nevertheless he requires
+netconversion stuff :(

external/jsonwheel/netconversion2.ml

@@ -0,0 +1,8 @@
+
+let once = ref false
+let ustring_of_uchar x y =
+  if not !once then begin
+    prerr_string "(lib-json)ustring_of_uchar: Todo\n"; flush stderr;
+    once := true
+  end;
+  "PBUSTRINGOFCHAR"

external/jsonwheel/readme.txt

@@ -0,0 +1,70 @@
+This is an OCaml library which reads and writes data in the JSON format
+(JavaScript Object Notation).
+This format can be used as a light-weight replacement for XML.
+Visit http://www.json.org for more information about JSON.
+
+The documentation for this library is located at
+  http://martin.jambon.free.fr/json-wheel/
+
+
+Installation
+============
+
+Requirements:
+- OCaml
+- GNU make
+- the findlib library manager (ocamlfind command)
+- the netstring library
+
+From the source directory, do:
+
+  make
+  make install
+
+If you want to remove the package do:
+
+  make uninstall
+
+
+Standard compliance
+===================
+
+The JSON parser, in the default mode, conforms to the specifications 
+of RFC 4627, with only some limitations due to the implementation 
+of the corresponding OCaml types:
+
+* ints that are too large to be represented with the OCaml int type
+  cause an error. The limit depends whether it is a 32-bit or 64-bit
+  platform (see min_int and max_int).
+
+* floats may be represented with reduced precision as they must fit
+  into the 8 bytes of the "double" format.
+
+* The size of OCaml strings is limited to about 16MB on 32-bit
+  platforms, and much more on 64-bit platforms (see Sys.max_string_length).
+
+
+RFC 4627: http://www.ietf.org/rfc/rfc4627.txt?number=4627
+
+
+The UTF-8 encoding is supported, however no attempt is made at
+checking whether strings are actually valid UTF-8 or not. Therefore, other
+ASCII-compatible encodings such as the ISO 8859 series are supported
+as well.
+
+
+Tests
+=====
+
+Json.org provides a test suite. You can download the file (test.zip),
+unzip it in the parent directory, and run "make test".
+Look for ERROR messages, which indicate that a file that should fail
+actually passes or that a file that should pass fails the test.
+
+../test/fail18.json doesn't pass: this is only because an int which is
+too large for the OCaml int type on a 32-bit platform.
+
+../test/fail18.json passes: it is marked as "should fail" because is
+has a high number of nesting. Although the standard allows such
+restrictions, there are not mandatory at all. Our parser does not have
+such a restriction.

find_source.ml

@@ -0,0 +1,140 @@
+open Common
+
+
+let finder lang = 
+  match lang with
+  | "c++" -> 
+    Lib_parsing_cpp.find_source_files_of_dir_or_files
+  | "c" -> 
+    Lib_parsing_c.find_source_files_of_dir_or_files
+  | "dot" -> (fun _ -> [])
+  | _ -> failwith ("Find_source: unsupported language: " ^ lang)
+
+let skip_file dir = 
+  Filename.concat dir "skip_list.txt"
+
+
+let files_of_dir_or_files ~lang xs =
+  let finder = finder lang in
+  let xs = List.map Common.fullpath xs in
+  finder xs |> Skip_code.filter_files_if_skip_list
+
+
+(* todo: factorize with filter_files_if_skip_list? *)
+let files_of_root ~lang root =
+  let finder = finder lang in
+  let files = finder [root] in
+
+  let skip_list =
+    if Sys.file_exists (skip_file root)
+    then begin 
+      pr2 (spf "Using skip file: %s" (skip_file root));
+      Skip_code.load (skip_file root);
+    end
+    else []
+  in
+  let files = Skip_code.filter_files skip_list root files in
+  files
+
+(*
+  let root = Common.realpath dir in
+  let all_files = Lib_parsing_clang.find_source2_files_of_dir_or_files [root] in
+
+  (* step0: filter noisy modules/files *)
+  let files = Skip_code.filter_files skip_list root all_files in
+  (* step0: reorder files *)
+  let files = Skip_code.reorder_files_skip_errors_last skip_list root files in
+
+  let root = Common.realpath dir_or_file in
+  let all_files = 
+    Lib_parsing_bytecode.find_source_files_of_dir_or_files [root] in
+
+  (* step0: filter noisy modules/files *)
+  let files = 
+    Skip_code.filter_files skip_list root all_files in
+
+  let root = Common.realpath dir in
+  let all_files = Lib_parsing_c.find_source_files_of_dir_or_files [root] in
+
+  (* step0: filter noisy modules/files *)
+  let files = Skip_code.filter_files skip_list root all_files in
+
+
+  let root = Common.realpath dir_or_file in
+  let all_files = Lib_parsing_java.find_source_files_of_dir_or_files [root] in
+
+  (* step0: filter noisy modules/files *)
+  let files = Skip_code.filter_files skip_list root all_files in
+
+  let root = Common.realpath dir in
+  let all_files = Lib_parsing_ml.find_source_files_of_dir_or_files [root] in
+
+  (* step0: filter noisy modules/files *)
+  let files = Skip_code.filter_files skip_list root all_files in
+  
+
+  let root = Common.realpath dir in
+  let all_files = Lib_parsing_cpp.find_source_files_of_dir_or_files [root] in
+
+  (* step0: filter noisy modules/files *)
+  let files = Skip_code.filter_files skip_list root all_files in
+
+  let root, files =
+    Common.profile_code "Graph_php.step0" (fun () ->
+    match dir_or_files with
+    | Left dir ->
+        let root = Common.realpath dir in
+        let files = 
+          Lib_parsing_php.find_php_files_of_dir_or_files [root]
+          +> Skip_code.filter_files skip_list root
+          +> Skip_code.reorder_files_skip_errors_last skip_list root
+        in
+        root, files
+    (* useful when build codegraph from test code *)
+    | Right files ->
+        "/", files
+    )
+  in
+
+
+
+  
+  let root, files =
+    match dir_or_files with
+    | Left dir ->
+      let root = Common.realpath dir in
+      let all_files = Lib_parsing_php.find_php_files_of_dir_or_files [root] in
+
+      (* step0: filter noisy modules/files *)
+      let files = 
+        Skip_code.filter_files skip_list root all_files in
+      (* step0: reorder files *)
+      let files = 
+        Skip_code.reorder_files_skip_errors_last skip_list root files in
+      root, files
+    (* useful when build from test code *)
+    | Right files ->
+      "/", files
+  in
+
+  let skip_file = !skip_list ||| skip_file_of_dir root in
+  let skip_list =
+    if Sys.file_exists skip_file
+    then begin 
+      pr2 (spf "Using skip file: %s" skip_file);
+      Skip_code.load skip_file
+    end
+    else []
+  in
+  let finder = Find_source.finder lang in
+
+    let skip_file = "skip_list.txt" in
+    let skip_list =
+      if Sys.file_exists skip_file
+      then begin 
+        pr2 (spf "Using skip file: %s" skip_file);
+        Skip_code.load skip_file
+      end
+      else []
+    in
+*)

find_source.mli

@@ -0,0 +1,13 @@
+
+(* will manage optional skip list at root *)
+val files_of_root: 
+  lang:string -> 
+  Common.dirname -> Common.filename list
+
+(* will manage optional skip list at root of vcs *)
+val files_of_dir_or_files: 
+  lang:string ->
+  Common.path list -> Common.filename list
+
+
+val finder: string -> (Common.path list -> Common.filename list)

globals/.depend

@@ -0,0 +1,2 @@
+config_pfff.cmo :
+config_pfff.cmx :

globals/META

@@ -0,0 +1,4 @@
+description = "required pfff modules when using -linkall, from pfff"
+requires = "unix num"
+archive(byte) = "lib.cma"
+archive(native) = "lib.cmxa"

globals/Makefile

@@ -0,0 +1,49 @@
+TOP=..
+-include $(TOP)/Makefile.config
+
+##############################################################################
+# Variables
+##############################################################################
+TARGET=lib
+
+SRC= config_pfff.ml
+
+LIBS=
+INCLUDEDIRS=../commons
+
+##############################################################################
+# Generic
+##############################################################################
+-include $(TOP)/Makefile.common
+
+##############################################################################
+# Top rules
+##############################################################################
+all:: $(TARGET).cma
+
+all.opt: $(TARGET).cmxa
+
+$(TARGET).cma: $(OBJS) $(LIBS)
+	$(OCAMLC) -a -o $(TARGET).cma $(OBJS)
+
+$(TARGET).cmxa: $(OPTOBJS) $(LIBS:.cma=.cmxa)
+	$(OCAMLOPT) -a -o $(TARGET).cmxa $(OPTOBJS)
+
+
+config_pfff.ml:
+	@echo "config_pfff.ml is missing. Have you run ./configure?"
+	@exit 1
+
+distclean::
+	rm -f config_pfff.ml
+
+##############################################################################
+# install
+##############################################################################
+LIBNAME=pfff-config
+EXPORTSRC=\
+
+install-findlib: all all.opt
+	ocamlfind install $(LIBNAME) META \
+          lib.cma lib.cmxa lib.a \
+          $(EXPORTSRC) $(EXPORTSRC:%.mli=%.cmi) \

globals/config_pfff.ml

@@ -0,0 +1,11 @@
+let version = "0.29"
+
+let path =
+  try (Sys.getenv "PFFF_HOME")
+  with Not_found->"/usr/local/share/pfff"
+
+let std_xxx = ref (Filename.concat path "xxx.yyy")
+
+let logger =
+  try Some (Sys.getenv "PFFF_LOGGER")
+  with Not_found-> None

globals/config_pfff.ml.in

@@ -0,0 +1,11 @@
+let version = "0.29"
+
+let path = 
+  try (Sys.getenv "PFFF_HOME") 
+  with Not_found1->"/usr/local/share/pfff" 
+
+let std_xxx = ref (Filename.concat path "xxx.yyy")
+
+let logger = 
+  try Some (Sys.getenv "PFFF_LOGGER")
+  with Not_found2-> None

h_files-format/.depend

@@ -0,0 +1,13 @@
+outline.cmo : ../commons/common2.cmi ../commons/common.cmi outline.cmi
+outline.cmx : ../commons/common2.cmx ../commons/common.cmx outline.cmi
+outline.cmi : ../commons/common2.cmi ../commons/common.cmi
+simple_format.cmo : ../commons/common2.cmi ../commons/common.cmi \
+    simple_format.cmi
+simple_format.cmx : ../commons/common2.cmx ../commons/common.cmx \
+    simple_format.cmi
+simple_format.cmi : ../commons/common2.cmi
+source_tree.cmo : simple_format.cmi ../commons/common2.cmi \
+    ../commons/common.cmi source_tree.cmi
+source_tree.cmx : simple_format.cmx ../commons/common2.cmx \
+    ../commons/common.cmx source_tree.cmi
+source_tree.cmi : ../commons/common.cmi

h_files-format/META

@@ -0,0 +1,4 @@
+description = "Helper functions for dealing with file format, from pfff"
+requires = "unix num"
+archive(byte) = "lib.cma"
+archive(native) = "lib.cmxa"

h_files-format/Makefile

@@ -0,0 +1,42 @@
+TOP=..
+##############################################################################
+# Variables
+##############################################################################
+TARGET=lib
+
+SRC= outline.ml simple_format.ml source_tree.ml
+
+LIBS=$(TOP)/commons/lib.cma
+INCLUDEDIRS= $(TOP)/commons
+
+##############################################################################
+# Generic variables
+##############################################################################
+
+-include $(TOP)/Makefile.common
+
+##############################################################################
+# Top rules
+##############################################################################
+all:: $(TARGET).cma
+all.opt:: $(TARGET).cmxa
+opt:: all.opt
+
+
+$(TARGET).cma: $(OBJS) $(LIBS)
+	$(OCAMLC) -a -o $(TARGET).cma $(OBJS)
+
+$(TARGET).cmxa: $(OPTOBJS) $(LIBS:.cma=.cmxa)
+	$(OCAMLOPT) -a -o $(TARGET).cmxa $(OPTOBJS)
+
+##############################################################################
+# install
+##############################################################################
+LIBNAME=pfff-h_files-format
+EXPORTSRC=\
+  outline.mli
+
+install-findlib: all all.opt
+	ocamlfind install $(LIBNAME) META \
+          lib.cma lib.cmxa lib.a \
+          $(EXPORTSRC) $(EXPORTSRC:%.mli=%.cmi) \

h_files-format/authors.txt

@@ -0,0 +1,2 @@
+Yoann Padioleau
+

h_files-format/copyright.txt

@@ -0,0 +1,17 @@
+Copyright (C) 2008 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.
+

h_files-format/license.txt

@@ -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!

h_files-format/outline.ml

@@ -0,0 +1,116 @@
+open Common
+
+(*****************************************************************************)
+(* The data structure *)
+(*****************************************************************************)
+
+type outline_node = { 
+  stars: string;
+  title: string;
+  before_first_children: string list;
+}
+type outline = outline_node Common2.tree2
+
+let outline_default_regexp = "^\\(\\*+\\)[ ]*\\(.*\\)"
+
+let root_stars = ""
+let root_title = "__ROOT__"
+
+(*****************************************************************************)
+(* Helpers, accessors *)
+(*****************************************************************************)
+
+let is_root_node node = 
+  String.length node.stars = 0 &&
+  node.title = root_title
+
+
+let extract_outline_line ?(outline_regexp=outline_default_regexp) s = 
+  if s =~ outline_regexp
+  then matched2 s
+  else failwith (spf "line does not match regexp: %s  vs %s" s outline_regexp)
+
+
+(*****************************************************************************)
+(* Loading, saving *)
+(*****************************************************************************)
+
+(* Similar to parenthesizd expression parsing, or ifdef parsing as 
+ * in parsing_hacks, but a little different cos don't have the 
+ * end delimiter in most cases. The end delimiter is in fact
+ * the start of a new header or the end of the file.
+ *)
+let parse_outline ?(outline_regexp=outline_default_regexp) file = 
+  let xs = Common.cat file in
+
+  (* just differentiate outline lines from regular lines *)
+  let headers_or_not = 
+    xs +> List.map (fun s -> 
+      if s =~ outline_regexp
+      then
+        let (stars, line) = extract_outline_line ~outline_regexp s in
+        Left (String.length stars, stars, line)
+      else 
+        Right s
+    )
+  in
+  let root = (0, root_stars, root_title) in
+  (* pack the Right with each appropriate Left *)
+  let headers = 
+    let rec aux (acc_right, outline) xs = 
+      match xs with
+      | [] -> [(outline, List.rev acc_right)]
+      | x::xs -> 
+          (match x with
+          | Right regular -> 
+              aux (regular::acc_right, outline) xs
+          | Left outline2 -> 
+              (outline, List.rev acc_right)::aux ([], outline2) xs
+          )
+    in
+    aux ([], root) headers_or_not
+  in
+  
+  (* build the tree *)
+  let trees = 
+    let rec aux_outline xs = 
+      match xs with
+      | [] -> []
+      | x::xs -> 
+          let ((lvl, stars, title), before_first_children) = x in
+          
+          let (children, rest) = xs +> Common2.span (fun x2 -> 
+            let ((lvl2, _, _), _) = x2 in
+            lvl2 > lvl
+          )
+          in
+          let node = 
+            { stars = stars;
+              title = title;
+              before_first_children = before_first_children;
+            }
+          in
+          let children_trees = aux_outline children in
+
+          (Common2.Tree (node, children_trees))::aux_outline rest
+    in
+    aux_outline headers
+  in
+  match trees with
+  | [root] -> root
+  | _ -> failwith "wierd, multiple roots"
+          
+
+
+let write_outline outline file = 
+  Common.with_open_outfile file (fun (pr_no_nl, _chan) -> 
+    let pr s = pr_no_nl (s ^ "\n") in
+    
+    outline +> Common2.tree2_iter (fun node -> 
+      if not (is_root_node node)
+      then pr (node.stars ^ node.title);
+
+      node.before_first_children +> List.iter pr;
+    );
+  )
+

h_files-format/outline.mli

@@ -0,0 +1,20 @@
+
+type outline = outline_node Common2.tree2
+    and outline_node = {
+      stars : string;
+      title : string;
+      before_first_children : string list;
+    }
+
+
+
+val outline_default_regexp : string
+
+(* value for implicit root *)
+val root_title : string
+val root_stars : string
+val is_root_node : outline_node -> bool
+
+
+val parse_outline : ?outline_regexp:string -> Common.filename -> outline
+val write_outline : outline -> Common.filename -> unit

h_files-format/simple_format.ml

@@ -0,0 +1,48 @@
+open Common
+
+
+let regexp_comment_line = "#.*"
+
+(*****************************************************************************)
+(* Helpers *)
+(*****************************************************************************)
+
+let cat_and_filter_comments file = 
+  let xs = Common.cat file in
+  let xs = xs +> List.map 
+    (Str.global_replace (Str.regexp regexp_comment_line) "" ) in
+  let xs = xs +> Common.exclude Common2.is_blank_string in
+  xs
+
+(*****************************************************************************)
+(* csv *)
+
+
+(*****************************************************************************)
+(* hierarchy ? header of section like in kernel_files.meta ? *)
+
+(*
+  (* split by header of section *)
+  ..
+    let xs = xs +> Common.split_list_regexp "^[^ ]" in 
+
+    let group = xs +> List.map (fun s -> 
+      assert (s =~ "^[ ]+\\([^ ]+\\) *: *\\(.*\\)");
+      let (dir, email) = matched2 s in
+      let emails = Common.split "[ ,]+" email in
+      (dir, emails)
+    ) in
+    Subsystem ((dir, emails), group)
+*)
+
+(*****************************************************************************)
+let title_colon_elems_space_separated file = 
+
+  let xs = cat_and_filter_comments file in
+
+  xs +> List.map (fun s -> 
+    assert (s =~ "^\\([^ ]+\\):\\(.*\\)");
+    let (title, elems_str) = matched2 s in
+    let elems = Common.split "[ \t]+" elems_str in
+    title, elems
+  )

h_files-format/simple_format.mli

@@ -0,0 +1,8 @@
+open Common2.BasicType
+
+val regexp_comment_line : string
+
+val cat_and_filter_comments : filename -> string list
+
+val title_colon_elems_space_separated : 
+  filename -> (string * string list) list

h_files-format/source_tree.ml

@@ -0,0 +1,125 @@
+open Common
+
+
+type subsystem = SubSystem of string
+type dir = Dir of string
+
+let string_of_subsystem (SubSystem s) = s
+let string_of_dir (Dir s) = s
+
+type tree_reorganization = (subsystem * dir list) list
+
+let dir_to_dirfinal (Dir s) = 
+  Str.global_replace (Str.regexp "/") "___" s
+  
+(*
+let dirfinal_of_dir s = 
+  Dir (Str.global_replace (Str.regexp "___") "/" s)
+*)
+
+
+let all_subsystem reorg = 
+  reorg +> List.map fst +> List.map string_of_subsystem 
+let all_dirs reorg = 
+  reorg +> List.map snd +> List.concat +> List.map string_of_dir
+
+let reverse_index reorg = 
+  let res = ref [] in
+  reorg +> List.iter (fun (SubSystem s1, dirs) -> 
+    dirs +> List.iter (fun (Dir s2) -> 
+      push (Dir s2, SubSystem s1) res;
+    );
+  );
+  List.rev !res
+
+
+
+
+let (load_tree_reorganization : Common.filename -> tree_reorganization) = 
+ fun file -> 
+   let xs = Simple_format.title_colon_elems_space_separated file in
+   xs +> List.map (fun (title, elems) -> 
+     SubSystem title, elems +> List.map (fun s -> Dir s)
+   )
+
+let debug_source_tree = false
+
+let change_organization_dirs_to_subsystems reorg basedir = 
+  let cmd s = 
+    if debug_source_tree
+    then pr2 s
+    else Common.command2 s
+  in
+  reorg +> List.iter (fun (SubSystem sub, dirs) -> 
+    if not debug_source_tree 
+    then Common2.mkdir (spf "%s/%s" basedir sub);
+
+    dirs +> List.iter (fun (Dir dir) -> 
+      let dir' = dir_to_dirfinal (Dir dir) in
+      cmd (spf "mv %s/%s %s/%s/%s" basedir dir   basedir sub dir')
+    );
+  );
+  ()
+
+let change_organization_subsystems_to_dirs reorg basedir =
+  let cmd s = 
+    if debug_source_tree
+    then pr2 s
+    else Common.command2 s
+  in
+  reorg +> List.iter (fun (SubSystem sub, dirs) -> 
+    dirs +> List.iter (fun (Dir dir) -> 
+      let dir' = dir_to_dirfinal (Dir dir) in
+      cmd (spf "mv %s/%s/%s %s/%s" basedir sub dir' basedir dir)
+    );
+    if not debug_source_tree
+    then Unix.rmdir (spf "%s/%s" basedir sub);
+  );
+  ()
+
+
+
+let (change_organization: 
+      tree_reorganization -> Common.filename (* dir *) -> unit) = 
+ fun reorg dir -> 
+   pr2_gen reorg;
+   pr2_gen dir;
+
+
+   let subsystem_bools = 
+     all_subsystem reorg
+     +> List.map (fun s -> (Sys.file_exists (Filename.concat dir s)))
+   in
+   let dirs_bools = 
+     all_dirs reorg
+     +> List.map (fun s -> (Sys.file_exists (Filename.concat dir s)))
+   in
+   match () with
+   | _ when Common2.and_list subsystem_bools -> 
+       assert (not (Common2.or_list dirs_bools));
+       change_organization_subsystems_to_dirs reorg dir;
+   | _ when Common2.and_list dirs_bools -> 
+       assert (not (Common2.or_list subsystem_bools));
+       change_organization_dirs_to_subsystems reorg dir;
+   | _ -> failwith "have a mix of subsystem and dirs, wierd"
+
+         
+  
+       
+let subsystem_of_dir2 (Dir dir) reorg  = 
+  let index = reverse_index reorg in
+  let dirsplit = Common.split "/" dir in
+  let index = 
+    index +> List.map (fun (Dir d, sub) -> Common.split "/" d, sub)
+  in
+  try 
+    index +> List.find (fun (dirsplit2, _sub) -> 
+      let len = List.length dirsplit2 in
+      Common2.take_safe len dirsplit = dirsplit2
+    ) +> snd
+  with Not_found -> 
+    pr2 (spf "Cant find %s in reorganization information" dir);
+    raise Not_found
+    
+let subsystem_of_dir a b = 
+  Common.profile_code "subsystem_of_dir" (fun () -> subsystem_of_dir2 a b)

h_files-format/source_tree.mli

@@ -0,0 +1,16 @@
+
+type subsystem = SubSystem of string
+type dir = Dir of string
+
+type tree_reorganization = (subsystem * dir list) list
+
+
+
+val load_tree_reorganization : 
+  Common.filename -> tree_reorganization
+
+val change_organization: 
+  tree_reorganization -> Common.filename (* dir *) -> unit
+
+val subsystem_of_dir : 
+  dir -> tree_reorganization -> subsystem

h_program-lang/.depend

@@ -0,0 +1,132 @@
+archi_code.cmo : ../commons/common2.cmi ../commons/common.cmi archi_code.cmi
+archi_code.cmx : ../commons/common2.cmx ../commons/common.cmx archi_code.cmi
+archi_code.cmi : ../commons/common.cmi
+archi_code_lexer.cmo : archi_code.cmi
+archi_code_lexer.cmx : archi_code.cmx
+archi_code_parse.cmo : ../commons/common2.cmi ../commons/common.cmi \
+    archi_code_lexer.cmo archi_code.cmi archi_code_parse.cmi
+archi_code_parse.cmx : ../commons/common2.cmx ../commons/common.cmx \
+    archi_code_lexer.cmx archi_code.cmx archi_code_parse.cmi
+archi_code_parse.cmi : ../commons/common.cmi archi_code.cmi
+ast_fuzzy.cmo : parse_info.cmi ../commons/ocaml.cmi ../commons/common.cmi \
+    ast_fuzzy.cmi
+ast_fuzzy.cmx : parse_info.cmx ../commons/ocaml.cmx ../commons/common.cmx \
+    ast_fuzzy.cmi
+ast_fuzzy.cmi : parse_info.cmi ../commons/ocaml.cmi ../commons/common.cmi
+big_grep.cmo : database_code.cmi ../commons/common2.cmi \
+    ../commons/common.cmi big_grep.cmi
+big_grep.cmx : database_code.cmx ../commons/common2.cmx \
+    ../commons/common.cmx big_grep.cmi
+big_grep.cmi : database_code.cmi
+comment_code.cmo : parse_info.cmi ../commons/common2.cmi \
+    ../commons/common.cmi comment_code.cmi
+comment_code.cmx : parse_info.cmx ../commons/common2.cmx \
+    ../commons/common.cmx comment_code.cmi
+comment_code.cmi : parse_info.cmi
+coverage_code.cmo : ../external/jsonwheel/json_type.cmi \
+    ../external/jsonwheel/json_out.cmo ../external/jsonwheel/json_in.cmo \
+    ../commons/common.cmi coverage_code.cmi
+coverage_code.cmx : ../external/jsonwheel/json_type.cmx \
+    ../external/jsonwheel/json_out.cmx ../external/jsonwheel/json_in.cmx \
+    ../commons/common.cmx coverage_code.cmi
+coverage_code.cmi : ../external/jsonwheel/json_type.cmi \
+    ../commons/common.cmi
+database_code.cmo : ../external/jsonwheel/json_type.cmi \
+    ../external/jsonwheel/json_io.cmi ../external/jsonwheel/json_in.cmo \
+    highlight_code.cmi ../commons/file_type.cmi entity_code.cmi \
+    ../commons/common2.cmi ../commons/common.cmi database_code.cmi
+database_code.cmx : ../external/jsonwheel/json_type.cmx \
+    ../external/jsonwheel/json_io.cmx ../external/jsonwheel/json_in.cmx \
+    highlight_code.cmx ../commons/file_type.cmx entity_code.cmx \
+    ../commons/common2.cmx ../commons/common.cmx database_code.cmi
+database_code.cmi : highlight_code.cmi entity_code.cmi \
+    ../commons/common2.cmi ../commons/common.cmi
+datalog_code.cmo : ../commons/common2.cmi ../commons/common.cmi \
+    datalog_code.cmi
+datalog_code.cmx : ../commons/common2.cmx ../commons/common.cmx \
+    datalog_code.cmi
+datalog_code.cmi : ../commons/common.cmi
+entity_code.cmo : ../commons/common.cmi entity_code.cmi
+entity_code.cmx : ../commons/common.cmx entity_code.cmi
+entity_code.cmi :
+errors_code.cmo : scope_code.cmi parse_info.cmi entity_code.cmi \
+    ../commons/common2.cmi ../commons/common.cmi errors_code.cmi
+errors_code.cmx : scope_code.cmx parse_info.cmx entity_code.cmx \
+    ../commons/common2.cmx ../commons/common.cmx errors_code.cmi
+errors_code.cmi : scope_code.cmi parse_info.cmi entity_code.cmi \
+    ../commons/common.cmi
+highlight_code.cmo : entity_code.cmi ../commons/common.cmi \
+    highlight_code.cmi
+highlight_code.cmx : entity_code.cmx ../commons/common.cmx \
+    highlight_code.cmi
+highlight_code.cmi : entity_code.cmi
+info_code.cmo : ../h_files-format/outline.cmi info_code.cmi
+info_code.cmx : ../h_files-format/outline.cmx info_code.cmi
+info_code.cmi : ../h_files-format/outline.cmi ../commons/common.cmi
+layer_code.cmo : parse_info.cmi ../commons/ocaml.cmi \
+    ../external/jsonwheel/json_type.cmi ../external/jsonwheel/json_out.cmo \
+    ../external/jsonwheel/json_in.cmo ../commons/file_type.cmi \
+    ../commons/common2.cmi ../commons/common.cmi layer_code.cmi
+layer_code.cmx : parse_info.cmx ../commons/ocaml.cmx \
+    ../external/jsonwheel/json_type.cmx ../external/jsonwheel/json_out.cmx \
+    ../external/jsonwheel/json_in.cmx ../commons/file_type.cmx \
+    ../commons/common2.cmx ../commons/common.cmx layer_code.cmi
+layer_code.cmi : parse_info.cmi ../external/jsonwheel/json_type.cmi \
+    ../commons/common.cmi
+layer_coverage.cmo : layer_code.cmi coverage_code.cmi ../commons/common2.cmi \
+    ../commons/common.cmi layer_coverage.cmi
+layer_coverage.cmx : layer_code.cmx coverage_code.cmx ../commons/common2.cmx \
+    ../commons/common.cmx layer_coverage.cmi
+layer_coverage.cmi : layer_code.cmi coverage_code.cmi ../commons/common.cmi
+layer_parse_errors.cmo : parse_info.cmi layer_code.cmi \
+    ../commons/common2.cmi ../commons/common.cmi layer_parse_errors.cmi
+layer_parse_errors.cmx : parse_info.cmx layer_code.cmx \
+    ../commons/common2.cmx ../commons/common.cmx layer_parse_errors.cmi
+layer_parse_errors.cmi : parse_info.cmi layer_code.cmi ../commons/common.cmi
+meta_ast_generic.cmo : meta_ast_generic.cmi
+meta_ast_generic.cmx : meta_ast_generic.cmi
+meta_ast_generic.cmi :
+overlay_code.cmo : layer_code.cmi database_code.cmi ../commons/common2.cmi \
+    ../commons/common.cmi overlay_code.cmi
+overlay_code.cmx : layer_code.cmx database_code.cmx ../commons/common2.cmx \
+    ../commons/common.cmx overlay_code.cmi
+overlay_code.cmi : layer_code.cmi database_code.cmi ../commons/common.cmi
+parse_info.cmo : ../commons/ocaml.cmi ../commons/common2.cmi \
+    ../commons/common.cmi parse_info.cmi
+parse_info.cmx : ../commons/ocaml.cmx ../commons/common2.cmx \
+    ../commons/common.cmx parse_info.cmi
+parse_info.cmi : ../commons/ocaml.cmi ../commons/common.cmi
+pleac.cmo : ../commons/common2.cmi ../commons/common.cmi pleac.cmi
+pleac.cmx : ../commons/common2.cmx ../commons/common.cmx pleac.cmi
+pleac.cmi : ../commons/common.cmi
+pretty_print_code.cmo : ../commons/common2.cmi
+pretty_print_code.cmx : ../commons/common2.cmx
+prolog_code.cmo : entity_code.cmi ../commons/common.cmi prolog_code.cmi
+prolog_code.cmx : entity_code.cmx ../commons/common.cmx prolog_code.cmi
+prolog_code.cmi : entity_code.cmi ../commons/common.cmi
+refactoring_code.cmo : ../commons/common.cmi refactoring_code.cmi
+refactoring_code.cmx : ../commons/common.cmx refactoring_code.cmi
+refactoring_code.cmi : ../commons/common.cmi
+scope_code.cmo : ../commons/ocaml.cmi scope_code.cmi
+scope_code.cmx : ../commons/ocaml.cmx scope_code.cmi
+scope_code.cmi : ../commons/ocaml.cmi
+skip_code.cmo : ../commons/common2.cmi ../commons/common.cmi skip_code.cmi
+skip_code.cmx : ../commons/common2.cmx ../commons/common.cmx skip_code.cmi
+skip_code.cmi : ../commons/common.cmi
+tags_file.cmo : parse_info.cmi entity_code.cmi ../commons/common.cmi \
+    tags_file.cmi
+tags_file.cmx : parse_info.cmx entity_code.cmx ../commons/common.cmx \
+    tags_file.cmi
+tags_file.cmi : parse_info.cmi entity_code.cmi ../commons/common.cmi
+test_program_lang.cmo : refactoring_code.cmi layer_code.cmi \
+    ../external/jsonwheel/json_out.cmo entity_code.cmi database_code.cmi \
+    ../commons/common.cmi big_grep.cmi test_program_lang.cmi
+test_program_lang.cmx : refactoring_code.cmx layer_code.cmx \
+    ../external/jsonwheel/json_out.cmx entity_code.cmx database_code.cmx \
+    ../commons/common.cmx big_grep.cmx test_program_lang.cmi
+test_program_lang.cmi : ../commons/common.cmi
+unit_program_lang.cmo : ../commons/oUnit.cmi entity_code.cmi \
+    unit_program_lang.cmi
+unit_program_lang.cmx : ../commons/oUnit.cmx entity_code.cmx \
+    unit_program_lang.cmi
+unit_program_lang.cmi : ../commons/oUnit.cmi

h_program-lang/META

@@ -0,0 +1,4 @@
+description = "Helper functions for parsing, analyzing, from pfff"
+requires = "unix num"
+archive(byte) = "lib.cma"
+archive(native) = "lib.cmxa"

h_program-lang/Makefile

@@ -0,0 +1,71 @@
+TOP=..
+##############################################################################
+# Variables
+##############################################################################
+TARGET=lib
+
+SRC= parse_info.ml \
+     ast_fuzzy.ml meta_ast_generic.ml \
+     skip_code.ml \
+     scope_code.ml \
+     pretty_print_code.ml
+
+# See also graph_code/graph_code.ml! closely related to h_program-lang/
+
+SYSLIBS= str.cma unix.cma
+LIBS=../commons/lib.cma
+INCLUDEDIRS= $(TOP)/commons \
+ $(TOP)/external/jsonwheel \
+ $(TOP)/h_files-format
+
+# other sources:
+#  prolog_code.pl, facts.pl, for the prolog-based code query engine
+
+# dead: visitor_code, statistics_code, programming-language, ast_generic
+##############################################################################
+# Generic variables
+##############################################################################
+
+-include $(TOP)/Makefile.common
+
+##############################################################################
+# Top rules
+##############################################################################
+all:: $(TARGET).cma
+all.opt:: $(TARGET).cmxa
+
+$(TARGET).cma: $(OBJS)
+	$(OCAMLC) -a -o $(TARGET).cma $(OBJS)
+
+$(TARGET).cmxa: $(OPTOBJS) $(LIBS:.cma=.cmxa)
+	$(OCAMLOPT) -a -o $(TARGET).cmxa $(OPTOBJS)
+
+$(TARGET).top: $(OBJS) $(LIBS)
+	$(OCAMLMKTOP) -o $(TARGET).top $(SYSLIBS) $(LIBS) $(OBJS)
+
+clean::
+	rm -f $(TARGET).top
+
+
+archi_code_lexer.ml: archi_code_lexer.mll
+	$(OCAMLLEX) $<
+clean::
+	rm -f archi_code_lexer.ml
+beforedepend:: archi_code_lexer.ml
+
+##############################################################################
+# install
+##############################################################################
+LIBNAME=pfff-h_program-lang
+EXPORTSRC=\
+  ast_fuzzy.mli \
+  meta_ast_generic.mli \
+  parse_info.mli \
+  scope_code.mli \
+  skip_code.mli
+
+install-findlib: all all.opt
+	ocamlfind install $(LIBNAME) META \
+          lib.cma lib.cmxa lib.a \
+          $(EXPORTSRC) $(EXPORTSRC:%.mli=%.cmi) \
+	  pretty_print_code.cmi

h_program-lang/archi_code.ml

@@ -0,0 +1,212 @@
+(* Yoann Padioleau
+ *
+ * Copyright (C) 2010 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 *)
+(*****************************************************************************)
+(* 
+ * Categorizing a source file according to recurring architecture "aspects"
+ * (really a directory structure) of a project. We often have some tests/,
+ * some commons/ library, some include/, etc.
+ * 
+ * A file may belong to multiple categories at once.
+ * 
+ * Right now the "aspects" are slightly modeled according to my
+ * own code and facebook flib code.
+ *
+ * This is used by codemap to colorize files. This is also used
+ * mainly for its AutoGenerated category in pfff -test_loc to
+ * not count auto generated code in the LOC of a project. This
+ * can also be used in the deadcode detector to not count auto
+ * generated files (e.g. visitor_xxx.ml) as real users of an entity.
+ *)
+
+(*****************************************************************************)
+(* Types *)
+(*****************************************************************************)
+
+(* coupling: if add category, dont forget to extend the source_archi_list 
+ * below
+ *)
+type source_archi =
+  | Main
+  | Init
+  | Interface
+
+  (* I put Test and Logging together because if some dirs do not have some
+   * unit tests, but have some code to logs his action, then it's quite 
+   * similar. Such code should be more robust and it's good to see it
+   * visually.
+   *)
+  | Test
+  | Logging
+
+  | Core
+  | Utils (* utils base common *)
+
+  | Constants 
+  | GetSet  (* mutators, accessors *)
+
+  | Configuration (* settings *)
+  | Building (* makefiles *)
+  | Data (* big files *)
+  | Doc
+
+  | Ui      (* ui render display *)
+  | Storage (* storage db  *)
+  | Parsing (* scanner, parser *)
+  | Security 
+  | I18n
+  (* todo? 
+   * Memory (e.g. malloc, buffer), Fonts (font, charset)
+   * IO (e.g. keyboard, mouse)
+   * Strings (e.g. regex
+   *)
+
+  | Architecture (* e.g. x86 *)
+  | OS (* e.g. win32, macos, unix *)
+  | Network (* e.g. protocols ssh, ftp *)
+
+  | Ffi 
+  | ThirdParty (* external *)
+  | Legacy  (* legacy, deprecated *)
+
+  | AutoGenerated
+  | BoilerPlate
+
+  (* a project often contains itself some infrastructure to run tests or 
+   * benchmarks.
+   *)
+  | Unittester
+  | Profiler
+
+  | MiniLite
+  | Intern
+
+  | Script
+
+  | Regular
+ (* with tarzan *)
+
+
+let source_archi_list = [
+  Main; Init; 
+  Interface;
+  Test; Logging; 
+  Core; Utils; 
+  Configuration; Building; 
+  Doc; Data;
+  Constants; 
+  GetSet; 
+  Ui; Storage; Parsing; Security; I18n;
+  Architecture; OS; Network;
+  Script;
+  ThirdParty; Legacy; Ffi;
+  AutoGenerated; BoilerPlate;
+  Unittester; Profiler;
+  MiniLite;
+  Intern;
+  Regular;
+]
+
+type source_kind =
+  | Header
+  | Source
+
+(*****************************************************************************)
+(* String of *)
+(*****************************************************************************)
+
+(* ocamltarzan generated *)
+let s_of_source_archi =
+  function
+  | Init ->  "Init"
+  | Main ->  "Main"
+  | Interface ->  "Interface"
+  | AutoGenerated ->  "AutoGenerated"
+  | BoilerPlate ->  "BoilerPlate"
+  | Test ->  "Test"
+  | Logging ->  "Logging"
+  | Core ->  "Core"
+  | Utils ->  "Utils"
+  | Constants ->  "Constants"
+  | Script -> "Script"
+  | Ffi -> "Ffi"
+  | Configuration -> "Configuration"
+  | Building -> "Building"
+  | GetSet ->  "GetSet"
+  | Ui ->  "Ui"
+  | Storage ->  "Storage"
+  | Parsing ->  "Parsing"
+  | ThirdParty ->  "ThirdParty"
+  | Legacy ->  "Legacy"
+  | Unittester ->  "Unittester"
+  | Profiler ->  "Profiler"
+  | Intern ->  "Intern"
+  | Regular ->  "Regular"
+  | Doc -> "Doc"
+  | Data -> "Data"
+  | MiniLite -> "MiniLite"
+  | Security -> "Security"
+  | I18n -> "I18n"
+  | Architecture -> "Architecture"
+  | OS -> "OS"
+  | Network -> "Network"
+
+(*****************************************************************************)
+(* Misc *)
+(*****************************************************************************)
+
+(* TODO move this elsewhere *)
+let find_duplicate_dirname dir =
+
+  let h = Hashtbl.create 101 in
+  let dups = Common2.hash_with_default (fun () -> 0) in
+
+  let rec aux path = 
+    let subdirs = Common2.readdir_to_dir_list path +> List.sort compare in
+
+    subdirs +> List.iter (fun dir ->
+      let path = Filename.concat path dir in
+
+      if Hashtbl.mem h dir
+      then begin
+        pr2 (spf "duplicate dir for %s already there: %s"
+                dir (Hashtbl.find h dir));
+        dups#update dir (fun old -> old + 1);
+      end else begin
+        Hashtbl.add h dir path;
+      end;
+      aux path
+    );
+  in
+  aux dir;
+  pr2 "duplicate are:";
+  dups#to_list +> Common.sort_by_val_highfirst +> List.iter (fun (dir,cnt) ->
+    pr2 (spf " %s: %d" dir cnt);
+  );
+  ()
+
+(*****************************************************************************)
+(* actions *)
+(*****************************************************************************)
+
+(*
+let actions () = [
+  "-test_dup_dir", "<dir>",
+  Common.mk_action_1_arg (find_duplicate_dirname);
+]
+*)

h_program-lang/archi_code.mli

@@ -0,0 +1,31 @@
+
+type source_archi =
+  | Main | Init
+  | Interface 
+  | Test | Logging
+  | Core  | Utils
+  | Constants     | GetSet   
+  | Configuration | Building | Data
+  | Doc 
+
+  | Ui | Storage | Parsing | Security | I18n
+  | Architecture | OS | Network
+
+  | Ffi | ThirdParty  | Legacy 
+  | AutoGenerated | BoilerPlate
+
+  | Unittester  | Profiler
+  | MiniLite | Intern
+  | Script
+
+  | Regular
+val s_of_source_archi: source_archi -> string
+
+val source_archi_list: source_archi list
+
+type source_kind =
+  | Header
+  | Source
+
+(* can tell you about architecture, and also about design pbs *)
+val find_duplicate_dirname: Common.dirname -> unit

h_program-lang/archi_code_lexer.mll

@@ -0,0 +1,517 @@
+{
+(* Yoann Padioleau
+ *
+ * Copyright (C) 2010 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 Archi_code
+
+(*****************************************************************************)
+(* Prelude *)
+(*****************************************************************************)
+
+(* This code assumes we are called with a string enclosed by "/"
+ * as in /foo.php/ so it's easy to specify the beginning or
+ * end of a string (ocamllex does not handle ^ or $).
+ * 
+ * It also assumes the string has been lowercased. Note also that
+ * the filenames has been reversed, for instance a/b/foo.php becomes
+ * /foo.php/b/a/ because we want to return the most specialized category.
+ * update: now we first run the lexer on the lowecased basename and
+ * then separately on the dirname.
+ * 
+ * Note that ocamllex will try the longest match and we will return
+ * the leftmost match so on "common.mli" for instance the
+ * "common" rule will be applied before the .mli rule.
+ *)
+
+}
+
+let b = ['/' '_' '-' '.']
+
+(*****************************************************************************)
+
+rule category = parse
+  | ".vcproj/" { Building }
+  | ".thrift/" { Ffi }
+
+  (* pad specific, noweb *)
+  | ".nw/" 
+      { Doc }
+
+  | ".texi/" 
+      { Doc }
+
+  | ".pdf/" 
+  | ".rtf/"
+      { Doc }
+
+  | ".sql/"
+      { Storage }
+
+  | ".mli/"
+  | ".h/"
+  | ".hpp/"
+  | ".hrl/"
+      { Interface }
+
+  (* ml specific *)
+  | ".depend" { Building }
+  | "ocamlmakefile" { BoilerPlate }
+  (* oasis boilerplate *)
+  | "setup.ml" { BoilerPlate }
+  (* ocamlbuild boilerplate *)
+  | "/_build" { BoilerPlate }
+
+  | "makefile" 
+  | "/configure" 
+      { Building }
+
+  (* linux specific *)
+  | "kconfig" { Building }
+
+  | "/changes" { Doc }
+  | "readme"   { Doc }
+
+  | "/license" 
+  | "/copyright" 
+  | b "copying" 
+      { BoilerPlate }
+
+  (* gnu software boilerplate *)
+  | "/copying/" 
+  | "/about-nls/" 
+  | "/shtool/"
+  | "/texinfo.tex/"
+  | "/ltmain.sh/"
+      { BoilerPlate }
+
+
+
+  (* pad specific ? *)
+  | "/main_" { Main }
+  | "/flag_" { Configuration }
+  | "/test_" { Test }
+  | "/unit_" { Test }
+  | "/visitor_" { AutoGenerated }
+  | "/meta_ast_" { AutoGenerated }
+  | "generated" { AutoGenerated }
+
+  (* facebook specific *)
+  | "/autoload_map" { AutoGenerated }
+
+
+  | "/main." { Main }
+  | "/init." { Init }
+
+  | "/init/" { Init }
+
+  (* facebook specific *)
+  | "/home.php" { Main }
+  | "/profile.php" { Main }
+
+  | "/alite/" { Init }
+  | "/urimaps/" { Init }
+
+
+  | "core" { Core }
+(*  | "/base" { Core } *)
+
+  | "mysql" 
+  | "sqlite" 
+      { Storage }
+
+  | "database" { Storage }
+
+  | "security" { Security }
+
+(* too many false positives, like mini in mono
+  | "mini" { MiniLite } 
+  | "lite" { MiniLite }
+*)
+
+  | b "tests" b
+  | "/test/" 
+  | "/test2/" 
+  | "/t/" 
+  | "/_test"
+  | "/testsuite/"
+  (* gnugo *) 
+  | "/regression"
+      { Test }
+
+  | "/benchmarks"
+      { Test }
+
+  | "/example"
+      { Test }
+  | "dummy"
+      { Test }
+  | "/demos"
+      { Test }
+
+  (* facebook specific a little *)
+  | "/__tests__/" { Test }
+
+  (* pad specific *)
+  | "pleac" { Test }
+
+  | "/docs/"
+  | "/doc/" 
+      { Doc }
+
+  | "/unittest/" { Unittester }
+  (* can not just say "profil" because at facebook profile means
+   * something else
+   *)
+  | "profiling" { Profiler }
+
+  (* False positif for util below *)
+  | "binutils" 
+  | "coreutils"
+  | "diffutils"
+  | "findutils"
+  | "inetutils"
+      { Regular }
+
+(*  | "stdlib" { Core } *)
+  | "util" { Utils }
+(*  | "/base" { Utils } *)
+  | "common" { Utils }
+  (* Exact "lib", Utils; *)
+
+ | "/conf/haste/" { AutoGenerated }
+
+  (* Can not say just thrift here because we could also want
+   * to look at the thrift source itself. So really just
+   * want to hide all generated code.
+   * 
+   * The code is actually in thrift/packages but because the filename
+   * is reverse, it's /packages/thrift/ here
+   *)
+ | "/packages/thrift/" { AutoGenerated }
+
+ | "/thriftdoc/" { AutoGenerated }
+
+  (* thrift auto generated files *)
+ | "/gen-" { AutoGenerated }
+  (* for some projects I don't remember *)
+ | "/gen/" { AutoGenerated }
+  (* in android dalvik *)
+ | "/out/" { AutoGenerated }
+
+
+  | "storage" 
+  | "/db/"
+  | "/fs/"
+  | "/database/"
+
+  (* pad specific ... *)
+  | "bdb/"
+      { Storage }
+
+  (* Exact "data", Storage; *)
+  | "constants" { Constants }
+  | "mutators"
+  | "accessors"
+      { GetSet }
+
+  | "logging" { Logging }
+
+  | "third-party"
+  | "third_party" 
+  | "3rdparty"
+      { ThirdParty }
+
+  | "external" { ThirdParty }
+  | "legacy" { ThirdParty }
+  (* opam src *)
+  | "src_ext" { ThirdParty }
+  | "deprecated" { Legacy }
+  | "/attic/" { Legacy }
+
+  | "/out/" { Legacy }
+
+  (* pad specfic *)
+  | "ocamlextra" { ThirdParty }
+  | "/score_parsing" { Data }
+  | "/score_tests" { Data }
+  | "/archive.org" { Data }
+
+  (* facebook fbcode fsl specifix ... *)
+  | "test.txt" { Data }
+  | "twl06.txt" { Data }
+  | "wordlist.gz" { AutoGenerated }
+  | "/big/" { Data }
+
+  | "/data/" { Data }
+(* in haskell this is a valid dir
+   | "/data/" { Data } 
+*)
+
+
+  (* facebook specific ? *)
+  | "/si/"
+  | "site_integrity" 
+      { Security }
+
+  | "/auth" b 
+      { Security }
+
+  (* as in OCaml asmcomp/ directory *)
+  | "x86"
+  | "i386"
+  | "i686"
+
+  | "ia64"
+  (* v8 source *)
+  | "ia32"
+  | b "x64"
+
+  | "mips"
+  | "m68k"
+  | "sparc"
+  | "amd64"
+  | b "arm" b
+  | "hppa"
+  (* linux source *)
+  | "parisc"
+  | "s390"
+  | "blackfin"
+  | b "ppc" b
+  | "ppc64"
+  | "/power/"
+  | b "powerpc" b
+  | b "alpha" b
+  (* gcc source *)
+  | "rs6000"
+  | "h8300"
+  | b "vax" b
+  | "sh64"
+  | b "cris" b
+  | "/frv/"
+  (* emacs source *)
+  | "386"
+  | "hp800"
+  | "iris4d"
+  | "macppc"
+  | "xtensa"
+
+  (* qemu source *)
+  | b "sh4" b
+  | "microblaze"
+
+
+
+      { Architecture }
+
+  (* plan9 source *)
+  | "/pc/" 
+  | "/alphapc/" 
+      { Architecture }
+
+  | "/arch/" 
+      { Architecture }
+
+  | "unix"
+  (* commented when analyze linux itself *)
+  | "linux"
+  | "macos"
+  | "win32"
+
+  | "cygwin"
+  | "msdos"
+  | b "vms" b
+  | b "dos/" b
+  | "mswin"
+  | "ms-w32"
+  (* emacs source *)
+  | b "aix" b
+  | b "hpux" b
+  | b "irix" b
+  | "darwin"
+  | "freebsd"
+  | "netbsd"
+  | "openbsd"
+  | b "bsd" b
+
+  | b "w32" b
+
+  (* tinyGL *)
+  | "/beos"
+
+      { OS }
+
+  | "dns" 
+  | "ftp"
+  | "ssh" 
+  | "http" 
+  | "smtp" 
+  | "ldap" 
+  | b "imap" b  (* because can have files like guimap *)
+  | "krb4" 
+  | "pop3" 
+  | "socks" 
+  | "ssl" 
+  | "socket" 
+  | "mime" 
+  | "url." 
+  | "uri." 
+  | "ipv4"
+  | "ipv6"
+  | "icmp."
+  | "tcp."
+      { Network }
+
+  (* scan and gram ? too short ? *)
+  | "scanne"
+  | "parse"
+  | "lexer"
+  | "token" (* false positive with security stuff ? *)
+  | "/gram."
+  | "/scan."
+  | "grammar"
+  | "/lex"
+
+  (* invent UnParsing category ? do also print ? *)
+  | "pretty_print"
+      { Parsing }
+
+  | "/ui/"
+  | "/gui/" 
+
+  (* too many false positives ? *)
+  | "gui"
+
+  | "display"
+  | "render"
+  | "/video/"
+  | "/media/"
+  | "screen"
+  | "visual"
+  | "image"
+  | "jpeg"
+  | "/ui."
+  | "window"
+  | "/draw_"
+      { Ui }
+
+  (* pad specfici ? *)
+  | "/layer_"
+      { Ui }
+
+  | "/gtk/"
+  | "/qt/"
+  | "/tcltk/"
+  | "x11"
+  (* wxwindows. it's also used in efuns, e.g. toolkit/wX_edit.ml *)
+  | "/wx" 
+      { Ui }
+
+  | "/intern/" { Intern }
+
+  (* overlay specific, because of all those __xxx__ directories *)
+  | b "intern" b { Intern }
+  | b "ui/" b
+ | "/lib__thrift__packages/" { AutoGenerated }
+ | "/lib__thrift__packages__intern/" { AutoGenerated }
+ | "/conf/flib__intern__web/haste" { AutoGenerated }
+
+  (* as in Linux *)
+  | "documentation" { Doc }
+  (* todo also  memory ?  so mm/ is colored too  *)
+  | "/net/" { Network }
+
+  | "/old/"
+  | "/backup/"
+      { Legacy }
+
+  | "/tmp/"
+      { Legacy }
+
+  (* i18n *)
+
+  | "/af/"
+  | "/ar/"
+  | "/az/"
+  | "/bg/"
+  | "/ca/"
+  | "/ca-valencia/"
+  | "/cs/"
+  | "/da/"
+  | "/de/"
+  | "/de-informal/"
+  | "/el/"
+  (* I keep this one so at least I can see one | "/en/" *)
+  | "/eo/"
+  | "/es/"
+  | "/et/"
+  | "/eu/"
+  | "/fa/"
+  | "/fi/"
+  | "/fo/"
+  | "/fr/"
+  | "/gl/"
+  | "/he/"
+  | "/hi/"
+  | "/hr/"
+  | "/hu/"
+(*  | "/ia/", can mean interpreteur abstrait *)
+  | "/id/"
+  | "/id-ni/"
+  | "/is/"
+  | "/it/"
+  | "/ja/"
+  | "/km/"
+  | "/ko/"
+  | "/ku/"
+  | "/lb/"
+  | "/lt/"
+  | "/lv/"
+  | "/mg/"
+(*  | "/mk/" can be source of mk *)
+  | "/mr/"
+  | "/ne/"
+  | "/nl/"
+  | "/no/"
+  | "/pl/"
+  | "/pt/"
+  | "/pt-br/"
+  | "/ro/"
+  | "/ru/"
+  | "/sk/"
+  | "/sl/"
+  | "/sq/"
+  | "/sr/"
+  | "/sv/"
+  | "/th/"
+  | "/tr/"
+  | "/uk/"
+(* plan9 exception mips emulator 
+  | "/vi/"
+*)
+  | "/zh/"
+  | "/zh-tw/"
+  | "/la/"
+      { I18n }
+
+  | "i18n" 
+  | "unicode"
+  | "gettext"
+  | "/intl/"
+      { I18n }
+      
+
+  | _ { 
+      category lexbuf
+    }
+  | eof { Regular }

h_program-lang/archi_code_parse.ml

@@ -0,0 +1,153 @@
+(* Yoann Padioleau
+ *
+ * Copyright (C) 2010 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
+
+open Archi_code
+
+(*****************************************************************************)
+(* Prelude *)
+(*****************************************************************************)
+(* 
+ * The "inference" of the architecture category from a filename
+ * used to be slow. The "parser" used to be a 'match' with a long series
+ * of '_ when f =~ ...' but it was getting really slow when
+ * applied on thousands of filenames. Then we provided a fast-path
+ * for files that do not match any category, but it was still slow
+ * when most of the files had a category (for instance because
+ * most of the files in a project are under something like lib/ or intern/).
+ * Then we used ocamllex and that was fine! 
+ * 
+ * Current stat of -profile on codemap.opt ~/www:
+ *  Archi.source_of_filename                 :      1.690 sec     112755 count
+ *)
+
+(*****************************************************************************)
+(* Helpers *)
+(*****************************************************************************)
+
+let (==~) = Common2.(==~)
+
+let re_c_yaccfile = Str.regexp "\\(.*\\).tab"
+
+(* coupling: don't forget to extend re_auto_generated below too *)
+let is_auto_generated file =
+  let (d,b,e) = Common2.dbe_of_filename_noext_ok file in
+  match e with
+  | "ml"->
+      Sys.file_exists (Common2.filename_of_dbe (d,b, "mll")) || 
+      Sys.file_exists (Common2.filename_of_dbe (d,b, "mly")) ||
+      Sys.file_exists (Common2.filename_of_dbe (d,b, "mlb"))
+
+  | "mli" ->
+      Sys.file_exists (Common2.filename_of_dbe (d,b, "mly"))
+
+  | "tex" ->
+      Sys.file_exists (Common2.filename_of_dbe (d,b ^ ".tex", "nw"))
+
+  | "info" ->
+      Sys.file_exists (Common2.filename_of_dbe (d,b, "texi"))
+
+  (* Makefile.in *)
+  | "in" ->
+      Sys.file_exists (Common2.filename_of_dbe (d,b, "am"))
+
+  | "c" ->
+      b =$= "y.tab" ||
+      Sys.file_exists (Common2.filename_of_dbe (d,b, "y")) ||
+      Sys.file_exists (Common2.filename_of_dbe (d,b, "l")) ||
+      (* bigloo (hmm but then conflict with s9 that have s9.c and s9.scm *)
+      (* Sys.file_exists (Common2.filename_of_dbe (d,b, "scm")) || *)
+      (if  b ==~ re_c_yaccfile
+      then 
+        let b' = Common.matched1 b in
+        Sys.file_exists (Common2.filename_of_dbe (d,b', "y"))
+      else false
+      )
+ 
+  | _ when b = "Makefile" && e = "NOEXT" ->
+      Sys.file_exists (Common2.filename_of_dbe (d,b, "am")) ||
+      Sys.file_exists (Common2.filename_of_dbe (d,b, "in")) ||
+      Sys.file_exists (Common2.filename_of_dbe (d,"Imakefile", ""))
+
+  | _ -> false
+
+(* opti: for some fastpath *)
+let re_auto_generated = Str.regexp
+  "\\(.*\\.\\(ml\\|mli\\|tex\\|info\\|in\\|c\\)\\)\\|.*Makefile"
+
+(*****************************************************************************)
+(* Filename->archi *)
+(*****************************************************************************)
+
+let _hmemo_categ_dir = Hashtbl.create 101 
+
+(* Why taking the root ? Because if the data are in /tmp/data/soft/... then
+ * you would get the rule for tmp and data :( should not consider
+ * directories too far away.
+ * Why not passing a readable path then? Because most of the functions
+ * in common expect full path, and also because I use file operations
+ * like Sys.file_exists in is_auto_generated() which is used by this
+ * function.
+ *)
+let source_archi_of_filename3 ~root file = 
+
+  let base = Filename.basename file in
+  let f = Common.readable ~root file in
+
+  if base ==~ re_auto_generated && is_auto_generated file
+  then AutoGenerated
+  else
+    let b = "/" ^ Common2.lowercase base ^ "/" in
+    (* we try to give the most specialized category by first considering
+     * the extension of the file, then its basename, and then its
+     * directory component starting from the last one (hence the List.rev)
+     *)
+    let lexbuf = Lexing.from_string b in
+    let categ1 = Archi_code_lexer.category lexbuf in
+    
+    let d = Filename.dirname f in
+    (* try the directory, caching the result.
+     *
+     * note: should perhaps put (root, d) as the key for the memoized call
+     * because when we start from a nested dir and go up, 
+     * the root has changed and so what was considered Regular
+     * could not be considered Intern. But then
+     * when we click to go down, we can't reuse the cached
+     * archi and the color may actually change which can be confusing.
+     * 
+     *)
+    let categ2 =
+      Common.memoized _hmemo_categ_dir d (fun () ->
+        
+        let d = Common2.lowercase d in
+        
+        let xs = Common.split "/" d in
+        let xs = List.rev xs in
+        let str = "/" ^ Common.join "/" xs ^ "/" in
+        
+        let lexbuf = Lexing.from_string str in
+        Archi_code_lexer.category lexbuf
+      )
+    in
+    (match categ1, categ2 with
+    | _, (Data | AutoGenerated | ThirdParty | Ffi | Legacy) -> categ2
+    | Regular, _x -> categ2
+    | _, _ -> categ1
+    )
+
+
+let source_archi_of_filename ~root f = 
+  Common.profile_code "Archi.source_of_filename" (fun () ->
+    source_archi_of_filename3 ~root f)

h_program-lang/archi_code_parse.mli

@@ -0,0 +1,4 @@
+
+val source_archi_of_filename: 
+  root:Common.dirname ->
+  Common.filename -> Archi_code.source_archi

h_program-lang/ast_fuzzy.ml

@@ -0,0 +1,288 @@
+(* Yoann Padioleau
+ *
+ * Copyright (C) 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 *)
+(*****************************************************************************)
+(* 
+ * When searching for or refactoring code, regexps are good enough most of 
+ * the time; tools such as 'grep' or 'sed' are great. But certain regexps
+ * are tedious to write when one needs to handle variations in spacing,
+ * the possibilty to have comments in the middle of the code you
+ * are looking for, or newlines. Things are even more complicated when
+ * you want to handle nested parenthesized expressions or statements. This is
+ * because regexps can't count. For instance how would you
+ * remove a namespace in C++? You would like to write a transformation
+ * like:
+ * 
+ *  - namespace my_namespace {
+ *    ...
+ *  - }
+ * 
+ * but regexps can't do that[1].
+ * 
+ * The alternative is then to use more precise tools such as 'sgrep'
+ * or 'spatch'. But implementing sgrep/spatch in the usual way 
+ * for a new language, by matching AST against AST, can be really tedious. 
+ * The AST can be big and even if we can auto generate most of the
+ * boilerplate code, this still takes quite some effort (see lang_php/matcher).
+ * 
+ * Moreover, in my experience matching AST against AST lacks
+ * flexibility sometimes. For instance many people want to use 'sgrep' to
+ * find a method foo and so do "sgrep -e 'foo(...)'" but
+ * because the matching is done at the AST level, 'foo(...)' is
+ * parsed as a function call, not a method call, and so it will
+ * not work. But people expect it to work because it works
+ * with regexps. So 'sgrep' for PHP currently forces people to write this
+ * pattern '$V->foo(...)'.
+ * In the same way a pattern like '1' was originally matching
+ * only expressions, but was not matching static constants because
+ * again it was a different AST constructor. Actually many
+ * of the extensions and bugfixes in sgrep_php/spatch_php in 
+ * the last year has been related to this lack of flexibility
+ * because the AST was too precise.
+ * 
+ * Enter Ast_fuzzy, a way to factorize most of the needs of
+ * 'sgrep' and 'spatch' over different programming languages,
+ * while being more flexible in some ways than having a precise AST.
+ * It fills a niche between regexps and very-precise ASTs.
+ * 
+ * In Ast_fuzzy we just want to keep the parenthesized information
+ * from the code, and abstract away spacing, the main things that 
+ * regexps have troubles with, and then let people match over this
+ * parenthesized cleaned-up tree in a flexible way.
+ * 
+ * related:
+ *  - xpath? but do programming languages need the full power of xpath?
+ *    usually an AST just have 3 different kinds of nodes, Defs, Stmts,
+ *    and Exprs.
+ * 
+ * See also lang_cpp/parsing_cpp/test_parsing_cpp and its parse_cpp_fuzzy()
+ * and dump_cpp_fuzzy() functions. Most of the code related to Ast_fuzzy
+ * is in matcher/ and called from 'sgrep' and 'spatch'.
+ * For 'sgrep' and 'spatch' examples, see unit_matcher.ml as well as
+ * tests/cpp/sgrep/ and tests/cpp/spatch/
+ * 
+ * notes:
+ *  [1] Actually Perl regexps are more powerful so one can do for instance:
+ *  echo 'something< namespace<x<y<z,t>>>, other >' | 
+ *    perl -pe 's/namespace(<(?:[^<>]|(?1))*>)/foo/'
+ *  => 'something< foo, other >'
+ *  but it's arguably more complicated than the proposed spatch above.
+ * 
+ * todo:
+ *  - handle infix operators: parse them not as a sequence
+ *    but as a tree as we want for instance '$X->foo()' to match
+ *    whole expression like 'this->bar()->foo()', or we want
+ *    '$X' to match '1+1' (and not only in Parens context)
+ *  - same for function calls? so maybe we need to transform our
+ *    original program in a lisp like AST where things are more uniform
+ *  - how to handle isomorphisms like 'order of attributes don't matter'
+ *    as in XHP? or class that can be mentioned anywhere in the arguments
+ *    to implements? or how can we make 'class X { ... }' to also match
+ *    'class X extends whatever { ... }'? or have public/static to
+ *    be optional?
+ *    Use regexp over trees? Use isomorphisms file as in coccinelle?
+ *    Have special mark about optional things in ast_fuzzy? 
+ *    Derives such information from the grammar?
+ *  - want powerful queries like 
+ *      'class X { ... function(...) { ... foo() ... } ... }
+ *    so sgrep powerful for microlevel queries, and prolog for macrolevel
+ *    queries. Xpath? Css selector?
+ *)
+
+(*****************************************************************************)
+(* Types *)
+(*****************************************************************************)
+
+type tok = Parse_info.info
+type 'a wrap = 'a * tok
+
+type tree =
+  | Braces of tok * trees * tok
+  (* todo: comma *)
+  | Parens of tok * (trees, tok (* comma*)) Common.either list * tok
+  | Angle  of tok * trees * tok
+
+  (* note that gcc allows $ in identifiers, so using $ for metavariables
+   * means we will not be able to match such identifiers. No big deal.
+   *)
+  | Metavar of string wrap
+  (* note that "..." are allowed in many languages, so using "..."
+   * to represent a list of anything means we will not be able to
+   * match specifically "...".
+   *)
+  | Dots of tok
+
+  | Tok of string wrap
+and trees = tree list
+ (* with tarzan *)
+
+let is_metavar s =
+  s =~ "^\\$.*"
+
+(*****************************************************************************)
+(* Visitor *)
+(*****************************************************************************)
+
+type visitor_out = trees -> unit
+
+type visitor_in = {
+  ktree: (tree -> unit) * visitor_out -> tree -> unit;
+  ktrees: (trees -> unit) * visitor_out -> trees -> unit;
+  ktok: (tok -> unit) * visitor_out -> tok -> unit;
+}
+
+let (default_visitor : visitor_in) = 
+  { ktree = (fun (k, _) x -> k x);
+    ktok  = (fun (k, _) x -> k x);
+    ktrees = (fun (k, _) x -> k x);
+  }
+
+let (mk_visitor: visitor_in -> visitor_out) = fun vin ->
+
+  let rec v_tree x =
+    let k x = match x with
+      | Braces ((v1, v2, v3)) ->
+        let _v1 = v_tok v1 and _v2 = v_trees v2 and _v3 = v_tok v3 in ()
+      | Parens ((v1, v2, v3)) ->
+        let _v1 = v_tok v1
+        and _v2 = Ocaml.v_list (Ocaml.v_either v_trees v_tok) v2
+        and _v3 = v_tok v3
+      in ()
+
+      | Angle ((v1, v2, v3)) ->
+        let _v1 = v_tok v1 and _v2 = v_trees v2 and _v3 = v_tok v3 in ()
+      | Metavar v1 -> let _v1 = v_wrap v1 in ()
+      | Dots v1 -> let _v1 = v_tok v1 in ()
+      | Tok v1 -> let _v1 = v_wrap v1 in ()
+    in
+    vin.ktree (k, all_functions) x
+ and v_trees a = 
+    let k xs =
+      match xs with
+      | [] -> ()
+      | x::xs ->
+        v_tree x;
+        v_trees xs;
+    in
+    vin.ktrees (k, all_functions) a
+
+ and v_wrap (_s, x) = v_tok x
+        
+ and v_tok x =
+    let k _x = () in
+    vin.ktok (k, all_functions) x
+
+  and all_functions x = v_trees x in
+  all_functions
+
+(*****************************************************************************)
+(* Map *)
+(*****************************************************************************)
+
+type map_visitor = {
+  mtok: (tok -> tok) -> tok -> tok;
+}
+
+let (mk_mapper: map_visitor -> (trees -> trees)) = fun hook ->
+  let rec map_tree =
+    function
+    | Braces ((v1, v2, v3)) ->
+      let v1 = map_tok v1
+      and v2 = map_trees v2
+      and v3 = map_tok v3
+      in Braces ((v1, v2, v3))
+    | Parens ((v1, v2, v3)) ->
+      let v1 = map_tok v1
+      and v2 = List.map (Ocaml.map_of_either map_trees map_tok) v2
+      and v3 = map_tok v3
+      in Parens ((v1, v2, v3))
+    | Angle ((v1, v2, v3)) ->
+      let v1 = map_tok v1
+      and v2 = map_trees v2
+      and v3 = map_tok v3
+      in Angle ((v1, v2, v3))
+  | Metavar v1 -> let v1 = map_wrap v1 in Metavar ((v1))
+  | Dots v1 -> let v1 = map_tok v1 in Dots ((v1))
+  | Tok v1 -> let v1 = map_wrap v1 in Tok ((v1))
+  and map_trees v = List.map map_tree v
+  and map_tok v = 
+    let k v = v in
+    hook.mtok k v
+  and map_wrap (s, t) = (s, map_tok t)
+  in
+  map_trees
+
+(*****************************************************************************)
+(* Extractor *)
+(*****************************************************************************)
+
+let (toks_of_trees: trees -> Parse_info.info list) = fun trees ->
+  let globals = ref [] in
+  let hooks = { default_visitor with
+    ktok = (fun (_k, _) i -> Common.push i globals)
+  } in
+  begin
+    let vout = mk_visitor hooks in
+    vout trees;
+    List.rev !globals
+  end
+
+(*****************************************************************************)
+(* Abstract position *)
+(*****************************************************************************)
+
+let abstract_position_trees trees = 
+  let hooks = { 
+    mtok = (fun (_k) i -> 
+      { i with Parse_info.token = Parse_info.Ab }
+    )
+  } in
+  let mapper = mk_mapper hooks in
+  mapper trees
+
+(*****************************************************************************)
+(* Vof *)
+(*****************************************************************************)
+
+let vof_token t =
+  Ocaml.VString (Parse_info.str_of_info t)
+  (* Parse_info.vof_token t*)
+
+let rec vof_multi_grouped =
+  function
+  | Braces ((v1, v2, v3)) ->
+      let v1 = vof_token v1
+      and v2 = Ocaml.vof_list vof_multi_grouped v2
+      and v3 = vof_token v3
+      in Ocaml.VSum (("Braces", [ v1; v2; v3 ]))
+  | Parens ((v1, v2, v3)) ->
+      let v1 = vof_token v1
+      and v2 = Ocaml.vof_list (Ocaml.vof_either vof_trees vof_token) v2
+      and v3 = vof_token v3
+      in Ocaml.VSum (("Parens", [ v1; v2; v3 ]))
+  | Angle ((v1, v2, v3)) ->
+      let v1 = vof_token v1
+      and v2 = Ocaml.vof_list vof_multi_grouped v2
+      and v3 = vof_token v3
+      in Ocaml.VSum (("Angle", [ v1; v2; v3 ]))
+  | Metavar v1 -> let v1 = vof_wrap v1 in Ocaml.VSum (("Metavar", [ v1 ]))
+  | Dots v1 -> let v1 = vof_token v1 in Ocaml.VSum (("Dots", [ v1 ]))
+  | Tok v1 -> let v1 = vof_wrap v1 in Ocaml.VSum (("Tok", [ v1 ]))
+and vof_wrap (s, _x) = Ocaml.VString s
+and vof_trees xs =
+  Ocaml.VList (xs +> List.map vof_multi_grouped)

h_program-lang/ast_fuzzy.mli

@@ -0,0 +1,42 @@
+
+type tok = Parse_info.info
+type 'a wrap = 'a * tok
+
+type tree =
+  | Braces of tok * trees * tok
+  | Parens of tok * (trees, tok (* comma*)) Common.either list * tok
+  | Angle  of tok * trees * tok
+
+  (* note that gcc allows $ in identifiers, so using $ for metavariables
+   * means we will not be able to match such identifiers (but no big deal)
+   *)
+  | Metavar of string wrap
+  (* note that "..." are allowed in many languages, so using "..."
+   * to represent a list of anything means we will not be able to
+   * match specifically "...".
+   *)
+  | Dots of tok
+
+  | Tok of string wrap
+
+and trees = tree list
+
+(* see matcher/parse_fuzzy.mli for helpers to build such trees *)
+
+val is_metavar: string -> bool
+
+(* visitors, dumpers, extractors, abstractors, mappers *)
+
+val abstract_position_trees: trees -> trees
+val toks_of_trees: trees -> tok list
+val vof_trees: trees -> Ocaml.v
+
+type visitor_out = trees -> unit
+type visitor_in = {
+  ktree: (tree -> unit) * visitor_out -> tree -> unit;
+  ktrees: (trees -> unit) * visitor_out -> trees -> unit;
+  ktok: (tok -> unit) * visitor_out -> tok -> unit;
+}
+
+val default_visitor: visitor_in
+val mk_visitor: visitor_in -> visitor_out

h_program-lang/big_grep.ml

@@ -0,0 +1,194 @@
+(* Yoann Padioleau
+ *
+ * Copyright (C) 2010 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
+
+module Db = Database_code
+
+(*****************************************************************************)
+(* Prelude *)
+(*****************************************************************************)
+(*
+ * Inspired by 'tbgs' and big_grep at facebook.
+ * The trick is to build a giant string and run compiled-regexps
+ * on it. For each match have to go back to find the start and
+ * end of entity, or the entity number so can display
+ * the information associated with it. So need markers
+ * in the string.
+ * 
+ * One-liner in perl by Erling:
+ * perl -e '$|++; open F,"/usr/share/dict/words"; { local $/; $all=<F>;
+ * } while(<STDIN>) { chomp; $w=$_; $n = 0; while($all =~ /$w.*/g) {
+ * print "$&\n"; last if ++$n>10; } print "[$w]\n"; }'
+ * 
+ *)
+
+(*****************************************************************************)
+(* Types *)
+(*****************************************************************************)
+
+type index = {
+  big_string: string;
+  pos_to_entity: (int, Db.entity) Hashtbl.t;
+  case_sensitive: bool;
+}
+
+(* using \n is convenient so can allow regexp queries like
+ * employee.* without having the regexp engine to try to match
+ * the whole string; it will stop at the first \n.
+ *)
+let separation_marker_char = '\n'
+
+let empty_index () = {
+  big_string = "";
+  pos_to_entity = Hashtbl.create 1;
+  case_sensitive = false;
+}
+
+(*****************************************************************************)
+(* Helpers *)
+(*****************************************************************************)
+
+let (==~) = Common2.(==~)
+
+(*****************************************************************************)
+(* Naive version *)
+(*****************************************************************************)
+
+(* This is the naive version, just to have a baseline for benchmarks *)
+let naive_top_n_search2 ~top_n ~query xs =
+  let re = Str.regexp (".*" ^ query) in
+
+  let rec aux ~n xs =
+    if n = top_n
+    then []
+    else 
+      (match xs with
+      | [] -> []
+      | e::xs ->
+          if e.Db.e_name ==~ re
+          then
+            e::aux ~n:(n+1) xs
+          else 
+            aux ~n xs
+      )
+  in
+  aux ~n:0 xs
+
+
+let naive_top_n_search ~top_n ~query idx =
+  Common.profile_code "Big_grep.naive_top_n" (fun () -> 
+    naive_top_n_search2 ~top_n ~query idx
+  )
+
+(*****************************************************************************)
+(* Main entry point *)
+(*****************************************************************************)
+
+let build_index2 ?(case_sensitive=false) entities =
+  
+  let buf = Buffer.create 20_000_000 in
+  let h = Hashtbl.create 1001 in
+
+  let current = ref 0 in
+
+  entities +> List.iter (fun e ->
+    (* Use fullname ? The caller, that is for instance
+     * files_and_dirs_and_sorted_entities_for_completion
+     * should have done the job of putting the fullename in e_name.
+     *)
+    let s = Common2.string_of_char separation_marker_char ^ e.Db.e_name in
+    let s = 
+      if case_sensitive
+      then s
+      else Common2.lowercase s
+    in
+
+    Buffer.add_string buf s;
+    Hashtbl.add h !current e;
+    current := !current + String.length s;
+  );
+  (* just to make it easier to code certain algorithms such as
+   * find_position_marker_after
+   *)
+  Buffer.add_string buf (Common2.string_of_char separation_marker_char);
+
+  {
+    big_string = Buffer.contents buf;
+    pos_to_entity = h;
+    case_sensitive = case_sensitive;
+  }
+
+let build_index ?case_sensitive a =
+  Common.profile_code "Big_grep.build_idx" (fun () -> 
+    build_index2 ?case_sensitive a)
+
+
+let find_position_marker_before start_pos str =
+  let pos = ref (start_pos - 1) in
+  
+  while String.get str !pos <> separation_marker_char do
+    pos := !pos - 1
+  done;
+  !pos
+
+let find_position_marker_after start_pos str =
+  let pos = ref (start_pos + 1) in
+  
+  while String.get str !pos <> separation_marker_char do
+    pos := !pos + 1
+  done;
+  !pos
+
+(* the query can now contain multipe words *)
+let top_n_search2 ~top_n ~query idx =
+
+  let query = 
+    if idx.case_sensitive then query else Common2.lowercase query
+  in
+
+  let words = Str.split (Str.regexp "[ \t]+") query in
+  let re =
+    match words with
+    | [_] -> Str.regexp (".*" ^ query)
+    | [a;b] -> 
+        Str.regexp (spf 
+                       ".*\\(%s.*%s\\)\\|\\(%s.*%s\\)"
+                       a b b a)
+    | _ -> 
+        failwith "more-than-2-words query is not supported; give money to pad"
+  in
+  
+  let rec aux ~n ~pos =
+    if n = top_n
+    then []
+    else 
+      try 
+        let new_pos = Str.search_forward re idx.big_string pos in
+        (* let's found the marker *)
+        let pos_mark = 
+          find_position_marker_before new_pos idx.big_string in
+        let pos_next_mark = 
+          find_position_marker_after new_pos idx.big_string in
+        let e = Hashtbl.find idx.pos_to_entity pos_mark in
+        e::aux ~n:(n+1) ~pos:pos_next_mark
+      with Not_found -> []
+  in
+  aux ~n:0 ~pos:0
+
+
+let top_n_search ~top_n ~query idx =
+  Common.profile_code "Big_grep.top_n" (fun () -> 
+    top_n_search2 ~top_n ~query idx
+  )

h_program-lang/big_grep.mli

@@ -0,0 +1,27 @@
+
+type index = {
+  big_string: string;
+  pos_to_entity: (int, Database_code.entity) Hashtbl.t;
+  case_sensitive: bool;
+}
+val empty_index: unit -> index
+
+(* the list is supposed to be sorted by importance so that the
+ * top n search returns first the most important entities
+ *)
+val build_index: 
+  ?case_sensitive:bool ->
+  Database_code.entity list -> index
+
+val top_n_search: 
+  top_n:int ->
+  query:string -> 
+  index -> 
+  Database_code.entity list
+
+val naive_top_n_search:
+  top_n:int ->
+  query:string -> 
+  Database_code.entity list ->
+  Database_code.entity list
+  

h_program-lang/comment_code.ml

@@ -0,0 +1,95 @@
+(* Yoann Padioleau
+ *
+ * Copyright (C) 2014 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
+
+module PI = Parse_info
+
+(*****************************************************************************)
+(* Prelude *)
+(*****************************************************************************)
+(*
+ * todo: extract and factorize more from comment_php.ml
+ *)
+
+(*****************************************************************************)
+(* Types *)
+(*****************************************************************************)
+
+(* todo: duplicate of matcher/parse_fuzzy.ml *)
+type 'tok hooks = {
+  kind: 'tok -> Parse_info.token_kind;
+  tokf: 'tok -> Parse_info.info;
+}
+
+(*****************************************************************************)
+(* Functions *)
+(*****************************************************************************)
+
+
+let comment_before hooks tok all_toks =
+  let pos = Parse_info.pos_of_info tok in
+  let before = 
+    all_toks +> Common2.take_while (fun tok2 ->
+      let info = hooks.tokf tok2 in
+      let pos2 = PI.pos_of_info info in
+      pos2 < pos
+    )
+  in
+  let first_non_space =
+    List.rev before +> Common2.drop_while (fun t ->
+      let kind = hooks.kind t in
+      match kind with
+      | PI.Esthet PI.Newline | PI.Esthet PI.Space -> true
+    | _ -> false
+    )
+  in
+  match first_non_space with
+  | x::_xs when hooks.kind x =*= PI.Esthet (PI.Comment) ->
+      let info = hooks.tokf x in
+      if PI.col_of_info info = 0
+      then Some info
+      else None
+  | _ -> None
+
+
+let comment_after hooks tok all_toks =
+  let pos = PI.pos_of_info tok in
+  let line = PI.line_of_info tok in
+  let after = 
+    all_toks +> Common2.drop_while (fun tok2 ->
+      let info = hooks.tokf tok2 in
+      let pos2 = PI.pos_of_info info in
+      pos2 <= pos
+    )
+  in
+  let first_non_space =
+    after +> Common2.drop_while (fun t ->
+      let kind = hooks.kind t in
+      match kind with
+      | PI.Esthet PI.Newline | PI.Esthet PI.Space -> true
+    | _ -> false
+    )
+  in
+  match first_non_space with
+  | x::_xs when hooks.kind x =*= PI.Esthet (PI.Comment) ->
+      let info = hooks.tokf x in
+      (* for ocaml comments they are not necessarily in
+       * column 0, but they must be just after
+       *)
+      if PI.line_of_info info = line || PI.line_of_info info = line + 1
+         (* && PI.col_of_info info > 0 *)
+      then Some info
+      else None
+  | _ -> None

h_program-lang/comment_code.mli

@@ -0,0 +1,11 @@
+
+type 'tok hooks = {
+  kind: 'tok -> Parse_info.token_kind;
+  tokf: 'tok -> Parse_info.info;
+}
+
+val comment_before:
+ 'a hooks -> Parse_info.info -> 'a list -> Parse_info.info option
+
+val comment_after:
+ 'a hooks -> Parse_info.info -> 'a list -> Parse_info.info option

h_program-lang/copyright.txt

@@ -0,0 +1,13 @@
+Copyright (C) 2010 Facebook
+
+   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.
+
+

h_program-lang/coverage_code.ml

@@ -0,0 +1,156 @@
+(* Yoann Padioleau
+ *
+ * Copyright (C) 2010 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
+
+module J = Json_type
+
+(*****************************************************************************)
+(* Prelude *)
+(*****************************************************************************)
+(*
+ * The goal of this module is to provide data structures that can be
+ * used to mimic the Microsoft Echelon[1] project which given a patch
+ * try to run the most relevant tests that could be affected by the
+ * patch. It is probably easier in interpreted languages such as PHP which
+ * contain simple tracers/profilers.
+ * 
+ * We can even run the tests and says whether the new code has
+ * been covered (like in MySql test infrastructure).
+ * 
+ * For now we just provide types for a mapping from
+ * a source code file to a list of relevant test files. 
+ * 
+ * References:
+ *  [1] http://research.microsoft.com/apps/pubs/default.aspx?id=69911
+ *)
+
+(*****************************************************************************)
+(* Types *)
+(*****************************************************************************)
+
+(* relevant test files exercising source, with term-frequency of 
+ * file in the test *)
+type tests_coverage = (Common.filename, tests_score) Common.assoc
+ and tests_score = (Common.filename * float) list
+ (* with tarzan *)
+
+(* Note that xdebug by default does not trace assignements but only 
+ * function and method calls, which mean the list of lines returned
+ * is an under-approximation. We compensate such an approximation by
+ * also computing the static set of function/method calls so that
+ * a coverage percentage can be computed.
+ * 
+ * update: with hphpi tracer, we actually also cover assignement and
+ * this type is actually independent of such design decision.
+ * It's line-based though, so don't expect complex path coverage
+ * or MCDC stuff. Just simple line coverage ...
+ *)
+type lines_coverage = (Common.filename, file_lines_coverage) Common.assoc
+ and file_lines_coverage = {
+   covered_sites: int list;
+   all_sites: int list;
+ }
+ (* with tarzan *)
+
+(*****************************************************************************)
+(* String of, json, etc *)
+(*****************************************************************************)
+
+(* This helps generates a coverage file that 'arc unit' can read *)
+let (json_of_tests_coverage: tests_coverage -> J.json_type) = fun cov ->
+  J.Object (cov +> List.map (fun (cover_file, tests_score) ->
+    cover_file, 
+    J.Array (tests_score +> List.map (fun (test_file, score) -> 
+      J.Array [J.String test_file; J.String (spf "%.3f" score)]
+    ))
+  ))
+
+(* todo: should be autogenerated by ocamltarzan *)
+let (tests_coverage_of_json: J.json_type -> tests_coverage) = fun j ->
+  match j with
+  | J.Object (xs) ->
+      xs +> List.map (fun (cover_file, tests_score) ->
+        cover_file, 
+        match tests_score with
+        | J.Array zs -> 
+            zs +> List.map (fun test_file_score_pair ->
+              (match test_file_score_pair with
+              | J.Array [J.String test_file; J.String str_score] ->
+                  test_file, float_of_string str_score
+                    
+              | _ -> failwith "Bad json, tests_coverage_of_json"
+              )
+            )
+        | _ ->  failwith "Bad json, tests_coverage_of_json"
+      )
+  | _ -> failwith "Bad json, tests_coverage_of_json"
+
+(* todo: should be autogenerated by ocamltarzan *)
+let (json_of_lines_coverage: lines_coverage -> J.json_type) = fun cov ->
+  J.Object (cov +> List.map (fun (file, cover) -> 
+    file, 
+    J.Object ([
+      (* I use short fieldnames to avoid generating a huge JSON file.
+      *)
+      "cov", J.Array (cover.covered_sites +> List.map (fun l -> J.Int l));
+      "all", J.Array (cover.all_sites +> List.map (fun l -> J.Int l));
+    ])
+  ))
+
+let (lines_coverage_of_json: J.json_type -> lines_coverage) = fun j ->
+  match j with
+  | J.Object (xs) ->
+      xs +> List.map (fun (file, cover) ->
+        file, 
+        match cover with
+        | J.Object ([
+            "cov", J.Array covered_lines;
+            "all", J.Array call_sites;
+          ]) ->
+            {
+              covered_sites = 
+                covered_lines +> List.map (function
+                | J.Int l -> l
+                | _ -> failwith "Bad json, files_coverage_of_json"
+                );
+              all_sites = 
+                call_sites +> List.map (function
+                | J.Int l -> l
+                | _ -> failwith "Bad json, files_coverage_of_json"
+                );
+            }
+        | _ ->  failwith "Bad json, files_coverage_of_json"
+      )
+  | _ -> failwith "Bad json, files_coverage_of_json"
+
+
+let (save_tests_coverage: tests_coverage -> Common.filename -> unit) = 
+ fun cov file -> 
+   cov +> json_of_tests_coverage +> Json_out.string_of_json
+   +> Common.write_file ~file
+
+let (load_tests_coverage: Common.filename -> tests_coverage) = 
+ fun file ->
+   file +> Json_in.load_json +> tests_coverage_of_json
+
+
+let (save_lines_coverage: lines_coverage -> Common.filename -> unit) = 
+ fun cov file -> 
+   cov +> json_of_lines_coverage +> Json_out.string_of_json
+   +> Common.write_file ~file
+   
+let (load_lines_coverage: Common.filename -> lines_coverage) = 
+ fun file ->
+   file +> Json_in.load_json +> lines_coverage_of_json

h_program-lang/coverage_code.mli

@@ -0,0 +1,25 @@
+
+(* relevant test files exercising source, with term-frequency of 
+ * file in the test *)
+type tests_coverage = (Common.filename (* source *), tests_score) Common.assoc
+ and tests_score = (Common.filename (* a test *) * float) list
+
+type lines_coverage = (Common.filename, file_lines_coverage) Common.assoc
+ and file_lines_coverage = {
+   covered_sites: int list;
+   all_sites: int list;
+ }
+
+(* input/output *)
+val json_of_tests_coverage: tests_coverage -> Json_type.json_type
+val json_of_lines_coverage: lines_coverage -> Json_type.json_type
+
+val tests_coverage_of_json: Json_type.json_type -> tests_coverage
+val lines_coverage_of_json: Json_type.json_type -> lines_coverage
+
+(* shortcuts *)
+val save_tests_coverage: tests_coverage -> Common.filename -> unit
+val load_tests_coverage: Common.filename -> tests_coverage
+
+val save_lines_coverage: lines_coverage -> Common.filename -> unit
+val load_lines_coverage: Common.filename -> lines_coverage

h_program-lang/database_code.ml

@@ -0,0 +1,698 @@
+(* Yoann Padioleau
+ *
+ * Copyright (C) 2009, 2010 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
+
+open Entity_code
+module J = Json_type
+module HC = Highlight_code
+
+(*****************************************************************************)
+(* Prelude *)
+(*****************************************************************************)
+(* 
+ * This module provides a generic "database" of semantic information
+ * on a codebase (a la CIA [1]). The goal is to give access to
+ * information computed by a set of global static or dynamic analysis
+ * such as 'what are the number of callers to a certain function', 'what
+ * is the test coverage of a file', etc. This is mainly used by codemap
+ * to give semantic visual feedback on the code. See also layer_code.ml
+ * for complementary semantic information about a codebase.
+ * 
+ * update: prolog_code.pl and Prolog may now be the prefered way to
+ * represent a code database, but for codemap it's still good to use
+ * this database.
+ * 
+ * Each programming language analysis library usually provides
+ * a more powerful database (e.g. analyze_php/database/database_php.mli)
+ * with more information. Such a database is usually also efficiently stored
+ * on disk via BerkeleyDB. Nevertheless generic tools like
+ * codemap can benefit from a shorter and generic version of this
+ * database. Moreover, when we have codebase with multiple langages
+ * (e.g. PHP and javascript), having a common type can help for some
+ * analysis or visualization.
+ * 
+ * Note that by storing this toy database in a JSON format or with Marshall,
+ * this database can also easily be read by multiple
+ * process at the same time (there is currently a few problems with
+ * concurrent access of Berkeley Db data; for instance one database
+ * created by a user can not even be read by another user ...).
+ * This also avoids forcing the user to spend time running all
+ * the global analysis on his own codebase. We can factorize the essential
+ * results of such long computation in a single file.
+ * 
+ * An alternative would be to use the TAGS file or information from
+ * cscope. But this would require to implement a reader for those
+ * two formats. Moreover ctags/cscope do just lexical-based analysis
+ * so it's not a good basis and it contains only defition->position
+ * information.
+ * 
+ * history: 
+ *  - started when working for eurosys'06 in patchparse/ in a file called
+ *    c_info.ml
+ *  - extended for eurosys'08 for coccinelle/ in coccinelle/extra/ 
+ *    and use it to discover some .c .h mapping and generate some crazy 
+ *    graphs and also to detect drivers splitted in multiple files.
+ *  - extended it for aComment in 2008 and 2009, to feed information to some 
+ *    inter-procedural analysis.
+ *  - rewrite it for PHP in Nov 2009
+ *  - adapted in Jan 2010 for flib_navigator
+ *  - make it generic in Aug 2010 for my code/treemap visualizer
+ *  - added comments about Prolog database which may be a better db for
+ *    certain use cases.
+ * 
+ * history bis:
+ *  - Before, I was optimizing stuff by caching the ast in 
+ *    some xxx_raw files. But there was lots of small raw files; 
+ *    get lots of ast files and waste space. Also not good for random
+ *    access to the asts. So better to use berkeley DB. My experience with
+ *    LFS helped me a little as I was already using berkeley DB and glimpse.
+ *    
+ *  - I was also using glimpse and I tried to accelerate even more coccinelle
+ *    to generate some mini C files so that glimpse can directly tell us
+ *    the toplevel elements to look for. But this generates lots of 
+ *    very small mini C files which also waste lots of disk space.
+ * 
+ * References:
+ *  [1] CIA, the C Information Abstractor
+ *)
+
+(*****************************************************************************)
+(* Type *)
+(*****************************************************************************)
+
+(* How to store the id of an entity ? A int ? A name and hope few conflicts ?
+ * Using names will increase the size of the db which will slow down
+ * the loading of the database.
+ * So it's better to use an id. Moreover at some point we want to provide
+ * callers/callees navigations and more entities relationships
+ * so we need a real way to reference an entity.
+ *)
+type entity_id = int
+
+type entity = {
+  e_kind: entity_kind;
+
+  e_name: string;
+  (* can be empty to save space when e_fullname = e_name *)
+  e_fullname: string;
+
+  e_file: Common.filename;
+  e_pos: Common2.filepos;
+  
+  (* Semantic information that can be leverage by a code visualizer.
+   * The fields are set as mutable because usually we compute
+   * the set of all entities in a first phase and then we
+   * do another pass where we adjust numbers of other entity references.
+   *)
+  
+  (* todo: could give more importance when used externally not just
+   * from another file but from another directory!
+   * or could refine this int with more information.
+   *)
+  mutable e_number_external_users: int;
+
+  (* Usually the id of a unit test of pleac file. 
+   *
+   * Indeed a simple algorithm to compute this list is:
+   * just look at the callers, filter the one in unit test or pleac files, 
+   * then for each caller, look at the number of callees, and take
+   * the one with best ratio.
+   * 
+   * With references to good examples of use, we can offer
+   * what Perl programmers had for years with their function 
+   * documentations.
+   * If there is no examples_of_use then the user can visually
+   * see that some functions should be unit tested :)
+   *)
+  mutable e_good_examples_of_use: entity_id list;
+
+  (* todo? code_rank ? this is more useful for number_internal_users
+   * when we want to know what is the core function in a module,
+  * even when it's called only once, but by a small wrapper that is
+  * itself very often called.
+  *)
+
+  e_properties: property list;
+ }
+
+(* Note that because we now use indexed entities, you can not
+ * play with.entities as before. For instance merging databases
+ * requires to adjust all the entity_id internal references.
+ *)
+type database = {
+
+  (* The common root if the database was built with multiple dirs
+   * as an argument. Such a root is mostly useful when displaying
+   * filenames in which case we can strip the root from it
+   * (e.g. in the treemap browser when we mouse over a rectangle).
+   *)
+  root: Common.dirname;
+
+  (* Such list can be used in a search box powered by completion.
+   * The int is for the total number of times this files is
+   * externally referenced. Can be use for instance in the treemap
+   * to artificially augment the size of what is probably a more 
+   * "important" file.
+  *)
+  dirs: (Common.filename * int) list;
+
+  (* see also build_top_k_sorted_entities_per_file for dynamically
+   * computed summary information for a file 
+   *)
+  files: (Common.filename * int) list;
+
+  (* indexed by entity_id *)
+  entities: entity array;
+}
+
+let empty_database () = {
+  root = "";
+  dirs = [];
+  files = [];
+  entities = Array.of_list [];
+}
+
+let default_db_name = 
+  "PFFF_DB.marshall"
+
+
+(*****************************************************************************)
+(* Json *)
+(*****************************************************************************)
+
+(*---------------------------------------------------------------------------*)
+(* json -> X *)
+(*---------------------------------------------------------------------------*)
+
+let json_of_filepos x = 
+  J.Array [J.Int x.Common2.l; J.Int x.Common2.c]
+
+let json_of_property x =
+  match x with
+  | ContainDynamicCall ->    J.Array [J.String "ContainDynamicCall"]
+  | ContainReflectionCall -> J.Array [J.String "ContainReflectionCall"]
+  | TakeArgNByRef i -> J.Array [J.String "TakeArgNByRef"; J.Int i]
+  | _ -> raise Todo
+
+let json_of_entity e = 
+  J.Object [
+    "k", J.String (string_of_entity_kind e.e_kind);
+    "n", J.String e.e_name;
+    "fn", J.String e.e_fullname;
+    "f", J.String e.e_file;
+    "p", json_of_filepos e.e_pos;
+    (* different from type *)
+    "cnt", J.Int e.e_number_external_users;
+    "u", J.Array (e.e_good_examples_of_use +> List.map (fun id -> J.Int id));
+    "ps", J.Array (e.e_properties +> List.map json_of_property);
+  ]
+
+let json_of_database db = 
+  J.Object [
+    "root", J.String db.root;
+    "dirs", J.Array (db.dirs +> List.map (fun (x, i) ->
+      J.Array([J.String x; J.Int i])));
+    "files", J.Array (db.files +> List.map (fun (x, i) ->
+      J.Array([J.String x; J.Int i])));
+    "entities", J.Array (db.entities +> 
+                         Array.to_list +> List.map json_of_entity);
+  ]
+
+(*---------------------------------------------------------------------------*)
+(* X -> json *)
+(*---------------------------------------------------------------------------*)
+let ids_of_json json =
+  match json with
+  | J.Array xs ->
+      xs +> List.map (function
+      | J.Int id -> id
+      | _ -> failwith "bad json"
+      )
+  | _ -> failwith "bad json"
+
+let filepos_of_json json = 
+  match json with
+  | J.Array [J.Int l; J.Int c] ->
+      { Common2.l = l; Common2.c = c }
+  | _ -> failwith "Bad json"
+
+let property_of_json json =
+  match json with
+  | J.Array [J.String "ContainDynamicCall"] -> ContainDynamicCall
+  | J.Array [J.String "ContainReflectionCall"] -> ContainReflectionCall
+  | J.Array [J.String "TakeArgNByRef"; J.Int i] -> TakeArgNByRef i
+  | _ -> failwith "property_of_json: bad json"
+
+
+let properties_of_json json =
+  match json with
+  | J.Array xs ->
+      xs +> List.map property_of_json
+  | _ -> failwith "Bad json"
+
+(* Reverse of json_of_entity_info; must follow same convention for the order
+ * of the fields.
+ *)
+let entity_of_json2 json =
+  match json with
+  | J.Object [
+    "k", J.String e_kind;
+    "n", J.String e_name;
+    "fn", J.String e_fullname;
+    "f", J.String e_file;
+    "p", e_pos;
+    (* different from type *)
+    "cnt", J.Int e_number_external_users;
+    "u", ids;
+    "ps", properties;
+    ] -> {
+      e_kind = entity_kind_of_string e_kind;
+      e_name = e_name;
+      e_file = e_file;
+      e_fullname = e_fullname;
+      e_pos = filepos_of_json e_pos;
+      e_number_external_users = e_number_external_users;
+      e_good_examples_of_use = ids_of_json ids;
+      e_properties = properties_of_json properties;
+    }
+  | _ -> failwith "Bad json"
+
+let entity_of_json a = 
+  Common.profile_code "Db.entity_of_json" (fun () ->
+    entity_of_json2 a)
+
+
+let database_of_json2 json =
+  match json with
+  | J.Object [
+    "root", J.String db_root;
+    "dirs", J.Array db_dirs;
+    "files", J.Array db_files;
+    "entities", J.Array db_entities;
+    ] -> {
+      root = db_root;
+      
+      dirs = db_dirs +> List.map (fun json ->
+        match json with
+        | J.Array([J.String x; J.Int i]) ->
+            x, i
+        | _ -> failwith "Bad json"
+      );
+
+      files = db_files +> List.map (fun json ->
+        match json with
+        | J.Array([J.String x; J.Int i]) ->
+            x, i
+        | _ -> failwith "Bad json"
+      );
+      entities = 
+        db_entities +> List.map entity_of_json +> Array.of_list
+    }
+      
+  | _ -> failwith "Bad json"
+
+let database_of_json json =
+  Common.profile_code "Db.database_of_json" (fun () -> 
+    database_of_json2 json
+  )
+
+(*****************************************************************************)
+(* Load/Save *)
+(*****************************************************************************)
+
+let load_database2 file =
+  pr2 (spf "loading database: %s" file);
+  if File_type.is_json_filename file
+  then
+    (* This code is mostly obsolete. It's more efficient to use Marshall
+     * to store big database. This should be used only when
+     * one wants to have a readable database.
+     *)
+    let json = 
+      Common.profile_code "Json_in.load_json" (fun () ->
+        Json_in.load_json file
+      ) in
+    database_of_json json
+  else Common2.get_value file
+
+let load_database file =
+  Common.profile_code "Db.load_db" (fun () -> load_database2 file)
+
+(* We allow to save in JSON format because it may be useful to let
+ * the user edit read the generated data.
+ * 
+ * less: could use the more efficient json pretty printer, but really
+ * marshall is probably better. Only biniou could be a valid alternative.
+ *)
+let save_database database file =
+  if File_type.is_json_filename file
+  then
+    database +> json_of_database 
+    +> Json_io.string_of_json ~compact:false ~recursive:false ~allow_nan:true
+    +> Common.write_file ~file
+  else Common2.write_value database file
+
+
+(*****************************************************************************)
+(* Entities categories *)
+(*****************************************************************************)
+
+(* coupling: if you add a new kind of entity, then 
+ * don't forget to modify size_font_multiplier_of_categ in code_map/
+ * 
+ * How sure this list is exhaustive ? C-c for usedef2
+ *)
+let entity_kind_of_highlight_category_def categ = 
+  match categ with
+  | HC.Entity (kind, HC.Def2 _) -> Some kind
+
+  | HC.FunctionDecl _ -> Some Prototype
+  | HC.StaticMethod (HC.Def2 _) -> Some Method
+  | HC.StructName (HC.Def) -> Some Type
+
+  (* todo: what about other Def ? like Label, Parameter, etc ? *)
+  | _ -> None
+
+let is_entity_def_category categ = 
+  entity_kind_of_highlight_category_def categ <> None
+
+(* less: merge with other function? *)
+let entity_kind_of_highlight_category_use categ = 
+  match categ with
+  | HC.Entity (kind, HC.Use2 _) -> Some kind
+  | HC.FunctionDecl _ -> Some Function
+  | HC.StaticMethod (HC.Use2 _) -> Some Method
+  | HC.StructName HC.Use -> Some Class
+  | _ -> None
+
+
+let matching_def_short_kind_kind short_kind kind =
+  (match short_kind, kind with
+  (* Struct/Union are generated as Type for now in graph_code_clang.ml *)
+  | Class, Type -> true
+  | Global, GlobalExtern -> true
+  | Function, Prototype -> true
+  | a, b -> a =*= b
+  )
+
+(* See the code of the different highlight_code_xxx.ml to
+ * know the different possible pairs.
+ * todo: merge with other functions too?
+ *)
+let matching_use_categ_kind categ kind =
+  match kind, categ with
+  | kind1, HC.Entity (kind2, _) when kind1 =*= kind2 -> true
+
+  | Prototype,    HC.Entity (Function, _)
+  | Constructor, HC.ConstructorMatch _
+  | GlobalExtern,      HC.Entity (Global, _)
+  | Method,    HC.StaticMethod _
+  | ClassConstant,  HC.Entity (Constant, _)
+    
+  (* tofix at some point, wrong tokenizer *)
+  | Constant, HC.Local _
+  | Global,   HC.Local _
+  | Function, HC.Local _
+  | Constructor, HC.Entity (Global, _)
+  | Function, HC.Builtin
+  | Function, HC.BuiltinCommentColor
+  | Function, HC.BuiltinBoolean
+  (* because what looks like a constant is actually a partially applied func *)
+  | Function, HC.Entity (Constant, _)
+
+  (* function pointers in structure initialized (poor's man oo in C) *)
+  | Function, HC.Entity (Global, _)
+  (* function calls to pointer function via direct syntax *)
+  | GlobalExtern, HC.Entity (Function, _)
+    
+  | Global,   HC.UseOfRef
+  | Field, HC.UseOfRef
+    -> true
+    
+  | _ -> false
+
+
+
+(* In database_light_xxx we sometimes need, given a 'use', to increment
+ * the e_number_external_users counter of an entity. Nevertheless
+ * multiple entities may have the same name in which case looking
+ * for an entity in the environment will return multiple
+ * entities of different kinds. Here we filter back the
+ * non valid entities.
+ *)
+let entity_and_highlight_category_correpondance entity categ =
+  let entity_kind_use = 
+    Common2.some (entity_kind_of_highlight_category_use categ) in
+  entity.e_kind = entity_kind_use
+
+(*****************************************************************************)
+(* Misc *)
+(*****************************************************************************)
+
+(* When we compute the light database for a language we usually start
+ * by calling a function to get the set of files in this language
+ * (e.g. Lib_parsing_ml.find_all_ml_files) and then "infer"
+ * the set of directories used by those files by just calling dirname
+ * on them. Nevertheless in the search box of the visualizer we
+ * want to propose for instance flib/herald even if there is no
+ * php file in flib/herald but files in flib/herald/lib/foo.php.
+ * Having flib/herald/lib is not enough. Enter alldirs_and_parent_dirs_of_dirs
+ * which will compute all the directories.
+ * 
+ * It's a kind of 'find -type d' but reversed, using a set of complete dirs
+ * as the starting point. In fact we could define a 
+ * Common.dirs_of_dirs but then directory without any interesting files
+ * would be listed.
+ *)
+let alldirs_and_parent_dirs_of_relative_dirs dirs =
+  dirs 
+  +> List.map Common2.inits_of_relative_dir 
+  +> List.flatten +> Common2.uniq_eff
+
+
+let merge_databases db1 db2 =
+  (* assert same root ?then can just add the fields *)
+  if db1.root <> db2.root
+  then begin
+    pr2 (spf "merge_database: the root differs, %s != %s"
+            db1.root db2.root);
+    if not (Common2.y_or_no "Continue ?")
+    then failwith "ok we stop";
+  end;
+
+  (* entities now contain references to other entities through
+   * the index to the entities array. So concatenating 2 array
+   * entities requires care.
+   *)
+  let length_entities1 = Array.length db1.entities in
+  
+  let db2_entities = db2.entities in
+  let db2_entities_adjusted = 
+    db2_entities +> Array.map (fun e ->
+      { e with
+        e_good_examples_of_use = 
+          e.e_good_examples_of_use 
+          +> List.map (fun id -> id + length_entities1);
+      }
+    )
+  in
+
+  {
+    root = db1.root;
+    dirs = (db1.dirs @ db2.dirs) 
+      +> Common.group_assoc_bykey_eff
+      +> List.map (fun (file, xs) ->
+        file, Common2.sum xs
+      );
+    files = db1.files @ db2.files; (* should ensure exclusive ? *)
+    entities = Array.append db1.entities db2_entities_adjusted;
+  }
+
+
+let build_top_k_sorted_entities_per_file2 ~k xs =
+  xs 
+  +> Array.to_list
+  +> List.map (fun e -> e.e_file, e)
+  +> Common.group_assoc_bykey_eff
+  +> List.map (fun (file, xs) ->
+    file, (xs +> List.sort (fun e1 e2 ->
+      (* high first *)
+      compare e2.e_number_external_users e1.e_number_external_users
+    ) +> Common.take_safe k
+    )
+  ) +> Common.hash_of_list
+
+let build_top_k_sorted_entities_per_file ~k xs =
+  Common.profile_code "Db.build_sorted_entities" (fun () ->
+    build_top_k_sorted_entities_per_file2 ~k xs
+  )
+
+
+let mk_dir_entity dir n = { 
+  e_name = Common2.basename dir ^ "/";
+  e_fullname = "";
+  e_file = dir;
+  e_pos = { Common2.l = 1; c = 0 };
+  e_kind = Dir;
+  e_number_external_users = n;
+  e_good_examples_of_use = [];
+  e_properties = [];
+}
+let mk_file_entity file n = { 
+  e_name = Common2.basename file;
+  e_fullname = "";
+  e_file = file;
+  e_pos = { Common2.l = 1; c = 0 };
+  e_kind = File;
+  e_number_external_users = n;
+  e_good_examples_of_use = [];
+  e_properties = [];
+}
+
+let mk_multi_dirs_entity name dirs_entities =
+  let dirs_fullnames = dirs_entities +> List.map (fun e -> e.e_file) in
+
+  {
+  e_name = name ^ "//";
+  (* hack *)
+  e_fullname = "";
+
+  (* hack *)
+  e_file = Common.join "|" dirs_fullnames;
+
+  e_pos = { Common2.l = 1; c = 0 };
+  e_kind = MultiDirs;
+  e_number_external_users = 
+    (* todo? *)
+    (List.length dirs_fullnames);
+  e_good_examples_of_use = [];
+  e_properties = [];
+  }
+
+let multi_dirs_entities_of_dirs es =
+  let h = Hashtbl.create 101 in
+  es +> List.iter (fun e ->
+    Hashtbl.add h e.e_name e
+  );
+  let keys = Common2.hkeys h in
+  keys +> Common.map_filter (fun k ->
+    let vs = Hashtbl.find_all h k in
+    if List.length vs > 1
+    then Some (mk_multi_dirs_entity k vs)
+    else None
+  )
+
+let files_and_dirs_database_from_files ~root files =
+
+  (* quite similar to what we first do in a database_light_xxx.ml *)
+  let dirs = files +> List.map Filename.dirname +> Common2.uniq_eff in
+  let dirs = dirs +> List.map (fun s -> Common.readable ~root s) in
+  let dirs = alldirs_and_parent_dirs_of_relative_dirs dirs in
+
+  { root = root;
+    dirs =  dirs  +> List.map (fun d -> d, 0); (* TODO *)
+    files = files +> List.map (fun f -> Common.readable ~root f, 0); (* TODO *)
+    entities = [| |];
+  }
+
+
+let files_and_dirs_and_sorted_entities_for_completion2
+ ~threshold_too_many_entities
+ db 
+ =
+  let nb_entities = Array.length db.entities in
+
+  let dirs = 
+    db.dirs +> List.map (fun (dir, n) -> mk_dir_entity dir n)
+  in
+  let files = 
+    db.files +> List.map (fun (file, n) -> mk_file_entity file n)
+  in
+  let multidirs = multi_dirs_entities_of_dirs dirs in
+
+  let xs =
+   multidirs @ dirs @ files @
+   (if nb_entities > threshold_too_many_entities
+    then begin 
+      pr2 "Too many entities. Completion just for filenames";
+      []
+    end else 
+       (db.entities +> Array.to_list +> List.map (fun e -> 
+         (* we used to return 2 entities per entity by having
+          * both an entity with the short name and one with the long
+          * name, but now that we do a suffix search, no need
+          * to keep the short one
+          *)
+         if e.e_fullname = "" 
+         then e
+         else { e with e_name = e.e_fullname }
+       )
+       )
+   )
+  in
+
+  (* note: return first the dirs and files so that when offer
+   * completion the dirs and files will be proposed first
+   * (could also enforce this rule when building the gtk completion model).
+   *)
+  xs +> List.map (fun e ->
+    (match e.e_kind with
+    | MultiDirs -> 100
+    | Dir -> 40
+    | File -> 20
+    | _ -> e.e_number_external_users
+    ), e
+  ) +> Common.sort_by_key_highfirst
+  +> List.map snd
+
+  
+let files_and_dirs_and_sorted_entities_for_completion
+    ~threshold_too_many_entities a =
+ Common.profile_code "Db.sorted_entities" (fun () ->
+   files_and_dirs_and_sorted_entities_for_completion2
+    ~threshold_too_many_entities a)
+
+
+
+(* The e_number_external_users count is not always very accurate for methods
+ * when we do very trivial class/methods analysis for some languages.
+ * This helper function can compensate back this approximation.
+ *)
+let adjust_method_or_field_external_users ~verbose entities =
+  (* phase1: collect all method counts *)
+  let h_method_def_count = Common2.hash_with_default (fun () -> 0) in
+  
+  entities +> Array.iter (fun e ->
+    match e.e_kind with
+    | Method | Field ->
+        let k = e.e_name in
+        h_method_def_count#update k (Common2.add1)
+    | _ -> ()
+  );
+
+  (* phase2: adjust *)
+  entities +> Array.iter (fun e ->
+    match e.e_kind with
+    | Method | Field ->
+        let k = e.e_name in
+        let nb_defs = h_method_def_count#assoc k in
+        if nb_defs > 1 && verbose
+        then pr2 ("Adjusting: " ^ e.e_fullname);
+
+        let orig_number = e.e_number_external_users in
+        e.e_number_external_users <- orig_number / nb_defs;
+    | _ -> ()
+  );
+  ()

h_program-lang/database_code.mli

@@ -0,0 +1,81 @@
+open Entity_code
+
+type entity_id = int
+
+type entity = {
+  e_kind: entity_kind;
+  (* needs to be a shortname, e.g. "map", not "List.map", otherwise the
+   * highlighter (which uses only a lexer/parser) will not enlarge the
+   * corresponding token in the file.
+   *)
+  e_name: string;
+  e_fullname: string; (* can be empty *)
+  e_file: Common.filename;
+  e_pos: Common2.filepos;
+  mutable e_number_external_users: int;
+  mutable e_good_examples_of_use: entity_id list;
+  e_properties: property list;
+}
+
+(* for debugging *)
+(* val json_of_entity: entity -> Json_type.t *)
+
+
+(* The dirs and filenames in this database are in readable format
+ * so one can use the database generated by another user on
+ * its own repository (this also saves some space in the generated
+ * JSON file). Only root is in absolute path format.
+ *)
+type database = {
+  root: Common.dirname;
+
+  (* the int are for the total number of times this file or dir is
+   * externally referenced.
+   *)
+  dirs: (Common.filename * int) list;
+  files: (Common.filename * int) list;
+
+  entities: entity array;
+}
+
+(* builders *)
+val empty_database: unit -> database
+val default_db_name: string
+(* save either in a (readable) json format or (fast) marshalled form 
+ * depending on the extension of the filename 
+*)
+val load_database: Common.filename -> database
+val save_database: database -> Common.filename -> unit
+(* when we want to analyze multi-languages projets *)
+val merge_databases: database -> database -> database
+
+(* build database helpers *)
+val alldirs_and_parent_dirs_of_relative_dirs: 
+  Common.dirname list -> Common.dirname list
+val files_and_dirs_database_from_files:
+  root:Common.dirname -> Common.filename list -> database
+val adjust_method_or_field_external_users:
+  verbose:bool -> entity array -> unit
+
+(* for displaying a summary of the important functions in a file *)
+val build_top_k_sorted_entities_per_file:
+  k:int -> entity array -> (Common.filename, entity list) Hashtbl.t
+
+(* for big grep *)
+val files_and_dirs_and_sorted_entities_for_completion:
+  threshold_too_many_entities:int -> database -> entity list
+
+(* codemap collaboration, highlighter (lexer/parser) <-> semantic database *)
+val entity_kind_of_highlight_category_def: 
+  Highlight_code.category -> entity_kind option
+val entity_kind_of_highlight_category_use: 
+  Highlight_code.category -> entity_kind option
+val is_entity_def_category: 
+  Highlight_code.category -> bool
+val matching_def_short_kind_kind:
+  entity_kind -> entity_kind -> bool
+val matching_use_categ_kind:
+  Highlight_code.category -> entity_kind -> bool
+(* use vs def *)
+val entity_and_highlight_category_correpondance:
+  entity -> Highlight_code.category -> bool