@ -17,157 +17,162 @@ module L = Logging
(* * {2 Source Files} *)
let count_newlines ( path : string ) : int =
let open Core . Std in
let f file = In_channel . fold_lines file ~ init : 0 ~ f : ( fun i _ -> i + 1 ) in
In_channel . with_file path ~ f
type source_file =
| Absolute of string
| RelativeProjectRoot of string (* relative to project root *)
| RelativeInferModel of string (* relative to infer models *)
[ @@ deriving compare ]
let equal_source_file sf1 sf2 =
compare_source_file sf1 sf2 = 0
module OrderedSourceFile =
struct
type t = source_file [ @@ deriving compare ]
end
module SourceFile = struct
module SourceFileMap = Map . Make ( OrderedSourceFile )
module SourceFileSet = Set . Make ( OrderedSourceFile )
let rel_path_from_abs_path root fname =
let relative_complemented_fname = filename_to_relative root fname in
if string_is_prefix root fname &&
Filename . is_relative relative_complemented_fname then
Some relative_complemented_fname
else None (* The project root is not a prefix of the file name *)
let source_file_from_abs_path fname =
if Filename . is_relative fname then
( failwithf
" ERROR: Path %s is relative, when absolute path was expected .@. "
fname ) ;
(* try to get realpath of source file. Use original if it fails *)
let fname_real = try realpath fname with Unix . Unix_error _ -> fname in
let project_root_real = realpath Config . project_root in
let models_dir_real = Config . models_src_dir in
match rel_path_from_abs_path project_root_real fname_real with
| Some path -> RelativeProjectRoot path
| None -> (
match rel_path_from_abs_path models_dir_real fname_real with
| Some path -> RelativeInferModel path
| None -> Absolute fname (* fname is absolute already *)
)
let count_newlines ( path : string ) : int =
let open Core . Std in
let f file = In_channel . fold_lines file ~ init : 0 ~ f : ( fun i _ -> i + 1 ) in
In_channel . with_file path ~ f
let curr_encoding = ` Enc_crc
let source_file_to_string fname =
match fname with
| RelativeInferModel path -> " INFER_MODEL/ " ^ path
| RelativeProjectRoot path
| Absolute path -> path
let source_file_pp fmt fname =
Format . fprintf fmt " %s " ( source_file_to_string fname )
(* Checking if the path exists may be needed only in some cases, hence the flag check_exists *)
let source_file_to_abs_path fname =
match fname with
| RelativeProjectRoot path -> Filename . concat Config . project_root path
| RelativeInferModel path -> Filename . concat Config . models_src_dir path
| Absolute path -> path
let source_file_line_count source_file =
let abs_path = source_file_to_abs_path source_file in
count_newlines abs_path
let source_file_to_rel_path fname =
match fname with
| RelativeProjectRoot path -> path
| _ -> source_file_to_abs_path fname
(* * string encoding of a source file ( including path ) as a single filename *)
let source_file_encoding source_file =
let prefix = match source_file with
| RelativeProjectRoot _ -> " P "
| RelativeInferModel _ -> " MOD "
| Absolute _ -> " ABS " in
let source_file_s = source_file_to_string source_file in
match curr_encoding with
| ` Enc_base ->
Filename . basename source_file_s
| ` Enc_path_with_underscores ->
prefix ^ Escape . escape_path source_file_s
| ` Enc_crc ->
let base = Filename . basename source_file_s in
let dir = prefix ^ Filename . dirname source_file_s in
string_append_crc_cutoff ~ key : dir base
let source_file_empty = Absolute " "
let source_file_is_infer_model source_file = match source_file with
| RelativeProjectRoot _ | Absolute _ -> false
| RelativeInferModel _ -> true
(* * Returns true if the file is a C++ model *)
let source_file_is_cpp_model file =
match file with
| RelativeInferModel path ->
string_is_prefix Config . relative_cpp_models_dir path
| _ -> false
let source_file_is_under_project_root = function
| RelativeProjectRoot _ -> true
| Absolute _ | RelativeInferModel _ -> false
let source_file_exists_cache = Hashtbl . create 256
let source_file_path_exists abs_path =
try Hashtbl . find source_file_exists_cache abs_path
with Not_found ->
let result = Sys . file_exists abs_path in
Hashtbl . add source_file_exists_cache abs_path result ;
result
let source_file_of_header header_file =
let abs_path = source_file_to_abs_path header_file in
let source_file_exts = [ " c " ; " cc " ; " cpp " ; " cxx " ; " m " ; " mm " ] in
let header_file_exts = [ " h " ; " hh " ; " hpp " ; " hxx " ] in
let file_no_ext , ext_opt = Core . Std . Filename . split_extension abs_path in
let file_opt = match ext_opt with
| Some ext when IList . mem Core . Std . String . equal ext header_file_exts -> (
let possible_files = IList . map ( fun ext -> file_no_ext ^ " . " ^ ext ) source_file_exts in
try Some ( IList . find source_file_path_exists possible_files )
with Not_found -> None
)
| _ -> None in
Option . map source_file_from_abs_path file_opt
let changed_source_files_set =
let create_source_file path =
if Filename . is_relative path then
(* sources in changed-files-index may be specified relative to project root *)
RelativeProjectRoot path
else
source_file_from_abs_path path in
Option . map_default read_file None Config . changed_files_index | >
Option . map (
IList . fold_left
( fun changed_files line ->
let source_file = create_source_file line in
let changed_files' = SourceFileSet . add source_file changed_files in
(* Add source corresponding to changed header if it exists *)
match source_file_of_header source_file with
| Some src -> SourceFileSet . add src changed_files'
| None -> changed_files'
type t =
| Absolute of string
| RelativeProjectRoot of string (* relative to project root *)
| RelativeInferModel of string (* relative to infer models *)
[ @@ deriving compare ]
let equal sf1 sf2 =
compare sf1 sf2 = 0
module OrderedSourceFile =
struct
(* Don't use nonrec due to https://github.com/janestreet/ppx_compare/issues/2 *)
type _ t = t [ @@ deriving compare ]
type t = _ t [ @@ deriving compare ]
end
module Map = Map . Make ( OrderedSourceFile )
module Set = Set . Make ( OrderedSourceFile )
let rel_path_from_abs_path root fname =
let relative_complemented_fname = filename_to_relative root fname in
if string_is_prefix root fname &&
Filename . is_relative relative_complemented_fname then
Some relative_complemented_fname
else None (* The project root is not a prefix of the file name *)
let from_abs_path fname =
if Filename . is_relative fname then
( failwithf
" ERROR: Path %s is relative, when absolute path was expected .@. "
fname ) ;
(* try to get realpath of source file. Use original if it fails *)
let fname_real = try realpath fname with Unix . Unix_error _ -> fname in
let project_root_real = realpath Config . project_root in
let models_dir_real = Config . models_src_dir in
match rel_path_from_abs_path project_root_real fname_real with
| Some path -> RelativeProjectRoot path
| None -> (
match rel_path_from_abs_path models_dir_real fname_real with
| Some path -> RelativeInferModel path
| None -> Absolute fname (* fname is absolute already *)
)
SourceFileSet . empty
)
let curr_encoding = ` Enc_crc
let to_string fname =
match fname with
| RelativeInferModel path -> " INFER_MODEL/ " ^ path
| RelativeProjectRoot path
| Absolute path -> path
let pp fmt fname =
Format . fprintf fmt " %s " ( to_string fname )
(* Checking if the path exists may be needed only in some cases, hence the flag check_exists *)
let to_abs_path fname =
match fname with
| RelativeProjectRoot path -> Filename . concat Config . project_root path
| RelativeInferModel path -> Filename . concat Config . models_src_dir path
| Absolute path -> path
let line_count source_file =
let abs_path = to_abs_path source_file in
count_newlines abs_path
let to_rel_path fname =
match fname with
| RelativeProjectRoot path -> path
| _ -> to_abs_path fname
(* * string encoding of a source file ( including path ) as a single filename *)
let encoding source_file =
let prefix = match source_file with
| RelativeProjectRoot _ -> " P "
| RelativeInferModel _ -> " MOD "
| Absolute _ -> " ABS " in
let source_file_s = to_string source_file in
match curr_encoding with
| ` Enc_base ->
Filename . basename source_file_s
| ` Enc_path_with_underscores ->
prefix ^ Escape . escape_path source_file_s
| ` Enc_crc ->
let base = Filename . basename source_file_s in
let dir = prefix ^ Filename . dirname source_file_s in
string_append_crc_cutoff ~ key : dir base
let empty = Absolute " "
let is_infer_model source_file = match source_file with
| RelativeProjectRoot _ | Absolute _ -> false
| RelativeInferModel _ -> true
(* * Returns true if the file is a C++ model *)
let is_cpp_model file =
match file with
| RelativeInferModel path ->
string_is_prefix Config . relative_cpp_models_dir path
| _ -> false
let is_under_project_root = function
| RelativeProjectRoot _ -> true
| Absolute _ | RelativeInferModel _ -> false
let exists_cache = Hashtbl . create 256
let path_exists abs_path =
try Hashtbl . find exists_cache abs_path
with Not_found ->
let result = Sys . file_exists abs_path in
Hashtbl . add exists_cache abs_path result ;
result
let of_header header_file =
let abs_path = to_abs_path header_file in
let source_exts = [ " c " ; " cc " ; " cpp " ; " cxx " ; " m " ; " mm " ] in
let header_exts = [ " h " ; " hh " ; " hpp " ; " hxx " ] in
let file_no_ext , ext_opt = Core . Std . Filename . split_extension abs_path in
let file_opt = match ext_opt with
| Some ext when IList . mem Core . Std . String . equal ext header_exts -> (
let possible_files = IList . map ( fun ext -> file_no_ext ^ " . " ^ ext ) source_exts in
try Some ( IList . find path_exists possible_files )
with Not_found -> None
)
| _ -> None in
Option . map from_abs_path file_opt
let changed_files_set =
let create_source_file path =
if Filename . is_relative path then
(* sources in changed-files-index may be specified relative to project root *)
RelativeProjectRoot path
else
from_abs_path path in
Option . map_default read_file None Config . changed_files_index | >
Option . map (
IList . fold_left
( fun changed_files line ->
let source_file = create_source_file line in
let changed_files' = Set . add source_file changed_files in
(* Add source corresponding to changed header if it exists *)
match of_header source_file with
| Some src -> Set . add src changed_files'
| None -> changed_files'
)
Set . empty
)
end
(* * {2 Source Dirs} *)
@ -189,7 +194,7 @@ let captured_dir =
(* * get the source directory corresponding to a source file *)
let source_dir_from_source_file source_file =
Filename . concat captured_dir ( source_file_ source_file )
Filename . concat captured_dir ( SourceFile . source_file )
(* * Find the source directories in the results dir *)
let find_source_dirs () =
@ -312,7 +317,7 @@ module Results_dir = struct
type path_kind =
| Abs_root
(* * absolute path implicitly rooted at the root of the results dir *)
| Abs_source_dir of source_file
| Abs_source_dir of SourceFile . t
(* * absolute path implicitly rooted at the source directory for the file *)
| Rel
(* * relative path *)
@ -343,7 +348,7 @@ module Results_dir = struct
create_dir specs_dir ;
create_dir ( path_to_filename Abs_root [ Config . attributes_dir_name ] ) ;
create_dir ( path_to_filename Abs_root [ Config . captured_dir_name ] ) ;
if not ( equal_source_file source source_file_ ) then
if not ( SourceFile . equal source SourceFile . ) then
create_dir ( path_to_filename ( Abs_source_dir source ) [] )
let clean_specs_dir () =
Andrzej Kotulski
8 years ago
committed by
Facebook Github Bot