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

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

171
h_program-lang/datalog_code.dl Normal file
View file

@ -0,0 +1,171 @@
% -*- prolog -*-
%*******************************************************************************
% Prelude
%*******************************************************************************
% This file implements a basic context-insensitive pointer analysis.
% Its outputs are the following relations:
%
% point_to(V, M) - variable 'V' may point to abstract memory loc 'M'
% call_edge(INVOKE, TARGET) - invocation site 'INVOKE' calls function 'TARGET'
% Based upon: Java context-insensitive inclusion-based pointer analysis
% by John Whaley
% Related work:
% - Andersen, Steengaard, Manuvir Das, Lin, etc
% - bddbddb, DOOP, http://pag-www.gtisc.gatech.edu/chord/user_guide/datalog.html
% - http://blog.jetbrains.com/idea/2009/08/analyzing-dataflow-with-intellij-idea
% - Frama C, CodeSonar, Coverity, ...
%
% note: I always wanted (but was never able to write ...) an interprocedural
% (dataflow) analysis. With Datalog I did it in one day! It's so easy.
%
% history:
% - I used to have an array_point_to/2 but it can not work, we have to
% unify array and pointers and so point_to and array_point_to
%*******************************************************************************
% Relations
%*******************************************************************************
% Abstract memory locations (also called heap objects), are mostly qualified
% symbols (e.g 'main__foo', 'ret_main', '_cst_line2_'):
% - each globals, functions, constants
% - each malloc (context insensitively). will do sensitively later for
% malloc wrappers or maybe each malloc with certain type. (e.g. any Proc)
% so have some form of type sensitivty at least
% - each locals (context insensitively first), when their addresses are taken
% - each fields (field-based, see sep08.pdf lecture, so *.f, not x.*)
% - array element (array insensitive, aggregation)
% Invocations: line in the file (e.g. '_in_main_line_14_')
%assign(dest:V, source:V) input
%assign_address (dest:V, source:V) input
%assign_deref(dest:V, source:V) input
%assign_content(dest:V, source:V) input
%parameter(f:F, z:Z, v:V)
%return(f:F, v:V)
%argument(i:I, z:Z, v:V)
%call_direct(i:I, f:F)
%call_indirect(i:I, v:V)
%call_ret(i:I, v:V)
%assign_array_elt(dest:V, source:V) input
%assign_array_element_address(dest:V, source:V) input
%assign_load_field
%assign_field_address
%assign_store_field
%field_point_to?? hmm maybe once we differentiate objects heap
% and not do just *.f
%*******************************************************************************
% Rules
%*******************************************************************************
%-------------------------------------------------------------------------------
% Basic
%-------------------------------------------------------------------------------
% p = &q
point_to(P, Q) :-
assign_address(P, Q).
% p = q
point_to(P, L) :-
assign(P, Q),
point_to(Q, L).
% *p = q, given: q -> l, and p -> w => w now points to l
point_to(W, L) :-
assign_deref(P, Q),
point_to(Q, L),
point_to(P, W).
% p = *q
point_to(P, L) :-
assign_content(P, Q),
point_to(Q, X),
point_to(X, L).
% see here that X is used both as first and second argument of point_to
% because the domain of the variable is included in the domain of abstract
% memory locations.
%-------------------------------------------------------------------------------
% Arrays insensitive
%-------------------------------------------------------------------------------
% p = a[...], which is really just equivalent to p = *a for array insensitivty
point_to(P, Q) :-
assign_array_elt(P, A),
point_to(A, AELT),
point_to(AELT, Q).
% a[...] = q, again similar to *a = q
point_to(AELT, L) :-
assign_array_deref(A, Q),
point_to(Q, L),
point_to(A, AELT).
% p = &a[...], equivalent to p = a for array insensitivty
point_to(P, AELT) :-
assign_array_element_address(P, A),
point_to(A, AELT).
%-------------------------------------------------------------------------------
% Field-base sensitive (*.f, not x.* nor x.f)
%-------------------------------------------------------------------------------
% p = x->fld
point_to(P, L) :-
assign_load_field(P, X, F),
point_to(F, L).
% p->fld = x
point_to(F, L) :-
assign_store_field(P, F, X),
point_to(X, L).
% p = &x->fld
point_to(P, F) :-
assign_field_address(P, X, F).
%point_to(F, L) :-
% field_point_to(F, L).
%-------------------------------------------------------------------------------
% Calls context-insensitive
%-------------------------------------------------------------------------------
% ret = foo(v1, v2, ...)
assign(PARAM, ARG) :-
parameter(F, IDX, PARAM),
call_edge(I, F),
argument(I, IDX, ARG).
assign(RET, V) :-
return(F, V),
call_edge(I, F),
call_ret(I, RET).
call_edge(I, F) :-
call_direct(I, F).
% power of mutually recursive analysis! dataflow -> controlflow -> dataflow
call_edge(I, F) :-
call_indirect(I, V),
point_to(V, F).
%note: heartbleed detection strongly relies on accurate calls though
% function pointers tracking
%*******************************************************************************
% Postlude
%*******************************************************************************
point_to(A,B)?
%call_edge(A,B)?

218
h_program-lang/datalog_code.dtl Normal file
View file

@ -0,0 +1,218 @@
# -*- sh -*- # the datalog dialect used by bddbddb is not prolog-mode compliant :(
#*******************************************************************************
# Prelude
#*******************************************************************************
# This file implements a basic interprocedural context-insensitive
# inclusion-based pointer analysis for C. Its outputs are the following
# relations:
#
# point_to(V, M) - variable 'V' may point to abstract memory loc 'M'
# field_point_to(FIELD, M) - qualified field may point to loc 'M'
# call_edge(INVOKE, TARGET) - invocation site 'INVOKE' calls function 'TARGET'
# Based upon: Java context-insensitive inclusion-based pointer analysis
# by John Whaley
# Related work:
# - Andersen, Steengaard, Manuvir Das, Lin, etc
# - bddbddb, DOOP, http://pag-www.gtisc.gatech.edu/chord/user_guide/datalog.html
# - http://blog.jetbrains.com/idea/2009/08/analyzing-dataflow-with-intellij-idea
# - Frama C, CodeSonar, Coverity, ...
#
# note: I always wanted (but was never able to write ...) an interprocedural
# (dataflow) analysis. With Datalog I did it in one day! It's so easy.
#
# TODO: abuse cpp to express context-sensitivity in a generic way
# (like they do in DOOP with logiblox)
.basedir "data"
#*******************************************************************************
# Domains
#*******************************************************************************
# actually for variables, heap alloc, func, globals, address of locals
V 262144 V.map
F 16384 F.map
N 16384 N.map
I 32768 I.map
Z 256
#todo? .bddvarorder N0_F0_I0_M1_M0_V1_V0_T0_Z0_T1_H0_H1
#*******************************************************************************
# Relations
#*******************************************************************************
# Abstract memory locations (also called heap objects), are mostly qualified
# symbols (e.g 'main__foo', 'ret_main', '_cst_line2_'):
# - each globals, functions, constants
# - each malloc (context insensitively). will do sensitively later for
# malloc wrappers or maybe each malloc with certain type. (e.g. any Proc)
# so have some form of type sensitivty at least
# - each locals (context insensitively first), when their addresses are taken
# - each fields (field-based, see sep08.pdf lecture, so *.f, not x.*)
# - array element (array insensitive, aggregation)
# Invocations: line in the file (e.g. '_in_main_line_14_')
assign0(dest:V, source:V) inputtuples
assign_address (dest:V, source:V) inputtuples
assign_deref(dest:V, source:V) inputtuples
assign_content(dest:V, source:V) inputtuples
parameter(f:N, z:Z, v:V) inputtuples
return(f:N, v:V) inputtuples
argument(i:I, z:Z, v:V) inputtuples
call_direct(i:I, f:N) inputtuples
call_indirect(i:I, v:V) inputtuples
call_ret(i:I, v:V) inputtuples
# typing!
var_to_func(v:V, f:N) inputtuples
assign_array_elt(dest:V, source:V) inputtuples
assign_array_element_address(dest:V, source:V) inputtuples
assign_array_deref(a:V, v:V) inputtuples
assign_load_field(dest:V, source:V, fld:F) inputtuples
assign_store_field(dest:V, fld:F, source:V) inputtuples
assign_field_address(dest:V, source:V, fld:F) inputtuples
# typing!
field_to_var(fld:F, v:V) inputtuples
#field_point_to?? hmm maybe once we differentiate objects heap
# and not do just *.f
point_to0(v:V, h:V) inputtuples
point_to(v:V, h:V) outputtuples
call_edge(i:I, f:N) outputtuples
assign(dest:V, source:V)
# the data we really care to export
PointingData (v:V, h:V) outputtuples
CallingData (i:I, f:N) outputtuples
#*******************************************************************************
# Rules
#*******************************************************************************
#-------------------------------------------------------------------------------
# Basic
#-------------------------------------------------------------------------------
point_to(p, q) :- point_to0(p, q).
# p = &q
point_to(p, q) :- \
assign_address(p, q).
# p = q
# (covers regular assignments but also arguments to parameters and return
# to caller, see the assign/2 definition down in this file)
point_to(p, l) :- \
assign(p, q),\
point_to(q, l).
# *p = q, given: q -> l, and p -> w, we can now infer w -> l
point_to(w, l) :- \
assign_deref(p, q),\
point_to(q, l),\
point_to(p, w).
# p = *q
point_to(p, l) :- \
assign_content(p, q),\
point_to(q, x),\
point_to(x, l).
# see here that X is used both as first and second argument of point_to
# because the domain of the variable is included in the domain of abstract
# memory locations.
#-------------------------------------------------------------------------------
# Arrays insensitive
#-------------------------------------------------------------------------------
# p = a[...], which is really just equivalent to p = *a for array insensitivty
point_to(p, q) :- \
assign_array_elt(p, a),\
point_to(a, aelt),\
point_to(aelt, q).
# a[...] = q, again similar to *a = q
point_to(aelt, l) :- \
assign_array_deref(a, q),\
point_to(q, l),\
point_to(a, aelt).
# p = &a[...], equivalent to p = a for array insensitivty
point_to(p, aelt) :- \
assign_array_element_address(p, a),\
point_to(a, aelt).
#-------------------------------------------------------------------------------
# Field-based sensitivity (*.f, not x.* nor x.f)
#-------------------------------------------------------------------------------
# p = x->fld
point_to(p, l) :- \
assign_load_field(p, x, f),\
field_to_var(f, v),\
point_to(v, l).
# p->fld = x
point_to(v, l) :- \
assign_store_field(p, f, x),\
field_to_var(f, v), \
point_to(x, l).
# p = &x->fld
point_to(p, v) :- \
assign_field_address(p, x, f),\
field_to_var(f, v).
#point_to(F, L) :-
# field_point_to(F, L).
#-------------------------------------------------------------------------------
# Calls context-insensitive
#-------------------------------------------------------------------------------
assign(a, b) :- assign0(a,b).
# ret = foo(v1, v2, ...)
# (covers regular function calls but also dynamic calls, see call_edge/2 below)
assign(param, arg) :- \
parameter(f, idx, param),\
call_edge(i, f),\
argument(i, idx, arg).
assign(ret, v) :- \
return(f, v),\
call_edge(i, f),\
call_ret(i, ret).
call_edge(i, f) :- \
call_direct(i, f).
# power of mutually recursive analysis! dataflow -> controlflow -> dataflow
call_edge(i, f) :- \
call_indirect(i, v),\
point_to(v, vf),\
var_to_func(vf, f).
#note: heartbleed detection strongly relies on accurate tracking of calls
# through function pointers, so this is important!
#*******************************************************************************
# Postlude
#*******************************************************************************
# the data we care to export
PointingData (v,h) :- point_to(v,h).
CallingData (i,f) :- call_indirect(i, v), point_to(v, vf), var_to_func(vf, f).

357
h_program-lang/datalog_code.ml Normal file
View file

@ -0,0 +1,357 @@
(* 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
(*****************************************************************************)
(* Prelude *)
(*****************************************************************************)
(*
* See also prolog_code.ml!
*
* datalog engines:
* - toy datalog using lua
* - bddbddb, a scalabe engine!
* - TODO: pydatalog, embedded DSL in python that can import data from
* SQL
* - ciao? xsb?
* - http://www.learndatalogtoday.org/ and datomic.com
*
* TODO: https://yanniss.github.io/points-to-tutorial15.pdf
*)
(*****************************************************************************)
(* Types *)
(*****************************************************************************)
(* for locals, but also right now for fields, globals, constants, enum, ... *)
type var = string
type func = string
type fld = string
(* _cst_xxx, _str_line_xxx, _malloc_in_xxx_line, ... *)
type heap = string
(* _in_xxx_line_xxx_col_xxx *)
type callsite = string
(* mimics datalog_code.dl top comment *)
type fact =
| PointTo of var * heap
| Assign of var * var
| AssignContent of var * var
| AssignAddress of var * var
| AssignDeref of var * var
| AssignLoadField of var * var * fld
| AssignStoreField of var * fld * var
| AssignFieldAddress of var * var * fld
| AssignArrayElt of var * var
| AssignArrayDeref of var * var
| AssignArrayElementAddress of var * var
| Parameter of func * int * var
| Return of func * var (* ret_xxx convention *)
| Argument of callsite * int * var
| ReturnValue of callsite * var
| CallDirect of callsite * func
| CallIndirect of callsite * var
(*****************************************************************************)
(* Meta *)
(*****************************************************************************)
(* see datalog_code.dl domain *)
type value =
| V of var
| F of fld
| N of func
| I of callsite
| Z of int
let string_of_value = function
| V x | F x | N x | I x -> x
| Z _ -> raise Impossible
type _rule = string
type _meta_fact =
string * value list
let meta_fact = function
| PointTo (a, b) -> "point_to", [ V a; V b; ]
| Assign (a, b) -> "assign", [ V a; V b; ]
| AssignContent (a, b) -> "assign_content", [ V a; V b; ]
| AssignAddress (a, b) -> "assign_address", [ V a; V b; ]
| AssignDeref (a, b) -> "assign_deref", [ V a; V b; ]
| AssignLoadField (a, b, c) -> "assign_load_field", [ V a; V b; F c ]
| AssignStoreField (a, b, c) -> "assign_store_field", [ V a; F b; V c ]
| AssignFieldAddress (a, b, c) -> "assign_field_address", [ V a; V b; F c ]
| AssignArrayElt (a, b) -> "assign_array_elt", [ V a; V b; ]
| AssignArrayDeref (a, b) -> "assign_array_deref", [ V a; V b; ]
| AssignArrayElementAddress (a, b) -> "assign_array_element_address", [ V a; V b; ]
| Parameter (a, b, c) -> "parameter", [ N a; Z b; V c ]
| Return (a, b) -> "return", [ N a; V b; ]
| Argument (a, b, c) -> "argument", [ I a; Z b; V c ]
| ReturnValue (a, b) -> "call_ret", [ I a; V b; ]
| CallDirect (a, b) -> "call_direct", [ I a; N b; ]
| CallIndirect (a, b) -> "call_indirect", [ I a; V b; ]
(*****************************************************************************)
(* Toy datalog *)
(*****************************************************************************)
let string_of_fact fact =
let str, xs = meta_fact fact in
spf "%s(%s)" str
(xs +> List.map (function
| V x | F x | N x | I x -> spf "'%s'" x
| Z i -> spf "%d" i
) +> Common.join ", "
)
(*****************************************************************************)
(* Bddbddb *)
(*****************************************************************************)
(* "V", "F", ... *)
type _domain = string
let domain_of_value = function
| V _ -> "V"
| F _ -> "F"
| N _ -> "N"
| I _ -> "I"
| Z _ -> "Z"
type _idx = (string (* metadomain*), value Common.hashset) Hashtbl.t
let bddbddb_of_facts facts dir =
let metas = facts +> List.map meta_fact in
let hvalues = Hashtbl.create 6 in
let hrules = Hashtbl.create 30 in
(* build sets *)
metas +> List.iter (fun (arule, xs) ->
let listref =
try Hashtbl.find hrules arule
with Not_found ->
let aref = ref [] in
Hashtbl.add hrules arule aref;
aref
in
listref := xs :: !listref;
xs +> List.iter (fun v ->
let add_v v =
let domain = domain_of_value v in
let hdomain =
try Hashtbl.find hvalues domain
with Not_found ->
let h = Hashtbl.create 10001 in
Hashtbl.add hvalues domain h;
h
in
Hashtbl.replace hdomain v true;
in
add_v v;
(* for field_to_var and var_to_func *)
(match v with
| F s -> add_v (V s)
| N s -> add_v (V s)
| _ -> ()
)
)
);
(* now build integer indexes *)
let domains_idx =
hvalues +> Common.hash_to_list +> List.map (fun (domain, hdomain) ->
let conv = hdomain +> Common.hashset_to_list +> Common.index_list_0 in
domain, (
conv, conv +> Common.hash_of_list
)
)
in
Common.command2 (spf "rm -f %s/*" dir);
(* generate .map *)
domains_idx +> List.iter (fun (domain, (map, _idx)) ->
if domain <> "Z"
then begin
let file = Filename.concat dir (domain ^ ".map") in
Common.with_open_outfile file (fun (pr_no_nl, _chan) ->
let pr s = pr_no_nl (s ^ "\n") in
map +> List.iter (fun (v, _int) ->
pr (string_of_value v)
)
)
end
);
(* generate .tuples *)
hrules +> Common.hash_to_list +> List.iter (fun (arule, xxs) ->
let arule =
match arule with
| "point_to" -> "point_to0"
| "assign" -> "assign0"
| s -> s
in
let file = Filename.concat dir (arule ^ ".tuples") in
Common.with_open_outfile file (fun (pr_no_nl, _chan) ->
let pr s = pr_no_nl (s ^ "\n") in
(* todo: header?? *)
(match !xxs with
| [] -> ()
| xs::_xxs ->
let hcnt = Hashtbl.create 6 in
pr (spf "# %s"
(xs +> List.map (fun v ->
let domain = domain_of_value v in
let cnt =
try Hashtbl.find hcnt domain
with Not_found ->
let cnt = ref 0 in
Hashtbl.add hcnt domain cnt;
cnt
in
let i = !cnt in
incr cnt;
(* less: size? *)
spf "%s%d:18" domain i
) +> Common.join " "))
);
!xxs +> List.iter (fun xs ->
let ints =
xs +> List.map (fun v ->
let i =
match v with
| Z i -> i
| _ ->
let domain = domain_of_value v in
let (_, hdomainconv) = List.assoc domain domains_idx in
Hashtbl.find hdomainconv v
in
i
)
in
pr (ints +> List.map i_to_s +> Common.join " ")
);
)
);
(* generate extra .tuples *)
let fvals = try List.assoc "F" domains_idx +> fst with Not_found -> [] in
let nvals = try List.assoc "N" domains_idx +> fst with Not_found -> [] in
let (_vvals, vconv) = List.assoc "V" domains_idx in
let arule = "field_to_var" in
let file = Filename.concat dir (arule ^ ".tuples") in
Common.with_open_outfile file (fun (pr_no_nl, _chan) ->
let pr s = pr_no_nl (s ^ "\n") in
pr "# F0:18 V0:18";
fvals +> List.iter (fun (fld, idx) ->
match fld with
| F s ->
let v = V s in
let idx2 = Hashtbl.find vconv v in
pr (spf "%d %d" idx idx2)
| _ ->
pr2_gen (fld, idx);
raise Impossible
)
);
let arule = "var_to_func" in
let file = Filename.concat dir (arule ^ ".tuples") in
Common.with_open_outfile file (fun (pr_no_nl, _chan) ->
let pr s = pr_no_nl (s ^ "\n") in
pr "# V0:18 N0:18";
nvals +> List.iter (fun (n, idx) ->
match n with
| N s ->
let v = V s in
let idx2 = Hashtbl.find vconv v in
(* subtle, different order than for field_to_var, idx2 before *)
pr (spf "%d %d" idx2 idx)
| _ ->
pr2_gen (n, idx);
raise Impossible
)
);
()
let bddbddb_explain_tuples file =
let (d,b,_e) = Common2.dbe_of_filename file in
let dst = Common2.filename_of_dbe (d,b,"explain") in
Common.with_open_outfile dst (fun (pr_no_nl, _chan) ->
let pr s = pr_no_nl (s ^ "\n") in
let xs = Common.cat file in
(match xs with
| header::xs ->
if header =~ "# \\(.*\\)"
then
let s = Common.matched1 header in
let flds = Common.split "[ \t]" s in
let fld_domains =
flds +> List.map (fun s ->
if s =~ "\\([A-Z]\\)[0-9]?:"
then Common.matched1 s
else failwith (spf "could not find header in %s" file)
)
in
let fld_translates =
fld_domains +> List.map (fun s ->
let mapfile = Common2.filename_of_dbe (d,s,"map") in
Common.cat mapfile +> Array.of_list
)
in
xs +> List.iter (fun s ->
let vs = Common.split "[ \t]" s +> List.map s_to_i in
let args =
Common2.zip vs fld_translates +> List.map (fun (i, arr) ->
arr.(i)
)
in
pr (spf "%s(%s)" b (Common.join ", " args))
)
else failwith (spf "could not find header in %s" file)
| [] -> pr2 (spf "empty file %s" file)
)
);
dst

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

@ -0,0 +1,42 @@
type var = string
type func = string
type fld = string
type heap = string
type callsite = string
type fact =
| PointTo of var * heap
| Assign of var * var
| AssignContent of var * var
| AssignAddress of var * var
| AssignDeref of var * var
| AssignLoadField of var * var * fld
| AssignStoreField of var * fld * var
| AssignFieldAddress of var * var * fld
| AssignArrayElt of var * var
| AssignArrayDeref of var * var
| AssignArrayElementAddress of var * var
| Parameter of func * int * var
| Return of func * var (* ret_xxx convention *)
| Argument of callsite * int * var
| ReturnValue of callsite * var
| CallDirect of callsite * func
| CallIndirect of callsite * var
(* for toy datalog *)
val string_of_fact:
fact -> string
val bddbddb_of_facts:
fact list -> Common.dirname -> unit
(* from a .tuples to a .explain *)
val bddbddb_explain_tuples:
Common.filename -> Common.filename

165
h_program-lang/entity_code.ml Normal file
View file

@ -0,0 +1,165 @@
(* 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
(*****************************************************************************)
(* Prelude *)
(*****************************************************************************)
(*
* The code in this module used to be in database_code.ml but many stuff
* now have their own view on how to represent a code database
* (database_code.ml but also graph_code.ml, prolog_code.ml, etc)
*)
(*****************************************************************************)
(* Type *)
(*****************************************************************************)
(*
* Code entities.
*
* See also http://ctags.sourceforge.net/FORMAT and the doc on 'kind'
* note: if you change this, you may want to bump graph_code.version.
*
* coupling: If you add a constructor modify also entity_kind_of_string()!
* coupling: if you add a new kind of entity, then don't forget to modify
* also size_font_multiplier_of_categ in code_map/.
*
* less: could perhaps factorize code with highlight_code.ml? see
* entity_kind_of_highlight_category_def|use
*)
type entity_kind =
| Package
(* when we use the database for completion purpose, then files/dirs
* are also useful "entities" to get completion for.
*)
| Dir
| Module
| File
| Function
| Class
| Type
| Constant | Global
| Macro
| Exception
| TopStmts
(* nested entities *)
| Field
| Method
| ClassConstant
| Constructor (* for ml *)
(* forward decl *)
| Prototype | GlobalExtern
(* people often spread the same component in multiple dirs with the same
* name (hmm could be merged now with Package)
*)
| MultiDirs
| Other of string
(* todo: IsInlinedMethod, ...
* todo: IsOverriding, IsOverriden
*)
type property =
(* mostly function properties *)
(* todo: could also say which argument is dataflow involved in the
* dynamic call if any
*)
| ContainDynamicCall
| ContainReflectionCall
(* the argument position taken by ref; 0-index based *)
| TakeArgNByRef of int
| UseGlobal of string
| ContainDeadStatements
| DeadCode (* the function itself is dead, e.g. never called *)
| CodeCoverage of int list (* e.g. covered lines by unit tests *)
(* for class *)
| ClassKind of class_kind
| Privacy of privacy
| Abstract
| Final
| Static
(* used for the xhp @required fields for now *)
| Required
| Async
(* todo: git info, e.g. Age, Authors, Age_profile (range) *)
and privacy = Public | Protected | Private
and class_kind = Struct | Class_ | Interface | Trait | Enum
(*****************************************************************************)
(* String of *)
(*****************************************************************************)
(* todo: should be autogenerated !! *)
let string_of_entity_kind e =
match e with
| Function -> "Function"
| Prototype -> "Prototype"
| GlobalExtern -> "GlobalExtern"
| Class -> "Class"
| Module -> "Module"
| Package -> "Package"
| Type -> "Type"
| Constant -> "Constant"
| Global -> "Global"
| Macro -> "Macro"
| TopStmts -> "TopStmts"
| Method -> "Method"
| Field -> "Field"
| ClassConstant -> "ClassConstant"
| Other s -> "Other:" ^ s
| File -> "File"
| Dir -> "Dir"
| MultiDirs -> "MultiDirs"
| Exception -> "Exception"
| Constructor -> "Constructor"
let entity_kind_of_string s =
match s with
| "Function" -> Function
| "Class" -> Class
| "Module" -> Module
| "Type" -> Type
| "Constant" -> Constant
| "Global" -> Global
| "Macro" -> Macro
| "TopStmts" -> TopStmts
| "Method" -> Method
| "Field" -> Field
| "ClassConstant" -> ClassConstant
| "File" -> File
| "Dir" -> Dir
| "MultiDirs" -> MultiDirs
| "Exception" -> Exception
| "Constructor" -> Constructor
| _ when s =~ "Other:\\(.*\\)" -> Other (Common.matched1 s)
| _ -> failwith ("entity_of_string: bad string = " ^ s)

60
h_program-lang/entity_code.mli Normal file
View file

@ -0,0 +1,60 @@
type entity_kind =
(* very high level entities *)
| Package | Dir
| Module | File
(* toplevel entities *)
| Function
| Class (* used also for struct, interfaces, traits, see class_kind below *)
| Type
| Constant
| Global
| Macro
| Exception
| TopStmts
(* class member entities *)
| Field
| Method
| ClassConstant
(* ocaml variants (not oo ctor, see Method for that *)
| Constructor
(* misc *)
| Prototype | GlobalExtern
| MultiDirs (* computed on the fly from many Dir by codemap *)
| Other of string
val string_of_entity_kind: entity_kind -> string
val entity_kind_of_string: string -> entity_kind
type property =
(* mostly for Function|Method kind, for codemap to highlight! *)
| ContainDynamicCall | ContainReflectionCall
| TakeArgNByRef of int (* the argument position taken by ref *)
| UseGlobal of string
| ContainDeadStatements
| DeadCode (* the function itself is dead, e.g. never called *)
| CodeCoverage of int list (* e.g. covered lines by unit tests *)
(* for class *)
| ClassKind of class_kind
| Privacy of privacy
| Abstract | Final
| Static
(* facebook specific: used for the xhp @required fields for now *)
| Required | Async
and privacy = Public | Protected | Private
and class_kind =
| Struct | Class_ | Interface
| Trait
(* in Scala, Java, and now PHP enums are actually closer to class
* than C enums.
*)
| Enum

281
h_program-lang/errors_code.ml Normal file
View file

@ -0,0 +1,281 @@
(* 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 E = Entity_code
module PI = Parse_info
(*****************************************************************************)
(* Prelude *)
(*****************************************************************************)
(*
* Centralize errors report functions (they did the same in c--).
* Mostly a copy paste of error_php.ml
*
* history:
* - was in check_module.ml
* - was generalized for scheck php
* - introduced ranking via int (but mess)
* - introduced simplified ranking using intermediate rank type
* - fully generalize when introduced graph_code_checker.ml
* - added @Scheck annotation
* - added some false positive deadcode detection
*
* todo:
* - priority to errors, so dead code func more important than dead field
* - factorize code with errors_cpp.ml, errors_php.ml, error_php.ml
*)
(*****************************************************************************)
(* Globals *)
(*****************************************************************************)
(* see g_errors below *)
(*****************************************************************************)
(* Types *)
(*****************************************************************************)
type error = {
typ: error_kind;
loc: Parse_info.token_location;
sev: severity;
}
(* less: Advice | Noisy | Meticulous ? *)
and severity = Fatal | Warning
and error_kind =
(* entities *)
(* done while building the graph:
* - UndefinedEntity (UseOfUndefined)
* - MultiDefinedEntity (DupeEntity)
*)
(* As done by my PHP global analysis checker.
* Never done by compilers, and unusual for linters to do that.
*
* note: OCaml 4.01 now does that partially by locally checking if
* an entity is unused and not exported (which does not require
* global analysis)
*)
| Deadcode of entity
| UndefinedDefOfDecl of entity
(* really a special case of Deadcode decl *)
| UnusedExport of entity (* tge decl*) * Common.filename (* file of def *)
(* call sites *)
(* should be done by the compiler (ocaml does):
* - TooManyArguments, NotEnoughArguments
* - WrongKeywordArguments
* - ...
*)
(* variables *)
(* also done by some compilers (ocaml does):
* - UseOfUndefinedVariable
* - UnusedVariable
*)
| UnusedVariable of string * Scope_code.scope
(* classes *)
(* files (include/import) *)
(* bail-out constructs *)
(* a proper language should not have that *)
(* lint *)
(* other *)
(* todo: should be merged with Graph_code.entity or put in Database_code?*)
and entity = (string * Entity_code.entity_kind)
type rank =
(* Too many FPs for now. Not applied even in strict mode. *)
| Never
(* Usually a few FPs or too many of them. Only applied in strict mode. *)
| OnlyStrict
| Less
| Ok
| Important
| ReallyImportant
(* @xxx to acknowledge or explain false positives *)
type annotation =
| AtScheck of string
(* to detect false positives (we use the Hashtbl.find_all property) *)
type identifier_index = (string, Parse_info.token_location) Hashtbl.t
(*****************************************************************************)
(* Pretty printers *)
(*****************************************************************************)
let string_of_error_kind error_kind =
match error_kind with
| Deadcode (s, kind) ->
spf "dead %s, %s" (Entity_code.string_of_entity_kind kind) s
| UndefinedDefOfDecl (s, kind) ->
spf "no def found for %s (%s)" s (Entity_code.string_of_entity_kind kind)
| UnusedExport ((s, kind), file_def) ->
spf "useless export of %s (%s) (consider forward decl in %s)"
s (Entity_code.string_of_entity_kind kind) file_def
| UnusedVariable (name, scope) ->
spf "Unused variable %s, scope = %s" name
(Scope_code.string_of_scope scope)
(*
let loc_of_node root n g =
try
let info = G.nodeinfo n g in
let pos = info.G.pos in
let file = Filename.concat root pos.PI.file in
spf "%s:%d" file pos.PI.line
with Not_found -> "NO LOCATION"
*)
let string_of_error err =
let pos = err.loc in
spf "%s:%d: %s" pos.PI.file pos.PI.line (string_of_error_kind err.typ)
(*****************************************************************************)
(* Main entry points *)
(*****************************************************************************)
let g_errors = ref []
let fatal loc err =
Common.push { loc = loc; typ = err; sev = Fatal } g_errors
let warning loc err =
Common.push { loc = loc; typ = err; sev = Warning } g_errors
(*****************************************************************************)
(* Ranking *)
(*****************************************************************************)
let score_of_rank = function
| Never -> 0
| OnlyStrict -> 1
| Less -> 2
| Ok -> 3
| Important -> 4
| ReallyImportant -> 5
let rank_of_error err =
match err.typ with
| Deadcode (_s, kind) ->
(match kind with
| E.Function -> Ok
(* or enable when use propagate_uses_of_defs_to_decl in graph_code *)
| E.GlobalExtern | E.Prototype -> Less
| _ -> Ok
)
(* probably defined in assembly code? *)
| UndefinedDefOfDecl _ -> Important
(* we want to simplify interfaces as much as possible! *)
| UnusedExport _ -> ReallyImportant
| UnusedVariable _ -> Less
let score_of_error err =
err +> rank_of_error +> score_of_rank
(*****************************************************************************)
(* False positives *)
(*****************************************************************************)
let adjust_errors xs =
xs +> Common.exclude (fun err ->
let file = err.loc.PI.file in
match err.typ with
| Deadcode (s, kind) ->
(match kind with
| E.Dir | E.File -> true
(* kencc *)
| E.Prototype when s = "SET" || s = "USED" -> true
(* FP in graph_code_clang for now *)
| E.Type when s =~ "E__anon" -> true
| E.Type when s =~ "U__anon" -> true
| E.Type when s =~ "S__anon" -> true
| E.Type when s =~ "E__" -> true
| E.Type when s =~ "T__" -> true
(* FP in graph_code_c for now *)
| E.Type when s =~ "U____anon" -> true
(* TODO: to remove, but too many for now *)
| E.Constructor
| E.Field
-> true
(* hmm plan9 specific? being unused for one project does not mean
* it's not used by another one.
*)
| _ when file =~ "^include/" -> true
| _ when file =~ "^EXTERNAL/" -> true
(* too many FP on dynamic lang like PHP *)
| E.Method -> true
| _ -> false
)
(* kencc *)
| UndefinedDefOfDecl (("SET" | "USED"), _) -> true
| UndefinedDefOfDecl _ ->
(* hmm very plan9 specific *)
file =~ "^include/" ||
file = "kernel/lib/lib.h" ||
file = "kernel/network/ip/ip.h" ||
file =~ "kernel/conf/" ||
false
| _ -> false
)
(*****************************************************************************)
(* Annotations *)
(*****************************************************************************)
let annotation_of_line_opt s =
if s =~ ".*@\\([A-Za-z_]+\\):[ ]?\\([^@]*\\)"
then
let (kind, explain) = Common.matched2 s in
Some (match kind with
| "Scheck" -> AtScheck explain
| s -> failwith ("Bad annotation: " ^ s)
)
else None
(* The user can override the checks by adding special annotations
* in the code at the same line than the code it related to.
*)
let annotation_at2 loc =
let file = loc.PI.file in
let line = max (loc.PI.line - 1) 1 in
match Common2.cat_excerpts file [line] with
| [s] -> annotation_of_line_opt s
| _ -> failwith (spf "wrong line number %d in %s" line file)
let annotation_at a =
Common.profile_code "Errors_code.annotation" (fun () -> annotation_at2 a)

55
h_program-lang/errors_code.mli Normal file
View file

@ -0,0 +1,55 @@
type error = {
typ: error_kind;
loc: Parse_info.token_location;
sev: severity;
}
and severity = Fatal | Warning
and error_kind =
| Deadcode of entity
| UndefinedDefOfDecl of entity
| UnusedExport of entity * Common.filename
| UnusedVariable of string * Scope_code.scope
and entity = (string * Entity_code.entity_kind)
(* @xxx to acknowledge or explain false positives *)
type annotation =
| AtScheck of string
(* to detect false positives (we use the Hashtbl.find_all property) *)
type identifier_index = (string, Parse_info.token_location) Hashtbl.t
val string_of_error: error -> string
val string_of_error_kind: error_kind -> string
val g_errors: error list ref
(* !modify g_errors! *)
val fatal: Parse_info.token_location -> error_kind -> unit
val warning: Parse_info.token_location -> error_kind -> unit
type rank =
| Never
| OnlyStrict
| Less
| Ok
| Important
| ReallyImportant
val score_of_rank:
rank -> int
val rank_of_error:
error -> rank
val score_of_error:
error -> int
val annotation_at:
Parse_info.token_location -> annotation option
(* have some approximations and Fps in graph_code_checker so filter them *)
val adjust_errors:
error list -> error list

5
h_program-lang/facts.pl Normal file
View file

@ -0,0 +1,5 @@
extends('B', 'A').
extends('C', 'B').

740
h_program-lang/highlight_code.ml Normal file
View file

@ -0,0 +1,740 @@
(* Yoann Padioleau
*
* Copyright (C) 2010-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 E = Entity_code
(*****************************************************************************)
(* Prelude *)
(*****************************************************************************)
(*
* Emacs-like font-lock-mode, or SourceInsight-like display.
*
* This file contains the generic part of a code highlighter
* that is programming language independent.
* See highlight_xxx.ml for the code specific to the 'xxx'
* programming language.
*
* This source code viewer is based on good semantic information,
* not fragile regexps (as in Emacs), or partial parsing
* (as in SourceInsight, probably because they call cpp).
*
* Augmented visual! Augmented intellect! See what can not see, like in
* movies where HUD show invisible things.
*
* history:
* Some code such as the visitor code was using Emacs_mode_xxx
* visitors before, but now we use directly the raw visitor, cos
* emacs_mode_xxx was not a big win as we must colorize
* and so visit and so get hooks for almost every programming constructs.
*
* Moreover there was some duplication, such as for the different
* categories: I had notes in emacs_mode_xxx and also notes in this file
* about those categories like yacfe_imprecision, cpp, etc. So
* better and cleaner to put all related code in the same file.
*
*
* Why better to have such visualisation ? cf via_pram_readbyte example:
* - better see that use global via1, and that global to module
* - better see local macro
* - better see that some func are local too, the via_pram_writebyte
* - better see if local, or parameter
* - better see in comments that important words such as interrupts,
* and disabled, and must
*
*
* SEMI do first like gtk source view
* SEMI do first like emacs
* SEMI do like my pad emacs mode extension
* SEMI do for yacfe specific stuff
*
* less: level of font-lock-mode ? so can colorify a lot the current function
* and less the rest (so maybe avoid some of the bugs of GText ?
*
* Take more ideas from Source Insight ?
* - variable size parens depending on depth of nestedness
* - do same for curly braces ?
*
* TODO estet: I often revisit in very similar way the code, and do
* some matching to know if pointercall, methodcall, to know if
* prototype or decl extern, to know if typedef inside, or structdef
* inside. Could
* perhaps define helpers so not redo each time same things ?
*
* estet?: redundant with - place_code ? - entity_c ?
*
* related work:
* - http://pygments.org/
*)
(*****************************************************************************)
(* Types helpers *)
(*****************************************************************************)
(* will be italic vs non-italic (could be large vs small ? or bolder ? *)
type usedef =
| Use
| Def
(* colors will be adjusted (degrade de couleurs) (could also do size? *)
type place =
| PlaceLocal
| PlaceSameDir
| PlaceExternal
(* | ReallyExternal | PlaceCloseHeader *)
(* will be in a lighter color, almost like wheat, so know we don't have
* information on it. Could highlight in Red because it's
* quite similar to an error.
*)
| NoInfoPlace
(* will be underlined or strikedthrough *)
type def_arity =
| UniqueDef
| DoubleDef
| MultiDef
| NoDef
(* will be different colors *)
type use_arity =
| NoUse
| UniqueUse
| SomeUse
| MultiUse
| LotsOfUse
| HugeUse
type use_info = place * def_arity * use_arity
type def_info = use_arity
type usedef2 =
| Use2 of use_info
| Def2 of def_info
(*****************************************************************************)
(* Main type *)
(*****************************************************************************)
(* coupling: if add constructor, don't forget to add its handling in 2 places
* below, for its color and associated string representation.
*
* If you look at usedef below, you should get all the way C programmer
* can name things:
* - macro, macrovar
* - functions
* - variables (global/param/local)
* - typedefs, structname, enumname, enum, fields
* - labels
* But at the user site, can see only if
* - FunCallOrMacroCall
* - VarOrEnumValOrMacroVar
* - labels
* - field
* - tag (struct, union, enum)
* - typedef
*)
(* color, foreground or background will be changed *)
type category =
| Comment
(* pad addons *)
| Null
| Boolean | Number
| String | Regexp
(* classic emacs mode *)
| Keyword (* SEMI multi *)
| KeywordConditional
| KeywordLoop
| KeywordExn
| KeywordObject
| KeywordModule
| Builtin
| BuiltinCommentColor (* e.g. for "pr", "pr2", "spf". etc *)
| BuiltinBoolean (* e.g. "not" *)
| Operator (* TODO multi *)
| Punctuation
(* Functions, macros, globals, types, ... see Entity_code.entity_kind.
* By default global scope (macro can have local
* but not that used), so no need to like for variables and have a
* global/local dichotomy of scope. (But even if functions are globals,
* still can have some global/local dichotomy but at the module level.
*)
| Entity of Entity_code.entity_kind * usedef2
(* kind of specific case of Global of Local which we know are really
* really local. Don't really need a def_arity and place here. *)
| Local of usedef
| Parameter of usedef
(* less: could be Entity Prototype, but there is just def for Prototype *)
| FunctionDecl of def_info
(* hmm does not fit Constructor use_def, because special kind of use *)
| ConstructorMatch of use_info
(* less: use Entity instead? *)
| StaticMethod of usedef2
| StructName of usedef
| EnumName of usedef
(* ClassName of place ... *)
(* special types *)
| TypeVoid | TypeInt
(* haskell *)
| FunctionEquation
(* misc *)
| Label of usedef
(* semantic information *)
| BadSmell
(* less: TodoComment? *)
(* could reuse Global (Use2 ...) but the use of refs is not always
* the use of a global. Moreover using a ref in OCaml is really bad
* which is why I want to highlight it specially.
*)
| UseOfRef
| PointerCall (* a.k.a dynamic call *)
| CallByRef
| ParameterRef
| IdentUnknown
(* module/cpp related *)
| Ifdef
| Include
| IncludeFilePath
| Define
| CppOther
(* web related *)
| EmbededCode (* e.g. javascript *)
| EmbededUrl (* e.g. xhp *)
| EmbededHtml (* e.g. xhp *)
| EmbededHtmlAttr
| EmbededStyle (* e.g. css *)
| Verbatim (* for latex, noweb, html pre *)
(* misc *)
| GrammarRule
(* Ccomment *)
| CommentWordImportantNotion
| CommentWordImportantModal
(* pad style specific *)
| CommentSection0
| CommentSection1
| CommentSection2
| CommentSection3
| CommentSection4
| CommentEstet
| CommentCopyright
| CommentSyncweb
(* search and match *)
| MatchGlimpse
| MatchSmPL
| MatchParent
| MatchSmPLPositif
| MatchSmPLNegatif
(* basic *)
| BackGround | ForeGround
(* parsing imprecision *)
| NotParsed | Passed | Expanded | Error
| NoType
(* well, normal code *)
| Normal
type highlighter_preferences = {
mutable show_type_error: bool;
mutable show_local_global: bool;
}
let default_highlighter_preferences = {
show_type_error = false;
show_local_global = true;
}
(*****************************************************************************)
(* Color and font settings *)
(*****************************************************************************)
(*
* capabilities: (cf also pango.ml)
* - colors, and can provide semantic information by
* * using opposite colors
* * using close colors,
* * using degrade color
* * using tone (darker, brighter)
* * can also use background/foreground
*
* - fontsize
* - bold, italic, slanted, normal
* - underlined/strikedthrough, pango can even do double underlined
* - fontkind, for instance comment could be in a different font
* in addition of different colors ?
* - casse, smallcaps ? (but can confondre avec macro ?)
* - stretch? (condenset)
*
* Recurrent conventions, which would be counter productive to change maybe:
* - string: green
* - keywords: red/orange
*
* Emacs C-mode conventions:
* - entities declarations: light/dark blue
* (dark for param and local, light for func)
* - types: green
* - keywords: orange/dark-orange, this include:
* - control keywords
* - declaration keywords (static/register, but also struct, typedef)
* - cpp builtin keywords
* - labels: cyan
* - entities used: basic
* - comments: grey
* - strings: dark green
*
* pad:
* - punctuation: blue
* - numbers: yellow
*
* semantic variable:
* - global
* - parameter
* - local
* semantic function:
* - local, defined in file
* - global
* - global and multidef
* - global and utilities, so kind of keyword, like my Common.map or
* like kprintf
* semantic types:
* - local/specific
* - globals
* operators:
* - boolean
* - arithmetic
* - bits
* - memory
*
* notions:
* declaration vs use (italic vs non italic, or large vs small)
* type vs values (use color?)
* control vs data (use color?)
* local vs global (bold vs non bold, also can use degarde de couleur)
* module vs program (use font size ?)
* unique vs multi (use underline ? and strikedthrough ?)
*
* more and more distant => darker ?
* less and less unique => bigger ?
* (but both notions of distant and unique are strongly correlated ?)
*
* Normally can leverage indentation and place in file. We know when
* we are not at the toplevel because of the indentation, so can overload
* some colors.
*
*
*
* final:
* (total colors)
* - blanc
* wheat: default (but what remains default??)
* - noir
* gray: comments
*
*
*
* (primary colors)
* - rouge:
* control, conditional vs loop vs jumps, functions
* - bleue:
* variables, values
* - vert:
* types
* - vert-dark: string, chars
*
*
* (secondary colors)
* - jaune (rouge-vert):
* numbers, value
* - magenta (rouge-bleu):
*
* - cyan (vert-bleu):
*
*
* (tertiary colors)
* - orange (rouge-jaune):
*
* - pourpre (rouge-violet)
*
* - rose:
*
* - turquoise:
*
* - marron
*
*)
let legend_color_codes = "
The big principles for the colors, fonts, and strikes are:
- italic: for definitions,
normal: for uses
- doubleline: double def,
singleline: multi def,
strike: no def,
normal: single def
- big fonts: use of global variables, or function pointer calls
- lighter: distance of definitions (very light means in same file)
- gray background: not parsed, no type information, or other tool limitations
- red background: expanded code
- other special backgrounds: search results
- green: types
- purple: fields
- yellow: functions (and macros)
- blue: globals, variables
- pink: constants, macros
- cyan and big: global,
turquoise and big: remote global,
dark blue: parameters,
blue: locals
- yellow and big: function pointer,
light yellow: local call (in same file),
dark yellow: remote module call (in same dir)
- salmon: many uses, probably a utility function (e.g. printf)
- red: problem, no definitions
"
let info_of_usedef usedef =
match usedef with
| Def -> [`STYLE `ITALIC]
| Use -> []
let info_of_def_arity defarity =
match defarity with
| UniqueDef -> []
| DoubleDef -> [`UNDERLINE `DOUBLE]
| MultiDef -> [`UNDERLINE `SINGLE]
| NoDef -> [`STRIKETHROUGH true]
let info_of_place _defplace =
raise Todo
(*****************************************************************************)
(* Main entry point *)
(*****************************************************************************)
(* pad taste *)
let info_of_category = function
(* `FAMILY "-misc-*-*-*-*-20-*-*-*-*-*-*"*)
(* `FONT "-misc-fixed-bold-r-normal--13-100-100-100-c-70-iso8859-1" *)
(* background *)
| BackGround -> [`BACKGROUND "DarkSlateGray"]
| ForeGround -> [`FOREGROUND "wheat";]
| NotParsed -> [`BACKGROUND "grey42" (*"lightgray"*)]
| NoType -> [`BACKGROUND "DimGray"]
| Passed -> [`BACKGROUND "DarkSlateGray4"]
| Expanded -> [`BACKGROUND "red"]
| Error -> [`BACKGROUND "red2"]
(* a flashy one that hurts the eye :) *)
| BadSmell -> [`FOREGROUND "magenta"]
| UseOfRef -> [`FOREGROUND "magenta"]
| PointerCall ->
[`FOREGROUND "firebrick";
`WEIGHT `BOLD;
`SCALE `XX_LARGE;
]
| ParameterRef -> [`FOREGROUND "magenta"]
| CallByRef ->
[`FOREGROUND "orange";
`WEIGHT `BOLD;
`SCALE `XX_LARGE;
]
| IdentUnknown -> [`FOREGROUND "red";]
(* searches, background *)
| MatchGlimpse -> [`BACKGROUND "grey46"]
| MatchSmPL -> [`BACKGROUND "ForestGreen"]
| MatchParent -> [`BACKGROUND "blue"]
| MatchSmPLPositif -> [`BACKGROUND "ForestGreen"]
| MatchSmPLNegatif -> [`BACKGROUND "red"]
(* foreground *)
| Comment -> [`FOREGROUND "gray";]
| CommentSection0 -> [`FOREGROUND "coral";]
| CommentSection1 -> [`FOREGROUND "orange";]
| CommentSection2 -> [`FOREGROUND "LimeGreen";]
| CommentSection3 -> [`FOREGROUND "LightBlue3";]
| CommentSection4 -> [`FOREGROUND "gray";]
| CommentEstet -> [`FOREGROUND "gray";]
| CommentCopyright -> [`FOREGROUND "gray";]
| CommentSyncweb -> [`FOREGROUND "DimGray";]
(* entities *)
| Entity (kind, defkind) ->
(match kind, defkind with
| E.Type, (Def2 _) -> [`FOREGROUND "chartreuse";]
| E.Type, (Use2 _) -> [`FOREGROUND "chartreuse";]
| E.Constructor, (Def2 _ ) -> [`FOREGROUND "tomato1";]
| E.Constructor, (Use2 _) -> [`FOREGROUND "pink3";]
| E.Module, (Def2 _) -> [`FOREGROUND "chocolate";]
| E.Module, (Use2 _) -> [`FOREGROUND "DarkSlateGray4";]
| E.Field, (Def2 _) -> [`FOREGROUND "MediumPurple1"] @ info_of_usedef (Def)
| E.Field, (Use2 _) -> [`FOREGROUND "MediumPurple2"] @ info_of_usedef (Use)
| E.Exception, (Def2 _) -> [`FOREGROUND "Orchid1"] @ info_of_usedef (Def)
| E.Exception, (Use2 _) -> [`FOREGROUND "Orchid2"] @ info_of_usedef (Use)
(* defs *)
| E.Function, (Def2 _) -> [`FOREGROUND "gold";
`WEIGHT `BOLD;`STYLE `ITALIC; `SCALE `MEDIUM;
]
| E.Macro, (Def2 _) -> [`FOREGROUND "gold";
`WEIGHT `BOLD;`STYLE `ITALIC; `SCALE `MEDIUM;
]
| E.Global, (Def2 _) -> [`FOREGROUND "cyan";
`WEIGHT `BOLD; `STYLE `ITALIC; `SCALE `MEDIUM;
]
| E.Constant, (Def2 _) -> [`FOREGROUND "pink";
`WEIGHT `BOLD; `STYLE `ITALIC; `SCALE `MEDIUM;
]
| E.Method, (Def2 _) -> [`FOREGROUND "gold3";
`WEIGHT `BOLD; `SCALE `MEDIUM;
]
| E.Class, (Def2 _) -> [`FOREGROUND "coral"] @ info_of_usedef (Def)
(* uses *)
| E.Function, (Use2 (defplace,def_arity,use_arity)) ->
(match defplace with
| PlaceLocal -> [`FOREGROUND "gold";]
| PlaceSameDir -> [`FOREGROUND "goldenrod";]
| PlaceExternal ->
(match use_arity with
| MultiUse -> [`FOREGROUND "DarkGoldenrod"]
| LotsOfUse | HugeUse | SomeUse -> [`FOREGROUND "salmon";]
| UniqueUse -> [`FOREGROUND "yellow"]
| NoUse -> [`FOREGROUND "IndianRed";]
)
| NoInfoPlace -> [`FOREGROUND "LightGoldenrod";]
) @ info_of_def_arity def_arity
| E.Global, (Use2 (defplace, def_arity, use_arity)) ->
[`SCALE `X_LARGE] @
(match defplace with
| PlaceLocal -> [`FOREGROUND "cyan";]
| PlaceSameDir -> [`FOREGROUND "turquoise3";]
| PlaceExternal ->
(match use_arity with
| MultiUse -> [`FOREGROUND "turquoise4"]
| LotsOfUse | HugeUse | SomeUse -> [`FOREGROUND "salmon";]
| UniqueUse -> [`FOREGROUND "yellow"]
| NoUse -> [`FOREGROUND "IndianRed";]
)
| NoInfoPlace -> [`FOREGROUND "LightCyan";]
) @ info_of_def_arity def_arity
| E.Constant, (Use2 (defplace, def_arity, use_arity)) ->
(match defplace with
| PlaceLocal -> [`FOREGROUND "pink";]
| PlaceSameDir -> [`FOREGROUND "LightPink";]
| PlaceExternal ->
(match use_arity with
| MultiUse -> [`FOREGROUND "PaleVioletRed"]
| LotsOfUse | HugeUse | SomeUse -> [`FOREGROUND "salmon";]
| UniqueUse -> [`FOREGROUND "yellow"]
| NoUse -> [`FOREGROUND "IndianRed";]
)
| NoInfoPlace -> [`FOREGROUND "pink1";]
) @ info_of_def_arity def_arity
(* copy paste of MacroVarUse for now *)
| E.Macro, (Use2 (defplace, def_arity, use_arity)) ->
(match defplace with
| PlaceLocal -> [`FOREGROUND "pink";]
| PlaceSameDir -> [`FOREGROUND "LightPink";]
| PlaceExternal ->
(match use_arity with
| MultiUse -> [`FOREGROUND "PaleVioletRed"]
| LotsOfUse | HugeUse | SomeUse -> [`FOREGROUND "salmon";]
| UniqueUse -> [`FOREGROUND "yellow"]
| NoUse -> [`FOREGROUND "IndianRed";]
)
| NoInfoPlace -> [`FOREGROUND "pink1";]
) @ info_of_def_arity def_arity
| E.Method, (Use2 _) -> [`FOREGROUND "gold3";]
| E.Class, (Use2 _) -> [`FOREGROUND "coral"] @ info_of_usedef (Use)
| _ ->
failwith (spf "info_of_category: missing case for '%s'"
(Entity_code.string_of_entity_kind kind))
)
| FunctionDecl (_) -> [`FOREGROUND "gold2";
`WEIGHT `BOLD;`STYLE `ITALIC; `SCALE `MEDIUM;
]
| Parameter usedef -> [`FOREGROUND "SteelBlue2";] @ info_of_usedef usedef
| Local usedef -> [`FOREGROUND "SkyBlue1";] @ info_of_usedef usedef
(* | FunCallMultiDef ->[`FOREGROUND "LightGoldenrod";] *)
| StaticMethod (Def2 _) -> [`FOREGROUND "gold3";
`WEIGHT `BOLD; `SCALE `MEDIUM;
]
| StaticMethod (Use2 _) -> [`FOREGROUND "gold3";
`WEIGHT `BOLD; `SCALE `MEDIUM;
]
| TypeVoid -> [`FOREGROUND "LimeGreen";]
| TypeInt -> [`FOREGROUND "chartreuse";]
| ConstructorMatch _ -> [`FOREGROUND "pink1";]
| FunctionEquation -> [`FOREGROUND "LightSkyBlue";]
| StructName usedef -> [`FOREGROUND "YellowGreen"] @ info_of_usedef usedef
| EnumName usedef -> [`FOREGROUND "YellowGreen"] @ info_of_usedef usedef
| Ifdef -> [`FOREGROUND "chocolate";]
| Include -> [`FOREGROUND "DarkOrange2";]
| IncludeFilePath -> [`FOREGROUND "SpringGreen3";]
| Define -> [`FOREGROUND "DarkOrange2";]
| CppOther -> [`FOREGROUND "DarkOrange2";]
| Keyword -> [`FOREGROUND "orange";]
| Builtin -> [`FOREGROUND "salmon";]
| BuiltinCommentColor -> [`FOREGROUND "gray";]
| BuiltinBoolean -> [`FOREGROUND "pink";]
| KeywordConditional -> [`FOREGROUND "DarkOrange";]
| KeywordLoop -> [`FOREGROUND "sienna1";]
| KeywordExn -> [`FOREGROUND "orchid";]
| KeywordObject -> [`FOREGROUND "aquamarine3";]
| KeywordModule -> [`FOREGROUND "chocolate";]
| Number -> [`FOREGROUND "yellow3";]
| Boolean -> [`FOREGROUND "pink3";]
| String -> [`FOREGROUND "MediumSeaGreen";]
| Regexp -> [`FOREGROUND "green3";]
| Null -> [`FOREGROUND "cyan3";]
| CommentWordImportantNotion ->
[`FOREGROUND "red"; `SCALE `LARGE;`UNDERLINE `SINGLE; ]
| CommentWordImportantModal ->
[`FOREGROUND "green"; `SCALE `LARGE; `UNDERLINE `SINGLE;]
| Punctuation -> [`FOREGROUND "cyan";]
| Operator -> [`FOREGROUND "DeepSkyBlue3";] (* could do better ? *)
| (Label Def) -> [`FOREGROUND "cyan";]
| (Label Use) -> [`FOREGROUND "CornflowerBlue";]
(* to be consistent with Archi_code.Ui color *)
| EmbededHtml -> [`FOREGROUND "RosyBrown"]
| EmbededHtmlAttr ->[`FOREGROUND "burlywood3"]
| EmbededUrl ->
(* yellow-like color, like function, because it's often
* used as a method call in method programming
*)
[`FOREGROUND "DarkGoldenrod2"]
| EmbededCode -> [`FOREGROUND "yellow3"]
| EmbededStyle -> [`FOREGROUND "peru"]
| Verbatim -> [`FOREGROUND "plum"]
| GrammarRule -> [`FOREGROUND "plum"]
| Normal -> [`FOREGROUND "wheat";]
(*****************************************************************************)
(* Generic helpers *)
(*****************************************************************************)
let arity_ids ids =
match ids with
| [] -> NoDef
| [_] -> UniqueDef
| [_;_] -> DoubleDef
| _::_::_::_ -> MultiDef
let rewrap_arity_def2_category arity categ =
match categ with
| Entity (kind, (Def2 _)) -> Entity (kind, (Def2 arity))
| FunctionDecl _ -> FunctionDecl (arity)
| StaticMethod (Def2 _) -> StaticMethod (Def2 arity)
| _ -> failwith "not a Def2-kind categoriy"

107
h_program-lang/highlight_code.mli Normal file
View file

@ -0,0 +1,107 @@
type category =
| Comment
| Null | Boolean | Number | String | Regexp
| Keyword
| KeywordConditional | KeywordLoop
| KeywordExn | KeywordObject | KeywordModule
| Builtin | BuiltinCommentColor | BuiltinBoolean
| Operator | Punctuation
| Entity of Entity_code.entity_kind * usedef2
| Local of usedef
| Parameter of usedef
| FunctionDecl of def_info
| ConstructorMatch of use_info
| StaticMethod of usedef2
| StructName of usedef
| EnumName of usedef
| TypeVoid | TypeInt
| FunctionEquation
| Label of usedef
(* semantic visual feedback! highlight more! *)
| BadSmell
| UseOfRef
| PointerCall
| CallByRef
| ParameterRef
| IdentUnknown
| Ifdef | Include | IncludeFilePath | Define | CppOther
| EmbededCode (* e.g. javascript *)
| EmbededUrl (* e.g. xhp *)
| EmbededHtml (* e.g. xhp *) | EmbededHtmlAttr
| EmbededStyle (* e.g. css *)
| Verbatim (* for latex, noweb, html pre *)
| GrammarRule
| CommentWordImportantNotion | CommentWordImportantModal
| CommentSection0 | CommentSection1 | CommentSection2
| CommentSection3 | CommentSection4
| CommentEstet | CommentCopyright | CommentSyncweb
| MatchGlimpse | MatchSmPL
| MatchParent
| MatchSmPLPositif | MatchSmPLNegatif
| BackGround | ForeGround
(* tools limitations *)
| NotParsed | Passed | Expanded | Error
| NoType
| Normal
and usedef = Use | Def
and usedef2 = Use2 of use_info | Def2 of def_info
(* semantic visual feedback! *)
and def_info = use_arity
and use_arity = NoUse | UniqueUse | SomeUse | MultiUse | LotsOfUse | HugeUse
(* semantic visual feedback! *)
and use_info = place * def_arity * use_arity
and place = PlaceLocal | PlaceSameDir | PlaceExternal | NoInfoPlace
and def_arity = UniqueDef | DoubleDef | MultiDef | NoDef
type highlighter_preferences = {
mutable show_type_error : bool;
mutable show_local_global : bool;
}
val default_highlighter_preferences: highlighter_preferences
val legend_color_codes : string
(* main entry point *)
val info_of_category :
category ->
[> `BACKGROUND of string
| `FOREGROUND of string
| `SCALE of [> `LARGE | `MEDIUM | `XX_LARGE | `X_LARGE ]
| `STRIKETHROUGH of bool
| `STYLE of [> `ITALIC ]
| `UNDERLINE of [> `DOUBLE | `SINGLE ]
| `WEIGHT of [> `BOLD ] ]
list
(* use the same polymorphic variants than in ocamlgtk *)
val info_of_usedef :
usedef ->
[> `STYLE of [> `ITALIC ] ] list
val info_of_def_arity :
def_arity ->
[> `STRIKETHROUGH of bool | `UNDERLINE of [> `DOUBLE | `SINGLE ] ] list
val info_of_place : 'a -> 'b
val arity_ids : 'a list -> def_arity
val rewrap_arity_def2_category: def_info -> category -> category

59
h_program-lang/info_code.ml Normal file
View file

@ -0,0 +1,59 @@
(* Yoann Padioleau
*
* Copyright (C) 2012 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.
*)
(*****************************************************************************)
(* Prelude *)
(*****************************************************************************)
(*
* history:
* - was in main_codestat.ml
*
* Example of project information:
* - http://www.gnu.org/manual/blurbs.html
*)
(*****************************************************************************)
(* Types *)
(*****************************************************************************)
type info_txt = Outline.outline
(* old: (string * string list) list *)
(*****************************************************************************)
(* IO *)
(*****************************************************************************)
let load file =
Outline.parse_outline file
(* old:
let xs =
Common.cat file
+> List.map (Str.global_replace (Str.regexp "#.*") "" )
+> List.map (Str.global_replace (Str.regexp "\\*+ -----.*") "" )
+> Common.exclude Common.is_blank_string
in
let xxs = Common.split_list_regexp "^\\*+ " xs in
xxs +> List.map (fun (s, body) ->
if s =~ "^\\*+ \\([^ ]+\\)[ \t]*$"
then
let dir = Common.matched1 s in
dir, body
else
failwith (spf "wrong format in %s, entry: %s" file s)
)
*)

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

@ -0,0 +1,4 @@
type info_txt = Outline.outline
val load: Common.filename -> info_txt

796
h_program-lang/layer_code.ml Normal file
View file

@ -0,0 +1,796 @@
(* 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 *)
(*****************************************************************************)
(*
* The goal of this module is to provide a data-structure to represent
* code "layers" (a.k.a. code "aspects"). The idea is to imitate google
* earth layers (e.g. the wikipedia layer, panoramio layer, etc), but
* for code. One can have a deadcode layer, a test coverage layer,
* and then can display those layers or not on an existing codebase in
* codemap. The layer is basically some mapping from files to a
* set of lines with a specific color code.
*
*
* A few design choices:
*
* - one could store such information directly into database_xxx.ml
* and have pfff_db compute such information (for instance each function
* could have a set of properties like unit_test, or dead) but this
* would force people to build their own db to visualize the results.
* One could compute this information in database_light_xxx.ml, but this
* will augment the size of the light db slowing down the codemap launch
* even when the people don't use the layers. So it's more flexible to just
* separate layer_code.ml from database_code.ml and have multiple persistent
* files for each information. Also it's quite convenient to have
* utilities like sgrep to be easily extendable to transform a query result
* into a layer.
*
* - How to represent a layer at the macro and micro level in codemap ?
*
* At the micro-level one has just to display the line with the
* requested color. At the macro-level have to either do a majority
* scheme or mixing scheme where for instance draw half of the
* treemap rectangle in red and the other in green.
*
* Because different layers could have different composition needs
* it is simpler to just have the layer say how it should be displayed
* at the macro_level. See the 'macro_level' field below.
*
* - how to have a layer data-structure that can cope with many
* needs ?
*
* Here are some examples of layers and how they are "encoded" by the
* 'layer' type below:
*
* * deadcode (dead function, dead class, dead statement, dead assignnements)
*
* How? dead lines in red color. At the macro_level one can give
* a grey_xxx color with a percentage (e.g. grey53).
*
* * test coverage (static or dynamic)
*
* How? covered lines in green, not covered in red ? Also
* convey a GreyLevel visualization by setting the 'macro_level' field.
*
* * age of file
*
* How? 2010 in green, 2009 in yelow, 2008 in red and so on.
* At the macro_level can do a mix of colors.
*
* * bad smells
*
* How? each bad smell could have a different color and macro_level
* showing a percentage of the rectangle with the right color
* for each smells in the file.
*
* * security patterns (bad smells)
*
* * activity ?
*
* How whow add and delete information ?
* At the micro_level can't show the delete, but at macro_level
* could divide the treemap_rectangle in 2 where percentage of
* add and delete, and also maybe white to show the amount of add
* and delete. Could also use my big circle scheme.
* How link to commit message ? TODO
*
*
* later:
* - could associate more than just a color, e.g. a commit message when want
* to display a version-control layer, or some filling-patterns in
* addition to the color.
* - Could have better precision than the line.
*
* history:
* - I was writing some treemap generator specific for the deadcode
* analysis, the static coverage, the dynamic coverage, and the activity
* in a file (see treemap_php.ml). I was also offering different
* way to visualize the result (DegradeArchiColor | GreyLevel | YesNo).
* It was working fine but there was no easy way to combine 2
* visualisations, like the age "layer" and the "deadcode" layer
* to see correlations. Also adding simple layers like
* visualizing all calls to HTML() or XHP was requiring to
* write another treemap generator. To be more generic and flexible require
* a real 'layer' type.
*)
(*****************************************************************************)
(* Type *)
(*****************************************************************************)
type color = string (* Simple_color.emacs_color *)
(* note: the filenames must be in readable format so layer files can be reused
* by multiple users.
*
* alternatives:
* - could have line range ? useful for layer matching lots of
* consecutive lines in a file ?
* - todo? have more precision than just the line ? precise pos range ?
*
* - could for the lines instead of a 'kind' to have a 'count',
* and then some mappings from range of values to a color.
* For instance on a coverage layer one could say that from X to Y
* then choose this color, from Y to Z another color.
* But can emulate that by having a "coverage1", "coverage2"
* kind with the current scheme.
*
* - have a macro_level_composing_scheme: Majority | Mixed
* that is then interpreted in codemap instead of forcing
* the layer creator to specific how to show the micro_level
* data at the macro_level.
*)
type layer = {
title: string;
description: string;
files: (filename * file_info) list;
kinds: (kind * color) list;
}
and file_info = {
micro_level: (int (* line *) * kind) list;
(* The list can be empty in which case codemap can use
* the micro_level information and show a mix of colors.
*
* The list can have just one element too and have a kind
* different than the one used in the micro_level. For instance
* for the coverage one can have red/green at micro_level
* and grey_xxx at macro_level.
*)
macro_level: (kind * float (* percentage of rectangle *)) list;
}
(* ugly: because of the ugly way Ocaml.json_of_v currently works
* the kind can not start with a uppercase
*)
and kind = string
(* with tarzan *)
(* The filenames in the index are in absolute path format. That way they
* can be used from codemap in hashtbl and compared to the
* current file.
*)
type layers_with_index = {
root: Common.dirname;
layers: (layer * bool (* is active *)) list;
micro_index:
(filename, (int, color) Hashtbl.t) Hashtbl.t;
macro_index:
(filename, (float * color) list) Hashtbl.t;
}
(*****************************************************************************)
(* Reusable properties *)
(*****************************************************************************)
let red_green_properties = [
"ok", "green";
"bad", "red";
"no_info", "white";
]
let heat_map_properties = [
"cover 100%", "red3";
"cover 90%", "red1";
"cover 80%", "orange";
"cover 70%", "yellow";
"cover 60%", "YellowGreen";
"cover 50%", "green";
"cover 40%", "cyan";
"cover 30%", "cyan3";
"cover 20%", "DeepSkyBlue1";
"cover 10%", "blue";
(* Should we use a dark blue for 0, as it is the case usually with
* heatmaps? The picture can become very blue then.
* Do not use white though because draw_macrolevel use white when nothing
* was found so we want to differentiate such cases
*)
"cover 0%", "blue4"; (* alternative: snow4 *)
(* when we zoom on a file we just show red/green coverage, no heat color *)
"ok", "green";
"bad", "red";
"base", "azure4";
"no_info", "white";
]
(*****************************************************************************)
(* Multi layers indexing *)
(*****************************************************************************)
(* Am I reinventing database indexing ? Should use a real database
* to store layer information so one can then just use SQL to
* fastly get all the information relevant to a file and a line ?
* I doubt MySQL can be as fast and light as my JSON + hashtbl indexing.
*)
let build_index_of_layers ~root layers =
let hmicro = Common2.hash_with_default (fun () -> Hashtbl.create 101) in
let hmacro = Common2.hash_with_default (fun () -> []) in
layers
+> List.filter (fun (_layer, active) -> active)
+> List.iter (fun (layer, _active) ->
let hkind = Common.hash_of_list layer.kinds in
layer.files +> List.iter (fun (file, finfo) ->
let file = Filename.concat root file in
(* todo? v is supposed to be a float representing a percentage of
* the rectangle but below we will add the macro info of multiple
* layers together which mean the float may not represent percentage
* anynore. They still represent a part of the file though.
* The caller would have to first recompute the sum of all those
* floats to recompute the actual multi-layer percentage.
*)
let color_macro_level =
finfo.macro_level +> Common.map_filter (fun (kind, v) ->
(* some sanity checking *)
try Some (v, Hashtbl.find hkind kind)
with Not_found ->
(* I was originally doing a failwith, but it can be convenient
* to be able to filter kinds in codemap by just editing the
* JSON file and removing certain kind definitions
*)
pr2_once (spf "PB: kind %s was not defined" kind);
None
)
in
hmacro#update file (fun old -> color_macro_level @ old);
finfo.micro_level +> List.iter (fun (line, kind) ->
try
let color = Hashtbl.find hkind kind in
hmicro#update file (fun oldh ->
(* We add so the same line could be assigned multiple colors.
* The order of the layer could determine which color should
* have priority.
*)
Hashtbl.add oldh line color;
oldh
)
with Not_found ->
pr2_once (spf "PB: kind %s was not defined" kind);
)
);
);
{
layers = layers;
root = root;
macro_index = hmacro#to_h;
micro_index = hmicro#to_h;
}
(*****************************************************************************)
(* Layers helpers *)
(*****************************************************************************)
let has_active_layers layers =
layers.layers +> List.map snd +> Common2.or_list
(*****************************************************************************)
(* Meta *)
(*****************************************************************************)
(* generated by ocamltarzan *)
let vof_emacs_color s = Ocaml.vof_string s
let vof_filename s = Ocaml.vof_string s
let rec
vof_layer {
title = v_title;
description = v_description;
files = v_files;
kinds = v_kinds
} =
let bnds = [] in
let arg =
Ocaml.vof_list
(fun (v1, v2) ->
let v1 = vof_kind v1
and v2 = vof_emacs_color v2
in Ocaml.VTuple [ v1; v2 ])
v_kinds in
let bnd = ("kinds", arg) in
let bnds = bnd :: bnds in
let arg =
Ocaml.vof_list
(fun (v1, v2) ->
let v1 = vof_filename v1
and v2 = vof_file_info v2
in Ocaml.VTuple [ v1; v2 ])
v_files in
let bnd = ("files", arg) in
let bnds = bnd :: bnds in
let arg = Ocaml.vof_string v_description in
let bnd = ("description", arg) in
let bnds = bnd :: bnds in
let arg = Ocaml.vof_string v_title in
let bnd = ("title", arg) in let bnds = bnd :: bnds in Ocaml.VDict bnds
and
vof_file_info { micro_level = v_micro_level; macro_level = v_macro_level }
=
let bnds = [] in
let arg =
Ocaml.vof_list
(fun (v1, v2) ->
let v1 = vof_kind v1
and v2 = Ocaml.vof_float v2
in Ocaml.VTuple [ v1; v2 ])
v_macro_level in
let bnd = ("macro_level", arg) in
let bnds = bnd :: bnds in
let arg =
Ocaml.vof_list
(fun (v1, v2) ->
let v1 = Ocaml.vof_int v1
and v2 = vof_kind v2
in Ocaml.VTuple [ v1; v2 ])
v_micro_level in
let bnd = ("micro_level", arg) in
let bnds = bnd :: bnds in Ocaml.VDict bnds
and vof_kind v = Ocaml.vof_string v
(*****************************************************************************)
(* Ocaml.v -> layer *)
(*****************************************************************************)
let emacs_color_ofv v = Ocaml.string_ofv v
let filename_ofv v = Ocaml.string_ofv v
let record_check_extra_fields = ref true
module Ocamlx = struct
open Ocaml
module J = Json_type
(*
let stag_incorrect_n_args _loc tag _v =
failwith ("stag_incorrect_n_args on: " ^ tag)
*)
(*
let unexpected_stag loc v =
failwith ("unexpected_stag:")
*)
(*
let record_only_pairs_expected loc v =
failwith ("record_only_pairs_expected:")
*)
let record_duplicate_fields _loc _dup_flds _v =
failwith ("record_duplicate_fields:")
let record_extra_fields _loc _flds _v =
failwith ("record_extra_fields:")
let record_undefined_elements _loc _v _xs =
failwith ("record_undefined_elements:")
let record_list_instead_atom _loc _v =
failwith ("record_list_instead_atom:")
let tuple_of_size_n_expected _loc n v =
failwith (spf "tuple_of_size_n_expected: %d, got %s" n (Common2.dump v))
let rec json_of_v v =
match v with
| VString s -> J.String s
| VSum ((s, vs)) ->J.Array ((J.String s)::(List.map json_of_v vs ))
| VTuple xs -> J.Array (xs +> List.map json_of_v)
| VDict xs -> J.Object (xs +> List.map (fun (s, v) ->
s, json_of_v v
))
| VList xs -> J.Array (xs +> List.map json_of_v)
| VNone -> J.Null
| VSome v -> J.Array [ J.String "Some"; json_of_v v]
| VRef v -> J.Array [ J.String "Ref"; json_of_v v]
| VUnit -> J.Null (* ? *)
| VBool b -> J.Bool b
(* Note that 'Inf' can be used as a constructor but is also recognized
* by float_of_string as a float (infinity), so when I was implementing
* this code by reverse engineering the generated sexp, it was important
* to guard certain code.
*)
| VFloat f -> J.Float f
| VChar c -> J.String (Common2.string_of_char c)
| VInt i -> J.Int i
| VTODO _v1 -> J.String "VTODO"
| VVar _v1 ->
failwith "json_of_v: VVar not handled"
| VArrow _v1 ->
failwith "json_of_v: VArrow not handled"
(*
* Assumes the json was generated via 'ocamltarzan -choice json_of', which
* have certain conventions on how to encode variants for instance.
*)
let rec (v_of_json: Json_type.json_type -> v) = fun j ->
match j with
| J.String s -> VString s
| J.Int i -> VInt i
| J.Float f -> VFloat f
| J.Bool b -> VBool b
| J.Null -> raise Todo
(* Arrays are used for represent constructors or regular list. Have to
* go sligtly deeper to disambiguate.
*)
| J.Array xs ->
(match xs with
(* VERY VERY UGLY. It is legitimate to have for instance tuples
* of strings where the first element is a string that happen to
* look like a constructor. With this ugly code we currently
* not handle that :(
*
* update: in the layer json file, one can have a filename
* like Makefile and we don't want it to be a constructor ...
* so for now I just generate constructors strings like
* __Pass so we know it comes from an ocaml constructor.
*)
| (J.String s)::xs when s =~ "^__\\([A-Z][A-Za-z_]*\\)$" ->
let constructor = Common.matched1 s in
VSum (constructor, List.map v_of_json xs)
| ys ->
VList (ys +> List.map v_of_json)
)
| J.Object flds ->
VDict (flds +> List.map (fun (s, fld) ->
s, v_of_json fld
))
let save_json file json =
let s = Json_out.string_of_json json in
Common.write_file ~file s
end
(* I have not yet an ocamltarzan script for the of_json ... but I have one
* for of_v, so have to pass through OCaml.v ... ugly
*)
let rec layer_ofv__ =
let _loc = "Xxx.layer"
in
function
| (Ocaml.VDict field_sexps as sexp) ->
let title_field = ref None and description_field = ref None
and files_field = ref None and kinds_field = ref None
and duplicates = ref [] and extra = ref [] in
let rec iter =
(function
| (field_name, field_sexp) :: tail ->
((match field_name with
| "title" ->
(match !title_field with
| None ->
let fvalue = Ocaml.string_ofv field_sexp
in title_field := Some fvalue
| Some _ -> duplicates := field_name :: !duplicates)
| "description" ->
(match !description_field with
| None ->
let fvalue = Ocaml.string_ofv field_sexp
in description_field := Some fvalue
| Some _ -> duplicates := field_name :: !duplicates)
| "files" ->
(match !files_field with
| None ->
let fvalue =
Ocaml.list_ofv
(function
| Ocaml.VList ([ v1; v2 ]) ->
let v1 = filename_ofv v1
and v2 = file_info_ofv v2
in (v1, v2)
| sexp ->
Ocamlx.tuple_of_size_n_expected _loc 2 sexp)
field_sexp
in files_field := Some fvalue
| Some _ -> duplicates := field_name :: !duplicates)
| "kinds" ->
(match !kinds_field with
| None ->
let fvalue =
Ocaml.list_ofv
(function
| Ocaml.VList ([ v1; v2 ]) ->
let v1 = kind_ofv v1
and v2 = emacs_color_ofv v2
in (v1, v2)
| sexp ->
Ocamlx.tuple_of_size_n_expected _loc 2 sexp)
field_sexp
in kinds_field := Some fvalue
| Some _ -> duplicates := field_name :: !duplicates)
| _ ->
if !record_check_extra_fields
then extra := field_name :: !extra
else ());
iter tail)
| [] -> ())
in
(iter field_sexps;
if !duplicates <> []
then Ocamlx.record_duplicate_fields _loc !duplicates sexp
else
if !extra <> []
then Ocamlx.record_extra_fields _loc !extra sexp
else
(match ((!title_field), (!description_field), (!files_field),
(!kinds_field))
with
| (Some title_value, Some description_value,
Some files_value, Some kinds_value) ->
{
title = title_value;
description = description_value;
files = files_value;
kinds = kinds_value;
}
| _ ->
Ocamlx.record_undefined_elements _loc sexp
[ ((!title_field = None), "title");
((!description_field = None), "description");
((!files_field = None), "files");
((!kinds_field = None), "kinds") ]))
| sexp -> Ocamlx.record_list_instead_atom _loc sexp
and layer_ofv sexp = layer_ofv__ sexp
and file_info_ofv__ =
let _loc = "Xxx.file_info"
in
function
| (Ocaml.VDict field_sexps as sexp) ->
let micro_level_field = ref None and macro_level_field = ref None
and duplicates = ref [] and extra = ref [] in
let rec iter =
(function
| (field_name, field_sexp) :: tail ->
((match field_name with
| "micro_level" ->
(match !micro_level_field with
| None ->
let fvalue =
Ocaml.list_ofv
(function
| Ocaml.VList ([ v1; v2 ]) ->
let v1 = Ocaml.int_ofv v1
and v2 = kind_ofv v2
in (v1, v2)
| sexp ->
Ocamlx.tuple_of_size_n_expected _loc 2 sexp)
field_sexp
in micro_level_field := Some fvalue
| Some _ -> duplicates := field_name :: !duplicates)
| "macro_level" ->
(match !macro_level_field with
| None ->
let fvalue =
Ocaml.list_ofv
(function
| Ocaml.VList ([ v1; v2 ]) ->
let v1 = kind_ofv v1
and v2 = Ocaml.float_ofv v2
in (v1, v2)
| sexp ->
Ocamlx.tuple_of_size_n_expected _loc 2 sexp)
field_sexp
in macro_level_field := Some fvalue
| Some _ -> duplicates := field_name :: !duplicates)
| _ ->
if !record_check_extra_fields
then extra := field_name :: !extra
else ());
iter tail)
| [] -> ())
in
(iter field_sexps;
if !duplicates <> []
then Ocamlx.record_duplicate_fields _loc !duplicates sexp
else
if !extra <> []
then Ocamlx.record_extra_fields _loc !extra sexp
else
(match ((!micro_level_field), (!macro_level_field)) with
| (Some micro_level_value, Some macro_level_value) ->
{
micro_level = micro_level_value;
macro_level = macro_level_value;
}
| _ ->
Ocamlx.record_undefined_elements _loc sexp
[ ((!micro_level_field = None), "micro_level");
((!macro_level_field = None), "macro_level") ]))
| sexp -> Ocamlx.record_list_instead_atom _loc sexp
and file_info_ofv sexp = file_info_ofv__ sexp
and kind_ofv__ = let _loc = "Xxx.kind" in fun sexp -> Ocaml.string_ofv sexp
and kind_ofv sexp = kind_ofv__ sexp
(*****************************************************************************)
(* Json *)
(*****************************************************************************)
let json_of_layer layer =
layer +> vof_layer +> Ocamlx.json_of_v
let layer_of_json json =
json +> Ocamlx.v_of_json +> layer_ofv
(*****************************************************************************)
(* Load/Save *)
(*****************************************************************************)
(* we allow to save in JSON format because it may be useful to let
* the user edit the layer file, for instance to adjust the colors.
*)
let load_layer file =
(* pr2 (spf "loading layer: %s" file); *)
if File_type.is_json_filename file
then Json_in.load_json file +> layer_of_json
else Common2.get_value file
let save_layer layer file =
if File_type.is_json_filename file
(* layer +> vof_layer +> Ocaml.string_of_v +> Common.write_file ~file *)
then layer +> json_of_layer +> Ocamlx.save_json file
else Common2.write_value layer file
(*****************************************************************************)
(* Layer builder helper *)
(*****************************************************************************)
(* Simple layer builder - group by file, by line, by property.
* The layer can also be used to summarize statistics per dirs and
* subdirs and so on.
*)
let simple_layer_of_parse_infos ~root ~title ?(description="") xs kinds =
let ranks_kinds =
kinds +> List.map (fun (k, _color) -> k)
+> Common.index_list_1 +> Common.hash_of_list
in
(* group by file, group by line, uniq categ *)
let files_and_lines = xs +> List.map (fun (tok, kind) ->
let file = Parse_info.file_of_info tok in
let line = Parse_info.line_of_info tok in
let file' = Common2.relative_to_absolute file in
Common.readable ~root file', (line, kind)
)
in
let (group_by_file: (Common.filename * (int * kind) list) list) =
Common.group_assoc_bykey_eff files_and_lines
in
{
title = title;
description = description;
kinds = kinds;
files = group_by_file +> List.map (fun (file, lines_and_kinds) ->
let (group_by_line: (int * kind list) list) =
Common.group_assoc_bykey_eff lines_and_kinds
in
let all_kinds_in_file =
group_by_line +> List.map snd +> List.flatten +> Common2.uniq in
(file, {
micro_level =
group_by_line +> List.map (fun (line, kinds) ->
let kinds = Common2.uniq kinds in
(* many kinds om same line, keep highest prio *)
match kinds with
| [] -> raise Impossible
| [x] -> line, x
| _ ->
let sorted = kinds +> List.map (fun x ->
x, Hashtbl.find ranks_kinds x) +> Common.sort_by_val_lowfirst
in
line, List.hd sorted +> fst
);
macro_level =
(* we could give a percentage per kind but right now
* we instead give a priority based on the rank of the kinds
* in the kind list
*)
all_kinds_in_file +> List.map (fun kind ->
(kind, 1. /. (float_of_int (Hashtbl.find ranks_kinds kind)))
)
})
);
}
(* old: superseded by Layer_code.layer.files and file_info
* type stat_per_file =
* (string (* a property *), int list (* lines *)) Common.assoc
*
* type stats =
* (Common.filename, stat_per_file) Hashtbl.t
*
*
* old:
* let (print_statistics: stats -> unit) = fun h ->
* let xxs = Common.hash_to_list h in
* pr2_gen (xxs);
* ()
*
* let gen_security_layer xs =
* let _root = Common.common_prefix_of_files_or_dirs xs in
* let files = Lib_parsing_php.find_php_files_of_dir_or_files xs in
*
* let h = Hashtbl.create 101 in
*
* files +> Common.index_list_and_total +> List.iter (fun (file, i, total) ->
* pr2 (spf "processing: %s (%d/%d)" file i total);
* let ast = Parse_php.parse_program file in
* let stat_file = stat_of_program ast in
* Hashtbl.add h file stat_file
* );
* Common.write_value h "/tmp/bigh";
* print_statistics h
*)
(* Generates a layer_red_green<output> and layer_heatmap<output> file.
* Take a list of files with a percentage and possibly micro_level
* information.
*)
(*
let layer_red_green_and_heatmap ~root ~output xs =
raise Todo
*)
(*****************************************************************************)
(* Layer stat *)
(*****************************************************************************)
(* todo? could be useful also to show # of files involved instead of
* just the line count.
*)
let stat_of_layer layer =
let h = Common2.hash_with_default (fun () -> 0) in
layer.kinds +> List.iter (fun (kind, _color) ->
h#add kind 0
);
layer.files +> List.iter (fun (_file, finfo) ->
finfo.micro_level +> List.iter (fun (_line, kind) ->
h#update kind (fun old -> old + 1)
)
);
h#to_list
let filter_layer f layer =
{ layer with
files = layer.files +> List.filter (fun (file, _) -> f file);
}

63
h_program-lang/layer_code.mli Normal file
View file

@ -0,0 +1,63 @@
type color = string (* Simple_color.emacs_color *)
(* The filenames in this data structure are in readable format
* so one can use the layer generated by another user on
* his own repository (this also saves some space in the generated
* JSON file).
*)
type layer = {
title: string;
description: string;
files: (Common.filename * file_info) list;
kinds: (kind * color) list;
}
and file_info = {
micro_level: (int (* line *) * kind) list;
macro_level: (kind * float (* percentage of rectangle *)) list;
}
(* ugly: the first letter of the propery cannot be in uppercase because
* of the ugly way Ocaml.json_of_v currently works.
*)
and kind = string
val red_green_properties: (kind * color) list
val heat_map_properties: (kind * color) list
(* The filenames are in absolute path format in the index. *)
type layers_with_index = {
root: Common.dirname;
layers: (layer * bool (* is active *)) list;
micro_index:
(Common.filename, (int, color) Hashtbl.t) Hashtbl.t;
macro_index:
(Common.filename, (float * color) list) Hashtbl.t;
}
val build_index_of_layers:
root:Common.dirname ->
(layer * bool) list ->
layers_with_index
val has_active_layers: layers_with_index -> bool
(* save either in a (readable) json format or (fast) marshalled form
* depending on the extension of the filename
*)
val load_layer: Common.filename -> layer
val save_layer: layer -> Common.filename -> unit
(* helpers *)
val json_of_layer: layer -> Json_type.t
val layer_of_json: Json_type.t -> layer
val simple_layer_of_parse_infos:
root:Common.dirname ->
title:string ->
?description:string ->
(Parse_info.info * kind) list ->
(kind * color) list ->
layer
val stat_of_layer: layer -> (kind * int) list
val filter_layer: (Common.filename -> bool) -> layer -> layer

127
h_program-lang/layer_coverage.ml Normal file
View file

@ -0,0 +1,127 @@
(* 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 *)
(*****************************************************************************)
(*
* Thin layer generator wrapper around the Coverage_tests_php.lines_coverage
* data, which itself is generated by running many unit tests with a
* tracer, xdebug or hphpi-tracer, on.
*
* We generate either a layer with red/green colors or one with
* heat-based colors for finer-grained visualization.
*)
(*****************************************************************************)
(* Types *)
(*****************************************************************************)
(*****************************************************************************)
(* Helper *)
(*****************************************************************************)
(*****************************************************************************)
(* Main entry point *)
(*****************************************************************************)
let gen_red_green_layer lines_coverage =
{ Layer_code.
title = "Test coverage (red/green)";
description = "Use information from xdebug";
files = lines_coverage +> List.map (fun (file, lines_cover) ->
let covered = lines_cover.Coverage_code.covered_sites in
let all = lines_cover.Coverage_code.all_sites in
let not_covered = Common2.minus_set all covered in
let percent =
try
Common2.pourcent_good_bad
(List.length covered) (List.length not_covered)
with Division_by_zero -> 0
in
file,
{ Layer_code.
micro_level =
(covered +> List.map (fun line -> line, "ok")) @
(not_covered +> List.map (fun line -> line, "bad"))
;
macro_level = [
(match percent with
| 0 -> "no_info"
| n when n < 50 -> "bad"
| _ -> "ok"
),
1.
];
}
);
kinds = Layer_code.red_green_properties;
}
(* mostly a copy paste of gen_red_green_layer *)
let gen_heatmap_layer lines_coverage =
{ Layer_code.
title = "Test coverage (heatmap)";
description = "Use information from xdebug";
files = lines_coverage +> List.map (fun (file, lines_cover) ->
let covered = lines_cover.Coverage_code.covered_sites in
let all = lines_cover.Coverage_code.all_sites in
let not_covered = Common2.minus_set all covered in
let percent =
try
Common2.pourcent_good_bad
(List.length covered) (List.length not_covered)
with Division_by_zero -> 0
in
file,
{ Layer_code.
micro_level =
(covered +> List.map (fun line -> line, "ok")) @
(not_covered +> List.map (fun line -> line, "bad"))
;
macro_level = [
(let percent_round = (percent / 10) * 10 in
spf "cover %d%%" percent_round
),
1.
];
}
);
kinds = Layer_code.heat_map_properties;
}
(*****************************************************************************)
(* Actions *)
(*****************************************************************************)
let actions () = [
"-gen_red_green_coverage_layer", " <json> <output>",
Common.mk_action_2_arg (fun jsonfile output ->
let cover = Coverage_code.load_lines_coverage jsonfile in
let layer = gen_red_green_layer cover in
Layer_code.save_layer layer output
);
"-gen_heatmap_coverage_layer", " <json> <output>",
Common.mk_action_2_arg (fun jsonfile output ->
let cover = Coverage_code.load_lines_coverage jsonfile in
let layer = gen_heatmap_layer cover in
Layer_code.save_layer layer output
);
]

9
h_program-lang/layer_coverage.mli Normal file
View file

@ -0,0 +1,9 @@
val gen_red_green_layer:
Coverage_code.lines_coverage -> Layer_code.layer
val gen_heatmap_layer:
Coverage_code.lines_coverage -> Layer_code.layer
val actions : unit -> Common.cmdline_actions

101
h_program-lang/layer_parse_errors.ml Normal file
View file

@ -0,0 +1,101 @@
(* 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 Parse_info
(*****************************************************************************)
(* Prelude *)
(*****************************************************************************)
(*****************************************************************************)
(* Types *)
(*****************************************************************************)
(* todo: do some generic red_green_and_heatmap helpers? so can factorize
* code with layer_coverage.ml
*)
(*****************************************************************************)
(* Helper *)
(*****************************************************************************)
(*****************************************************************************)
(* Main entry point *)
(*****************************************************************************)
let gen_red_green_layer ~root stats =
let root = Common2.relative_to_absolute root in
{ Layer_code.
title = "Parsing errors (red/green)";
description = "";
files = stats +> List.map (fun stat ->
let file =
stat.filename +> Common2.relative_to_absolute +> Common.readable ~root
in
file,
{ Layer_code.
micro_level = []; (* TODO use problematic_lines *)
macro_level = [
(if stat.bad > 0
then "bad"
else "ok"
), 1.
];
}
);
kinds = Layer_code.red_green_properties;
}
let gen_heatmap_layer ~root stats =
let root = Common2.relative_to_absolute root in
{ Layer_code.
title = "Parsing errors (heatmap)";
description = "lower is better";
files = stats +> List.map (fun stat ->
let file =
stat.filename +> Common2.relative_to_absolute +> Common.readable ~root
in
let covered = stat.correct in
let not_covered = stat.bad in
let percent =
try
Common2.pourcent_good_bad not_covered covered
with Division_by_zero -> 0
in
file,
{ Layer_code.
micro_level =
stat.problematic_lines +> List.map (fun (_strs, lineno) ->
lineno, "bad"
);
macro_level = [
(let percent_round = (percent / 10) * 10 in
spf "cover %d%%" percent_round
),
1.
];
}
);
kinds = Layer_code.heat_map_properties;
}

7
h_program-lang/layer_parse_errors.mli Normal file
View file

@ -0,0 +1,7 @@
val gen_red_green_layer:
root:Common.dirname -> Parse_info.parsing_stat list -> Layer_code.layer
val gen_heatmap_layer:
root:Common.dirname -> Parse_info.parsing_stat list -> Layer_code.layer

520
h_program-lang/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!

11
h_program-lang/meta_ast_generic.ml Normal file
View file

@ -0,0 +1,11 @@
type precision = {
full_info: bool;
token_info: bool;
type_info: bool;
}
let default_precision = {
full_info = false;
token_info = false;
type_info = false;
}

7
h_program-lang/meta_ast_generic.mli Normal file
View file

@ -0,0 +1,7 @@
type precision = {
full_info: bool;
token_info: bool;
type_info: bool;
}
val default_precision: precision

223
h_program-lang/overlay_code.ml Normal file
View file

@ -0,0 +1,223 @@
(* Yoann Padioleau
*
* Copyright (C) 2011 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 *)
(*****************************************************************************)
(*
* Some code organizations are really bad. But because it's harder
* to convince people to change it, sometimes it's simpler to create
* a parallel organization, an "overlay" using simple symlinks
* that represent a better organization. One can then show
* statistics on those overlayed code organization, adapt layers,
* etc
*
* related: LFS on code.
*)
(*****************************************************************************)
(* Types *)
(*****************************************************************************)
type overlay = {
(* the filenames are in a readable path format *)
orig_to_overlay: (Common.filename, Common.filename) Hashtbl.t;
overlay_to_orig: (Common.filename, Common.filename) Hashtbl.t;
data: (Common.filename (* overlay *) * Common.filename) list;
(* in realpath format. This information is then specific
* to one user ... but infering back the root_orig/root_overlay
* from an arbitrary directory can be tedious.
*)
root_orig: Common.dirname;
root_overlay: Common.dirname;
}
(*****************************************************************************)
(* IO *)
(*****************************************************************************)
let load_overlay file =
Common2.get_value file
let save_overlay overlay file =
Common2.write_value overlay file
(*****************************************************************************)
(* Check consistency *)
(*****************************************************************************)
let check_overlay ~dir_orig ~dir_overlay =
let dir_orig = Common.fullpath dir_orig in
let files =
Common.files_of_dir_or_files_no_vcs_nofilter [dir_orig]
+> Common.exclude (fun file -> file =~ ".*/OVERLAY/.*")
in
let dir_overlay = Common.fullpath dir_overlay in
let links =
Common.cmd_to_list (spf "find %s -type l" dir_overlay) in
let links = links +> Common.map_filter (fun file ->
try Some (Common.fullpath file)
with Failure s ->
pr2 s;
None
)
in
let files2 =
links +> List.map (fun file_or_dir ->
Common.files_of_dir_or_files_no_vcs_nofilter [file_or_dir]
) +> List.flatten
in
pr2 (spf "#files orig = %d, #links overlay = %d, #files overlay = %d"
(List.length files) (List.length links) (List.length files2)
);
let h = Hashtbl.create 101 in
files2 +> List.iter (fun file ->
if Hashtbl.mem h file
then pr2 (spf "this one is a dupe: %s" file);
Hashtbl.add h file true;
);
let (_common, only_in_orig, only_in_overlay) =
Common2.diff_set_eff files files2 in
only_in_orig +> List.iter (fun l ->
pr2 (spf "this one is missing: %s" l);
);
only_in_overlay +> List.iter (fun l ->
pr2 (spf "this one is gone now: %s" l);
);
if not (null only_in_orig && null only_in_overlay)
then failwith "Overlay is not OK"
else pr2 "Overlay is OK"
(*****************************************************************************)
(* Generate equivalences *)
(*****************************************************************************)
let overlay_equivalences ~dir_orig ~dir_overlay =
let dir_overlay = Common.fullpath dir_overlay in
let dir_orig = Common.fullpath dir_orig in
let links =
Common.cmd_to_list (spf "find %s -type l" dir_overlay) in
let equiv =
links +> List.map (fun link ->
let stat = Common2.unix_stat_eff link in
match stat.Unix.st_kind with
| Unix.S_DIR ->
let (children, _) =
Common2.cmd_to_list_and_status (spf
"cd %s; find * -type f" (link)) in
let dir = Common.fullpath link in
children +> List.map (fun child ->
let overlay = Filename.concat link child in
let orig = Filename.concat dir child in
overlay, orig
)
| Unix.S_REG ->
[(link, Common.fullpath link)]
| _ ->
[]
) +> List.flatten
in
let data =
equiv +> Common.map_filter (fun (overlay, orig) ->
try
Some (
Common.readable ~root:dir_overlay overlay,
Common.readable ~root:dir_orig orig
)
with exn ->
pr2 (spf "PB with %s, exn = %s" orig (Common.exn_to_s exn));
None
)
in
{
data = data;
overlay_to_orig = Common.hash_of_list data;
orig_to_overlay = Common.hash_of_list (data +> List.map Common2.swap);
root_overlay = dir_overlay;
root_orig = dir_orig;
}
let gen_overlay ~dir_orig ~dir_overlay ~output =
let equiv = overlay_equivalences ~dir_orig ~dir_overlay in
equiv.data +> List.iter pr2_gen;
save_overlay equiv output
(*****************************************************************************)
(* Adapt layer *)
(*****************************************************************************)
let adapt_layer layer overlay =
{ layer with Layer_code.
files = layer.Layer_code.files +> Common.map_filter (fun (file, info) ->
try
Some (Hashtbl.find overlay.orig_to_overlay file, info)
with Not_found ->
pr2 (spf "PB could not find %s in overlay" file);
None
);
}
(* copy paste of the one in main_codemap.ml *)
let layers_in_dir dir =
Common2.readdir_to_file_list dir +> Common.map_filter (fun file ->
if file =~ "layer.*marshall"
then Some (Filename.concat dir file)
else None
)
let adapt_layers ~overlay ~dir_layers_orig ~dir_layers_overlay =
let layers = layers_in_dir dir_layers_orig in
layers +> List.iter (fun layer_filename ->
pr2 (spf "processing %s" layer_filename);
let layer = Layer_code.load_layer layer_filename in
let layer' = adapt_layer layer overlay in
Layer_code.save_layer layer'
(Filename.concat dir_layers_overlay (Common2.basename layer_filename))
)
(*****************************************************************************)
(* Adapt database code *)
(*****************************************************************************)
let adapt_database db overlay =
{ db with Database_code.
files = db.Database_code.files +> Common.map_filter (fun (file, info) ->
try
Some (Hashtbl.find overlay.orig_to_overlay file, info)
with Not_found ->
pr2 (spf "PB could not find %s in overlay" file);
None
);
entities = db.Database_code.entities +> Array.map (fun e ->
{ e with Database_code.
e_file =
try
(Hashtbl.find overlay.orig_to_overlay e.Database_code.e_file)
with Not_found ->
"not_found_file_overlay";
}
);
}

36
h_program-lang/overlay_code.mli Normal file
View file

@ -0,0 +1,36 @@
type overlay = {
(* the filenames are in a readable path format *)
orig_to_overlay: (Common.filename, Common.filename) Hashtbl.t;
overlay_to_orig: (Common.filename, Common.filename) Hashtbl.t;
data: (Common.filename (* overlay *) * Common.filename) list;
(* in realpath format *)
root_orig: Common.dirname;
root_overlay: Common.dirname;
}
val overlay_equivalences:
dir_orig:Common.dirname -> dir_overlay:Common.dirname ->
overlay
val adapt_layer:
Layer_code.layer -> overlay -> Layer_code.layer
val adapt_database:
Database_code.database -> overlay -> Database_code.database
val load_overlay: Common.filename -> overlay
val save_overlay: overlay -> Common.filename -> unit
val check_overlay:
dir_orig:Common.dirname -> dir_overlay:Common.dirname -> unit
val gen_overlay:
dir_orig:Common.dirname -> dir_overlay:Common.dirname ->
output:Common.filename -> unit
val adapt_layers:
overlay:overlay ->
dir_layers_orig:Common.dirname -> dir_layers_overlay:Common.dirname ->
unit

992
h_program-lang/parse_info.ml Normal file
View file

@ -0,0 +1,992 @@
(* 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 *)
(*****************************************************************************)
(*
* Some helpers for the different lexers and parsers in pfff.
* The main types are:
* ('token_location' < 'token_origin' < 'token_mutable') * token_kind
*
*)
(*****************************************************************************)
(* Types *)
(*****************************************************************************)
(* Currently core/lexing.ml does not handle the line number position.
* Even if there are certain fields in the lexing structure, they are not
* maintained by the lexing engine so the following code does not work:
*
* let pos = Lexing.lexeme_end_p lexbuf in
* sprintf "at file %s, line %d, char %d" pos.pos_fname pos.pos_lnum
* (pos.pos_cnum - pos.pos_bol) in
*
* Hence those types and functions below to overcome the previous limitation,
* (see especially complete_token_location_large()).
*)
type token_location = {
str: string;
charpos: int;
line: int;
column: int;
file: filename;
}
(* with tarzan *)
let fake_token_location = {
charpos = -1; str = ""; line = -1; column = -1; file = "";
}
type token_origin =
(* Present both in the AST and list of tokens *)
| OriginTok of token_location
(* Present only in the AST and generated after parsing. Can be used
* when building some extra AST elements. *)
| FakeTokStr of string (* to help the generic pretty printer *) *
(* Sometimes we generate fake tokens close to existing
* origin tokens. This can be useful when have to give an error
* message that involves a fakeToken. The int is a kind of
* virtual position, an offset. See compare_pos below.
*)
(token_location * int) option
(* In the case of a XHP file, we could preprocess it and incorporate
* the tokens of the preprocessed code with the tokens from
* the original file. We want to mark those "expanded" tokens
* with a special tag so that if someone do some transformation on
* those expanded tokens they will get a warning (because we may have
* trouble back-propagating the transformation back to the original file).
*)
| ExpandedTok of
(* refers to the preprocessed file, e.g. /tmp/pp-xxxx.pphp *)
token_location *
(* kind of virtual position. This info refers to the last token
* before a serie of expanded tokens and the int is an offset.
* The goal is to be able to compare the position of tokens
* between then, even for expanded tokens. See compare_pos
* below.
*)
token_location * int
(* The Ab constructor is (ab)used to call '=' to compare
* big AST portions. Indeed as we keep the token information in the AST,
* if we have an expression in the code like "1+1" and want to test if
* it's equal to another code like "1+1" located elsewhere, then
* the Pervasives.'=' of OCaml will not return true because
* when it recursively goes down to compare the leaf of the AST, that is
* the token_location, there will be some differences of positions. If instead
* all leaves use Ab, then there is no position information and we can
* use '='. See also the 'al_info' function below.
*
* Ab means AbstractLineTok. I Use a short name to not
* polluate in debug mode.
*)
| Ab
(* with tarzan *)
type token_mutable = {
(* contains among other things the position of the token through
* the token_location embedded inside the token_origin type.
*)
token : token_origin;
mutable transfo: transformation;
(* less: mutable comments: ...; *)
}
(* poor's man refactoring *)
and transformation =
| NoTransfo
| Remove
| AddBefore of add
| AddAfter of add
| Replace of add
| AddArgsBefore of string list
and add =
| AddStr of string
| AddNewlineAndIdent
(* with tarzan *)
type token_kind =
(* for the fuzzy parser and sgrep/spatch fuzzy AST *)
| LPar
| RPar
| LBrace
| RBrace
(* for the unparser helpers in spatch, and to filter
* irrelevant tokens in the fuzzy parser
*)
| Esthet of esthet
(* mostly for the lexer helpers, and for fuzzy parser *)
(* less: want to factorize all those TH.is_eof to use that?
* but extra cost? same for TH.is_comment?
* todo: could maybe get rid of that now that we don't really use
* berkeley DB and prefer Prolog, and so we don't need a sentinel
* ast elements to associate the comments with it
*)
| Eof
| Other
and esthet =
| Comment
| Newline
| Space
(* shortcut *)
type info = token_mutable
type parsing_stat = {
filename: Common.filename;
mutable correct: int;
mutable bad: int;
(* used only for cpp for now *)
mutable have_timeout: bool;
(* by our cpp commentizer *)
mutable commentized: int;
(* if want to know exactly what was passed through, uncomment:
*
* mutable passing_through_lines: int;
*
* it differs from bad by starting from the error to
* the synchro point instead of starting from start of
* function to end of function.
*)
(* for instance to report most problematic macros when parse c/c++ *)
mutable problematic_lines:
(string list (* ident in error line *) * int (* line_error *)) list;
}
let default_stat file = {
filename = file;
have_timeout = false;
correct = 0; bad = 0;
commentized = 0;
problematic_lines = [];
}
(* Many parsers need to interact with the lexer, or use tricks around
* the stream of tokens, or do some error recovery, or just need to
* pass certain tokens (like the comments token) which requires
* to have access to this stream of remaining tokens.
* The token_state type helps.
*)
type 'tok tokens_state = {
mutable rest: 'tok list;
mutable current: 'tok;
(* it's passed since last "checkpoint", not passed from the beginning *)
mutable passed: 'tok list;
(* if want to do some lalr(k) hacking ... cf yacfe.
* mutable passed_clean : 'tok list;
* mutable rest_clean : 'tok list;
*)
}
let mk_tokens_state toks = {
rest = toks;
current = (List.hd toks);
passed = [];
(* passed_clean = [];
* rest_clean = (toks +> List.filter TH.is_not_comment);
*)
}
(*****************************************************************************)
(* Lexer helpers *)
(*****************************************************************************)
let lexbuf_to_strpos lexbuf =
(Lexing.lexeme lexbuf, Lexing.lexeme_start lexbuf)
let tokinfo_str_pos str pos =
{
token = OriginTok {
charpos = pos;
str = str;
(* info filled in a post-lexing phase, see complete_token_location_large*)
line = -1;
column = -1;
file = "";
};
transfo = NoTransfo;
}
(*
val rewrap_token_location : token_location.token_location -> info -> info
let rewrap_token_location pi ii =
{ii with pinfo =
(match ii.pinfo with
| OriginTok _oldpi -> OriginTok pi
| FakeTokStr _ | Ab | ExpandedTok _ ->
failwith "rewrap_parseinfo: no OriginTok"
)
}
*)
let token_location_of_info ii =
match ii.token with
| OriginTok pinfo -> pinfo
(* TODO ? dangerous ? *)
| ExpandedTok (pinfo_pp, _pinfo_orig, _offset) -> pinfo_pp
| FakeTokStr (_, (Some (pi, _))) -> pi
| FakeTokStr (_, None)
| Ab
-> failwith "token_location_of_info: no OriginTok"
(* for error reporting *)
(*
let string_of_token_location x =
spf "%s at %s:%d:%d" x.str x.file x.line x.column
*)
let string_of_token_location x =
spf "%s:%d:%d" x.file x.line x.column
let string_of_info x =
string_of_token_location (token_location_of_info x)
let str_of_info ii = (token_location_of_info ii).str
let file_of_info ii = (token_location_of_info ii).file
let line_of_info ii = (token_location_of_info ii).line
let col_of_info ii = (token_location_of_info ii).column
(* todo: return a Real | Virt position ? *)
let pos_of_info ii = (token_location_of_info ii).charpos
let pinfo_of_info ii = ii.token
let is_origintok ii =
match ii.token with
| OriginTok _ -> true
| _ -> false
(*
let opos_of_info ii =
PI.get_orig_info (function x -> x.PI.charpos) ii
val pos_of_tok : Parser_cpp.token -> int
val str_of_tok : Parser_cpp.token -> string
val file_of_tok : Parser_cpp.token -> Common.filename
let pos_of_tok x = Ast.opos_of_info (info_of_tok x)
let str_of_tok x = Ast.str_of_info (info_of_tok x)
let file_of_tok x = Ast.file_of_info (info_of_tok x)
let pinfo_of_tok x = Ast.pinfo_of_info (info_of_tok x)
val is_origin : Parser_cpp.token -> bool
val is_expanded : Parser_cpp.token -> bool
val is_fake : Parser_cpp.token -> bool
val is_abstract : Parser_cpp.token -> bool
let is_origin x =
match pinfo_of_tok x with Parse_info.OriginTok _ -> true | _ -> false
let is_expanded x =
match pinfo_of_tok x with Parse_info.ExpandedTok _ -> true | _ -> false
let is_fake x =
match pinfo_of_tok x with Parse_info.FakeTokStr _ -> true | _ -> false
let is_abstract x =
match pinfo_of_tok x with Parse_info.Ab -> true | _ -> false
*)
(* info about the current location *)
(*
let get_pi = function
| OriginTok pi -> pi
| ExpandedTok (_,pi,_) -> pi
| FakeTokStr (_,(Some (pi,_))) -> pi
| FakeTokStr (_,None) ->
failwith "FakeTokStr None"
| Ab ->
failwith "Ab"
*)
(* original info *)
let get_original_token_location = function
| OriginTok pi -> pi
| ExpandedTok (pi,_, _) -> pi
| FakeTokStr (_,_) -> failwith "no position information"
| Ab -> failwith "Ab"
(* used by token_helpers *)
(*
let get_info f ii =
match ii.token with
| OriginTok pi -> f pi
| ExpandedTok (_,pi,_) -> f pi
| FakeTokStr (_,Some (pi,_)) -> f pi
| FakeTokStr (_,None) ->
failwith "FakeTokStr None"
| Ab ->
failwith "Ab"
*)
(*
let get_orig_info f ii =
match ii.token with
| OriginTok pi -> f pi
| ExpandedTok (pi,_, _) -> f pi
| FakeTokStr (_,Some (pi,_)) -> f pi
| FakeTokStr (_,None ) ->
failwith "FakeTokStr None"
| Ab ->
failwith "Ab"
*)
(* not used but used to be useful in coccinelle *)
type posrv =
| Real of token_location
| Virt of
token_location (* last real info before expanded tok *) *
int (* virtual offset *)
let compare_pos ii1 ii2 =
let get_pos = function
| OriginTok pi -> Real pi
(* todo? I have this for lang_php/
| FakeTokStr (s, Some (pi_orig, offset)) ->
Virt (pi_orig, offset)
*)
| FakeTokStr _
| Ab
-> failwith "get_pos: Ab or FakeTok"
| ExpandedTok (_pi_pp, pi_orig, offset) ->
Virt (pi_orig, offset)
in
let pos1 = get_pos (pinfo_of_info ii1) in
let pos2 = get_pos (pinfo_of_info ii2) in
match (pos1,pos2) with
| (Real p1, Real p2) ->
compare p1.charpos p2.charpos
| (Virt (p1,_), Real p2) ->
if (compare p1.charpos p2.charpos) =|= (-1)
then (-1)
else 1
| (Real p1, Virt (p2,_)) ->
if (compare p1.charpos p2.charpos) =|= 1
then 1
else (-1)
| (Virt (p1,o1), Virt (p2,o2)) ->
let poi1 = p1.charpos in
let poi2 = p2.charpos in
match compare poi1 poi2 with
| -1 -> -1
| 0 -> compare o1 o2
| 1 -> 1
| _ -> raise Impossible
let min_max_ii_by_pos xs =
match xs with
| [] -> failwith "empty list, max_min_ii_by_pos"
| [x] -> (x, x)
| x::xs ->
let pos_leq p1 p2 = (compare_pos p1 p2) =|= (-1) in
xs +> List.fold_left (fun (minii,maxii) e ->
let maxii' = if pos_leq maxii e then e else maxii in
let minii' = if pos_leq e minii then e else minii in
minii', maxii'
) (x,x)
(*
let mk_info_item2 ~info_of_tok toks =
let buf = Buffer.create 100 in
let s =
(* old: get_slice_file filename (line1, line2) *)
begin
toks +> List.iter (fun tok ->
let info = info_of_tok tok in
match info.token with
| OriginTok _
| ExpandedTok _ ->
Buffer.add_string buf (str_of_info info)
(* the virtual semicolon *)
| FakeTokStr _ ->
()
| Ab -> raise Impossible
);
Buffer.contents buf
end
in
(s, toks)
let mk_info_item_DEPRECATED ~info_of_tok a =
Common.profile_code "Parsing.mk_info_item"
(fun () -> mk_info_item2 ~info_of_tok a)
*)
(*
I used to have:
type program2 = toplevel2 list
(* the token list contains also the comment-tokens *)
and toplevel2 = Ast_php.toplevel * Parser_php.token list
type program_with_comments = program2
and a function below called distribute_info_items_toplevel that
would distribute the list of tokens to each toplevel entity.
This was when I was storing parts of AST in berkeley DB and when
I wanted to get some information about an entity (a function, a class)
I wanted to get the list also of tokens associated with that entity.
Now I just have
type program_and_tokens = Ast_php.program * Parser_php.token list
because I don't use berkeley DB. I use codegraph and an entity_finder
we just focus on use/def and does not store huge asts on disk.
let rec distribute_info_items_toplevel2 xs toks filename =
match xs with
| [] -> raise Impossible
| [Ast_php.FinalDef e] ->
(* assert (null toks) ??? no cos can have whitespace tokens *)
let info_item = toks in
[Ast_php.FinalDef e, info_item]
| ast::xs ->
(match ast with
| Ast_js.St (Ast_js.Nop None) ->
distribute_info_items_toplevel2 xs toks filename
| _ ->
let ii = Lib_parsing_php.ii_of_any (Ast.Toplevel ast) in
(* ugly: I use a fakeInfo for lambda f_name, so I have
* have to filter the abstract info here
*)
let ii = List.filter PI.is_origintok ii in
let (min, max) = PI.min_max_ii_by_pos ii in
let toks_before_max, toks_after =
(* on very huge file, this function was previously segmentation fault
* in native mode because span was not tail call
*)
Common.profile_code "spanning tokens" (fun () ->
toks +> Common2.span_tail_call (fun tok ->
match PI.compare_pos (TH.info_of_tok tok) max with
| -1 | 0 -> true
| 1 -> false
| _ -> raise Impossible
))
in
let info_item = toks_before_max in
(ast, info_item)::distribute_info_items_toplevel2 xs toks_after filename
let distribute_info_items_toplevel a b c =
Common.profile_code "distribute_info_items" (fun () ->
distribute_info_items_toplevel2 a b c
)
*)
let rewrap_str s ii =
{ii with token =
(match ii.token with
| OriginTok pi -> OriginTok { pi with str = s;}
| FakeTokStr (s, info) -> FakeTokStr (s, info)
| Ab -> Ab
| ExpandedTok _ ->
(* ExpandedTok ({ pi with Common.str = s;},vpi) *)
failwith "rewrap_str: ExpandedTok not allowed here"
)
}
let tok_add_s s ii =
rewrap_str ((str_of_info ii) ^ s) ii
(*****************************************************************************)
(* vtoken -> ocaml *)
(*****************************************************************************)
let vof_filename v = Ocaml.vof_string v
let vof_token_location {
str = v_str;
charpos = v_charpos;
line = v_line;
column = v_column;
file = v_file
} =
let bnds = [] in
let arg = vof_filename v_file in
let bnd = ("file", arg) in
let bnds = bnd :: bnds in
let arg = Ocaml.vof_int v_column in
let bnd = ("column", arg) in
let bnds = bnd :: bnds in
let arg = Ocaml.vof_int v_line in
let bnd = ("line", arg) in
let bnds = bnd :: bnds in
let arg = Ocaml.vof_int v_charpos in
let bnd = ("charpos", arg) in
let bnds = bnd :: bnds in
let arg = Ocaml.vof_string v_str in
let bnd = ("str", arg) in let bnds = bnd :: bnds in Ocaml.VDict bnds
let vof_token_origin =
function
| OriginTok v1 ->
let v1 = vof_token_location v1 in Ocaml.VSum (("OriginTok", [ v1 ]))
| FakeTokStr (v1, opt) ->
let v1 = Ocaml.vof_string v1 in
let opt = Ocaml.vof_option (fun (p1, i) ->
Ocaml.VTuple [vof_token_location p1; Ocaml.vof_int i]
) opt
in
Ocaml.VSum (("FakeTokStr", [ v1; opt ]))
| Ab -> Ocaml.VSum (("Ab", []))
| ExpandedTok (v1, v2, v3) ->
let v1 = vof_token_location v1 in
let v2 = vof_token_location v2 in
let v3 = Ocaml.vof_int v3 in
Ocaml.VSum (("ExpandedTok", [ v1; v2; v3 ]))
let rec vof_transformation =
function
| NoTransfo -> Ocaml.VSum (("NoTransfo", []))
| Remove -> Ocaml.VSum (("Remove", []))
| AddBefore v1 -> let v1 = vof_add v1 in Ocaml.VSum (("AddBefore", [ v1 ]))
| AddAfter v1 -> let v1 = vof_add v1 in Ocaml.VSum (("AddAfter", [ v1 ]))
| Replace v1 -> let v1 = vof_add v1 in Ocaml.VSum (("Replace", [ v1 ]))
| AddArgsBefore v1 -> let v1 = Ocaml.vof_list Ocaml.vof_string v1 in Ocaml.VSum
(("AddArgsBefore", [ v1 ]))
and vof_add =
function
| AddStr v1 ->
let v1 = Ocaml.vof_string v1 in Ocaml.VSum (("AddStr", [ v1 ]))
| AddNewlineAndIdent -> Ocaml.VSum (("AddNewlineAndIdent", []))
let vof_info
{ token = v_token; transfo = v_transfo } =
let bnds = [] in
let arg = vof_transformation v_transfo in
let bnd = ("transfo", arg) in
let bnds = bnd :: bnds in
let arg = vof_token_origin v_token in
let bnd = ("token", arg) in
let bnds = bnd :: bnds in
Ocaml.VDict bnds
(*****************************************************************************)
(* Error location report *)
(*****************************************************************************)
(* A changen is a stand-in for a file for the underlying code. We use
* channels in the underlying parsing code as this avoids loading
* potentially very large source files directly into memory before we
* even parse them, but this makes it difficult to parse small chunks of
* code. The changen works around this problem by providing a channel,
* size and source for underlying data. This allows us to wrap a string
* in a channel, or pass a file, depending on our needs.
*)
type changen = unit -> (in_channel * int * Common.filename)
(* Many functions in parse_php were implemented in terms of files and
* are now adapted to work in terms of changens. However, we wish to
* provide the original API to users. This wraps changen-based functions
* and makes them operate on filenames again.
*)
let file_wrap_changen : (changen -> 'a) -> (Common.filename -> 'a) = fun f ->
(fun file ->
f (fun () -> (open_in file, Common2.filesize file, file)))
(*
let full_charpos_to_pos_from_changen changen =
let (chan, chansize, _) = changen () in
let size = (chansize + 2) in
let arr = Array.create size (0,0) in
let charpos = ref 0 in
let line = ref 0 in
let rec full_charpos_to_pos_aux () =
try
let s = (input_line chan) in
incr line;
(* '... +1 do' cos input_line dont return the trailing \n *)
for i = 0 to (String.length s - 1) + 1 do
arr.(!charpos + i) <- (!line, i);
done;
charpos := !charpos + String.length s + 1;
full_charpos_to_pos_aux();
with End_of_file ->
for i = !charpos to Array.length arr - 1 do
arr.(i) <- (!line, 0);
done;
();
in
begin
full_charpos_to_pos_aux ();
close_in chan;
arr
end
let full_charpos_to_pos2 = file_wrap_changen full_charpos_to_pos_from_changen
let full_charpos_to_pos a =
profile_code "Common.full_charpos_to_pos" (fun () -> full_charpos_to_pos2 a)
*)
(*
let test_charpos file =
full_charpos_to_pos file +> Common2.dump +> pr2
*)
(*
let complete_token_location filename table x =
{ x with
file = filename;
line = fst (table.(x.charpos));
column = snd (table.(x.charpos));
}
*)
let full_charpos_to_pos_large_from_changen = fun changen ->
let (chan, chansize, _) = changen () in
let size = (chansize + 2) in
(* old: let arr = Array.create size (0,0) in *)
let arr1 = Bigarray.Array1.create
Bigarray.int Bigarray.c_layout size in
let arr2 = Bigarray.Array1.create
Bigarray.int Bigarray.c_layout size in
Bigarray.Array1.fill arr1 0;
Bigarray.Array1.fill arr2 0;
let charpos = ref 0 in
let line = ref 0 in
let full_charpos_to_pos_aux () =
try
while true do begin
let s = (input_line chan) in
incr line;
(* '... +1 do' cos input_line dont return the trailing \n *)
for i = 0 to (String.length s - 1) + 1 do
(* old: arr.(!charpos + i) <- (!line, i); *)
arr1.{!charpos + i} <- (!line);
arr2.{!charpos + i} <- i;
done;
charpos := !charpos + String.length s + 1;
end done
with End_of_file ->
for i = !charpos to (* old: Array.length arr *)
Bigarray.Array1.dim arr1 - 1 do
(* old: arr.(i) <- (!line, 0); *)
arr1.{i} <- !line;
arr2.{i} <- 0;
done;
();
in
begin
full_charpos_to_pos_aux ();
close_in chan;
(fun i -> arr1.{i}, arr2.{i})
end
let full_charpos_to_pos_large2 =
file_wrap_changen full_charpos_to_pos_large_from_changen
let full_charpos_to_pos_large a =
profile_code "Common.full_charpos_to_pos_large"
(fun () -> full_charpos_to_pos_large2 a)
let complete_token_location_large filename table x =
{ x with
file = filename;
line = fst (table (x.charpos));
column = snd (table (x.charpos));
}
(*---------------------------------------------------------------------------*)
(* return line x col x str_line from a charpos. This function is quite
* expensive so don't use it to get the line x col from every token in
* a file. Instead use full_charpos_to_pos.
*)
let (info_from_charpos2: int -> filename -> (int * int * string)) =
fun charpos filename ->
(* Currently lexing.ml does not handle the line number position.
* Even if there is some fields in the lexing structure, they are not
* maintained by the lexing engine :( So the following code does not work:
* let pos = Lexing.lexeme_end_p lexbuf in
* sprintf "at file %s, line %d, char %d" pos.pos_fname pos.pos_lnum
* (pos.pos_cnum - pos.pos_bol) in
* Hence this function to overcome the previous limitation.
*)
let chan = open_in filename in
let linen = ref 0 in
let posl = ref 0 in
let rec charpos_to_pos_aux last_valid =
let s =
try Some (input_line chan)
with End_of_file when charpos =|= last_valid -> None in
incr linen;
match s with
Some s ->
let s = s ^ "\n" in
if (!posl + String.length s > charpos)
then begin
close_in chan;
(!linen, charpos - !posl, s)
end
else begin
posl := !posl + String.length s;
charpos_to_pos_aux !posl;
end
| None -> (!linen, charpos - !posl, "\n")
in
let res = charpos_to_pos_aux 0 in
close_in chan;
res
let info_from_charpos a b =
profile_code "Common.info_from_charpos" (fun () -> info_from_charpos2 a b)
(* Decalage is here to handle stuff such as cpp which include file and who
* can make shift.
*)
let (error_messagebis: filename -> (string * int) -> int -> string)=
fun filename (lexeme, lexstart) decalage ->
let charpos = lexstart + decalage in
let tok = lexeme in
let (line, pos, linecontent) = info_from_charpos charpos filename in
spf "File \"%s\", line %d, column %d, charpos = %d
around = '%s', whole content = %s"
filename line pos charpos tok (Common2.chop linecontent)
let error_message = fun filename (lexeme, lexstart) ->
try error_messagebis filename (lexeme, lexstart) 0
with
End_of_file ->
("PB in Common.error_message, position " ^ i_to_s lexstart ^
" given out of file:" ^ filename)
let error_message_token_location = fun info ->
let filename = info.file in
let lexeme = info.str in
let lexstart = info.charpos in
try error_messagebis filename (lexeme, lexstart) 0
with
End_of_file ->
("PB in Common.error_message, position " ^ i_to_s lexstart ^
" given out of file:" ^ filename)
let error_message_info info =
let pinfo = token_location_of_info info in
error_message_token_location pinfo
(*
let error_message_short = fun filename (lexeme, lexstart) ->
try
let charpos = lexstart in
let (line, pos, linecontent) = info_from_charpos charpos filename in
spf "File \"%s\", line %d" filename line
with End_of_file ->
begin
("PB in Common.error_message, position " ^ i_to_s lexstart ^
" given out of file:" ^ filename);
end
*)
let print_bad line_error (start_line, end_line) filelines =
begin
pr2 ("badcount: " ^ i_to_s (end_line - start_line));
for i = start_line to end_line do
let line = filelines.(i) in
if i =|= line_error
then pr2 ("BAD:!!!!!" ^ " " ^ line)
else pr2 ("bad:" ^ " " ^ line)
done
end
(*****************************************************************************)
(* Parsing statistics *)
(*****************************************************************************)
(* todo: stat per dir ? give in terms of func_or_decl numbers:
* nbfunc_or_decl pbs / nbfunc_or_decl total ?/
*
* note: cela dit si y'a des fichiers avec des #ifdef dont on connait pas les
* valeurs alors on parsera correctement tout le fichier et pourtant y'aura
* aucune def et donc aucune couverture en fait.
* ==> TODO evaluer les parties non parsé ?
*)
let print_parsing_stat_list ?(verbose=false)statxs =
(* old:
let total = List.length statxs in
let perfect =
statxs
+> List.filter (function
| {bad = n; _} when n = 0 -> true
| _ -> false)
+> List.length
in
pr2 "\n\n\n---------------------------------------------------------------";
pr2 (
(spf "NB total files = %d; " total) ^
(spf "perfect = %d; " perfect) ^
(spf "=========> %d" ((100 * perfect) / total)) ^ "%"
);
let good = statxs +> List.fold_left (fun acc {correct = x; _} -> acc+x) 0 in
let bad = statxs +> List.fold_left (fun acc {bad = x; _} -> acc+x) 0 in
let gf, badf = float_of_int good, float_of_int bad in
pr2 (
(spf "nb good = %d, nb bad = %d " good bad) ^
(spf "=========> %f" (100.0 *. (gf /. (gf +. badf))) ^ "%"
)
)
*)
let total = (List.length statxs) in
let perfect =
statxs
+> List.filter (function
{have_timeout = false; bad = 0; _} -> true | _ -> false)
+> List.length
in
if verbose then begin
pr "\n\n\n---------------------------------------------------------------";
pr "pbs with files:";
statxs
+> List.filter (function
| {have_timeout = true; _} -> true
| {bad = n; _} when n > 0 -> true
| _ -> false)
+> List.iter (function
{filename = file; have_timeout = timeout; bad = n; _} ->
pr (file ^ " " ^ (if timeout then "TIMEOUT" else i_to_s n));
);
pr "\n\n\n";
pr "files with lots of tokens passed/commentized:";
let threshold_passed = 100 in
statxs
+> List.filter (function
| {commentized = n; _} when n > threshold_passed -> true
| _ -> false)
+> List.iter (function
{filename = file; commentized = n; _} ->
pr (file ^ " " ^ (i_to_s n));
);
pr "\n\n\n";
end;
let good = statxs +> List.fold_left (fun acc {correct = x; _} -> acc+x) 0 in
let bad = statxs +> List.fold_left (fun acc {bad = x; _} -> acc+x) 0 in
let passed = statxs +> List.fold_left (fun acc {commentized = x; _} -> acc+x) 0
in
let total_lines = good + bad in
pr "---------------------------------------------------------------";
pr (
(spf "NB total files = %d; " total) ^
(spf "NB total lines = %d; " total_lines) ^
(spf "perfect = %d; " perfect) ^
(spf "pbs = %d; " (statxs +> List.filter (function
{bad = n; _} when n > 0 -> true | _ -> false)
+> List.length)) ^
(spf "timeout = %d; " (statxs +> List.filter (function
{have_timeout = true; _} -> true | _ -> false)
+> List.length)) ^
(spf "=========> %d" ((100 * perfect) / total)) ^ "%"
);
let gf, badf = float_of_int good, float_of_int bad in
let passedf = float_of_int passed in
pr (
(spf "nb good = %d, nb passed = %d " good passed) ^
(spf "=========> %f" (100.0 *. (passedf /. gf)) ^ "%")
);
pr (
(spf "nb good = %d, nb bad = %d " good bad) ^
(spf "=========> %f" (100.0 *. (gf /. (gf +. badf))) ^ "%"
)
)
(*****************************************************************************)
(* Most problematic tokens *)
(*****************************************************************************)
(* inspired by a comment by a reviewer of my CC'09 paper *)
let lines_around_error_line ~context (file, line) =
let arr = Common2.cat_array file in
let startl = max 0 (line - context) in
let endl = min (Array.length arr) (line + context) in
let res = ref [] in
for i = startl to endl -1 do
Common.push arr.(i) res
done;
List.rev !res
let print_recurring_problematic_tokens xs =
let h = Hashtbl.create 101 in
xs +> List.iter (fun x ->
let file = x.filename in
x.problematic_lines +> List.iter (fun (xs, line_error) ->
xs +> List.iter (fun s ->
Common2.hupdate_default s
(fun (old, example) -> old + 1, example)
(fun() -> 0, (file, line_error)) h;
)));
Common2.pr2_xxxxxxxxxxxxxxxxx();
pr2 ("maybe 10 most problematic tokens");
Common2.pr2_xxxxxxxxxxxxxxxxx();
Common.hash_to_list h
+> List.sort (fun (_k1,(v1,_)) (_k2,(v2,_)) -> compare v2 v1)
+> Common.take_safe 10
+> List.iter (fun (k,(i, (file_ex, line_ex))) ->
pr2 (spf "%s: present in %d parsing errors" k i);
pr2 ("example: ");
let lines = lines_around_error_line ~context:2 (file_ex, line_ex) in
lines +> List.iter (fun s -> pr2 (" " ^ s));
);
Common2.pr2_xxxxxxxxxxxxxxxxx();
()

124
h_program-lang/parse_info.mli Normal file
View file

@ -0,0 +1,124 @@
(* ('token_location' < 'token_origin' < 'token_mutable') * token_kind *)
(* to report errors, regular position information *)
type token_location = {
str: string; (* the content of the "token" *)
charpos: int; (* byte position *)
line: int; column: int;
file: Common.filename;
}
(* see also type filepos = { l: int; c: int; } in common.mli *)
(* to deal with expanded tokens, e.g. preprocessor like cpp for C *)
type token_origin =
| OriginTok of token_location
| FakeTokStr of string * (token_location * int) option (* next to *)
| ExpandedTok of token_location * token_location * int
| Ab (* abstract token, see parse_info.ml comment *)
(* to allow source to source transformation via token "annotations",
* see the documentation for spatch
*)
type token_mutable = {
token: token_origin;
(* for spatch *)
mutable transfo: transformation;
}
and transformation =
| NoTransfo
| Remove
| AddBefore of add
| AddAfter of add
| Replace of add
| AddArgsBefore of string list
and add =
| AddStr of string
| AddNewlineAndIdent
(* shortcut *)
type info = token_mutable
(* mostly for the fuzzy AST builder *)
type token_kind =
| LPar | RPar
| LBrace | RBrace
| Esthet of esthet
| Eof
| Other
and esthet =
| Comment
| Newline
| Space
val fake_token_location : token_location
val str_of_info : info -> string
val line_of_info : info -> int
val col_of_info : info -> int
val pos_of_info : info -> int
val file_of_info : info -> Common.filename
(* small error reporting, for longer reports use error_message above *)
val string_of_info: info -> string
(* meta *)
val vof_info: info -> Ocaml.v
val is_origintok: info -> bool
val token_location_of_info: info -> token_location
val get_original_token_location: token_origin -> token_location
val compare_pos: info -> info -> int
val min_max_ii_by_pos: info list -> info * info
type parsing_stat = {
filename: Common.filename;
mutable correct: int;
mutable bad: int;
(* used only for cpp for now *)
mutable have_timeout: bool;
mutable commentized: int;
mutable problematic_lines: (string list * int ) list;
}
val default_stat: Common.filename -> parsing_stat
val print_parsing_stat_list: ?verbose:bool -> parsing_stat list -> unit
val print_recurring_problematic_tokens: parsing_stat list -> unit
(* lexer helpers *)
type 'tok tokens_state = {
mutable rest: 'tok list;
mutable current: 'tok;
(* it's passed since last "checkpoint", not passed from the beginning *)
mutable passed: 'tok list;
}
val mk_tokens_state: 'tok list -> 'tok tokens_state
val tokinfo_str_pos:
string -> int -> info
val lexbuf_to_strpos:
Lexing.lexbuf -> string * int
val rewrap_str: string -> info -> info
val tok_add_s: string -> info -> info
(* f(i) will contain the (line x col) of the i char position *)
val full_charpos_to_pos_large:
Common.filename -> (int -> (int * int))
(* fill in the line and column field of token_location that were not set
* during lexing because of limitations of ocamllex. *)
val complete_token_location_large :
Common.filename -> (int -> (int * int)) -> token_location -> token_location
val error_message : Common.filename -> (string * int) -> string
val error_message_info : info -> string
val print_bad: int -> int * int -> string array -> unit
(* channel, size, source *)
type changen = unit -> (in_channel * int * Common.filename)
(* Create filename-arged functions from changen-type ones *)
val file_wrap_changen : (changen -> 'a) -> (Common.filename -> 'a)
val full_charpos_to_pos_large_from_changen : changen -> (int -> (int * int))

232
h_program-lang/pleac.ml Normal file
View file

@ -0,0 +1,232 @@
(* 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 *)
(*****************************************************************************)
(*
* PLEAC, the Programming Language Examples Alike Cookbook,
* is a great resource when learning a new language. This module
* provides some functions to parse pleac data and to generate
* regular code that can then be analyzed and indexed and
* then visualized like any other code.
*
* See http://pleac.sourceforge.net/
*
* Important files:
* - skeleton.sgml
* - *.data, language implementations
*)
(*****************************************************************************)
(* Types *)
(*****************************************************************************)
type code_excerpt = string list
type section = string
type comment_style =
string (* comment_start *) * string (* comment_end *)
type sections = (section, code_excerpt) Common.assoc
type skeleton =
(string (* section1 *) *
((string (* section2 title *) * section) list))
list
(*****************************************************************************)
(* Helpers *)
(*****************************************************************************)
let skip_no_heading xs =
xs +> Common.exclude (fun (s, _) -> s =$= Common2.split_list_regexp_noheading)
let mangle_to_generate_filename s =
Str.global_replace (Str.regexp "[- /.,':()]") "_" s
(*****************************************************************************)
(* Parsing *)
(*****************************************************************************)
(* ex: (* @@PLEAC@@_1.0 *), or # @@PLEAC@@_1.0 *)
let regexp_section_pleac_data = "\\(.*\\) @@PLEAC@@_\\([0-9\\.]+\\)\\(.*\\)"
let parse_data_file file =
file
+> Common.cat
+> Common2.split_list_regexp regexp_section_pleac_data +> skip_no_heading
+> List.map (fun (s, group) ->
if s =~ regexp_section_pleac_data
then
let (_, section, _) = Common.matched3 s in
section, group
else
failwith ("Pleac.parse_data_file: impossible: " ^ s)
)
let detect_comment_style file =
file
+> Common.cat
+> Common2.return_when (fun s ->
if s =~ regexp_section_pleac_data
then
let (s1, _s2, s3) = Common.matched3 s in
Some (s1, s3)
else None
)
(* ex: <sect1 id="strings" label="1"><title>Strings</title> *)
let regexp_skeleton_section1 = "<sect1 .*<title>\\(.*\\)</title>"
(* ex: <sect2><title>Short Sleeps</title> *)
let regexp_skeleton_section2 = "<sect2><title>\\(.*\\)</title>"
(* ex: PLEAC:3.9:CAELP *)
let regexp_skeleton_section_number = "PLEAC:\\(.*\\):"
(* It's a sgml file so we could parse it using pxp and then visiting it
* but using regexps is probably ok.
*)
let parse_skeleton_file file =
file
+> Common.cat
+> Common2.split_list_regexp regexp_skeleton_section1 +> skip_no_heading
+> List.map (fun (s, group) ->
if s =~ regexp_skeleton_section1
then
let section1 = Common.matched1 s in
section1,
group
+> Common2.split_list_regexp regexp_skeleton_section2 +> skip_no_heading
+> List.map (fun (s2, group) ->
if s2 =~ regexp_skeleton_section2
then
let section2 = Common.matched1 s2 in
section2,
group +> Common2.return_when (fun s3 ->
if s3 =~ regexp_skeleton_section_number
then Some (Common.matched1 s3)
else None
)
else
failwith ("Pleac.parse_data_file: impossible: " ^ s)
)
else
failwith ("Pleac.parse_data_file: impossible: " ^ s)
)
(*****************************************************************************)
(* Main entry point *)
(*****************************************************************************)
(* todo? could also split using class with sections and static methods with
* subsections. So could use M-x Pleac_Strings::TAB :)
*)
type gen_mode =
| OneFilePerSection
| OneDirPerSection
let gen_source_files
skeleton sections (comment_start, comment_end)
~gen_mode
~output_dir
~ext_file
~hook_start_section2
~hook_line_body
~hook_end_section2
=
if not (Common2.command2_y_or_no("rm -rf " ^ output_dir))
then failwith "ok we stop";
Common.command2("mkdir -p " ^ output_dir);
let hsections = Common.hash_of_list sections in
let estet_sect1 = (Common2.repeat "*" 70) +> Common.join "" in
let estet_sect2 = (Common2.repeat "-" 70) +> Common.join "" in
(match gen_mode with
| OneFilePerSection ->
skeleton +> List.iter (fun (section1, xs) ->
let file =
Filename.concat output_dir
(mangle_to_generate_filename section1) ^ "." ^ ext_file
in
Common.with_open_outfile file (fun (pr_no_nl, _chan) ->
let pr s = pr_no_nl (s ^ "\n") in
pr (spf "%s %s %s" comment_start estet_sect1 comment_end);
pr (spf "%s %s %s" comment_start section1 comment_end);
pr (spf "%s %s %s" comment_start estet_sect1 comment_end);
xs +> List.iter (fun (section2, secnumber) ->
let code_opt =
try
Some (Hashtbl.find hsections secnumber)
with Not_found ->
pr2 (spf "Section %s was not found in data file" secnumber);
None
in
pr (spf "%s %s %s" comment_start estet_sect2 comment_end);
pr (spf "%s %s %s" comment_start section2 comment_end);
pr (spf "%s %s %s" comment_start estet_sect2 comment_end);
code_opt +> Common.do_option (fun code -> code +> List.iter pr)
)
)
)
| OneDirPerSection ->
skeleton +> List.iter (fun (section1, xs) ->
let dir =
Filename.concat output_dir
(mangle_to_generate_filename section1) in
Common.command2("mkdir -p " ^ dir);
xs +> List.iter (fun (section2, secnumber) ->
let file =
Filename.concat dir
(mangle_to_generate_filename section2) ^ "." ^ ext_file in
let code_opt =
try
Some (Hashtbl.find hsections secnumber)
with Not_found ->
pr2 (spf "Section %s was not found in data file" secnumber);
None
in
code_opt +> Common.do_option (fun code ->
Common.with_open_outfile file (fun (pr_no_nl, _chan) ->
let pr s = pr_no_nl (s ^ "\n") in
pr (spf "%s %s %s" comment_start estet_sect1 comment_end);
pr (spf "%s %s %s" comment_start section2 comment_end);
pr (spf "%s %s %s" comment_start estet_sect1 comment_end);
pr (hook_start_section2 (mangle_to_generate_filename section2));
code +> List.iter (fun s ->
pr (hook_line_body s)
);
pr (hook_end_section2 (mangle_to_generate_filename section2));
)
)
)
)
)

38
h_program-lang/pleac.mli Normal file
View file

@ -0,0 +1,38 @@
(* e.g. "10.1" *)
type section = string
type code_excerpt = string list
type comment_style =
string (* comment_start *) * string (* comment_end *)
type skeleton =
(string (* section1 *) *
((string (* section2 title *) * section) list))
list
type sections = (section, code_excerpt) Common.assoc
val parse_data_file:
Common.filename -> sections
val parse_skeleton_file:
Common.filename -> skeleton
val detect_comment_style:
Common.filename -> comment_style
type gen_mode =
| OneFilePerSection
| OneDirPerSection
val gen_source_files:
skeleton -> sections -> comment_style ->
gen_mode:gen_mode ->
output_dir:Common.dirname ->
ext_file:string ->
hook_start_section2:(string -> string) ->
hook_line_body:(string -> string) ->
hook_end_section2:(string -> string) ->
unit

454
h_program-lang/pretty_print_code.ml Normal file
View file

@ -0,0 +1,454 @@
(* Julien Verlaguet, Yoann Padioleau
*
* Copyright (C) 2011 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.
*)
(*****************************************************************************)
(* Prelude *)
(*****************************************************************************)
(* julien: this is a copy/paste of the original pp.ml.
* It is slightly modified, and I don't know how much these modifications
* affect xhpizer. I hope to be able to merge these two files back together.
*)
(*****************************************************************************)
(* Types *)
(*****************************************************************************)
(* we use a backtracking model *)
exception Fail
type env = {
(* the actual printing hook, sometimes temporarily set to do_nothing()
* when trying something before actually printing it. *)
print: (string -> unit);
(* stack of margin, push'ed and pop'ed when processing {} *)
mutable margin: int list;
(* current column *)
mutable cmargin: int;
(* current line *)
mutable line: int;
(* depth in the tree of try_ *)
mutable level: int;
(* for the parenthesis automatic insertion *)
mutable priority: int;
(* pad: ?? *)
mutable last_nl: bool;
mutable emptyl: bool;
mutable failed: bool;
mutable pushed: bool;
}
(*****************************************************************************)
(* Helpers *)
(*****************************************************************************)
let empty o = {
print = o;
margin = [0];
priority = 0;
cmargin = 0;
level = 0;
pushed = false;
last_nl = false;
emptyl = false;
failed = false;
line = 0;
}
let debug env f =
let buf = Buffer.create 256 in
let env' = { env with print = (fun s -> Buffer.add_string buf s)} in
(try f env' with _ -> ());
Printf.printf "Debug %s\n" (Buffer.contents buf)
let do_nothing _ = ()
(*****************************************************************************)
(* Newlines and spaces *)
(*****************************************************************************)
let print env x =
(* todo: this is the case right now for comments.
* we should normalize those comments?
* if (String.contains x '\n')
* then failwith (Printf.sprintf "%s contains a newline\n" x);
*)
env.last_nl <- false;
env.emptyl <- false;
env.cmargin <- env.cmargin + String.length x;
if env.cmargin >= 80
then
(* there is nothing to backtrack on, so just print it *)
if env.level = 0
then begin env.print x; env.failed <- true end
else raise Fail
else env.print x
let spaces env =
for _i = 1 to List.hd env.margin do
print env " ";
done
let newline env =
env.pushed <- false;
if env.last_nl
then env.emptyl <- true;
env.last_nl <- true;
env.cmargin <- 0;
env.line <- env.line + 1;
env.print "\n"
let newline_opt env =
if env.last_nl
then ()
else newline env
let space_or_nl env =
if env.cmargin < 75
then print env " "
else (newline env; spaces env)
(*****************************************************************************)
(* Margins *)
(*****************************************************************************)
let margin_offset = ref 2
let push env =
env.pushed <- true;
env.margin <- List.hd env.margin + !margin_offset :: env.margin
let pop env =
env.margin <- List.tl env.margin
let nest env f =
push env;
f env;
pop env
let nest_opt env f =
if env.pushed
then f env
else begin
push env;
f env;
pop env
end
let nestc env f =
env.margin <- env.cmargin :: env.margin;
f env;
pop env
let nest_block env f =
print env "{";
newline env;
nest env f;
spaces env;
print env "}"
let nest_block_nl env f =
nest_block env f;
newline env
(*****************************************************************************)
(* Lists *)
(*****************************************************************************)
let rec simpl_list env f sep = function
| [] -> ()
| [x] -> f env x
| x :: rl -> f env x; print env sep; simpl_list env f sep rl
let rec list_sep env f sep = function
| [] -> ()
| [x] -> f env x
| x :: rl -> f env x; sep env; list_sep env f sep rl
let flat_list env f opar l sep cpar =
print env opar;
list_sep env f (fun env -> print env sep; print env " ") l;
print env cpar
(* pad: used to take a last_nl parameter, but it was not used *)
let nl_nested_list env f opar l sep cpar =
print env opar;
nest env (fun env ->
newline env;
spaces env;
list_sep env f (fun env -> print env sep; newline env; spaces env) l;
newline env;
);
if cpar <> ""
then begin
spaces env;
print env cpar
end
(*****************************************************************************)
(* Backtracking combinators *)
(*****************************************************************************)
let fail () = raise Fail
let try_ env f =
f { env with print = do_nothing; level = env.level + 1};
f env
let choice_left env f1 f2 =
try try_ env f1
with
| Fail when env.level = 0 ->
(try f2 env with Fail -> assert false)
(* otherwise, just let the exception bubble up more *)
let choice_right env f1 f2 =
try try_ env f1
with Fail ->
f2 env
let try_hard env f =
try
f { env with print = do_nothing; level = 1 };
f env
with Fail ->
let env' = { env with failed = false; print = do_nothing; level = 0 } in
f env';
if env'.failed
then raise Fail
else f { env with level = 0 }
let cut_list env f l =
List.iter (
fun x ->
choice_right env
(fun env -> f env x)
(fun env -> newline env; spaces env; f env x)
) l
let list env f opar l sep cpar =
let simple = (fun env -> flat_list env f opar l sep cpar) in
let nested = (fun env -> nl_nested_list env f opar l sep cpar) in
choice_right env simple nested
let list_left env f opar l sep cpar =
let simple = (fun env -> if l <> [] then print env " "; flat_list env f opar l sep cpar) in
let nested = (fun env -> nl_nested_list env f opar l sep cpar) in
choice_left env simple nested
let nested_arg env f opar l sep cpar =
let rec elt = function
| [] -> assert false
| [x] ->
f env x;
newline env;
| x :: rl ->
f env x; print env sep; newline env; spaces env;
elt rl
in
nestc env (
fun env ->
print env opar;
nestc env (
fun _env ->
elt l;
);
spaces env;
print env cpar;
)
let fun_args env f opar l sep cpar =
let simple = (
fun env ->
let line = env.line in
flat_list env f opar l sep cpar;
if line <> env.line then fail();
) in
let nl_nested = (fun env -> nl_nested_list env f opar l sep cpar) in
choice_right env simple nl_nested
let nested_list env f opar l sep cpar last_nl =
env.margin <- env.cmargin :: env.margin;
print env opar;
env.margin <- env.cmargin :: env.margin;
list_sep env f (fun env -> print env sep; newline env; spaces env) l;
if last_nl
then begin
print env sep;
newline env;
pop env;
spaces env;
print env cpar;
end
else begin
print env cpar;
pop env;
end;
pop env
let fun_params env f l =
let opar = "(" in
let sep = "," in
let cpar = ")" in
let simple = (
fun env ->
let line = env.line in
flat_list env f opar l sep cpar;
if line <> env.line then fail();
) in
let nl_nested = (fun env -> nested_list env f opar l sep cpar true) in
choice_right env simple nl_nested
(*****************************************************************************)
(* Parenthesis handling *)
(*****************************************************************************)
let paren prio env f =
let old_prio = env.priority in
env.priority <- prio;
if (prio >= old_prio) || (prio = -1)
then f env
else begin
print env "(";
f env;
print env ")";
end;
env.priority <- old_prio
(*****************************************************************************)
(* String helpers *)
(*****************************************************************************)
(* module PpString = struct *)
let char_is_space = function
| ' ' | '\t' | '\n' | '\r' -> true
| _ -> false
let is_space s i = char_is_space s.[i]
let rec is_only_space s i =
if i >= String.length s
then true
else is_space s i && is_only_space s (i+1)
let strip s =
let c1 = ref 0 in
let c2 = ref (String.length s - 1) in
while is_space s !c1 do
incr c1;
done;
while is_space s !c2 do
decr c2;
done;
let c2 = String.length s - 1 - !c2 in
String.sub s !c1 (String.length s - !c1 - c2)
let space = function
| ' ' | '\t' -> true
| _ -> false
let rec find_cut x start i =
if i < 20
then start
else if space x.[i]
then i
else find_cut x start (i-1)
let rec string quote sep env x =
choice_left env (
fun env ->
print env x
) (
fun env ->
let size = 80 - env.cmargin - String.length sep - 1 in
let size = find_cut x size size in
let s = String.sub x 0 size in
let rest = String.sub x size (String.length x - size) in
print env s;
print env quote;
print env sep;
newline env;
spaces env;
print env quote;
string quote sep env rest
)
let string quote sep env x =
if env.cmargin >= 20
then begin
print env quote;
print env x;
print env quote
end
else
nestc env (
fun env ->
print env quote;
string quote sep env x;
print env quote;
)
let first_char_escape env s =
if s = "" then 0 else
match s.[0] with
| 'A' .. 'Z' | 'a' .. 'z' | '&' | ' ' | '\n' | '<' | '>' -> 0
| _c ->
print env "{'";
let size = ref 1 in
while !size < String.length s && not (char_is_space s.[!size]) do incr size done;
let size = !size in
print env (String.sub s 0 size);
print env "'}";
if size < String.length s then print env " ";
size
let print_text env s =
let size = ref (String.length s - 1) in
while !size >= 0 && char_is_space s.[!size] do
decr size;
done;
let size = !size in
let buf = Buffer.create 80 in
let last_is_space = ref true in
nestc env (
fun env ->
let i = first_char_escape env s in
for i = i to size do
if Common2.is_space s.[i]
then
if !last_is_space
then ()
else begin
last_is_space := true;
print env (Buffer.contents buf);
Buffer.clear buf;
space_or_nl env;
end
else (last_is_space := false; Buffer.add_char buf s.[i])
done;
print env (Buffer.contents buf);
Buffer.clear buf;
)

175
h_program-lang/prolog_code.ml Normal file
View file

@ -0,0 +1,175 @@
(* 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 E = Entity_code
(*****************************************************************************)
(* Prelude *)
(*****************************************************************************)
(*
* For more information look at h_program-lang/prolog_code.pl
* and its many predicates.
*)
(*****************************************************************************)
(* Types *)
(*****************************************************************************)
(* mimics prolog_code.pl top comment *)
type fact =
| At of entity * Common.filename (* readable path *) * int (* line *)
| Kind of entity * Entity_code.entity_kind
| Type of entity * string (* could be more structured ... *)
| Extends of string * string
| Implements of string * string
| Mixins of string * string
| Privacy of entity * Entity_code.privacy
(* direct use of entities, e.g. foo() *)
| Call of entity * entity
| UseData of entity * entity * bool option (* read/write *)
(* indirect uses of entities, e.g. xxx.f = &foo; *)
| Special of entity (* enclosing *) *
entity (* ctx entity, e.g. function/field/global *) *
entity (* the value *) *
string (* field/function *)
| Misc of string
(* todo? could use a record with
* namespace: string list;
* enclosing: string option;
* name: string
*)
and entity =
string list (* package/module/namespace/class/struct/type qualifier*) *
string (* name *)
(*****************************************************************************)
(* IO *)
(*****************************************************************************)
(* todo: hmm need to escape x no? In OCaml toplevel values can have a quote
* in their name, like foo'', which will not work well with Prolog atoms.
*)
(* http://pleac.sourceforge.net/pleac_ocaml/strings.html *)
let escape charlist str =
let rx = Str.regexp ("\\([" ^ charlist ^ "]\\)") in
Str.global_replace rx "\\\\\\1" str
let escape_quote_and_double_quote s = escape "'\"" s
let string_of_entity (xs, x) =
match xs with
| [] -> spf "'%s'" (escape_quote_and_double_quote x)
| xs -> spf "('%s', '%s')" (Common.join "." xs)
(escape_quote_and_double_quote x)
(* Quite similar to database_code.string_of_id_kind, but with lowercase
* because of prolog atom convention. See also prolog_code.pl comment
* about kind/2.
*)
let string_of_entity_kind = function
| E.Function -> "function"
| E.Constant -> "constant"
| E.Global -> "global"
| E.Macro -> "macro"
| E.Class -> "class"
| E.Type -> "type"
| E.Method -> "method"
| E.ClassConstant -> "constant"
| E.Field -> "field"
| E.Constructor -> "constructor"
| E.TopStmts -> "stmtlist"
| E.Other _ -> "idmisc"
| E.Exception -> "exception"
| E.Module -> "module"
| E.Package -> "package"
| E.Prototype -> "prototype"
| E.GlobalExtern -> "global_extern"
| (E.MultiDirs|E.Dir|E.File) ->
raise Impossible
let string_of_fact fact =
let s =
match fact with
| Kind (entity, kind) ->
spf "kind(%s, %s)" (string_of_entity entity)
(string_of_entity_kind kind)
| At (entity, file, line) ->
spf "at(%s, '%s', %d)" (string_of_entity entity) file line
| Type (entity, str) ->
spf "type(%s, '%s')" (string_of_entity entity)
(escape_quote_and_double_quote str)
| Extends (s1, s2) ->
spf "extends('%s', '%s')" s1 s2
| Mixins (s1, s2) ->
spf "mixins('%s', '%s')" s1 s2
| Implements (s1, s2) ->
spf "implements('%s', '%s')" s1 s2
| Privacy (entity, p) ->
let predicate =
match p with
| E.Public -> "is_public"
| E.Private -> "is_private"
| E.Protected -> "is_protected"
in
spf "%s(%s)" predicate (string_of_entity entity)
(* less: depending on kind of e1 we could have 'method' or 'constructor'*)
| Call (e1, e2) ->
spf "docall(%s, %s)"
(string_of_entity e1) (string_of_entity e2)
| UseData (e1, e2, b) ->
spf "use(%s, %s, %s)"
(string_of_entity e1) (string_of_entity e2)
(match b with
| None -> "na"
| Some true -> "write"
| Some false -> "read"
)
| Special (e1, e2, e3, str) ->
spf "special(%s, %s, %s, '%s')"
(string_of_entity e1)
(string_of_entity e2)
(string_of_entity e3)
str
| Misc s -> s
in
s ^ "."
(*****************************************************************************)
(* Helpers *)
(*****************************************************************************)
let entity_of_str s =
let xs = Common.split "\\." s in
match List.rev xs with
| [] -> raise Impossible
| [x] -> ([], x)
| x::xs -> (List.rev xs, x)

26
h_program-lang/prolog_code.mli Normal file
View file

@ -0,0 +1,26 @@
type fact =
| At of entity * Common.filename (* readable path *) * int (* line *)
| Kind of entity * Entity_code.entity_kind
| Type of entity * string
| Extends of string * string
| Implements of string * string
| Mixins of string * string
| Privacy of entity * Entity_code.privacy
| Call of entity * entity
| UseData of entity * entity * bool option (* read/write *)
| Special of entity * entity * entity * string (* field/function *)
| Misc of string
and entity =
string list (* package/module/namespace/class qualifier*) * string (* name *)
val string_of_fact: fact -> string
val entity_of_str: string -> entity
(* reused in other modules which generate prolog facts *)
val string_of_entity_kind: Entity_code.entity_kind -> string

407
h_program-lang/prolog_code.pl Normal file
View file

@ -0,0 +1,407 @@
% -*- prolog -*-
%---------------------------------------------------------------------------
% Prelude
%---------------------------------------------------------------------------
% This file is the basis of an interactive tool a la SQL to query
% information about the structure of a codebase (the inheritance tree,
% the call graph, the data graph), for instance "What are all the
% children of class Foo?". The data is the code. The query language is
% Prolog (http://en.wikipedia.org/wiki/Prolog), a logic-based
% programming language used mainly in AI but also popular in database
% (http://en.wikipedia.org/wiki/Datalog). The particular Prolog
% implementation we use for now is SWI-prolog
% (http://www.swi-prolog.org/pldoc/refman/). We've chosen Prolog over
% SQL because it's really easy to define recursive predicates like
% children/2 (see below) in Prolog, and such predicates are necessary
% when dealing with object-oriented codebase.
%
% This tool is inspired by a similar tool for Java called JQuery
% (http://jquery.cs.ubc.ca/, nothing to do with the JS library), itself
% inspired by CIA (C Information Abstractor). The code below is mostly
% generic (programming language agnostic) but it was tested mainly
% on PHP, Java (and its bytecode), and OCaml code (see
% lang_php/analyze/foundation/unit_prolog_php.ml,
% lang_bytecode/analyze/unit_analyze_bytecode.ml, and
% lang_ml/analyze/unit_analyze_ml.ml).
%
% This file assumes the presence of another file, facts.pl, containing
% the actual "database" of facts about a codebase. There is potentially
% an infinite numbers of predicates we could define. For instance
% does the method contains a for loop, does it call '+', etc. But for now
% we focus on predicates related to entities, to names, e.g. defs and uses
% of functions/classes/etc.
% Here are the predicates that should be defined in facts.pl:
%
% - entities: kind/2 with the
% function/method, constant, class/interface/trait, field
% atoms.
% ex: kind('array_map', function).
% ex: kind('Preparable', class).
% ex: kind(('Preparable', 'gen'), method).
% ex: kind((Preparable', '__count'), field).
% ex: kind((Preparable', 'OK'), constant).
% The identifier for a function is its name in a string and for
% class members a pair with the name of the class and then the member name,
% both in a string. We don't differentiate methods from static methods;
% the static/1 predicate below can be used for that (same for fields).
% Note that for fields the name of the field does not contain the $ because
% when used, as in '$this->field, there is no $.
%
% - callgraph: docall/3, special/1 with the function/method/class atoms
% to differentiate regular function calls, method calls, and class
% instantiations via new (see also the calls/2 infix operator).
% ex: docall('foo', 'bar', function).
% ex: docall(('A', 'foo'), 'toInt', method).
% ex: docall('foo', ':x:frag', class).
% Note that for method calls we actually don't resolve to which class
% the method belongs to (that would require to leverage results from
% an interprocedural static analysis) unless it's a static method call.
% Note that we use 'docall' and not 'call' because call is a
% reserved predicate in Prolog.
% A new atom 'special' can be used to indicate calls to special functions
% taking entities as parameters. For instance a wrapper to 'new' in
% a dynamic language like PHP.
% ex: docall('foo', ('new_wrapper','A'), special).
% and a special/1 predicate is used to remember all those special functions.
% ex: special('new_wrapper').
%
%
% - exception graph: throw/2, catch/2.
% ex: throw('foo', 'ViolationException').
% ex: catch('bar', 'Exception').
%
% - datagraph: use/4 with the field/array atoms to differentiate access
% to object members, and access to fields of an array (often because people
% abuse arrays to represent records), and the read/write atoms to
% indicate in which position the field is used.
% ex: use('foo', 'count', field, read).
% ex: use(('A','foo'), 'name', array, write).
%
% - types: type/2, parameter/4, return/2, arity/2
% ex: type('foobar', 'int').
% ex: parameter('foo', 0, '$first_param_name', 'int')
% ex: return('foo', 'int')
% ex: arity('foobar', 3).
% ex: arity(('Preparable', 'gen'), 0).
%
% - properties: static/1, abstract/1, final/1, is_public/1, is_private/1,
% is_protected/1, async/1
% ex: static(('Filesystem', 'readFile')).
% ex: abstract('AbstractTestCase').
% ex: is_public(('Preparable', 'gen')).
% We use 'is_public' and not 'public' because public is a reserved keyword
% in Prolog.
%
% - inheritance: extends/2, implements/2, mixins/2
% ex: extends('EntPhoto', 'Ent').
% ex: implements('MyTest', 'NeedSqlShim').
% ex: mixins('MyTest', 'TraitHaveFeedback').
% See also the children/2, parent/2, related/2, isa/2, inherits/2,
% reuses/2, predicates defined below, where isa and inherits are
% infix operators.
%
% - include/require: include/2, require_module/2
% ex: include('wap/index.php', 'flib/core/__init__.php').
% ex: require_module('flib/core/__init__.php', 'core/db').
% We don't differentiate 'include' from 'require'. Note that include works
% on desugared flib code so the require_module() are translated in
% their equivalent includes. Finally path are resolved statically
% when we can, so for instance include $THRIFT_ROOT . '...' is resolved
% in its final path form 'lib/thrift/...'.
%
% - yield/1.
%
% - position: at/3
% ex: at(('Preparable', 'gen'), 'flib/core/preparable.php', 10).
%
% - file information: file/2, hh/2
% ex: file('wap/index.php', ['wap','index.php']).
% ex: hh('flib/x/foo.php', strict).
% By having a list one then use member/3 to select subparts of the codebase
% easily (or use explode_file/2).
%
% related work:
% - jquery, tyruba
% - CIA
% - ODASA, codequest
% - LFS/PofFS
%
% limitations:
% - in the case of PHP, the language is case insensitive but we actually
% generate facts where the case matters. You can use downcase_atom/2
% to try to do case insensitive search, e.g.
% ? kind(X, class), downcase_atom(X, Y), Y = 'exception', <query with X>
% but this will work only for the first level. If in the code
% some extends or implements are using the wrong case, you're lost.
%---------------------------------------------------------------------------
% How to run/compile
%---------------------------------------------------------------------------
% Generates a /tmp/facts.pl for your codebase for your programming language
% (e.g. with pfff_db_heavy -gen_prolog_db /tmp/pfff_db /tmp/facts.pl)
% and then:
%
% $ swipl -s /tmp/facts.pl -f prolog_code.pl
%
% If you want to test a new predicate you can do for instance:
%
% $ swipl -s /tmp/facts.pl -f prolog_code.pl -t halt --quiet -g "children(X,'Foo'), writeln(X), fail"
%
% If you want to compile a database do:
%
% $ swipl -c /tmp/facts.pl prolog_code.pl #this will generate a 'a.out'
%
% Finally you can also use a precompiled database with:
%
% $ cmf --prolog or /home/engshare/pfff/prolog_www
%
%---------------------------------------------------------------------------
% Inheritance
%---------------------------------------------------------------------------
extends_or_implements(Child, Parent) :-
extends(Child, Parent).
extends_or_implements(Child, Parent) :-
implements(Child, Parent).
extends_or_mixins(Child, Parent) :-
extends(Child, Parent).
extends_or_mixins(Class, Trait) :-
mixins(Class, Trait).
public_or_protected(X) :-
is_public(X).
public_or_protected(X) :-
is_protected(X).
method_or_field(method).
method_or_field(field).
children(Child, Parent) :-
extends_or_implements(Child, Parent).
children(GrandChild, Parent) :-
extends_or_implements(GrandChild, Child),
children(Child, Parent).
children(GrandChild, Parent) :-
mixins(GrandChild, Trait),
children(Trait, Parent).
%aran: only extends
inherits(Child, Parent) :-
extends(Child, Parent).
inherits(GrandChild, Parent) :-
extends(GrandChild, Child),
inherits(Child, Parent).
%only for traits
reuses(Child, Trait) :-
mixins(Child, Trait).
reuses(GrandChild, Trait) :-
extends(GrandChild, Child),
reuses(Child, Trait).
parent(X, Y) :-
children(Y, X).
% bidirectional
related(X, Y) :-
children(X, Y).
related(X, Y) :-
children(Y, X).
%---------------------------------------------------------------------------
% Class information
%---------------------------------------------------------------------------
% one can use the same predicate in many ways in Prolog :)
method_in_class(X, Method) :-
kind((X, Method), method).
class_defining_method(Method, X) :-
kind((X, Method), method).
% get all methods/fields accessible from a class
% todo: for mixins it does not handle yet insteadof and as, but we should
% not use those features anyway.
method(Class, (Class, Method)) :-
kind((Class, Method), method).
method(Class, (Class2, Method)) :-
extends_or_mixins(Class, Parent),
method(Parent, (Class2, Method)),
% ensure we don't count parent implementations of overridden functions
\+ kind((Class, Method), method),
public_or_protected((Class2, Method)).
field(Class, (Class, Field)) :-
kind((Class, Field), field).
field(Class, (Class2, Field)) :-
extends_or_mixins(Class, Parent),
field(Parent, (Class2, Field)),
public_or_protected((Class2, Field)).
all_methods(Class) :- findall(X, method(Class, X), XS), writeln(XS).
all_fields(Class) :- findall(X, field(Class, X), XS), writeln(XS).
% for aran
at_method((Class, Method), File, Line) :-
method(Class, (Class2, Method)),
at((Class2, Method), File, Line).
% aran's override (shadowed methods) bad smell detector. People should use
% @override to be more explicit.
% todo: need then to extract annotations from php code and generate facts.
overrides(ChildClass, Class, Method) :-
kind((ChildClass, Method), method),
(inherits(ChildClass, Class) ; reuses(ChildClass, Class)),
kind((Class, Method), method).
overrides(ChildClass, Method) :-
overrides(ChildClass, _Class, Method).
% trait specific overriding
overrides_trait(ChildClass, Method) :-
overrides(ChildClass, Class, Method),
kind(Class, trait).
%---------------------------------------------------------------------------
% Callgraph
%---------------------------------------------------------------------------
%---------------------------------------------------------------------------
% Exception
%---------------------------------------------------------------------------
% todo: could try to find uncaught exception by using docall, throw, and
% catch predicates? would require a precise callgraph though.
%---------------------------------------------------------------------------
% Files
%---------------------------------------------------------------------------
explode_file(F, XS) :-
atomic_list_concat(XS, '/', F).
%---------------------------------------------------------------------------
% Operators for erling
%---------------------------------------------------------------------------
calls(A,B) :- docall(A, B, _).
:- op(42, xfx, calls).
:- op(42, xfx, inherits).
isa(A,B) :- children(A,B).
:- op(42, xfx, isa).
%---------------------------------------------------------------------------
% Statistics
%---------------------------------------------------------------------------
% does not work very well with big data :(
%:- use_module(library('R')).
%load_r :- r_open([with(non_interactive)]).
%---------------------------------------------------------------------------
% Reporting
%---------------------------------------------------------------------------
%---------------------------------------------------------------------------
% Clown code
%---------------------------------------------------------------------------
%todo: histogram for kent of function arities :)
too_many_params(X) :-
arity(X, N), N > 20.
include_not_www_code(X, Y) :-
include(X, Y),
\+ file(Y, _).
% this is what makes the callgraph for methods more complicated
same_method_in_unrelated_classes(Method, Class1, Class2) :-
kind((Class1, Method), method),
kind((Class2, Method), method),
Method \= '__construct',
Class1 \= Class2,
\+ related(Class1, Class2).
%classes with more than 10 public methods: http://en.wikipedia.org/wiki/.QL
too_many_public_methods(X) :-
kind(X, class),
findall(M, (kind((X, M), method), public((X,M))), Res),
length(Res, N),
N > 10.
%---------------------------------------------------------------------------
% Security
%---------------------------------------------------------------------------
scary('XSS').
scary('POTENTIAL_XSS_HOLE').
scary('ToXHP_UNSAFE').
%---------------------------------------------------------------------------
% Refactoring opportunities
%---------------------------------------------------------------------------
% aran's code
could_be_final(Class) :-
kind(Class, class),
not(final(Class)),
not(extends(_Child, Class)).
could_be_final(Class, Method) :-
kind(Class, class),
kind((Class, Method), method),
not(final((Class, Method))),
not(overrides(_ChildClass, Class, Method)).
% for paul
could_remove_delegate_method(Class, Method) :-
docall((Class, Method), 'delegateToYield', method),
not((children(Class, Parent), kind((Parent, Method), _Kind))).
%---------------------------------------------------------------------------
% checks
%---------------------------------------------------------------------------
check_exception_inheritance(X) :-
throw(_, X),
not(children(X, 'Exception')),
X \= 'Exception',
% make sure it's defined
kind(X, class).
check_duplicated_entity(X, File1, File2, Kind) :-
kind(X, Kind),
at(X, File1, _),
at(X, File2, _),
File1 \= File2.
check_duplicated_field(Class, Class2, Var) :-
kind((Class,Var), field),
public_or_protected((Class, Var)),
Class \= 'Exception',
children(Class2, Class),
kind((Class2, Var), field).
check_call_unexisting_method_anywhere(Caller, Method) :-
docall(Caller, Method, method),
not(kind((_X, Method), method)).
% for paul
wrong_public_genRender(X) :-
kind((X, 'genRender'), _),
children(X, 'GenXHP'),
is_public((X, 'genRender')).
%todo:
% check for inconsistent case, e.g. Exception vs exception.
% just check if 2 classes are different but downcase to the same name
:- discontiguous mixins/2.
:- discontiguous implements/2.

77
h_program-lang/refactoring_code.ml Normal file
View file

@ -0,0 +1,77 @@
(* Yoann Padioleau
*
* Copyright (C) 2012, 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 *)
(*****************************************************************************)
type refactoring_kind =
| AddInterface of string option (* specific class *)
* string (* the interface to add *)
| RemoveInterface of string option * string
| SplitMembers
(* todo: Rename of entity * entity *)
(* type related *)
| AddReturnType of string
| AddTypeHintParameter of string
| OptionizeTypeParameter
| AddTypeMember of string
type position = {
file: Common.filename;
line: int;
col: int;
}
type refactoring = refactoring_kind * position option
(*****************************************************************************)
(* IO *)
(*****************************************************************************)
(* format: file;RETURN;line;col;value *)
let load file =
Common.cat file +> List.map (fun s ->
let xs = Common.split ";" s in
match xs with
| [file;action;line;col;value] when
line =~ "[0-9]+" && col =~ "[0-9]+" &&
(List.mem action [
"RETURN";"PARAM";"MEMBER"; "MAKE_OPTION_TYPE"; "SPLIT_MEMBERS";
]) ->
(match action with
| "RETURN" -> AddReturnType value
| "PARAM" -> AddTypeHintParameter value
| "MEMBER" -> AddTypeMember value
| "MAKE_OPTION_TYPE" -> OptionizeTypeParameter
| "SPLIT_MEMBERS" -> SplitMembers
| _ -> raise Impossible
), Some
{ file;
line = int_of_string line;
col = int_of_string col;
}
| _ -> failwith ("wrong format for refactoring action: " ^ s)
)

26
h_program-lang/refactoring_code.mli Normal file
View file

@ -0,0 +1,26 @@
(* many refactorings can be done by spatch! used this code only as
* last resort
*)
type refactoring_kind =
| AddInterface of string option (* specific class *)
* string (* the interface to add *)
| RemoveInterface of string option * string
| SplitMembers
(* type related *)
| AddReturnType of string
| AddTypeHintParameter of string
| OptionizeTypeParameter
| AddTypeMember of string
type position = {
file: Common.filename;
line: int;
col: int;
}
type refactoring = refactoring_kind * position option
val load: Common.filename -> refactoring list

84
h_program-lang/scope_code.ml Normal file
View file

@ -0,0 +1,84 @@
(* 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.
*)
(*****************************************************************************)
(* Prelude *)
(*****************************************************************************)
(*
* It would be more convenient to move this file elsewhere like in analyse_xxx/
* but we want our AST to contain scope annotations so it's convenient to
* have the type definition of scope there.
*)
(*****************************************************************************)
(* Types *)
(*****************************************************************************)
(* todo? could use open polymorphic variant for that ? the scoping will
* be differerent for each language but they will also have stuff
* in common which may be a good spot for open polymorphic variant.
*)
type scope =
| Global
| Local
| Param
| Static
| Class
| LocalExn
| LocalIterator
(* php specific? *)
| ListBinded
(* closure, could be same as Local, but can be good to visually
* differentiate them in codemap
*)
| Closed
| NoScope
(*****************************************************************************)
(* String-of *)
(*****************************************************************************)
let string_of_scope = function
| Global -> "Global"
| Local -> "Local"
| Param -> "Param"
| Static -> "Static"
| Class -> "Class"
| LocalExn -> "LocalExn"
| LocalIterator -> "LocalIterator"
| ListBinded -> "ListBinded"
| Closed -> "Closed"
| NoScope -> "NoScope"
(*****************************************************************************)
(* Meta *)
(*****************************************************************************)
let vof_scope x =
match x with
| Global -> Ocaml.VSum (("Global", []))
| Local -> Ocaml.VSum (("Local", []))
| Param -> Ocaml.VSum (("Param", []))
| Static -> Ocaml.VSum (("Static", []))
| Class -> Ocaml.VSum (("Class", []))
| LocalExn -> Ocaml.VSum (("LocalExn", []))
| LocalIterator -> Ocaml.VSum (("LocalIterator", []))
| ListBinded -> Ocaml.VSum (("ListBinded", []))
| Closed -> Ocaml.VSum (("Closed", []))
| NoScope -> Ocaml.VSum (("NoScope", []))

12
h_program-lang/scope_code.mli Normal file
View file

@ -0,0 +1,12 @@
type scope =
| Global | Local | Param | Static | Class
| LocalExn | LocalIterator
| ListBinded
| Closed
| NoScope
val string_of_scope: scope -> string
val vof_scope: scope -> Ocaml.v

161
h_program-lang/skip_code.ml Normal file
View file

@ -0,0 +1,161 @@
(* Yoann Padioleau
*
* Copyright (C) 2012 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 *)
(*****************************************************************************)
(*
* It is often useful to skip certain parts of a codebase. Large codebase
* often contains special code that can not be parsed, that contains
* dependencies that should not exist, old code that we don't want
* to analyze, etc.
*
* todo: simplify interface in skip_list.txt file? can infer
* dir or file, and maybe sometimes instead of skip we would like
* to specify the opposite, what we want to keep, so maybe a simple
* +/- syntax would be better.
*)
(*****************************************************************************)
(* Types *)
(*****************************************************************************)
(* the filename are in readable path format *)
type skip =
| Dir of Common.dirname
| File of Common.filename
| DirElement of Common.dirname
| SkipErrorsDir of Common.dirname
(*****************************************************************************)
(* IO *)
(*****************************************************************************)
let load file =
Common.cat file
+> Common.exclude (fun s ->
s =~ "#.*" || s =~ "^[ \t]*$"
)
+> List.map (fun s ->
match s with
| _ when s =~ "^dir:[ ]*\\([^ ]+\\)" ->
Dir (Common.matched1 s)
| _ when s =~ "^skip_errors_dir:[ ]*\\([^ ]+\\)" ->
SkipErrorsDir (Common.matched1 s)
| _ when s =~ "^file:[ ]*\\([^ ]+\\)" ->
File (Common.matched1 s)
| _ when s =~ "^dir_element:[ ]*\\([^ ]+\\)" ->
DirElement (Common.matched1 s)
| _ -> failwith ("wrong line format in skip file: " ^ s)
)
(*****************************************************************************)
(* Main entry point *)
(*****************************************************************************)
(* less: say when skipped stuff? *)
let filter_files skip_list root xs =
let skip_files =
skip_list +> Common.map_filter (function
| File s -> Some s
| _ -> None
) +> Common.hashset_of_list
in
let skip_dirs =
skip_list +> Common.map_filter (function
| Dir s -> Some s
| _ -> None
)
in
let skip_dir_elements =
skip_list +> Common.map_filter (function
| DirElement s -> Some s
| _ -> None
)
in
xs +> Common.exclude (fun file ->
let readable = Common.readable ~root file in
(Hashtbl.mem skip_files readable) ||
(skip_dirs +> List.exists
(fun dir -> readable =~ (dir ^ ".*"))) ||
(skip_dir_elements +> List.exists
(fun dir -> readable =~ (".*/" ^ dir ^ "/.*")))
)
(* copy paste of h_version_control/git.ml *)
let find_vcs_root_from_absolute_path file =
let xs = Common.split "/" (Common2.dirname file) in
let xxs = Common2.inits xs in
xxs +> List.rev +> Common.find_some (fun xs ->
let dir = "/" ^ Common.join "/" xs in
if Sys.file_exists (Filename.concat dir ".git") ||
Sys.file_exists (Filename.concat dir ".hg") ||
false
then Some dir
else None
)
let find_skip_file_from_root root =
let candidates = [
"skip_list.txt";
(* fbobjc specific *)
"Configurations/Sgrep/skip_list.txt";
(* www specific *)
"conf/codegraph/skip_list.txt";
]
in
candidates +> Common.find_some (fun f ->
let full = Filename.concat root f in
if Sys.file_exists full
then Some full
else None
)
let filter_files_if_skip_list xs =
match xs with
| [] -> []
| x::_ ->
try
let root = find_vcs_root_from_absolute_path x in
let skip_file = find_skip_file_from_root root in
let skip_list = load skip_file in
pr2 (spf "using skip list in %s" skip_file);
filter_files skip_list root xs
with Not_found -> xs
(*****************************************************************************)
(* Helpers *)
(*****************************************************************************)
let build_filter_errors_file skip_list =
let skip_dirs =
skip_list +> Common.map_filter (function
| SkipErrorsDir dir -> Some dir
| _ -> None
)
in
(fun readable ->
skip_dirs +> List.exists (fun dir -> readable =~ ("^" ^ dir))
)
let reorder_files_skip_errors_last skip_list root xs =
let is_file_want_to_skip_error = build_filter_errors_file skip_list in
let (skip_errors, ok) =
xs +> List.partition (fun file ->
let readable = Common.readable ~root file in
is_file_want_to_skip_error readable
)
in
ok @ skip_errors

26
h_program-lang/skip_code.mli Normal file
View file

@ -0,0 +1,26 @@
type skip =
(* mostly to avoid parsing errors messages *)
| Dir of Common.dirname
| File of Common.filename
| DirElement of Common.dirname
| SkipErrorsDir of Common.dirname
val load: Common.filename -> skip list
val filter_files:
skip list -> Common.dirname (* root *) -> Common.filename list ->
Common.filename list
(* assumes given full paths *)
val filter_files_if_skip_list:
Common.filename list -> Common.filename list
val reorder_files_skip_errors_last:
skip list -> Common.dirname (* root *) -> Common.filename list ->
Common.filename list
(* returns true if we should skip the file for errors *)
val build_filter_errors_file:
skip list -> (Common.filename (* readable *) -> bool)

237
h_program-lang/tags_file.ml Normal file
View file

@ -0,0 +1,237 @@
(* Yoann Padioleau
*
* Copyright (C) 2010-2012 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
module E = Entity_code
(*****************************************************************************)
(* Prelude *)
(*****************************************************************************)
(*
* Generating TAGS file (for emacs or vim)
*
* Supposed syntax for emacs TAGS (.tags) files, as analysed from output
* of etags, read in etags.c and discussed with Francesco Potorti.
* src: otags readme:
*
* <file> ::= <page>+
* <page> ::= <header><body>
* <header> ::= <NP><CR><file-name>,<body-length><CR>
* <body> ::= <tag-line>*
* <tag-line> ::= <prefix><DEL><tag><SOH><line-number>,<begin-char-index><CR>
* pad: when tag is already at the beginning of the line:
* <tag-line> ::=<tag><DEL><line-number>,<begin-char-index><CR>
*
* <NP> ::= ascii NP, (emacs ^L)
* <DEL> ::= ascii DEL, (emacs ^?)
* <SOH> ::= ascii SOH, (emacs ^A)
* <CR> :: ascii CR
*
* See also http://en.wikipedia.org/wiki/Ctags#Tags_file_formats
*)
(*****************************************************************************)
(* Types *)
(*****************************************************************************)
(* see http://en.wikipedia.org/wiki/Ctags#Tags_file_formats *)
let header = "\x0c\n"
let footer = ""
type tag = {
tag_definition_text: string;
tagname: string;
line_number: int;
(* offset of beginning of tag_definition_text, when have 0-indexed filepos *)
byte_offset: int;
(* only used by vim *)
kind: Entity_code.entity_kind;
}
let mk_tag s1 s2 i1 i2 k = {
tag_definition_text = s1;
tagname = s2;
line_number = i1;
byte_offset = i2;
kind = k;
}
(*****************************************************************************)
(* Helpers *)
(*****************************************************************************)
let string_of_tag t =
spf "%s\x7f%s\x01%d,%d\n"
t.tag_definition_text
t.tagname
t.line_number
t.byte_offset
(* of tests/misc/functions.php *)
(*
let fake_defs = [
mk_tag "function a() {" "a" 3 7;
mk_tag "function b() {" "b" 7 32;
mk_tag "function c() {" "c" 14 65;
mk_tag "function d() {" "d" 20 107;
]
*)
(* helpers used externally by language taggers *)
let tag_of_info filelines info kind =
let line = PI.line_of_info info in
let pos = PI.pos_of_info info in
let col = PI.col_of_info info in
let s = PI.str_of_info info in
mk_tag (filelines.(line)) s line (pos - col) kind
(* C-s for "kind" in http://ctags.sourceforge.net/FORMAT *)
let vim_tag_kind_str tag_kind =
match tag_kind with
| E.Class -> "c"
| E.Constant -> "d"
| E.Function -> "f"
| E.Method -> "f"
| E.Type -> "t"
| E.Field -> "m"
| E.Module | E.Package
| E.Global | E.Macro
| E.TopStmts
| E.Other _
| E.ClassConstant
| E.Constructor
| E.File | E.Dir | E.MultiDirs
| E.Exception
| E.Prototype | E.GlobalExtern
-> ""
(* vim uses '/' as a marker for the tag definition text, so if this
* test contains '/' they must be escaped.
*)
let vim_escape_slash str =
Str.global_replace (Str.regexp "/") "\\/" str
(* For methods, in addition to the tag for the precise 'class::method'
* name, it can be convenient to generate another tag with just the
* 'method' name so people can quickly jump to some code with just the
* method name. Of course if there is also a function somewhere using the
* same name then this function could be hard to reach so we generate
* an (imprecise) method tag only when there is no ambiguity.
*)
let add_method_tags_when_unambiguous files_and_defs =
(* step1: global analysis on all defs, remember all names and methods *)
let h_toplevel_names =
files_and_defs +> List.map (fun (_file, tags) ->
tags +> Common.map_filter (fun t ->
match t.kind with
| E.Class | E.Function | E.Constant -> Some t.tagname
| _ -> None
)
) +> List.flatten +> Common.hashset_of_list
in
let h_grouped_methods =
files_and_defs +> List.map (fun (_file, tags) ->
tags +> Common.map_filter (fun t ->
match t.kind with
| E.Method ->
if t.tagname =~ ".*::\\(.*\\)"
then Some (Common.matched1 t.tagname, t)
else failwith ("method tag should contain '::[, got: " ^ t.tagname)
| _ -> None
)
(* could skip the group_assoc_bykey and do Hashtbl.find_all below instead *)
) +> List.flatten +> Common.group_assoc_bykey_eff +> Common.hash_of_list
in
(* step2: add method tag when no ambiguity *)
files_and_defs +> List.map (fun (file, tags) ->
file,
tags +> List.map (fun t ->
match t.kind with
| E.Method ->
if t.tagname =~ ".*::\\(.*\\)"
then
let methodname = Common.matched1 t.tagname in
if not (Hashtbl.mem h_toplevel_names methodname) &&
List.length (Hashtbl.find h_grouped_methods methodname) = 1
then [t; { t with tagname = methodname }]
else [t]
else failwith("method tag should contain '::[, got: " ^ t.tagname)
| _ -> [t]
) +> List.flatten
)
(*****************************************************************************)
(* Main entry point *)
(*****************************************************************************)
let threshold_long_line = 1000
let generate_TAGS_file tags_file files_and_defs =
Common.with_open_outfile tags_file (fun (pr_no_nl, _chan) ->
pr_no_nl header;
files_and_defs +> List.iter (fun (file, defs) ->
let all_defs = defs +> Common.map_filter (fun tag ->
if String.length tag.tag_definition_text > threshold_long_line
then begin
pr2_once (spf "WEIRD long string in %s, passing the tag" file);
None
end
else Some (string_of_tag tag)
) +> Common.join "" in
let size_defs = String.length all_defs in
pr_no_nl (spf "%s,%d\n" file size_defs);
pr_no_nl all_defs;
pr_no_nl "\x0c\n";
);
);
()
(* http://vimdoc.sourceforge.net/htmldoc/tagsrch.html#tags-file-format *)
let generate_vi_tags_file tags_file files_and_defs =
Common.with_open_outfile tags_file (fun (pr_no_nl, _chan) ->
let all_tags =
files_and_defs +> List.map (fun (file, defs) ->
defs +> Common.map_filter (fun tag ->
if String.length tag.tag_definition_text > 300
then begin
pr2 (spf "WEIRD long string in %s, passing the tag" file);
None
end
else Some (tag.tagname, (tag, file))
))
+> List.flatten
+> Common.sort_by_key_lowfirst
in
all_tags +> List.iter (fun (_tagname, (tag, file)) ->
(* {tagname}<Tab>{tagfile}<Tab>{tagaddress}
* "The two characters semicolon and double quote [...] are
* interpreted by Vi as the start of a comment, which makes the
* following be ignored."
*)
pr_no_nl (spf "%s\t%s\t/%s/;\"\t%s\n"
tag.tagname
file
(vim_escape_slash tag.tag_definition_text)
(vim_tag_kind_str tag.kind)
);
);
)

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

@ -0,0 +1,31 @@
type tag = {
tag_definition_text: string;
tagname: string;
line_number: int;
(* offset of beginning of tag_definition_text, when have 0-indexed filepos *)
byte_offset: int;
(* only used by vim *)
kind: Entity_code.entity_kind;
}
(* will generate a TAGS file in the current directory *)
val generate_TAGS_file:
Common.filename -> (Common.filename * tag list) list -> unit
(* will generate a tags file in the current directory *)
val generate_vi_tags_file:
Common.filename -> (Common.filename * tag list) list -> unit
val add_method_tags_when_unambiguous:
(Common.filename * tag list) list -> (Common.filename * tag list) list
(* internals *)
val mk_tag: string -> string -> int -> int -> Entity_code.entity_kind -> tag
val string_of_tag: tag -> string
val header: string
val footer: string
(* helpers used by language taggers *)
val tag_of_info:
string array -> Parse_info.info -> Entity_code.entity_kind -> tag

83
h_program-lang/test_program_lang.ml Normal file
View file

@ -0,0 +1,83 @@
open Common
module Db = Database_code
module E = Entity_code
(*****************************************************************************)
(* Helpers *)
(*****************************************************************************)
(*****************************************************************************)
(* Subsystem testing *)
(*****************************************************************************)
let test_load_light_db file =
let _db = Db.load_database file in
()
let test_big_grep file =
let db = Db.load_database file in
let entities =
Db.files_and_dirs_and_sorted_entities_for_completion
~threshold_too_many_entities:300000
db in
let idx = Big_grep.build_index entities in
let query = "old_le" in
let top_n = 10 in
let xs = Big_grep.top_n_search ~top_n ~query idx in
xs +> List.iter (fun e ->
(*
let json = Db.json_of_entity e in
let s = Json_io.string_of_json json in
pr2 s
*)
pr2_gen e;
);
(* naive search *)
let xs = Big_grep.naive_top_n_search ~top_n ~query entities in
xs +> List.iter (fun e ->
(*
let json = Db.json_of_entity e in
let s = Json_io.string_of_json json in
pr2 s
*)
pr2_gen e
);
()
let test_layer file =
let layer = Layer_code.load_layer file in
let json = Layer_code.json_of_layer layer in
let s = Json_out.string_of_json json in
pr2 s
let layer_stat file =
let layer = Layer_code.load_layer file in
let stats = Layer_code.stat_of_layer layer in
stats +> List.iter (fun (k, v) ->
pr (spf " %s = %d" k v)
)
let test_refactoring file =
let xs = Refactoring_code.load file in
xs +> List.iter pr2_gen;
()
(*****************************************************************************)
(* Main entry for Arg *)
(*****************************************************************************)
let actions () = [
"-test_load_db", " <file>",
Common.mk_action_1_arg test_load_light_db;
"-test_big_grep", " <file>",
Common.mk_action_1_arg test_big_grep;
"-test_layer", " <file>",
Common.mk_action_1_arg test_layer;
"-test_refactoring", " <file>",
Common.mk_action_1_arg test_refactoring;
]

5
h_program-lang/test_program_lang.mli Normal file
View file

@ -0,0 +1,5 @@
val layer_stat: Common.filename -> unit
val actions: unit -> Common.cmdline_actions

19
h_program-lang/unit_program_lang.ml Normal file
View file

@ -0,0 +1,19 @@
open OUnit
module E = Entity_code
(*****************************************************************************)
(* Helpers *)
(*****************************************************************************)
(*****************************************************************************)
(* Data *)
(*****************************************************************************)
(*****************************************************************************)
(* Unit tests *)
(*****************************************************************************)
let unittest =
"program_lang" >::: [
]

6
h_program-lang/unit_program_lang.mli Normal file
View file

@ -0,0 +1,6 @@
(* Returns the testsuite for this directory. To be concatenated by
* the caller (e.g. in pfff/main_test.ml ) with other testsuites and
* run via OUnit.run_test_tt().
*)
val unittest: OUnit.test