From 1bd741b07065c510406eb94e23b6a12da0c4af08 Mon Sep 17 00:00:00 2001 From: Radu Grigore Date: Fri, 7 May 2021 05:08:09 -0700 Subject: [PATCH] [erl-frontend] Erlang AST, and parser for JSON AST. Summary: The wrapper in `infer/lib/erlang/erlang.sh` dumps Erlang AST forms [1] in a JSON format. The current commit parses that JSON to obtain an internal representation (ErlangAst). The main parts of the commit are: - data structures for Erlang AST - parser (Erlang abstract forms in JSON format -> Eralng AST) - Rebar3.ml now drives the parser [1] https://erlang.org/doc/apps/erts/absform.html Reviewed By: mmarescotti, jvillard Differential Revision: D28096896 fbshipit-source-id: b21263817 --- infer/man/man1/infer-capture.txt | 8 + infer/man/man1/infer-full.txt | 13 + infer/man/man1/infer.txt | 10 + infer/src/base/Config.ml | 20 + infer/src/base/Config.mli | 4 + infer/src/base/Utils.ml | 4 + infer/src/base/Utils.mli | 6 +- infer/src/deadcode/Makefile | 4 +- infer/src/erlang/ErlangAst.ml | 140 +++++++ infer/src/erlang/ErlangJsonParser.ml | 524 ++++++++++++++++++++++++++ infer/src/erlang/ErlangJsonParser.mli | 10 + infer/src/erlang/dune | 12 + infer/src/integration/Rebar3.ml | 32 +- infer/src/integration/dune.in | 4 +- 14 files changed, 779 insertions(+), 12 deletions(-) create mode 100644 infer/src/erlang/ErlangAst.ml create mode 100644 infer/src/erlang/ErlangJsonParser.ml create mode 100644 infer/src/erlang/ErlangJsonParser.mli create mode 100644 infer/src/erlang/dune diff --git a/infer/man/man1/infer-capture.txt b/infer/man/man1/infer-capture.txt index 05a66117f..161a69f8d 100644 --- a/infer/man/man1/infer-capture.txt +++ b/infer/man/man1/infer-capture.txt @@ -278,6 +278,14 @@ CLANG OPTIONS analyze an iOS app. xcpretty just needs to be in the path, infer command is still just `infer -- `. (Conversely: --no-xcpretty) +ERLANG OPTIONS + --erlang-ast-dir dir + Also load AST from all .json files in the given path. These .json + files usually come from a previous run with --debug. + + --erlang-skip-rebar3 + Activates: Skip running rebar, to save time. It is useful together + with --erlang-ast-dir. (Conversely: --no-erlang-skip-rebar3) JAVA OPTIONS --bootclasspath string Specify the Java bootclasspath diff --git a/infer/man/man1/infer-full.txt b/infer/man/man1/infer-full.txt index d8e9991e0..c12e7e053 100644 --- a/infer/man/man1/infer-full.txt +++ b/infer/man/man1/infer-full.txt @@ -613,6 +613,16 @@ OPTIONS Activates: Enable eradicate and disable all other checkers (Conversely: --no-eradicate-only) See also infer-analyze(1). + --erlang-ast-dir dir + Also load AST from all .json files in the given path. These .json + files usually come from a previous run with --debug. + See also infer-capture(1). + + --erlang-skip-rebar3 + Activates: Skip running rebar, to save time. It is useful together + with --erlang-ast-dir. (Conversely: --no-erlang-skip-rebar3) + See also infer-capture(1). + --external-java-packages +prefix Specify a list of Java package prefixes for external Java packages. If set, the analysis will not report non-actionable @@ -1637,6 +1647,9 @@ INTERNAL OPTIONS Activates: Print initial and final typestates (Conversely: --no-eradicate-verbose) + --erlang-ast-dir-reset + Cancel the effect of --erlang-ast-dir. + --export-changed-functions Activates: Make infer output changed functions, similar to test-determinator. It is used together with the --modified-lines. diff --git a/infer/man/man1/infer.txt b/infer/man/man1/infer.txt index 8693cb8eb..2a8ba9d21 100644 --- a/infer/man/man1/infer.txt +++ b/infer/man/man1/infer.txt @@ -613,6 +613,16 @@ OPTIONS Activates: Enable eradicate and disable all other checkers (Conversely: --no-eradicate-only) See also infer-analyze(1). + --erlang-ast-dir dir + Also load AST from all .json files in the given path. These .json + files usually come from a previous run with --debug. + See also infer-capture(1). + + --erlang-skip-rebar3 + Activates: Skip running rebar, to save time. It is useful together + with --erlang-ast-dir. (Conversely: --no-erlang-skip-rebar3) + See also infer-capture(1). + --external-java-packages +prefix Specify a list of Java package prefixes for external Java packages. If set, the analysis will not report non-actionable diff --git a/infer/src/base/Config.ml b/infer/src/base/Config.ml index 262167f95..4866e89c2 100644 --- a/infer/src/base/Config.ml +++ b/infer/src/base/Config.ml @@ -139,6 +139,8 @@ let manual_clang = "CLANG OPTIONS" let manual_clang_linters = "CLANG LINTERS OPTIONS" +let manual_erlang = "ERLANG OPTIONS" + let manual_explore_bugs = "EXPLORE BUGS" let manual_debug_procedures = "DEBUG PROCEDURES" @@ -1384,6 +1386,20 @@ and eradicate_return_over_annotated = and eradicate_verbose = CLOpt.mk_bool ~long:"eradicate-verbose" "Print initial and final typestates" +and erlang_ast_dir = + CLOpt.mk_path_opt ~long:"erlang-ast-dir" + ~in_help:InferCommand.[(Capture, manual_erlang)] + ~meta:"dir" + "Also load AST from all .json files in the given path. These .json files usually come from a \ + previous run with $(b,--debug)." + + +and erlang_skip_rebar3 = + CLOpt.mk_bool ~long:"erlang-skip-rebar3" + ~in_help:InferCommand.[(Capture, manual_erlang)] + "Skip running rebar, to save time. It is useful together with $(b,--erlang-ast-dir)." + + and export_changed_functions = CLOpt.mk_bool ~deprecated:["test-determinator-clang"] ~long:"export-changed-functions" ~default:false @@ -3012,6 +3028,10 @@ and eradicate_return_over_annotated = !eradicate_return_over_annotated and eradicate_verbose = !eradicate_verbose +and erlang_ast_dir = !erlang_ast_dir + +and erlang_skip_rebar3 = !erlang_skip_rebar3 + and external_java_packages = !external_java_packages and fail_on_bug = !fail_on_bug diff --git a/infer/src/base/Config.mli b/infer/src/base/Config.mli index 4e91df80a..846397e3e 100644 --- a/infer/src/base/Config.mli +++ b/infer/src/base/Config.mli @@ -294,6 +294,10 @@ val eradicate_return_over_annotated : bool val eradicate_verbose : bool +val erlang_ast_dir : string option + +val erlang_skip_rebar3 : bool + val fail_on_bug : bool val fcp_apple_clang : string option diff --git a/infer/src/base/Utils.ml b/infer/src/base/Utils.ml index a58a0560c..284a3df9e 100644 --- a/infer/src/base/Utils.ml +++ b/infer/src/base/Utils.ml @@ -210,6 +210,10 @@ let read_json_file path = try Ok (Yojson.Basic.from_file path) with Sys_error msg | Yojson.Json_error msg -> Error msg +let read_safe_json_file path = + try Ok (Yojson.Safe.from_file path) with Sys_error msg | Yojson.Json_error msg -> Error msg + + let do_finally_swallow_timeout ~f ~finally = let res = try f () diff --git a/infer/src/base/Utils.mli b/infer/src/base/Utils.mli index f3c532268..72a4e405a 100644 --- a/infer/src/base/Utils.mli +++ b/infer/src/base/Utils.mli @@ -52,16 +52,18 @@ val close_outf : outfile -> unit (** close an outfile *) val directory_fold : ('a -> string -> 'a) -> 'a -> string -> 'a -(** Functional fold function over all the file of a directory *) +(** Functional fold function over all the files of a directory *) val directory_iter : (string -> unit) -> string -> unit -(** Functional iter function over all the file of a directory *) +(** Functional iter function over all the files of a directory *) val directory_is_empty : string -> bool (** Returns true if a given directory is empty. The directory is assumed to exist. *) val read_json_file : string -> (Yojson.Basic.t, string) Result.t +val read_safe_json_file : string -> (Yojson.Safe.t, string) Result.t + val with_file_in : string -> f:(In_channel.t -> 'a) -> 'a val with_file_out : string -> f:(Out_channel.t -> 'a) -> 'a diff --git a/infer/src/deadcode/Makefile b/infer/src/deadcode/Makefile index 7f0c57676..231cdfc05 100644 --- a/infer/src/deadcode/Makefile +++ b/infer/src/deadcode/Makefile @@ -50,8 +50,8 @@ endif # Note that we run find under _build directory. Since we copy some # sources from subfolders to src/ folder to avoid duplicates we use # $(DEPTH_ONE) and iteration over main and library folders. -LIBRARY_FOLDERS = . ./IR ./absint ./al ./atd ./backend ./base ./biabduction ./bufferoverrun ./c_stubs ./checkers ./clang ./clang/unit ./concurrency ./cost ./integration ./istd ./java ./labs ./dotnet ./nullsafe ./nullsafe/unit ./pulse ./quandary ./scripts ./test_determinator ./topl ./unit -INCLUDE_FOLDERS = -I IR -I absint -I al -I atd -I backend -I base -I biabduction -I bufferoverrun -I c_stubs -I checkers -I clang -I clang/unit -I concurrency -I cost -I integration -I istd -I java -I labs -I dotnet -I nullsafe -I nullsafe/unit -I pulse -I quandary -I scripts -I test_determinator -I topl -I unit +LIBRARY_FOLDERS = . ./IR ./absint ./al ./atd ./backend ./base ./biabduction ./bufferoverrun ./c_stubs ./checkers ./clang ./clang/unit ./concurrency ./cost ./erlang ./integration ./istd ./java ./labs ./dotnet ./nullsafe ./nullsafe/unit ./pulse ./quandary ./scripts ./test_determinator ./topl ./unit +INCLUDE_FOLDERS = -I IR -I absint -I al -I atd -I backend -I base -I biabduction -I bufferoverrun -I c_stubs -I checkers -I clang -I clang/unit -I concurrency -I cost -I erlang -I integration -I istd -I java -I labs -I dotnet -I nullsafe -I nullsafe/unit -I pulse -I quandary -I scripts -I test_determinator -I topl -I unit ml_src_files = $(shell \ cd $(INFER_BUILD_DIR); \ diff --git a/infer/src/erlang/ErlangAst.ml b/infer/src/erlang/ErlangAst.ml new file mode 100644 index 000000000..48fa11862 --- /dev/null +++ b/infer/src/erlang/ErlangAst.ml @@ -0,0 +1,140 @@ +(* + * Copyright (c) Facebook, Inc. and its affiliates. + * + * This source code is licensed under the MIT license found in the + * LICENSE file in the root directory of this source tree. + *) +(** Erlang abstract forms, following https://erlang.org/doc/apps/erts/absform.html *) + +open! IStd + +(* TODO: validation, including basic type-checking *) + +(** {2 Basics} *) + +type module_reference = ModuleName of string | ModuleMissing | ModuleVariable of string + +type function_reference = FunctionName of string | FunctionVariable of string + +(* NOTE: Arity could be an expression but we don't handle that case, yet. *) +type function_ = {module_: module_reference; function_: function_reference; arity: int} + +type line = int + +type record_name = string + +type binary_operator = + | Add + | And + | AndAlso + | AtLeast + | AtMost + | BAnd + | BOr + | Bsl + | Bsr + | BXor + | Equal + | ExactlyEqual + | ExactlyNotEqual + | FDiv + | Greater + | IDiv + | Less + | ListAdd + | ListSub + | Mul + | NotEqual + | Or + | OrElse + | Rem + | Send + | Sub + | Xor + +type unary_operator = UBNot | UMinus | UNot + +type association_kind = Arrow | Exact + +type exception_ = Atom of string | Pattern of string + +type type_specifier = (* TODO *) unit + +(** {2 S8.2: Atomic literals} *) + +type literal = Atom of string | Char of string | Float of float | Int of string | String of string + +(** {2 S8.4: Expressions} *) + +type body = expression list + +and simple_expression = + | BinaryOperator of expression * binary_operator * expression + | BitstringComprehension of {expression: expression; qualifiers: qualifier list} + | BitstringConstructor of bin_element list + | Block of body + | Call of {module_: expression option; function_: expression; args: expression list} + | Case of {expression: expression; cases: case_clause list} + | Catch of expression + | Cons of {head: expression; tail: expression} + | Fun of function_ + | If of case_clause list + | Lambda of {name: string option; cases: case_clause list} + | ListComprehension of {expression: expression; qualifiers: qualifier list} + | Literal of literal + | Map of {map: expression option; updates: association list} + | Match of {pattern: pattern; body: (* body is a pattern within patterns *) expression} + | Nil + | Receive of {cases: case_clause list; timeout: timeout option} + | RecordAccess of {record: expression; name: record_name; field: string} + | RecordIndex of {name: record_name; field: string} (* factor from above? *) + | RecordUpdate of {record: expression option; name: record_name; updates: record_update list} + | TryCatch of {body: body; ok_cases: case_clause list; catch_cases: catch_clause list; after: body} + | Tuple of expression list + | UnaryOperator of unary_operator * expression + | Variable of string + +and expression = {line: line; simple_expression: simple_expression} + +and qualifier = + | BitsGenerator of {pattern: pattern; expression: expression} + | Filter of expression + | Generator of {pattern: pattern; expression: expression} + +and timeout = {time: expression; handler: body} + +and bin_element = + {expression: expression; size: expression option; types: type_specifier list option} + +(* A [None] field stands for _, which means "all other fields". *) +and record_update = {field: string option; expression: expression} + +and association = {kind: association_kind; key: expression; value: expression} + +and pattern = expression + +and guard = expression + +(** {2 S8.5 Clauses} *) + +and 'pat clause = {line: line; patterns: 'pat list; guards: guard list; body: body} + +and case_clause = pattern clause + +and catch_clause = catch_pattern clause + +and catch_pattern = {exception_: exception_; pattern: pattern; variable: string} + +(** {2 S8.1: Module declarations and forms} *) + +(* TODO: Add records, types, and specs. *) +type simple_form = + | Export of function_ list + | Import of {module_name: string; functions: function_ list} + | Module of string + | File of {path: string} + | Function of {function_: function_; clauses: case_clause list} + +type form = {line: line; simple_form: simple_form} + +type module_ = form list diff --git a/infer/src/erlang/ErlangJsonParser.ml b/infer/src/erlang/ErlangJsonParser.ml new file mode 100644 index 000000000..acae5a040 --- /dev/null +++ b/infer/src/erlang/ErlangJsonParser.ml @@ -0,0 +1,524 @@ +(* + * Copyright (c) Facebook, Inc. and its affiliates. + * + * This source code is licensed under the MIT license found in the + * LICENSE file in the root directory of this source tree. + *) + +open! IStd +module L = Logging +module YSU = Yojson.Safe.Util +module Ast = ErlangAst +open IOption.Let_syntax + +type json = Yojson.Safe.t + +type 'a parser = json -> 'a option + +let unknown name json = + L.debug Capture Verbose "ErlangAst.Parse: unknown %s: %s@." name (Yojson.Safe.show json) ; + None + + +(* Takes a json of the form `List [j1;...;jn] and returns [f j1;...;f jn]. If skip_errors, then + elements that fail to parse are filtered out; otherwise, a parsing failure propagates up. *) +let to_list ?(skip_errors = false) ~(f : 'a parser) : 'a list parser = + fun json -> + try + let xs = List.map ~f (YSU.to_list json) in + if skip_errors then Some (List.filter_opt xs) else Option.all xs + with YSU.Type_error (error, json) -> unknown error json + + +let default_or (to_a : 'a parser) : 'a option parser = function + | `String "default" -> + Some None + | a -> + let* a = to_a a in + Some (Some a) + + +let to_line json : Ast.line option = + (* TODO: When OTP is upgraded, add case for line&col locations. *) + match json with + | `Int line -> + Some line + | `List [`List (`String "generated" :: _); `List [`String "location"; `Int line]] -> + Some line + | _ -> + unknown "line" json + + +let rec kill_singleton_list json = + match json with + | `List (`String _ :: _) -> + json (* an expression *) + | `List [x] -> + kill_singleton_list x (* singleton list dropped *) + | x -> + x + + +let one_list json = + match kill_singleton_list json with + | `List (`String _ :: _) as json -> + `List [json] + | `List _ as json -> + json (* already (nonsingleton) list *) + | json -> + `List [json] + + +let to_intlit json = + match json with + | `Int x -> + Some (Printf.sprintf "%d" x) + | `Intlit s -> + Some s + | _ -> + unknown "intlit" json + + +let to_binary_operator json : Ast.binary_operator option = + match json with + | `String "!" -> + Some Send + | `String "*" -> + Some Mul + | `String "+" -> + Some Add + | `String "++" -> + Some ListAdd + | `String "-" -> + Some Sub + | `String "--" -> + Some ListSub + | `String "/" -> + Some FDiv + | `String "/=" -> + Some NotEqual + | `String "<" -> + Some Less + | `String "=/=" -> + Some ExactlyNotEqual + | `String "=:=" -> + Some ExactlyEqual + | `String "=<" -> + Some AtMost + | `String "==" -> + Some Equal + | `String ">" -> + Some Greater + | `String ">=" -> + Some AtLeast + | `String "and" -> + Some And + | `String "andalso" -> + Some AndAlso + | `String "band" -> + Some BAnd + | `String "bor" -> + Some BOr + | `String "bsl" -> + Some Bsl + | `String "bsr" -> + Some Bsr + | `String "bxor" -> + Some BXor + | `String "div" -> + Some IDiv + | `String "or" -> + Some Or + | `String "orelse" -> + Some OrElse + | `String "rem" -> + Some Rem + | `String "xor" -> + Some Xor + | _ -> + unknown "binary_operator" json + + +let to_unary_operator json : Ast.unary_operator option = + match json with + | `String "-" -> + Some UMinus + | `String "bnot" -> + Some UBNot + | `String "not" -> + Some UNot + | _ -> + unknown "binary_operator" json + + +let to_exception json : Ast.exception_ option = + match json with + | `List [`String "atom"; _anno; `String atom] -> + Some (Atom atom) + | `List [`String "var"; _anno; `String variable] -> + Some (Pattern variable) + | _ -> + unknown "exception" json + + +let to_arity json : int option = + match json with + | `Int arity -> + Some arity + | `List [`String "integer"; _anno; `Int arity] -> + Some arity + | _ -> + unknown "arity" json + + +let to_module_reference json : Ast.module_reference option = + match json with + | `List [`String "atom"; _anno; `String name] -> + Some (ModuleName name) + | `List [`String "var"; _anno; `String variable] -> + Some (ModuleVariable variable) + | `String name -> + Some (ModuleName name) + | _ -> + unknown "module_reference" json + + +let to_function_reference json : Ast.function_reference option = + match json with + | `List [`String "atom"; _anno; `String name] -> + Some (FunctionName name) + | `List [`String "var"; _anno; `String variable] -> + Some (FunctionVariable variable) + | `String name -> + Some (FunctionName name) + | _ -> + unknown "function_reference" json + + +let rec to_expression json : Ast.expression option = + let expr line simple_expression : Ast.expression option = Some {line; simple_expression} in + match json with + | `List [`String "atom"; anno; `Bool atom] -> + let* line = to_line anno in + expr line (Literal (Atom (Printf.sprintf "%b" atom))) + | `List [`String "atom"; anno; `Null] -> + let* line = to_line anno in + expr line (Literal (Atom "null")) + | `List [`String "atom"; anno; `String atom] -> + let* line = to_line anno in + expr line (Literal (Atom atom)) + | `List [`String "bc"; anno; expression; qualifiers] -> + let* line = to_line anno in + let* expression = to_expression expression in + let* qualifiers = to_list ~f:to_qualifier qualifiers in + expr line (BitstringComprehension {expression; qualifiers}) + | `List [`String "bin"; anno; elements] -> + let* line = to_line anno in + let* elements = to_list ~f:to_bin_element elements in + expr line (BitstringConstructor elements) + | `List [`String "block"; anno; body] -> + let* line = to_line anno in + let* body = to_body body in + expr line (Block body) + | `List [`String "call"; anno; `List [`String "remote"; `Int _line2; module_; function_]; args] -> + let* line = to_line anno in + let* module_ = to_expression module_ in + let* function_ = to_expression function_ in + let* args = to_body args in + expr line (Call {module_= Some module_; function_; args}) + | `List [`String "call"; anno; function_; args] -> + let* line = to_line anno in + let* function_ = to_expression function_ in + let* args = to_body args in + expr line (Call {module_= None; function_; args}) + | `List [`String "case"; anno; expression; cases] -> + let* line = to_line anno in + let* expression = to_expression expression in + let* cases = to_list ~f:to_case_clause cases in + expr line (Case {expression; cases}) + | `List [`String "catch"; anno; expression] -> + let* line = to_line anno in + let* expression = to_expression expression in + expr line (Catch expression) + | `List [`String "char"; anno; charlit] -> + let* line = to_line anno in + let* charlit = to_intlit charlit in + expr line (Literal (Char charlit)) + | `List [`String "cons"; anno; head; tail] -> + let* line = to_line anno in + let* head = to_expression head in + let* tail = to_expression tail in + expr line (Cons {head; tail}) + | `List [`String "float"; anno; `Float floatlit] -> + let* line = to_line anno in + expr line (Literal (Float floatlit)) + | `List [`String "fun"; anno; `List [`String "clauses"; cases]] -> + let* line = to_line anno in + let* cases = to_list ~f:to_case_clause cases in + expr line (Lambda {name= None; cases}) + | `List [`String "fun"; anno; `List [`String "function"; function_; arity]] -> + let* line = to_line anno in + let* function_ = to_function_reference function_ in + let* arity = to_arity arity in + expr line (Fun {module_= ModuleMissing; function_; arity}) + | `List [`String "fun"; anno; `List [`String "function"; module_; function_; arity]] -> + let* line = to_line anno in + let* module_ = to_module_reference module_ in + let* function_ = to_function_reference function_ in + let* arity = to_arity arity in + expr line (Fun {module_; function_; arity}) + | `List [`String "if"; anno; cases] -> + let* line = to_line anno in + let* cases = to_list ~f:to_case_clause cases in + expr line (If cases) + | `List [`String "integer"; anno; intlit] -> + let* line = to_line anno in + let* intlit = to_intlit intlit in + expr line (Literal (Int intlit)) + | `List [`String "lc"; anno; expression; qualifiers] -> + let* line = to_line anno in + let* expression = to_expression expression in + let* qualifiers = to_list ~f:to_qualifier qualifiers in + expr line (ListComprehension {expression; qualifiers}) + | `List [`String "map"; anno; map; updates] -> + let* line = to_line anno in + let* map = to_expression map in + let* updates = to_list ~f:to_association updates in + expr line (Map {map= Some map; updates}) + | `List [`String "map"; anno; updates] -> + let* line = to_line anno in + let* updates = to_list ~f:to_association updates in + expr line (Map {map= None; updates}) + | `List [`String "match"; anno; pattern; body] -> + let* line = to_line anno in + let* pattern = to_expression pattern in + let* body = to_expression body in + expr line (Match {pattern; body}) + | `List [`String "named_fun"; anno; `String name; cases] -> + let* line = to_line anno in + let* cases = to_list ~f:to_case_clause cases in + expr line (Lambda {name= Some name; cases}) + | `List [`String "nil"; anno] -> + let* line = to_line anno in + expr line Nil + | `List [`String "op"; _anno; `String "+"; argument] -> + to_expression argument + | `List [`String "op"; anno; op; argument] -> + let* line = to_line anno in + let* op = to_unary_operator op in + let* argument = to_expression argument in + expr line (UnaryOperator (op, argument)) + | `List [`String "op"; anno; op; left; right] -> + let* line = to_line anno in + let* op = to_binary_operator op in + let* left = to_expression left in + let* right = to_expression right in + expr line (BinaryOperator (left, op, right)) + | `List [`String "receive"; anno; cases; time; handler] -> + let* line = to_line anno in + let* cases = to_list ~f:to_case_clause cases in + let* time = to_expression time in + let* handler = to_body handler in + expr line (Receive {cases; timeout= Some {time; handler}}) + | `List [`String "receive"; anno; cases] -> + let* line = to_line anno in + let* cases = to_list ~f:to_case_clause cases in + expr line (Receive {cases; timeout= None}) + | `List [`String "record"; anno; `String name; updates] -> + let* line = to_line anno in + let* updates = to_list ~f:to_record_update updates in + expr line (RecordUpdate {record= None; name; updates}) + | `List [`String "record"; anno; record; `String name; updates] -> + let* line = to_line anno in + let* record = to_expression record in + let* updates = to_list ~f:to_record_update updates in + expr line (RecordUpdate {record= Some record; name; updates}) + | `List + [ `String "record_field" + ; anno + ; record + ; `String name + ; `List [`String "atom"; _anno; `String field] ] -> + let* line = to_line anno in + let* record = to_expression record in + expr line (RecordAccess {record; name; field}) + | `List + [ `String "record_index" + ; anno + ; `String name + ; `List [`String "atom"; _anno_field; `String field] ] -> + let* line = to_line anno in + expr line (RecordIndex {name; field}) + | `List [`String "string"; anno; `List []] -> + let* line = to_line anno in + expr line (Literal (String "")) + | `List [`String "string"; anno; `String s] -> + let* line = to_line anno in + expr line (Literal (String s)) + | `List [`String "try"; anno; body; ok_cases; catch_cases; after] -> + let* line = to_line anno in + let* body = to_body body in + let* ok_cases = to_list ~f:to_case_clause ok_cases in + let* catch_cases = to_list ~f:to_catch_clause catch_cases in + let* after = to_body after in + expr line (TryCatch {body; ok_cases; catch_cases; after}) + | `List [`String "tuple"; anno; tuple] -> + let* line = to_line anno in + let* xs = to_list ~f:to_expression tuple in + expr line (Tuple xs) + | `List [`String "var"; anno; `String variable] -> + let* line = to_line anno in + expr line (Variable variable) + | _ -> + unknown "expression" json + + +and to_body json : Ast.expression list option = to_list ~f:to_expression json + +and to_association json : Ast.association option = + match json with + | `List [`String "map_field_assoc"; _anno; key; value] -> + let* key = to_expression key in + let* value = to_expression value in + Some {Ast.kind= Arrow; key; value} + | `List [`String "map_field_exact"; _anno; key; value] -> + let* key = to_expression key in + let* value = to_expression value in + Some {Ast.kind= Exact; key; value} + | _ -> + unknown "association" json + + +and to_record_update json : Ast.record_update option = + match json with + | `List + [ `String "record_field" + ; _anno_update + ; `List [`String "var"; _anno_field; `String "_"] + ; expression ] -> + let* expression = to_expression expression in + Some {Ast.field= None; expression} + | `List + [ `String "record_field" + ; _anno_update + ; `List [`String "atom"; _anno_field; `String field] + ; expression ] -> + let* expression = to_expression expression in + Some {Ast.field= Some field; expression} + | _ -> + unknown "record_update" json + + +and to_bin_element json : Ast.bin_element option = + match json with + | `List [`String "bin_element"; _anno; expression; size; (* TODO *) _type_specifier_list] -> + let* expression = to_expression expression in + let* size = default_or to_expression size in + Some {Ast.expression; size; types= None} + | _ -> + unknown "bin_element" json + + +and to_catch_pattern json : Ast.catch_pattern option = + match json with + | `List + [ `String "tuple" + ; _anno + ; `List [exception_; pattern; `List [`String "var"; _var_anno; `String variable]] ] -> + let* exception_ = to_exception exception_ in + let* pattern = to_expression pattern in + Some {Ast.exception_; pattern; variable} + | _ -> + unknown "catch_pattern" json + + +and to_guards line json : Ast.expression list option = + let andalso e1 e2 = {Ast.line; simple_expression= BinaryOperator (e1, AndAlso, e2)} in + let to_dnf_term xs = + let* atom_guards = to_list ~f:to_expression (one_list xs) in + match atom_guards with + | [] -> + unknown "empty_guard?" json + | [e] -> + Some e + | e :: es -> + Some (List.fold ~init:e ~f:andalso es) + in + json |> one_list |> to_list ~f:to_dnf_term + + +and to_clause : 'pat. 'pat parser -> 'pat Ast.clause parser = + fun to_pat json -> + match json with + | `List [`String "clause"; anno; patterns; guards; body] -> + let* line = to_line anno in + let* patterns = to_list ~f:to_pat patterns in + let* guards = to_guards line guards in + let body = one_list body in + let* body = to_body body in + Some {Ast.line; patterns; guards; body} + | json -> + unknown "clause" json + + +and to_qualifier json : Ast.qualifier option = + match json with + | `List [`String "b_generate"; _anno; pattern; expression] -> + let* pattern = to_expression pattern in + let* expression = to_expression expression in + Some (Ast.BitsGenerator {pattern; expression}) + | `List [`String "generate"; _anno; pattern; expression] -> + let* pattern = to_expression pattern in + let* expression = to_expression expression in + Some (Ast.Generator {pattern; expression}) + | filter -> + let* filter = to_expression filter in + Some (Ast.Filter filter) + + +and to_case_clause json : Ast.case_clause option = to_clause to_expression json + +and to_catch_clause json : Ast.catch_clause option = to_clause to_catch_pattern json + +let to_function json : Ast.function_ option = + match json with + | `List [`String function_; `Int arity] -> + let function_ = Ast.FunctionName function_ in + Some {module_= ModuleMissing; function_; arity} + | _ -> + unknown "function" json + + +let to_line_form json : Ast.form option = + let form line simple_form : Ast.form option = Some {line; simple_form} in + match json with + | `List [`String "attribute"; anno; `String "file"; `List [`String path; _anno_file]] -> + let* line = to_line anno in + form line (File {path}) + | `List [`String "attribute"; anno; `String "module"; `String module_name] -> + let* line = to_line anno in + form line (Module module_name) + | `List [`String "attribute"; anno; `String "import"; `List [`String module_name; functions]] -> + let* line = to_line anno in + let* functions = to_list ~f:to_function functions in + form line (Import {module_name; functions}) + | `List [`String "attribute"; anno; `String "export"; function_] -> + let* line = to_line anno in + let* func_list = to_list ~f:to_function function_ in + form line (Export func_list) + | `List [`String "function"; anno; `String function_; `Int arity; case_clause] -> + let* line = to_line anno in + let* clauses = to_list ~f:to_case_clause case_clause in + let function_ : Ast.function_reference = FunctionName function_ in + let function_ : Ast.function_ = {module_= ModuleMissing; function_; arity} in + form line (Function {function_; clauses}) + | `List [`String "attribute"; _anno; `String _unknown_attribute; _] -> + (* TODO: handle types (spec, record, ...) *) + None + | `List [`String "eof"; _] -> + None + | _ -> + unknown "form" json + + +let to_module json : Ast.module_ option = to_list ~skip_errors:true ~f:to_line_form json diff --git a/infer/src/erlang/ErlangJsonParser.mli b/infer/src/erlang/ErlangJsonParser.mli new file mode 100644 index 000000000..ddba6de30 --- /dev/null +++ b/infer/src/erlang/ErlangJsonParser.mli @@ -0,0 +1,10 @@ +(* + * Copyright (c) Facebook, Inc. and its affiliates. + * + * This source code is licensed under the MIT license found in the + * LICENSE file in the root directory of this source tree. + *) + +open! IStd + +val to_module : Yojson.Safe.t -> ErlangAst.module_ option diff --git a/infer/src/erlang/dune b/infer/src/erlang/dune new file mode 100644 index 000000000..36cc80baa --- /dev/null +++ b/infer/src/erlang/dune @@ -0,0 +1,12 @@ +; Copyright (c) Facebook, Inc. and its affiliates. +; +; This source code is licensed under the MIT license found in the +; LICENSE file in the root directory of this source tree. + +(library + (name ErlangFrontend) + (public_name infer.ErlangFrontend) + (flags + (:standard -open Core -open IStdlib -open IStd -open OpenSource -open IBase + -open IR)) + (libraries core memtrace IStdlib IBase IR)) diff --git a/infer/src/integration/Rebar3.ml b/infer/src/integration/Rebar3.ml index e96db5b06..ca37501d6 100644 --- a/infer/src/integration/Rebar3.ml +++ b/infer/src/integration/Rebar3.ml @@ -4,7 +4,6 @@ * This source code is licensed under the MIT license found in the * LICENSE file in the root directory of this source tree. *) - open! IStd module L = Logging @@ -15,9 +14,30 @@ let run_rebar result_dir args = Process.create_process_and_wait ~prog ~args +let parse_and_store result_dir = + let process json = + let _ast = ErlangJsonParser.to_module json in + (* TODO: Translate to Sil, load source, call [SourceFiles.add]. *) + () + in + let log error = L.progress "E: %s@." error in + let read_one_ast json_file = + if Filename.check_suffix json_file ".json" then ( + L.progress "P: parsing %s@." json_file ; + match Utils.read_safe_json_file json_file with + | Ok json -> + process json + | Error error -> + log error ) + in + Utils.directory_iter read_one_ast result_dir + + let capture ~args = - let in_dir = ResultsDir.get_path Temporary in - let rebar_result_dir = Filename.temp_dir ~in_dir "rebar3infer" "" in - run_rebar rebar_result_dir args ; - (* TODO: parse the JSON files *) - if not Config.debug_mode then Utils.rmtree rebar_result_dir + Option.iter ~f:parse_and_store Config.erlang_ast_dir ; + if not Config.erlang_skip_rebar3 then ( + let in_dir = ResultsDir.get_path Temporary in + let rebar_result_dir = Filename.temp_dir ~in_dir "rebar3infer" "" in + run_rebar rebar_result_dir args ; + parse_and_store rebar_result_dir ; + if not Config.debug_mode then Utils.rmtree rebar_result_dir ) diff --git a/infer/src/integration/dune.in b/infer/src/integration/dune.in index 200d09b69..1fa63ab4f 100644 --- a/infer/src/integration/dune.in +++ b/infer/src/integration/dune.in @@ -17,9 +17,9 @@ let library = (:standard -open Core -open IStdlib -open IStd -open OpenSource -open ATDGenerated -open IBase -open IR -open Absint -open BO -open Checkers -open Costlib -open Concurrency -open Backend - -open TestDeterminators -open ClangFrontend -open ASTLanguage -open JavaFrontend %s %s)) + -open TestDeterminators -open ClangFrontend -open ASTLanguage -open JavaFrontend -open ErlangFrontend %s %s)) (libraries xmlm core IStdlib ATDGenerated IBase IR Absint BO Checkers Costlib Concurrency Backend - TestDeterminators ClangFrontend ASTLanguage JavaFrontend) + TestDeterminators ClangFrontend ASTLanguage JavaFrontend ErlangFrontend) (preprocess (pps ppx_compare)) )