Parse JSON input

Summary: Parses JSON input for the three selectors we have right now.

Reviewed By: pittsw

Differential Revision: D7701877

fbshipit-source-id: c69ebd79ee2b87ba4f9b577d1a384f8d6c7f0dbd

hphp/hack/src/hh_single_type_check.ml

@@ -717,23 +717,22 @@ let handle_mode
         end
       end
   | Cst_search ->
-    (* TODO: read the pattern from the user's JSON query *)
-    let open CstSearchService in
-    let pattern = DescendantPattern {
-      pattern = NodePattern {
-        kind = SyntaxKind.MethodishDeclaration;
-        children = [];
-      }
-    } in
-
+    let open Core_result.Monad_infix in
     let source_text = Full_fidelity_source_text.from_file filename in
     let syntax_tree = PositionedTree.make source_text in
-    let env = { syntax_tree } in
 
-    (* TODO: print actual JSON output *)
-    begin match CstSearchService.search ~env ~pattern with
-    | None -> Printf.printf "No result :(\n"
-    | Some _result -> Printf.printf "There was a result!\n"
+    let result = Sys_utils.read_stdin_to_string ()
+      |> Hh_json.json_of_string
+      |> CstSearchService.compile_pattern
+      >>| CstSearchService.search ~syntax_tree
+      >>| CstSearchService.result_to_json
+      >>| Hh_json.json_to_string
+    in
+    begin match result with
+    | Ok result -> Printf.printf "%s\n" result
+    | Error message ->
+      Printf.printf "%s\n" message;
+      exit 1
     end
   | Dump_symbol_info ->
       begin match Relative_path.Map.get files_info filename with

hphp/hack/src/server/cstSearchService.ml

@@ -5,6 +5,17 @@ module SyntaxKind = Full_fidelity_syntax_kind
 module SyntaxTree = Full_fidelity_syntax_tree
   .WithSyntax(Full_fidelity_positioned_syntax)
 
+(**
+ * A `SyntaxKind.t`. We can generate a string from a kind, but not the other way
+ * around, so we store the string value given to us in the input directly. Then,
+ * when examining a node to see if it's a match, we'll convert the node's kind
+ * to a string and simply use string comparison.
+ *
+ * (Note that multiple syntax kinds map to the same string anyways, so it would
+ * be hard to reverse the mapping.)
+ *)
+type node_kind = NodeKind of string
+
 (**
  * An identifier in the pattern used to identify the this node when returning
  * the results of a match to the caller. This identifier may not be unique in
@@ -38,7 +49,7 @@ type pattern =
    * patterns.
    *)
   | NodePattern of {
-      kind: SyntaxKind.t;
+      kind: node_kind;
 
       (**
        * Mapping from child name to pattern that the child must satisfy.
@@ -120,7 +131,8 @@ let rec search_node
     : env * result option =
   match pattern with
   | NodePattern { kind; children } ->
-    if (Syntax.kind node) <> kind
+    let kind = match kind with NodeKind kind -> kind in
+    if (node |> Syntax.kind |> SyntaxKind.to_string) <> kind
     then (env, None)
     else
     let (env, result) = List.fold_left_env env children
@@ -173,7 +185,128 @@ and search_descendants
       (env, (merge_results result acc_result))
     )
 
-let search ~(env: env) ~(pattern: pattern): result option =
+let compile_pattern (json: Hh_json.json): (pattern, string) Core_result.t =
+  let open Core_result in
+  let open Core_result.Monad_infix in
+
+  let wrap_json_accessor f =
+    fun x -> Core_result.map_error (f x)
+      ~f:Hh_json.Access.access_failure_to_string
+  in
+
+  let get_string x = wrap_json_accessor (Hh_json.Access.get_string x) in
+  let get_obj x = wrap_json_accessor (Hh_json.Access.get_obj x) in
+  let keytrace_to_string = Hh_json.Access.keytrace_to_string in
+  let error_at_keytrace ~keytrace error_message =
+    Error (error_message ^ (keytrace_to_string keytrace))
+  in
+
+  let rec compile_pattern ~json ~keytrace : (pattern, string) Core_result.t =
+    get_string "patternType" (json, keytrace)
+
+    >>= fun (pattern_type, pattern_type_keytrace) ->
+    match pattern_type with
+    | "node-pattern" ->
+      compile_node_pattern ~json ~keytrace
+    | "match-pattern" ->
+      compile_match_pattern ~json ~keytrace
+    | "descendant-pattern" ->
+      compile_descendant_pattern ~json ~keytrace
+    | pattern_type ->
+      error_at_keytrace ~keytrace:pattern_type_keytrace
+        (Printf.sprintf "Unknown pattern type '%s'" pattern_type)
+
+  and compile_node_pattern ~json ~keytrace : (pattern, string) Core_result.t =
+    get_string "kind" (json, keytrace)
+
+    >>= fun (kind, kind_keytrace) ->
+    let open Schema_definition in
+    let kind_info = List.find schema ~f:(fun schema_node ->
+      schema_node.description = kind
+    ) in
+    match kind_info with
+    | None ->
+      error_at_keytrace ~keytrace:kind_keytrace
+        (Printf.sprintf "Kind '%s' doesn't exist" kind)
+    | Some kind_info -> Ok kind_info
+
+    >>= fun kind_info ->
+    get_obj "children" (json, keytrace)
+
+    >>= fun (children_json, children_keytrace) ->
+    (* This has already been verified to be an object above. *)
+    let children = Hh_json.get_object_exn children_json in
+
+    let get_child_type
+        (child_name: string)
+        : (child_type, string) Core_result.t =
+      (* We're given a field name like `binary_right_operand`, but the field
+      names in the schema are things like `right_operand`, and you have to
+      affix the prefix yourself. For consistency with other tooling, we want
+      to use `binary_right_operand` instead of just `right_operand`. *)
+      let get_prefixed_field_name field_name =
+        kind_info.prefix ^ "_" ^ field_name
+      in
+      let field = List.find kind_info.fields ~f:(fun (field_name, _) ->
+        (get_prefixed_field_name field_name) = child_name)
+      in
+      match field with
+      | None ->
+        let valid_types = List.map kind_info.fields ~f:(fun (field_name, _) ->
+          get_prefixed_field_name field_name
+        ) in
+        error_at_keytrace ~keytrace:children_keytrace
+          (Printf.sprintf
+            ("Unknown child type '%s'; "^^
+            "valid child types for a node of kind '%s' are: %s")
+            child_name
+            kind
+            (String.concat ", " valid_types))
+      | Some _ -> Ok (ChildType child_name)
+    in
+    let children_patterns =
+      List.map children ~f:(fun (child_name, pattern_json) ->
+        get_child_type child_name >>= fun child_name ->
+        compile_pattern ~json:pattern_json ~keytrace:children_keytrace
+        >>| fun pattern ->
+        (child_name, pattern)
+      )
+    in
+    all children_patterns >>| fun children ->
+    NodePattern {
+      kind = NodeKind kind;
+      children;
+    }
+
+  and compile_match_pattern ~json ~keytrace =
+    get_string "matchName" (json, keytrace)
+    >>| fun (match_name, _match_name_keytrace) ->
+    MatchPattern {
+      match_name = MatchName match_name;
+    }
+
+  and compile_descendant_pattern ~json ~keytrace =
+    get_obj "pattern" (json, keytrace) >>= fun (pattern, pattern_keytrace) ->
+    compile_pattern ~json:pattern ~keytrace:pattern_keytrace >>| fun pattern ->
+    DescendantPattern {
+      pattern;
+    }
+
+  in
+  compile_pattern ~json ~keytrace:[]
+
+(* TODO(T28495794): write a real implementation *)
+let result_to_json (result: result option): Hh_json.json =
+  let open Hh_json in
+  match result with
+  | Some _ -> JSON_String "There was a match!"
+  | None -> JSON_String "No match :("
+
+let search
+    ~(syntax_tree: SyntaxTree.t)
+    (pattern: pattern)
+    : result option =
+  let env = { syntax_tree } in
   let (_env, result) =
     search_node ~env ~pattern ~node:(SyntaxTree.root env.syntax_tree) in
   result