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

Add poc files

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

262
Makefile Normal file
View file

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

170
Makefile.common Normal file
View file

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

24
Makefile.config Normal file
View file

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

26
commons/.depend Normal file
View file

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

4
commons/META Normal file
View file

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

57
commons/Makefile Normal file
View file

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

118
commons/Makefile.common Normal file
View file

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

6
commons/authors.txt Normal file
View file

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

1324
commons/common.ml Normal file
View file

File diff suppressed because it is too large Load diff

245
commons/common.mli Normal file
View file

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

6186
commons/common2.ml Normal file
View file

File diff suppressed because it is too large Load diff

2049
commons/common2.mli Normal file
View file

File diff suppressed because it is too large Load diff

17
commons/copyright.txt Normal file
View file

@ -0,0 +1,17 @@
Copyright (C) 1998-2018 Yoann Padioleau
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public License (LGPL)
version 2.1 as published by the Free Software Foundation, with the
special exception on linking described in file license.txt.
This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file
license.txt for more details.
The contents of some files in this directory was derived from external
sources with compatible licenses. The original copyright and license
notice was preserved in the affected files.

12
commons/credits.txt Normal file
View file

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

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

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

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

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

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

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

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

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

85
commons/dumper.ml Normal file
View file

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

6
commons/dumper.mli Normal file
View file

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

0
commons/features.ml Normal file
View file

323
commons/file_type.ml Normal file
View file

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

58
commons/file_type.mli Normal file
View file

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

520
commons/license.txt Normal file
View file

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

152
commons/map_.ml Normal file
View file

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

123
commons/map_.mli Normal file
View file

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

462
commons/oUnit.ml Normal file
View file

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

202
commons/oUnit.mli Normal file
View file

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

498
commons/ocaml.ml Normal file
View file

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

130
commons/ocaml.mli Normal file
View file

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

29
commons/readme.txt Normal file
View file

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

302
commons/set_.ml Normal file
View file

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

161
commons/set_.mli Normal file
View file

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

8
commons_core/.depend Normal file
View file

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

219
commons_core/ANSITerminal.ml Normal file
View file

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

107
commons_core/ANSITerminal.mli Normal file
View file

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

4
commons_core/META Normal file
View file

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

19
commons_core/Makefile Normal file
View file

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

93
commons_core/console.ml Normal file
View file

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

14
commons_core/console.mli Normal file
View file

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

81
commons_core/features.ml.in Normal file
View file

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

894
commons_core/macro.ml4 Normal file
View file

@ -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";;
*)
(******************************************************************************)

5
external/Makefile vendored Normal file
View file

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

16
external/dependencies.txt vendored Normal file
View file

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

17
external/jsonwheel/.depend vendored Normal file
View file

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

4
external/jsonwheel/META vendored Normal file
View file

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

118
external/jsonwheel/Makefile vendored Normal file
View file

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

26
external/jsonwheel/copyright.txt vendored Normal file
View file

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

51
external/jsonwheel/json_in.ml vendored Normal file
View file

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

421
external/jsonwheel/json_io.ml vendored Normal file
View file

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

111
external/jsonwheel/json_io.mli vendored Normal file
View file

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

542
external/jsonwheel/json_lexer.ml vendored Normal file
View file

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

163
external/jsonwheel/json_out.ml vendored Normal file
View file

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

429
external/jsonwheel/json_parser.ml vendored Normal file
View file

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

16
external/jsonwheel/json_parser.mli vendored Normal file
View file

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

153
external/jsonwheel/json_type.ml vendored Normal file
View file

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

224
external/jsonwheel/json_type.mli vendored Normal file
View file

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

22
external/jsonwheel/license.txt vendored Normal file
View file

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

8
external/jsonwheel/modif-orig.txt vendored Normal file
View file

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

8
external/jsonwheel/netconversion2.ml vendored Normal file
View file

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

70
external/jsonwheel/readme.txt vendored Normal file
View file

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

140
find_source.ml Normal file
View file

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

13
find_source.mli Normal file
View file

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

2
globals/.depend Normal file
View file

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

4
globals/META Normal file
View file

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

49
globals/Makefile Normal file
View file

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

11
globals/config_pfff.ml Normal file
View file

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

11
globals/config_pfff.ml.in Normal file
View file

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

13
h_files-format/.depend Normal file
View file

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

4
h_files-format/META Normal file
View file

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

42
h_files-format/Makefile Normal file
View file

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

2
h_files-format/authors.txt Normal file
View file

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

17
h_files-format/copyright.txt Normal file
View file

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

0
h_files-format/credits.txt Normal file
View file

520
h_files-format/license.txt Normal file
View file

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

116
h_files-format/outline.ml Normal file
View file

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

20
h_files-format/outline.mli Normal file
View file

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

48
h_files-format/simple_format.ml Normal file
View file

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

8
h_files-format/simple_format.mli Normal file
View file

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

125
h_files-format/source_tree.ml Normal file
View file

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

16
h_files-format/source_tree.mli Normal file
View file

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

132
h_program-lang/.depend Normal file
View file

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

4
h_program-lang/META Normal file
View file

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

71
h_program-lang/Makefile Normal file
View file

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

212
h_program-lang/archi_code.ml Normal file
View file

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

31
h_program-lang/archi_code.mli Normal file
View file

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

517
h_program-lang/archi_code_lexer.mll Normal file
View file

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

153
h_program-lang/archi_code_parse.ml Normal file
View file

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

4
h_program-lang/archi_code_parse.mli Normal file
View file

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

288
h_program-lang/ast_fuzzy.ml Normal file
View file

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

42
h_program-lang/ast_fuzzy.mli Normal file
View file

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

194
h_program-lang/big_grep.ml Normal file
View file

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

27
h_program-lang/big_grep.mli Normal file
View file

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

95
h_program-lang/comment_code.ml Normal file
View file

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

11
h_program-lang/comment_code.mli Normal file
View file

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

13
h_program-lang/copyright.txt Normal file
View file

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

156
h_program-lang/coverage_code.ml Normal file
View file

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

25
h_program-lang/coverage_code.mli Normal file
View file

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

698
h_program-lang/database_code.ml Normal file
View file

@ -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;
| _ -> ()
);
()

81
h_program-lang/database_code.mli Normal file
View file

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

Some files were not shown because too many files have changed in this diff Show more