Skip to content

Comparing changes

Choose two branches to see what’s changed or to start a new pull request. If you need to, you can also .

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also .
...
  • 9 commits
  • 11 files changed
  • 0 commit comments
  • 1 contributor
Commits on Dec 10, 2012
@aryx aryx [codequery] start support Prolog queries for ocaml code (using cmt fi…
…les)

Summary:
I want to ask questions about the pfff codebase such as:
 - What are the number functions in Common that are actually called a lot?
   (to know how much I can reduce common.ml without refactoring too much
   the code that uses Common)
 - Where is the function that takes a Database_code.entity_kind and
   return a string?
 - What is the dead code in lang_php/?
 - ...

I've made such a tool for PHP in lang_php/analyze/foundation/database_prolog_php.ml that is called from main_codequery.ml (and cmf --prolog). This patch
is the start of a serie to add support for OCaml to codequery (and eventually
also to add support for Java). Many
of the data I need to generate prolog facts are available in
Graph_code.graph that is used by codegraph, so I just start from there.

Test Plan:
cd ~/pfff/tests/ml/cmt/
$ ~/pfff/codequery -lang cmt -build .
...
Your compiled proog DB is ready. Run ./prolog_compiled_db
$ head facts.pl
kind(('Foo', 'partial_application'), function).
kind(('Record.record', 'mut_fld3'), field).
kind(('Foo', 'func_with_signature'), function).
$ ./prolog_compiled_db
?- kind(X, Y).
X = ('Foo', partial_application),
Y = function
...
$

Reviewers: pieter

Reviewed By: pieter

CC: julienv, platform-diffs@lists

Differential Revision: https://phabricator.fb.com/D652916
22447c6
@aryx aryx todo d5b8407
@aryx aryx * lang_ml/analyze/unit_analyze_ml.ml: estet d0b2e8c
@aryx aryx [codequery] basic unit test infrastructure for prolog queries on ml(.…
…cmt) code

Summary: This should make it easier to test things in the future.

Test Plan:
$ ./pfff_test prolog_ml
$ ./pfff_test all

Reviewers: pieter

Reviewed By: pieter

CC: julienv

Differential Revision: https://phabricator.fb.com/D652940
b0c3ae8
@aryx aryx * h_program-lang/graph_code_prolog.ml: todo feb4320
@aryx aryx [codequery] support for at/3 for ocaml code, get position information
Summary: Adding support for the at/3 predicate.

Test Plan:
unit test included
$ make test

Reviewers: pieter

Reviewed By: pieter

CC: julienv, mathieubaudet, platform-diffs@lists

Differential Revision: https://phabricator.fb.com/D653050
7ab93a4
@aryx aryx [stags] support for ocaml code
Summary:
Another wrapper around graph_code, this time not to generate a prolog
DB but to generate an emacs (or vi) TAGS file.

Test Plan:
$ cd ~/pfff; make tags
then under emacs
M-x List. TAB
list all the functions in list.ml and selecting one jump to the right place.

Reviewers: pieter

Reviewed By: pieter

CC: julienv, mathieubaudet, platform-diffs@lists, erling

Differential Revision: https://phabricator.fb.com/D653086
c9ca26a
@aryx aryx * Makefile: stags.opt fix 8efbbcf
@aryx aryx Merge branch 'master' of github.com:facebook/pfff 5653413
View
4 Makefile
@@ -424,7 +424,7 @@ purebytecode:
stags: $(LIBS) main_stags.cmo
$(OCAMLC) $(CUSTOM) -o $@ $(SYSLIBS) $^
stags.opt: $(LIBS:.cma=.cmxa) main_stags.cmx
- $(OCAMLOPT) $(STATIC) -o $@ $(BASICSYSLIBS:.cma=.cmxa) $^
+ $(OCAMLOPT) $(STATIC) -o $@ $(SYSLIBS:.cma=.cmxa) $^
clean::
rm -f stags
@@ -638,7 +638,7 @@ website:
.PHONY:: tags db graph visual layers tests test
tags:
- ./stags -verbose -lang ml .
+ ./stags -lang cmt .
db:
./pfff_db -verbose -lang ml -o DB_LIGHT.marshall .
graph:
View
2 h_program-lang/Makefile
@@ -14,7 +14,7 @@ SRC= programming_language.ml \
refactoring_code.ml \
layer_code.ml database_code.ml \
graph_code.ml graph_code_opti.ml dependencies_matrix_code.ml \
- tags_file.ml \
+ graph_code_prolog.ml tags_file.ml graph_code_tags.ml \
statistics_code.ml statistics_parsing.ml layer_parse_errors.ml \
coverage_code.ml layer_coverage.ml \
overlay_code.ml big_grep.ml pleac.ml info_code.ml \
View
163 h_program-lang/graph_code_prolog.ml
@@ -0,0 +1,163 @@
+(* 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
+
+module G = Graph_code
+module E = Database_code
+
+(*****************************************************************************)
+(* Prelude *)
+(*****************************************************************************)
+(* Generating prolog DB facts from a graph_code.
+ *
+ * less: could move stuff in a prolog_code.ml file.
+ *
+ * For more information look at h_program-lang/database_code.pl
+ * and its many predicates.
+ *)
+
+(*****************************************************************************)
+(* Types *)
+(*****************************************************************************)
+
+(* mimics database_code.pl top comment *)
+type fact =
+ | At of entity * Common.filename (* readable path *) * int (* line *)
+ | Kind of entity * Database_code.entity_kind
+ | 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 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 database_code.pl comment
+ * about kind/2.
+ *)
+let string_of_entity_kind = function
+ | E.Function -> "function"
+ | E.Constant -> "constant"
+ | E.Class x ->
+ (match x with
+ | E.RegularClass -> "class"
+ | E.Interface -> "interface"
+ | E.Trait -> "trait"
+ )
+ (* the static/1 predicate will say if static method (or class var) *)
+ | E.Method _ -> "method"
+
+ | E.ClassConstant -> "constant"
+ | E.Field -> "field"
+
+ | E.TopStmts -> "stmtlist"
+ | E.Other _ -> "idmisc"
+ | E.Exception -> "exception"
+ | E.Constructor -> "constructor"
+ | E.Global -> "global"
+ | E.Type -> "type"
+ | E.Module -> "module"
+
+ | (E.MultiDirs|E.Dir|E.File
+ |E.Macro|E.Package
+ ) ->
+ 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
+ | 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)
+
+(*****************************************************************************)
+(* Main entry point *)
+(*****************************************************************************)
+
+let build root g =
+
+ let res = ref [] in
+ let add x = Common.push2 x res in
+
+ add (Misc ":- discontiguous kind/2, at/3");
+ (* defs *)
+ g +> G.iter_nodes (fun n ->
+ let (str, kind) = n in
+ (match kind with
+ | E.Function | E.Global | E.Constant | E.Type
+ | E.Module
+ -> add (Kind (entity_of_str str, kind))
+ (* todo? field and constructor have a X.Y.type.fld so should
+ * we generate for the entity a ([X;Y;type], fld) or ([X;Y], "type.fld")
+ *)
+ | E.Field | E.Constructor
+ -> add (Kind (entity_of_str str, kind))
+ | E.Exception
+ -> add (Kind (entity_of_str str, kind))
+ | E.File -> ()
+ | E.Dir -> ()
+ | _ ->
+ pr2_gen n;
+ raise Todo
+ );
+ (try
+ let nodeinfo = G.nodeinfo n g in
+ add (At (entity_of_str str,
+ nodeinfo.G.pos.Parse_info.file,
+ nodeinfo.G.pos.Parse_info.line))
+ with Not_found -> ()
+ );
+
+ );
+ List.rev !res
View
14 h_program-lang/graph_code_prolog.mli
@@ -0,0 +1,14 @@
+type fact =
+ | At of entity * Common.filename (* readable path *) * int (* line *)
+ | Kind of entity * Database_code.entity_kind
+ | Misc of string
+
+ and entity =
+ string list (* package/module/namespace/class qualifier*) * string (* name *)
+
+val string_of_fact: fact -> string
+
+(* reused in other modules which generate prolog facts *)
+val string_of_entity_kind: Database_code.entity_kind -> string
+
+val build: Common.dirname -> Graph_code.graph -> fact list
View
101 h_program-lang/graph_code_tags.ml
@@ -0,0 +1,101 @@
+(* 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
+
+module G = Graph_code
+module E = Database_code
+
+(*****************************************************************************)
+(* Prelude *)
+(*****************************************************************************)
+(* Generating a set of TAGS from a graph_code.
+ *
+ * alternatives:
+ * - could start from the prolog facts (themselves generated from graph_code)
+ * to factorize some code, but for TAGS we are only interested
+ * in position and the only predicate that matters, at/3, does not
+ * actually contain enough information such as the byte offset in the file,
+ * so let's copy paste for now.
+ *)
+
+(*****************************************************************************)
+(* Helpers *)
+(*****************************************************************************)
+
+(*****************************************************************************)
+(* Main entry point *)
+(*****************************************************************************)
+
+(* quite similar to graph_code_prolog *)
+let defs_of_graph_code ?(verbose=false) g =
+
+ (* we use the multi-values-to-same-key property of Hashtbl.add and
+ * Hashtbl.find_all
+ *)
+ let hfile_to_tags = Hashtbl.create 101 in
+
+ let hmemo_file_array = Hashtbl.create 101 in
+
+
+ g +> G.iter_nodes (fun n ->
+ let (str, kind) = n in
+ (try
+ let nodeinfo = G.nodeinfo n g in
+ let file = nodeinfo.G.pos.Parse_info.file in
+ let line = nodeinfo.G.pos.Parse_info.line in
+ let text =
+ try
+ let array = Common.memoized hmemo_file_array file (fun () ->
+ Common.cat_array file
+ )
+ in
+ (* not sure why, but can't put an empty string for
+ * tag_definition_text; Emacs is then getting really confused
+ *)
+ array.(line)
+ with
+ | Invalid_argument _out_of_bound ->
+ pr2 (spf "PB accessing line %d of %s" line file);
+ ""
+ | Sys_error _no_such_file ->
+ pr2 (spf "PB accessing file %s" file);
+ ""
+ in
+ let tag = { Tags_file.
+ tagname = str;
+ line_number = nodeinfo.G.pos.Parse_info.line;
+ byte_offset = nodeinfo.G.pos.Parse_info.charpos;
+ kind = kind;
+ tag_definition_text = text;
+ }
+ in
+ Hashtbl.add hfile_to_tags file tag;
+ (* when add a tag for List.foo, also add foo.List *)
+ let reversed_tagname =
+ Common.split "\\." str +> List.rev +> Common.join "." in
+ Hashtbl.add hfile_to_tags file
+ { tag with Tags_file.tagname = reversed_tagname }
+
+ with Not_found -> ()
+ )
+ );
+ Common.hkeys hfile_to_tags +> List.map (fun file ->
+ file,
+ Hashtbl.find_all hfile_to_tags file
+ +> List.map (fun tag -> tag.Tags_file.byte_offset, tag)
+ +> Common.sort_by_key_lowfirst
+ +> List.map snd
+ )
+
View
5 h_program-lang/graph_code_tags.mli
@@ -0,0 +1,5 @@
+
+val defs_of_graph_code:
+ ?verbose:bool ->
+ Graph_code.graph ->
+ (Common.filename * Tags_file.tag list) list
View
68 lang_ml/analyze/graph_code_cmt.ml
@@ -56,7 +56,10 @@ type env = {
g: Graph_code.graph;
phase: phase;
+ (* the .cmt *)
file: Common.filename;
+ (* the file the .cmt is supposed to come from *)
+ source_file: Common.filename;
current: Graph_code.node;
current_entity: name;
@@ -137,7 +140,7 @@ let full_path_local_of_kind env kind =
let add_full_path_local env (s, name) kind =
Common.push2 (s, name) (full_path_local_of_kind env kind)
-let add_node_and_edge_if_defs_mode ?(dupe_ok=false) env name_node =
+let add_node_and_edge_if_defs_mode ?(dupe_ok=false) env name_node loc =
let (name, kind) = name_node in
let node = (s_of_n name, kind) in
if env.phase = Defs then begin
@@ -146,6 +149,19 @@ let add_node_and_edge_if_defs_mode ?(dupe_ok=false) env name_node =
else begin
env.g +> G.add_node node;
env.g +> G.add_edge (env.current, node) G.Has;
+ let lexing_pos = loc.Asttypes.loc.Location.loc_start in
+ let file = env.source_file in
+ let nodeinfo = { Graph_code.
+ pos = { Parse_info.
+ str ="";
+ line = lexing_pos.Lexing.pos_lnum;
+ charpos = lexing_pos.Lexing.pos_cnum;
+ column = lexing_pos.Lexing.pos_cnum - lexing_pos.Lexing.pos_bol;
+ file;
+ };
+ props = [];
+ } in
+ env.g +> G.add_nodeinfo node nodeinfo;
end
end;
add_full_path_local env (Common.list_last name, name) kind;
@@ -422,6 +438,12 @@ let rec extract_defs_uses
current_entity = [fst current];
current_module = [ast.cmt_modname];
file = readable;
+ (* less: it's in absolute format, should we use instead a readable format?*)
+ source_file = Filename.concat ast.cmt_builddir
+ (match ast.cmt_sourcefile with
+ | None -> failwith (spf "no cmt_source_file for %s" readable)
+ | Some file -> file
+ );
locals = [];
full_path_local_value = ref [];
full_path_local_type = ref [];
@@ -498,20 +520,22 @@ and structure_item_desc env = function
(* second pass *)
List.iter (fun (v1, v2) ->
match v1.pat_desc with
- | Tpat_var(id, _loc) | Tpat_alias (_, id, _loc) ->
+ | Tpat_var(id, loc) | Tpat_alias (_, id, loc) ->
let full_ident = env.current_entity ++ [Ident.name id] in
let node = (full_ident, kind_of_type_expr v2.exp_type) in
(* some people do let foo = ... let foo = ... in the same file *)
- let env = add_node_and_edge_if_defs_mode ~dupe_ok:true env node in
+ let env =
+ add_node_and_edge_if_defs_mode ~dupe_ok:true env node loc in
expression env v2
| Tpat_tuple xs ->
let xdone = ref false in
xs +> List.iter (fun p ->
match p.pat_desc with
- | Tpat_var(id, _loc) | Tpat_alias (_, id, _loc) ->
+ | Tpat_var(id, loc) | Tpat_alias (_, id, loc) ->
let full_ident = env.current_entity ++ [Ident.name id] in
let node = (full_ident, kind_of_type_expr p.pat_type) in
- let env = add_node_and_edge_if_defs_mode ~dupe_ok:true env node in
+ let env =
+ add_node_and_edge_if_defs_mode ~dupe_ok:true env node loc in
(* arbitrarily choose the first one as the source for v2 *)
if not !xdone then begin
@@ -528,16 +552,16 @@ and structure_item_desc env = function
pattern env v1;
expression env v2
) xs
- | Tstr_primitive ((id, _loc, vd)) ->
+ | Tstr_primitive ((id, loc, vd)) ->
let full_ident = env.current_entity ++ [Ident.name id] in
let node = (full_ident, kind_of_value_descr vd) in
- let env = add_node_and_edge_if_defs_mode env node in
+ let env = add_node_and_edge_if_defs_mode env node loc in
value_description env vd
| Tstr_type xs ->
- List.iter (fun (id, _loc, td) ->
+ List.iter (fun (id, loc, td) ->
let full_ident = env.current_entity ++ [Ident.name id] in
let node = (full_ident, E.Type) in
- let env = add_node_and_edge_if_defs_mode env node in
+ let env = add_node_and_edge_if_defs_mode env node loc in
(match td.typ_kind, td.typ_manifest with
| Ttype_abstract, Some ({ctyp_desc=Ttyp_constr (path, _loc, _xs); _}) ->
@@ -548,17 +572,17 @@ and structure_item_desc env = function
);
type_declaration env td
) xs
- | Tstr_exception ((id, _loc, v3)) ->
+ | Tstr_exception ((id, loc, v3)) ->
let full_ident = env.current_entity ++ ["exn";Ident.name id] in
let node = (full_ident, E.Exception) in
- let env = add_node_and_edge_if_defs_mode ~dupe_ok:true env node in
+ let env = add_node_and_edge_if_defs_mode ~dupe_ok:true env node loc in
exception_declaration env v3
- | Tstr_exn_rebind ((id, _loc, v3, _loc2)) ->
+ | Tstr_exn_rebind ((id, loc, v3, _loc2)) ->
let full_ident = env.current_entity ++ ["exn";Ident.name id] in
let node = (full_ident, E.Exception) in
- let env = add_node_and_edge_if_defs_mode env node in
+ let env = add_node_and_edge_if_defs_mode env node loc in
path_t env v3
- | Tstr_module ((id, _loc, modexpr)) ->
+ | Tstr_module ((id, loc, modexpr)) ->
let full_ident = env.current_entity ++ [Ident.name id] in
let node = (full_ident, E.Module) in
(match modexpr.mod_desc with
@@ -570,15 +594,15 @@ and structure_item_desc env = function
end;
add_full_path_local env (Ident.name id, full_ident) E.Module
| _ ->
- let env = add_node_and_edge_if_defs_mode env node in
+ let env = add_node_and_edge_if_defs_mode env node loc in
let env = { env with current_module = full_ident } in
module_expr env modexpr
)
| Tstr_recmodule xs ->
- List.iter (fun (id, _loc, v3, v4) ->
+ List.iter (fun (id, loc, v3, v4) ->
let full_ident = env.current_entity ++ [Ident.name id] in
let node = (full_ident, E.Module) in
- let env = add_node_and_edge_if_defs_mode env node in
+ let env = add_node_and_edge_if_defs_mode env node loc in
let env = { env with current_module = full_ident } in
module_type env v3;
module_expr env v4;
@@ -619,17 +643,17 @@ and type_declaration env
and type_kind env = function
| Ttype_abstract -> ()
| Ttype_variant xs ->
- List.iter (fun (id, _loc, v3, _loc2) ->
+ List.iter (fun (id, loc, v3, _loc2) ->
let full_ident = env.current_entity ++ [Ident.name id] in
let node = (full_ident, E.Constructor) in
- let env = add_node_and_edge_if_defs_mode env node in
+ let env = add_node_and_edge_if_defs_mode env node loc in
List.iter (core_type env) v3;
) xs
| Ttype_record xs ->
- List.iter (fun (id, _loc, _mutable_flag, v4, _loc2) ->
+ List.iter (fun (id, loc, _mutable_flag, v4, _loc2) ->
let full_ident = env.current_entity ++ [Ident.name id] in
let node = (full_ident, E.Field) in
- let env = add_node_and_edge_if_defs_mode env node in
+ let env = add_node_and_edge_if_defs_mode env node loc in
core_type env v4;
) xs
@@ -940,7 +964,7 @@ and
(* Main entry point *)
(*****************************************************************************)
-let build ?(verbose=true) dir_or_file skip_list =
+let build ?(verbose=false) dir_or_file skip_list =
let root = Common.realpath dir_or_file in
let all_files = Lib_parsing_ml.find_cmt_files_of_dir_or_files [root] in
View
116 lang_ml/analyze/unit_analyze_ml.ml
@@ -1,9 +1,7 @@
open Common
open Ast_ml
-
module Db = Database_light_ml
-
open OUnit
(*****************************************************************************)
@@ -16,29 +14,97 @@ open OUnit
let verbose = false
+let prolog_query ~files query =
+
+ let tmp_dir = Filename.temp_file (spf "prolog_ml-%d" (Unix.getpid())) "" in
+ Unix.unlink tmp_dir;
+ (* who cares about race *)
+ Unix.mkdir tmp_dir 0o755;
+ Common.finalize (fun () ->
+
+ (* generating cmt files *)
+ files +> List.iter (fun (filename, content) ->
+ Common.write_file ~file:(Filename.concat tmp_dir filename) content
+ );
+ (* otherwise will get many lookup failure when build the graph_code *)
+ let extra_args = "-nostdlib -nopervasives" in
+ Common.command2 (spf "cd %s; ocamlc -c %s -bin-annot %s"
+ tmp_dir
+ extra_args
+ (* dependency order pbs? assume the given list of files
+ * is ordered for ocamlc to work, which means generic
+ * files first and main files at the end.
+ *)
+ (files +> List.map fst +> Common.join " "));
+ let skip_list = [] in
+ let g = Graph_code_cmt.build ~verbose:verbose tmp_dir skip_list in
+ let facts = Graph_code_prolog.build tmp_dir g in
+ let facts_pl_file = Filename.concat tmp_dir "facts.pl" in
+ Common.with_open_outfile facts_pl_file (fun (pr_no_nl, _chan) ->
+ let pr s = pr_no_nl (s ^ "\n") in
+ facts +> List.iter (fun x -> pr (Graph_code_prolog.string_of_fact x))
+ );
+ let predicates_file =
+ Filename.concat Config_pfff.path "h_program-lang/database_code.pl" in
+ if verbose
+ then Common.cat facts_pl_file +> List.iter pr2;
+ let cmd =
+ spf "swipl -s %s -f %s -t halt --quiet -g \"%s ,fail\""
+ facts_pl_file predicates_file query
+ in
+ let xs = Common.cmd_to_list cmd in
+ xs
+ ) (fun () ->
+ Common.command2 (spf "rm -f %s/*" tmp_dir);
+ Unix.rmdir tmp_dir
+ )
+
+let unittest =
+"analyze_ml" >::: [
+
(*****************************************************************************)
-(* Unit tests *)
+(* Database building *)
(*****************************************************************************)
+ "building light database" >:: (fun () ->
+ let data_dir = Config_pfff.path ^ "/tests/ml/db/" in
+ let _db = Db.compute_database ~verbose [data_dir] in
+ ()
+ );
-(*---------------------------------------------------------------------------*)
-(* Database building *)
-(*---------------------------------------------------------------------------*)
-
-let database_unittest =
- "database_ml" >::: [
-
- "building light database" >:: (fun () ->
- let data_dir = Config_pfff.path ^ "/tests/ml/db/" in
- let _db = Db.compute_database ~verbose [data_dir] in
- ()
- )
- ]
-
-(*---------------------------------------------------------------------------*)
-(* Final suite *)
-(*---------------------------------------------------------------------------*)
-
-let unittest =
- "analyze_ml" >::: [
- database_unittest;
- ]
+(*****************************************************************************)
+(* Prolog queries *)
+(*****************************************************************************)
+ "prolog_ml" >::: ([
+
+ "kind" >:: (fun () ->
+ let files = [
+"pervasives.ml", "
+type 'a ref = { mutable contents : 'a }
+external ref : 'a -> 'a ref = \"%makemutable\"
+";
+"foo.ml", "
+let f x = x
+let g = Pervasives.ref 0
+";] in
+ assert_equal
+ ["function"] (prolog_query ~files "kind(('Foo','f'), X), writeln(X)");
+ assert_equal
+ ["global"] (prolog_query ~files "kind(('Foo','g'), X), writeln(X)");
+ );
+
+ "at" >:: (fun () ->
+ let files = [
+"foo.ml", " (* line 1 *)
+let f x = x (* line 2 *)
+let c = 1 (* line 3 *)
+";] in
+ assert_equal
+ ["3"] (prolog_query ~files "at(('Foo','c'), _, X), writeln(X)");
+ );
+
+ ])
+
+(*****************************************************************************)
+(* Postlude *)
+(*****************************************************************************)
+]
View
27 lang_php/analyze/foundation/database_prolog_php.ml
@@ -104,31 +104,8 @@ let name_of_node = function
| CG.Method (s1, s2) -> spf "('%s','%s')" s1 s2
| CG.FakeRoot -> "'__FAKE_ROOT__'"
-(* quite similar to database_code.string_of_id_kind *)
-let string_of_id_kind = function
- | E.Function -> "function"
- | E.Constant -> "constant"
- | E.Class x ->
- (match x with
- | E.RegularClass -> "class"
- | E.Interface -> "interface"
- | E.Trait -> "trait"
- )
- (* the static/1 predicate will say if static method (or class var) *)
- | E.Method _ -> "method"
-
- (* could also put 'constant' here as the pair of (class,cst) will already
- * differentiate it from regular constants.
- *)
- | E.ClassConstant -> "constant"
- | E.Field -> "field"
-
- | E.TopStmts -> "stmtlist"
- | E.Other _ -> "idmisc"
- | E.Exception -> "exception"
- | E.Constructor -> "constructor"
- | (E.MultiDirs|E.Dir|E.File|E.Macro|E.Global|E.Type|E.Module|E.Package) ->
- raise Impossible
+let string_of_id_kind x =
+ Graph_code_prolog.string_of_entity_kind x
let string_of_modifier = function
| Public -> "is_public"
View
26 main_codequery.ml
@@ -27,12 +27,15 @@ let verbose = ref false
let lang = ref "php"
-(* todo: should remove that at some point and be able to do everything in RAM *)
-let metapath = ref "/tmp/pfff_db"
+let skip_file dir =
+ Filename.concat dir "skip_list.txt"
(* todo: swipl (SWI-Prolog) is not in PATH by default on our machines *)
let swipl = "/home/pad/packages/Linux/bin/swipl"
let predicates_file = "/home/engshare/pfff/database_code.pl"
+(* todo: should remove that at some point and be able to do everything in RAM *)
+let metapath = ref "/tmp/pfff_db"
+
(* action mode *)
let action = ref ""
@@ -44,6 +47,11 @@ let action = ref ""
(* Language specific, building the prolog db *)
(*****************************************************************************)
let build_prolog_db lang root =
+ let skip_list =
+ if Sys.file_exists (skip_file root)
+ then Skip_code.load (skip_file root)
+ else []
+ in
match lang with
| "php" ->
(*
@@ -92,6 +100,20 @@ let build_prolog_db lang root =
pr2 (spf "Your compiled prolog DB is ready. Run %s/%s"
!metapath prolog_compiled_db);
+ | "cmt" ->
+ let g = Graph_code_cmt.build ~verbose:!verbose root skip_list in
+ let facts = Graph_code_prolog.build root g in
+ let facts_pl_file = Filename.concat root "facts.pl" in
+ Common.with_open_outfile facts_pl_file (fun (pr_no_nl, _chan) ->
+ let pr s = pr_no_nl (s ^ "\n") in
+ facts +> List.iter (fun x -> pr (Graph_code_prolog.string_of_fact x))
+ );
+ let prolog_compiled_db = Filename.concat root "prolog_compiled_db" in
+ Common.command2 (spf "%s -c %s %s" swipl facts_pl_file predicates_file);
+ Common.command2 (spf "mv a.out %s" prolog_compiled_db);
+ pr2 (spf "Your compiled proog DB is ready. Run %s" prolog_compiled_db);
+ ()
+
| _ -> failwith ("language not yet supported: " ^ lang)
(*****************************************************************************)
View
8 main_stags.ml
@@ -91,6 +91,14 @@ let rec defs_of_files_or_dirs lang xs =
| [x] -> Tags_java.defs_of_dir_or_file ~verbose x skip_list
| _ -> failwith "the java option accept only a single dir or file"
)
+ | "cmt" ->
+ (match xs with
+ | [root] ->
+ let g = Graph_code_cmt.build root skip_list in
+ Graph_code_tags.defs_of_graph_code ~verbose g
+
+ | _ -> failwith "the cmt option accept only a single dir or file"
+ )
| _ -> failwith ("language not supported: " ^ lang)

No commit comments for this range

Something went wrong with that request. Please try again.