Code refactoring and review implementations

src/analysis/ppx_expand.ml

@@ -0,0 +1,131 @@
+let ppx_expansion ~ppx ~attr_start ~attr_end : Query_protocol.ppx_expand_result
+    =
+  { code = ppx; attr_start; attr_end }
+
+let expand ~parsetree ~ppxed_parsetree ~pos =
+  let check_at_pos loc = Location_aux.compare_pos pos loc = 0 in
+  let atr = ref None in
+  let expression = ref [] in
+  let signature = ref [] in
+  let structure = ref [] in
+  let check_deriving_attr (attrs : Parsetree.attributes) =
+    List.exists
+      (fun (attr : Parsetree.attribute) ->
+        atr := Some attr.attr_loc;
+        attr.attr_name.txt = "deriving" && check_at_pos attr.attr_loc)
+      attrs
+  in
+  let check_structures (item : Parsetree.structure_item_desc) =
+    match item with
+    | Pstr_type (_, ty) ->
+        List.exists
+          (fun (t : Parsetree.type_declaration) ->
+            check_deriving_attr t.ptype_attributes)
+          ty
+    | Pstr_exception tc -> check_deriving_attr tc.ptyexn_attributes
+    | Pstr_modtype mt -> check_deriving_attr mt.pmtd_attributes
+    | Pstr_extension (_, attrs) -> check_deriving_attr attrs
+    | _ -> false
+  in
+  let check_signatures (item : Parsetree.signature_item_desc) =
+    match item with
+    | Psig_type (_, ty) ->
+        List.exists
+          (fun (t : Parsetree.type_declaration) ->
+            check_deriving_attr t.ptype_attributes)
+          ty
+    | Psig_exception tc -> check_deriving_attr tc.ptyexn_attributes
+    | Psig_modtype mt -> check_deriving_attr mt.pmtd_attributes
+    | Psig_extension (_, attrs) -> check_deriving_attr attrs
+    | _ -> false
+  in
+  let check_extension_node (expression : Parsetree.expression) =
+    match expression.pexp_desc with
+    | Pexp_extension (loc, _) ->
+        atr := Some expression.pexp_loc;
+        check_at_pos loc.loc
+    | _ -> false
+  in
+  let expr (self : Ast_iterator.iterator) (expr : Parsetree.expression) =
+    match check_extension_node expr with
+    | true -> (
+        let expr (self : Ast_iterator.iterator) (exp : Parsetree.expression) =
+          match exp.pexp_loc = expr.pexp_loc && check_at_pos exp.pexp_loc with
+          | true -> expression := exp :: !expression
+          | false -> Ast_iterator.default_iterator.expr self exp
+        in
+        let iterator = { Ast_iterator.default_iterator with expr } in
+        match ppxed_parsetree with
+        | `Interface si -> iterator.signature iterator si
+        | `Implementation str -> iterator.structure iterator str)
+    | false -> Ast_iterator.default_iterator.expr self expr
+  in
+  let signature_item (self : Ast_iterator.iterator)
+      (item_1 : Parsetree.signature_item) =
+    match check_signatures item_1.psig_desc with
+    | true -> (
+        let signature_item (self : Ast_iterator.iterator)
+            (item_2 : Parsetree.signature_item) =
+          match check_at_pos item_2.psig_loc && item_1 <> item_2 with
+          | true -> signature := item_2 :: !signature
+          | false -> Ast_iterator.default_iterator.signature_item self item_2
+        in
+        let iterator = { Ast_iterator.default_iterator with signature_item } in
+        match ppxed_parsetree with
+        | `Interface si -> iterator.signature iterator si
+        | `Implementation str -> iterator.structure iterator str)
+    | false -> Ast_iterator.default_iterator.signature_item self item_1
+  in
+  let structure_item (self : Ast_iterator.iterator)
+      (item_1 : Parsetree.structure_item) =
+    match check_structures item_1.pstr_desc with
+    | true -> (
+        let structure_item (self : Ast_iterator.iterator)
+            (item_2 : Parsetree.structure_item) =
+          match check_at_pos item_2.pstr_loc && item_1 <> item_2 with
+          | true -> structure := item_2 :: !structure
+          | false -> Ast_iterator.default_iterator.structure_item self item_2
+        in
+        let iterator = { Ast_iterator.default_iterator with structure_item } in
+        match ppxed_parsetree with
+        | `Interface si -> iterator.signature iterator si
+        | `Implementation str -> iterator.structure iterator str)
+    | false -> Ast_iterator.default_iterator.structure_item self item_1
+  in
+  let iterator =
+    { Ast_iterator.default_iterator with signature_item; structure_item; expr }
+  in
+  let _ =
+    match parsetree with
+    | `Interface si -> iterator.signature iterator si
+    | `Implementation str -> iterator.structure iterator str
+  in
+  match (!signature, !structure, !expression) with
+  | [], [], [] -> None
+  | signature, [], [] ->
+      let exp =
+        Pprintast.signature Format.str_formatter (List.rev signature);
+        Format.flush_str_formatter ()
+      in
+      Some
+        (ppx_expansion ~ppx:exp ~attr_start:(Option.get !atr).loc_start
+           ~attr_end:(Option.get !atr).loc_end)
+  | [], structure, [] ->
+      let exp =
+        Pprintast.structure Format.str_formatter (List.rev structure);
+        Format.flush_str_formatter ()
+      in
+      Some
+        (ppx_expansion ~ppx:exp ~attr_start:(Option.get !atr).loc_start
+           ~attr_end:(Option.get !atr).loc_end)
+  | [], [], expression ->
+      let exp =
+        List.iter
+          (fun exp -> Pprintast.expression Format.str_formatter exp)
+          (List.rev expression);
+        Format.flush_str_formatter ()
+      in
+      Some
+        (ppx_expansion ~ppx:exp ~attr_start:(Option.get !atr).loc_start
+           ~attr_end:(Option.get !atr).loc_end)
+  | _ -> None

src/analysis/ppx_expand.mli

@@ -0,0 +1,9 @@
+val expand :
+  parsetree:
+    [ `Implementation of Parsetree.structure
+    | `Interface of Parsetree.signature ] ->
+  ppxed_parsetree:
+    [ `Implementation of Parsetree.structure
+    | `Interface of Parsetree.signature ] ->
+  pos:Lexing.position ->
+  Query_protocol.ppx_expand_result option

src/frontend/ocamlmerlin/new/new_commands.ml

@@ -214,7 +214,7 @@ Otherwise, Merlin looks for the documentation for the entity under the cursor (a
     end
   ;
 
-  command "expand-node"
+  command "expand-ppx"
     ~doc: "Returns the generated code of a PPX."
     ~spec: [
       arg "-position" "<position> Position to complete"
@@ -225,7 +225,7 @@ Otherwise, Merlin looks for the documentation for the entity under the cursor (a
       match pos with 
       | `None -> failwith "-position <pos> is mandatory"
       | #Msource.position as pos -> 
-        run buffer (Query_protocol.Expand_node pos)
+        run buffer (Query_protocol.Expand_ppx pos)
     end
   ;
 

src/frontend/ocamlmerlin/query_json.ml

@@ -114,7 +114,7 @@ let dump (type a) : a t -> json =
     ]
   | Syntax_document pos ->
     mk "syntax-document" [ ("position", mk_position pos) ]
-  | Expand_node pos ->
+  | Expand_ppx pos ->
     mk "ppx-expand" [ ("position", mk_position pos) ]
   | Locate (prefix, look_for, pos) ->
     mk "locate" [
@@ -394,18 +394,18 @@ let json_of_response (type a) (query : a t) (response : a) : json =
         ("url", `String info.documentation);
       ]
     | `No_documentation -> `String "No documentation found")
-  | Expand_node _, resp -> 
+  | Expand_ppx _, resp -> 
     let str = match resp with
     | `Found ppx_info -> 
       `Assoc
       [
         ("code", `String ppx_info.code);
         ("deriver", `Assoc [
-          ("start", Lexing.json_of_position ppx_info.deriver.a_start);
-          ("end", Lexing.json_of_position ppx_info.deriver.a_end);
+          ("start", Lexing.json_of_position ppx_info.attr_start);
+          ("end", Lexing.json_of_position ppx_info.attr_end);
         ])
       ]
-    | `No_deriver -> `String "No PPX deriver/extension node found on this position"
+    | `No_ppx -> `String "No PPX deriver/extension node found on this position"
     in str
   | Locate_type _, resp -> json_of_locate resp
   | Locate _, resp -> json_of_locate resp

src/frontend/query_commands.ml

@@ -509,166 +509,16 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
     let node = Mtyper.node_at typer pos in
     let res = Syntax_doc.get_syntax_doc pos node in 
     (match res with
-    | Some res -> `Found res 
+    | Some res -> `Found res
     | None -> `No_documentation)
 
-  | Expand_node pos -> 
+  | Expand_ppx pos -> 
     let pos = Mpipeline.get_lexing_pos pipeline pos in
     let parsetree = Mpipeline.reader_parsetree pipeline in
     let ppxed_parsetree = Mpipeline.ppx_parsetree pipeline in
-    let ppx_expansion ~ppx ~a_start ~a_end = 
-      `Found {
-        code = ppx;
-        deriver = { a_start; a_end }
-      }
-    in
-    let check_at_pos loc = 
-      Location_aux.compare_pos pos loc = 0
-    in
-    let atr = ref None in
-    let expression = ref [] in
-    let signature = ref [] in
-    let structure = ref [] in
-    let check_deriving_attr (attrs : Parsetree.attributes) =
-      List.exists ~f:(fun (attr : Parsetree.attribute) ->
-        atr := Some attr.attr_loc;
-        attr.attr_name.txt = "deriving" && check_at_pos attr.attr_loc
-      ) attrs
-    in
-    let check_structures (item: Parsetree.structure_item_desc) = 
-      match item with 
-      | Pstr_type (_, ty) -> 
-        List.exists ~f:(fun (t:Parsetree.type_declaration) -> 
-          check_deriving_attr t.ptype_attributes
-          ) ty
-      | Pstr_exception tc ->
-        check_deriving_attr tc.ptyexn_attributes
-      | Pstr_modtype mt -> 
-        check_deriving_attr mt.pmtd_attributes
-      | Pstr_extension (_,attrs) ->
-          check_deriving_attr attrs
-      | _ -> false
-    in
-    let check_signatures (item: Parsetree.signature_item_desc) = 
-      match item with 
-      | Psig_type (_, ty) -> 
-        List.exists ~f:(fun (t:Parsetree.type_declaration) -> 
-          check_deriving_attr t.ptype_attributes
-          ) ty
-      | Psig_exception tc -> 
-        check_deriving_attr tc.ptyexn_attributes
-      | Psig_modtype mt -> 
-        check_deriving_attr mt.pmtd_attributes
-      | Psig_extension (_,attrs) ->
-          check_deriving_attr attrs
-      | _ -> false
-    in
-    let check_extension_node (expression: Parsetree.expression) = 
-      match expression.pexp_desc with
-      | Pexp_extension (loc,_) ->
-        atr := Some expression.pexp_loc; 
-        check_at_pos loc.loc
-      | _ -> false
-    in
-    let expr (self: Ast_iterator.iterator) (expr: Parsetree.expression) = 
-      match check_extension_node expr with
-      | true ->
-        let expr (self: Ast_iterator.iterator) (exp: Parsetree.expression) = 
-          match exp.pexp_loc = expr.pexp_loc && check_at_pos exp.pexp_loc with
-          | true -> 
-            expression := exp :: !expression
-          | false -> 
-            Ast_iterator.default_iterator.expr self exp
-        in
-        let iterator = 
-          {Ast_iterator.default_iterator with expr}
-        in 
-        (match ppxed_parsetree with
-        | `Interface si -> iterator.signature iterator si
-        | `Implementation str -> iterator.structure iterator str)
-      | false -> Ast_iterator.default_iterator.expr self expr
-    in
-    let signature_item (self : Ast_iterator.iterator) 
-    (item_1 : Parsetree.signature_item) =
-      match check_signatures item_1.psig_desc with
-      | true ->
-        let signature_item(self: Ast_iterator.iterator) 
-        (item_2: Parsetree.signature_item) = 
-        (match check_at_pos item_2.psig_loc && item_1 <> item_2 with
-        | true -> 
-          signature := item_2 :: !signature
-        | false -> 
-          Ast_iterator.default_iterator.signature_item self item_2) 
-        in 
-        let iterator = 
-          {Ast_iterator.default_iterator with signature_item}
-        in 
-        (match ppxed_parsetree with
-        | `Interface si -> iterator.signature iterator si
-        | `Implementation str -> iterator.structure iterator str)
-      | false -> Ast_iterator.default_iterator.signature_item self item_1
-    in
-    let structure_item (self : Ast_iterator.iterator) 
-    (item_1 : Parsetree.structure_item) =
-      (match check_structures item_1.pstr_desc with
-      | true ->
-        let structure_item(self: Ast_iterator.iterator) 
-        (item_2: Parsetree.structure_item) = 
-          (match check_at_pos item_2.pstr_loc && item_1 <> item_2 with
-          | true -> 
-            structure := item_2 :: !structure
-          | false -> 
-            Ast_iterator.default_iterator.structure_item self item_2) 
-        in 
-        let iterator = 
-          {Ast_iterator.default_iterator with structure_item}
-        in 
-        (match ppxed_parsetree with
-        | `Interface si -> iterator.signature iterator si
-        | `Implementation str -> iterator.structure iterator str)
-      | false -> Ast_iterator.default_iterator.structure_item self item_1)
-    in
-    let iterator =
-      { Ast_iterator.default_iterator with signature_item; structure_item; expr }
-    in
-    let _ =
-      match parsetree with
-      | `Interface si -> iterator.signature iterator si
-      | `Implementation str -> iterator.structure iterator str
-    in
-    begin
-      match !signature,!structure,!expression with
-      | signature,[],[] when signature <> [] ->
-        let exp =
-          Pprintast.signature Format.str_formatter (List.rev signature);
-          Format.flush_str_formatter ()
-        in
-        ppx_expansion 
-        ~ppx:exp 
-        ~a_start:(Option.get !atr).loc_start
-        ~a_end:(Option.get !atr).loc_end
-      | [],structure,[] when structure <> [] ->
-        let exp =
-          Pprintast.structure Format.str_formatter (List.rev structure);
-          Format.flush_str_formatter ()
-        in
-        ppx_expansion 
-        ~ppx:exp 
-        ~a_start:(Option.get !atr).loc_start
-        ~a_end:(Option.get !atr).loc_end
-      | [],[],expression when expression <> [] -> 
-        let exp = 
-          List.iter ~f:(fun exp -> 
-            Pprintast.expression Format.str_formatter exp)
-            (List.rev expression);
-            Format.flush_str_formatter ()
-        in
-        ppx_expansion 
-        ~ppx:exp 
-        ~a_start:(Option.get !atr).loc_start
-        ~a_end:(Option.get !atr).loc_end
-      | _ -> `No_deriver
-    end
+    (match Ppx_expand.expand ~parsetree ~ppxed_parsetree ~pos with 
+    | Some res -> `Found res 
+    | None -> `No_ppx)
 
   | Locate (patho, ml_or_mli, pos) ->
     let typer = Mpipeline.typer_result pipeline in

src/frontend/query_protocol.ml

@@ -103,16 +103,11 @@ type syntax_doc_result =
     documentation : string 
 }
 
-type ppx_deriver_pos =
-{ 
-  a_start : Lexing.position;
-  a_end : Lexing.position;
-}
-
 type ppx_expand_result = 
 {
   code : string;
-  deriver : ppx_deriver_pos
+  attr_start : Lexing.position;
+  attr_end : Lexing.position;
 }
 
 type is_tail_position = [`No | `Tail_position | `Tail_call]
@@ -157,11 +152,11 @@ type _ t =
     -> [ `Found of syntax_doc_result
        | `No_documentation
        ] t
-  | Expand_node
+  | Expand_ppx
     : Msource.position
     -> 
       [ `Found of ppx_expand_result
-      | `No_deriver
+      | `No_ppx
       ] t
   | Locate_type
     : Msource.position