From d041e89730f066e480c5f39e8508fad43c1db7f4 Mon Sep 17 00:00:00 2001
From: Mateo <mateo.dugas@ocamlpro.com>
Date: Mon, 9 Sep 2024 13:33:39 +0200
Subject: [PATCH] refactor: cleanup code

---
 assets/cfg-arc-renderer.html                  | 31 +++---
 assets/cfg-dot-renderer.html                  | 28 +++---
 package.json                                  | 17 ++--
 src/lsp/cobol_cfg/cfg_builder.ml              | 97 ++++++++-----------
 src/lsp/superbol_free_lib/vscode_extension.ml | 16 ++-
 .../superbol_cfg_explorer.ml                  | 53 +---------
 .../superbol_cfg_explorer.mli                 |  7 +-
 .../superbol_commands.ml                      | 17 +---
 8 files changed, 87 insertions(+), 179 deletions(-)

diff --git a/assets/cfg-arc-renderer.html b/assets/cfg-arc-renderer.html
index f77ba5ec..ee13d23d 100644
--- a/assets/cfg-arc-renderer.html
+++ b/assets/cfg-arc-renderer.html
@@ -161,13 +161,13 @@
   // List of node names
   const allNodes = data.nodes.map(d=>d.id).sort((a,b)=> a-b)
 
-  const sectionNames = data.nodes.filter(d=> !d.name.includes(" IN "))
+  const sectionNames = data.nodes.filter(d => !d.name.includes(" IN "))
   const color = d3.scaleOrdinal(sectionNames, d3.schemeCategory10)
 
   // A linear scale to position the nodes on the X axis
   y = d3.scalePoint()
-            .range([0, height])
-            .domain(allNodes)
+        .range([0, height])
+        .domain(allNodes)
 
   nodeColor = getNodeColor(color);
 
@@ -199,8 +199,8 @@
     .join('path')
     .attr('d', getLinkPath(y))
     .style("fill", "none")
-    .attr("stroke", "black")
-    .attr("stroke-dasharray", getDasharray)
+    .style("stroke", "black")
+    .style("stroke-dasharray", getDasharray)
 
   // Add the circle for the nodes
   nodes = svg
@@ -208,11 +208,20 @@
     .data(data.nodes)
     .join("circle")
       .attr("cx", NODE_CENTER_X)
-      .attr("cy", d=>y(d.id))
+      .attr("cy", d => y(d.id))
       .attr("r", NODE_RADIUS)
       .style("fill", nodeColor)
       .style('stroke-width', 4)
 
+  svg
+    .selectAll("sectionnodes")
+    .data(sectionNames)
+    .join("circle")
+      .attr("cx", NODE_CENTER_X)
+      .attr("cy", d => y(d.id))
+      .attr("r", 2)
+      .style("fill", "white")
+
   // Add the highlighting functionality
   nodes
     .on('mouseover', (_, n) => focusNode(n))
@@ -233,13 +242,13 @@
         graph = JSON.parse(event.data.graph)
         buildSVG(graph)
       break;
-        case "focused_proc":
-        const node = graph.nodes
-          .find(n => { return n.name === event.data.procedure })
-        window.scroll(0, y(node.id)-window.innerHeight/3)
+      case "focused_proc":
+        const node = graph.nodes.find(n => n.name === event.data.procedure)
+        if(!node) return;
+        window.scroll(0, y(node.id) - window.innerHeight/3)
         focusNode(node)
         unfocus(5000)
-        break;
+      break;
     }
   })
 
diff --git a/assets/cfg-dot-renderer.html b/assets/cfg-dot-renderer.html
index dba06a28..d8ebb765 100644
--- a/assets/cfg-dot-renderer.html
+++ b/assets/cfg-dot-renderer.html
@@ -70,7 +70,6 @@
     </body>
     <script>
       const vscode = acquireVsCodeApi()
-      var defaultTransform = undefined;
       var graphviz = undefined;
       var graph = undefined;
       var rendering = d3.select('#rendering')
@@ -122,23 +121,21 @@
 
       function setupOnEnd() {
         rendering.classed("hidden", true);
-        if(defaultTransform === undefined) {
-          defaultTransform = d3.select('#app g').attr('transform')
-        }
         d3.selectAll('svg g title').remove()
         d3.selectAll('svg text')
           .on("click", (_, e) => {
-            if(e.children[0].text) {
-              const node =
-                graph.nodes.find((n) => e.children[0].text === n.name)
-              if(node) {
-                focus(node.name)
-                vscode.postMessage({
-                    type: 'click',
-                    node: node.id
-                })
-              }
-            }
+            const clickedName = e.children[0].text;
+            if(!clickedName) return;
+            const node =
+              graph.nodes
+              .find(n => clickedName === n.name
+                      || n.name.startsWith(clickedName + " IN ") )
+            if(!node) return;
+            focus(clickedName)
+            vscode.postMessage({
+                type: 'click',
+                node: node.id
+            })
           })
       }
 
@@ -148,7 +145,6 @@
               if(graphviz) {
                 graphviz.destroy()
                 d3.select('#app svg').remove()
-                defaultTransform = undefined;
               }
               graphviz = d3.select('#app').graphviz().fit(true);
               graphviz.zoomScaleExtent([0.1, 50])
diff --git a/package.json b/package.json
index 52370aaf..61fa9f32 100644
--- a/package.json
+++ b/package.json
@@ -41,17 +41,12 @@
       },
       {
         "command": "superbol.cfg.open",
-        "title": "Open CFG",
+        "title": "Open a CFG of the current program",
         "category": "SuperBOL"
       },
       {
-        "command": "superbol.cfg.open.d3",
-        "title": "Open CFG D3",
-        "category": "SuperBOL"
-      },
-      {
-        "command": "superbol.cfg.test",
-        "title": "Open as WEbview",
+        "command": "superbol.cfg.open.arc",
+        "title": "Open an arc-representation CFG of the current program",
         "category": "SuperBOL"
       }
     ],
@@ -464,12 +459,12 @@
         {
           "command": "superbol.cfg.open",
           "group": "superbol",
-          "when": "editorTextFocus"
+          "when": "editorTextFocus && editorLangId == 'cobol'"
         },
         {
-          "command": "superbol.cfg.open.d3",
+          "command": "superbol.cfg.open.arc",
           "group": "superbol",
-          "when": "editorTextFocus"
+          "when": "editorTextFocus && editorLangId == 'cobol'"
         }
       ]
     },
diff --git a/src/lsp/cobol_cfg/cfg_builder.ml b/src/lsp/cobol_cfg/cfg_builder.ml
index 07562b51..a4132246 100644
--- a/src/lsp/cobol_cfg/cfg_builder.ml
+++ b/src/lsp/cobol_cfg/cfg_builder.ml
@@ -83,16 +83,19 @@ type node = {
   qid: qualname;
   mutable names: string NEL.t;
   loc: srcloc option;
-  entry: bool;
+  typ: [`External | `EntryPoint | `EntryPara | `EntrySection | `Internal ];
   jumps: Jumps.t;
   will_fallthru: bool;
   terminal: bool;
-  is_external: bool;
 }
 
-let qn_to_string qn =
+let fullqn_to_string qn =
   Pretty.to_string "%a" Cobol_ptree.pp_qualname qn
 
+let name_to_string (qn: qualname) =
+  Cobol_ptree.(match qn with
+  | Name name | Qual (name, _) -> Pretty.to_string "%a" pp_name' name)
+
 let qn_equal qn1 qn2 = 0 == Cobol_ptree.compare_qualname qn1 qn2
 
 let full_qn ~cu qn =
@@ -194,17 +197,16 @@ let build_node ~default_name ~cu paragraph =
   let qid, loc = match ~&paragraph.paragraph_name with
     | None -> default_name, ~@paragraph
     | Some qn -> full_qn' ~cu qn, ~@qn in
-  let name = qn_to_string qid
+  let name = fullqn_to_string qid
   in {
     id = !node_idx;
     qid;
     names = NEL.One name;
     loc = Some loc;
-    entry = false;
     jumps;
     will_fallthru;
     terminal;
-    is_external = false;
+    typ = `Internal;
   }
 
 module Node = struct
@@ -240,16 +242,7 @@ let vertex_name_record { names; _ } =
     (NEL.pp ~fopen:"{" ~fclose:"}" ~fsep:"|" Fmt.string)
     (NEL.rev names)
 
-let vertex_name { names; _ } =
-  Pretty.to_string "%a"
-    (NEL.pp ~fopen:"" ~fclose:"" ~fsep:"\n" Fmt.string)
-    (NEL.rev names)
-
-
-let qid_to_string { qid; _ } =
-  Pretty.to_string "%a" Cobol_ptree.pp_qualname qid
-
-  (* Graph.Graphviz.DotAttributes *)
+(* Graph.Graphviz.DotAttributes *)
 module Dot = Graph.Graphviz.Dot(struct
     include Cfg
     let edge_attributes (_,s,_) =
@@ -259,13 +252,15 @@ module Dot = Graph.Graphviz.Dot(struct
            | Go -> `Solid)]
     let default_edge_attributes _ = []
     let get_subgraph _ = None
-    let vertex_attributes ({ entry; is_external; _ } as n) =
-      [`Label (if entry then vertex_name n else vertex_name_record n)]
-      @ (if entry
-      then [`Shape `Doubleoctagon]
-      else if is_external
-      then [`Shape `Plaintext]
-      else [])
+    let vertex_attributes ({ typ; _ } as n) =
+      let label, shape =
+        match typ with
+        | `EntryPara -> "Entry\nparagraph", [`Shape `Doubleoctagon]
+        | `EntryPoint -> "Entry\npoint", [`Shape `Doubleoctagon]
+        | `EntrySection -> NEL.hd n.names, [`Shape `Doubleoctagon]
+        | `External -> NEL.hd n.names, [`Shape `Plaintext]
+        | `Internal -> vertex_name_record n, []
+      in `Label label :: shape
     let default_vertex_attributes _ = [`Shape `Record]
     let graph_attributes _ = []
     let vertex_name { id; _ } = string_of_int id
@@ -274,18 +269,20 @@ module Dot = Graph.Graphviz.Dot(struct
 let to_dot_string g =
   Pretty.to_string "%a" Dot.fprint_graph g
 
-let dummy_node qn =
+let dummy_node ?(typ=`External) (qn: qualname) =
+  let loc = match qn with
+  | Cobol_ptree.Name name -> ~@name
+  | Qual (name, _) -> ~@name in
   node_idx:= !node_idx + 1;
   {
     id = !node_idx;
     qid = qn;
-    loc = None;
-    entry = false;
-    names = NEL.One (qn_to_string qn);
+    loc = Some loc;
+    names = NEL.One (fullqn_to_string qn);
     jumps = Jumps.empty;
     will_fallthru = true;
     terminal = false;
-    is_external = true;
+    typ;
   }
 
 let clone_node node =
@@ -295,7 +292,6 @@ let clone_node node =
 let qmap_find_or_add qmap qn =
   match Qmap.find_opt qn qmap with
   | None -> let node = dummy_node qn in
-    (* qmap, node *)
     Qmap.add qn node qmap, node
   | Some node -> qmap, node
 
@@ -327,7 +323,7 @@ let rec build_edges ~vertexes g nodes =
 let do_collapse_fallthru g =
   Cfg.fold_vertex begin fun n cfg ->
     match Cfg.pred_e cfg n with
-    | [(({ entry = false; _ } as pred), FallThrough, _)] ->
+    | [(({ typ = `Internal; _ } as pred), FallThrough, _)] ->
       let cfg = Cfg.fold_succ_e begin fun (_, e, next) cfg ->
           if List.exists
               begin fun succ -> qn_equal succ.qid next.qid end
@@ -344,7 +340,7 @@ let do_hide_unreachable g =
   let rec aux cfg =
     let did_remove, cfg =
       Cfg.fold_vertex begin fun n (did_remove, cfg) ->
-        if Cfg.in_degree cfg n <= 0 && not n.entry
+        if Cfg.in_degree cfg n <= 0 && n.typ == `Internal
         then true, Cfg.remove_vertex cfg n
         else did_remove, cfg
       end cfg (false, cfg)
@@ -354,7 +350,7 @@ let do_hide_unreachable g =
 
 let do_shatter_hubs ?(limit=20) g =
   Cfg.fold_vertex begin fun n cfg ->
-    if Cfg.in_degree cfg n >= limit && not n.entry
+    if Cfg.in_degree cfg n >= limit
     then begin
       Cfg.fold_pred_e begin fun edge cfg ->
         let cfg = Cfg.remove_edge_e cfg edge in
@@ -400,9 +396,10 @@ let cfg_of ~(cu: cobol_unit) =
   |> begin function (* adding entry point if not already present *)
     | ({ qid; _ } as hd )::tl
       when qn_equal qid default_name ->
-        { hd with id=0; entry = true; names = NEL.One "Entry\nparagraph" }::tl
+      { hd with id=0; typ = `EntryPara; names = NEL.One "Entry paragraph" }::tl
     | l ->
-        { (dummy_node default_name) with id=0; entry = true; names = NEL.One "Entry\npoint" } :: l
+      { (dummy_node ~typ:`EntryPoint default_name)
+        with id=0; names = NEL.One "Entry point" } :: l
   end
   |> cfg_of_nodes
 
@@ -411,11 +408,13 @@ let cfg_of_section ~cu ({ section_paragraphs; section_name }: procedure_section)
   let default_name = ~&section_name in
   let nodes =
     List.fold_left begin fun acc p ->
-      build_node ~default_name ~cu p :: acc
+      let node = build_node ~default_name ~cu p  in
+      let name = name_to_string node.qid in
+      { node with names = NEL.One name } :: acc
     end [] section_paragraphs.list
     |> List.rev in
   let nodes = match nodes with
-    | entry::tl -> { entry with entry = true }::tl
+    | entry::tl -> { entry with typ = `EntrySection }::tl
     | [] -> []
   in cfg_of_nodes nodes
 
@@ -438,11 +437,12 @@ let to_d3_string cfg =
       begin fun (n1, e, n2) acc ->
         Pretty.to_string "{\"source\":%d,\"target\":%d,\"type\":\"%s\"}"
           n1.id n2.id (Edge.to_string e)
-          ::acc
+        ::acc
       end cfg [] in
   let cfg_nodes = Cfg.fold_vertex
       begin fun n acc ->
-        Pretty.to_string "{\"id\":%d,\"name\":\"%s\"}" n.id (qid_to_string n)
+        Pretty.to_string "{\"id\":%d,\"name\":\"%s\"}"
+          n.id (fullqn_to_string n.qid)
         :: acc
       end cfg [] in
   let str_nodes = String.concat "," cfg_nodes in
@@ -484,24 +484,3 @@ let make ~(options: Options.t) (checked_doc: Cobol_typeck.Outputs.t) =
       nodes_pos = nodes_pos cfg;
     }
   end
-
-(*
-List of node (sections & paragraphs)
-Visitor over procedure
-  - perform
-  - go to
-  - output_or_giving
-  - input_or_using
-  - alter
-  - resume
-  - declaratives
-  - debug_target
-  - if else
-  - evaluate
-  - exit
-
-  paragraph lié au suivant
-  section lié au suivant
-
-pp_dot_format => Graph.Graphviz.Dot
-*)
diff --git a/src/lsp/superbol_free_lib/vscode_extension.ml b/src/lsp/superbol_free_lib/vscode_extension.ml
index 3a9a010d..207b5f25 100644
--- a/src/lsp/superbol_free_lib/vscode_extension.ml
+++ b/src/lsp/superbol_free_lib/vscode_extension.ml
@@ -70,7 +70,7 @@ let package =
       "vscode-languageclient", "8.0.2";
       "polka", "^1.0.0-next.22";
       "sirv", "^2.0.2";
-      
+
       (* for the debug extension: *)
       "n-readlines", "^1.0.0";
     ]
@@ -585,15 +585,11 @@ let contributes =
         ~category:"SuperBOL";
       Manifest.command ()
         ~command:"superbol.cfg.open"
-        ~title:"Open CFG"
-        ~category:"SuperBOL";
-      Manifest.command ()
-        ~command:"superbol.cfg.open.d3"
-        ~title:"Open CFG D3"
+        ~title:"Open a CFG of the current program"
         ~category:"SuperBOL";
       Manifest.command ()
-        ~command:"superbol.cfg.test"
-        ~title:"Open as WEbview"
+        ~command:"superbol.cfg.open.arc"
+        ~title:"Open an arc CFG of the current program"
         ~category:"SuperBOL";
     ]
     ~tomlValidation: [
@@ -604,8 +600,8 @@ let contributes =
     ]
     ~menus: [
       "editor/context",
-      [menu ~command:"superbol.cfg.open" ~group:"superbol" ~when_:"editorTextFocus" ();
-      menu ~command:"superbol.cfg.open.d3" ~group:"superbol" ~when_:"editorTextFocus" ()]
+      [menu ~command:"superbol.cfg.open" ~group:"superbol" ~when_:"editorTextFocus && editorLangId == 'cobol'" ();
+      menu ~command:"superbol.cfg.open.arc" ~group:"superbol" ~when_:"editorTextFocus && editorLangId == 'cobol'" ()]
     ]
 
 let manifest =
diff --git a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml
index 5d351696..eaae049b 100644
--- a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml
+++ b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml
@@ -262,7 +262,7 @@ let open_cfg_for ?(typ=`Dot) ~text_editor ~extension_uri client =
               ~pathSegments:
                 ["assets"; match typ with
                  | `Dot -> "cfg-dot-renderer.html"
-                 | `D3 -> "cfg-arc-renderer.html"] in
+                 | `Arc -> "cfg-arc-renderer.html"] in
           let html_file = read_whole_file @@ Uri.fsPath html_uri in
           WebView.set_html webview html_file;
         end
@@ -282,54 +282,3 @@ let open_cfg ?(typ=`Dot) ?text_editor instance =
       @@ Superbol_instance.context instance in
     open_cfg_for ~typ ~extension_uri ~text_editor client
   | _ -> Promise.return ()
-
-(* debug TO REMOVE *)
-let debugWebviewPanelRef = ref None
-let open_webview ?text_editor instance =
-  let open_cfg_for ~text _client =
-    let webviewPanel = match !debugWebviewPanelRef with
-      | None ->
-        Window.createWebviewPanel
-          ~viewType:"cfg" ~title:"Tester webview"
-          ~showOptions:(ViewColumn.Two)
-      | Some wvp -> wvp in
-    debugWebviewPanelRef := Some webviewPanel;
-    let webview = WebviewPanel.webview webviewPanel in
-    WebView.set_html webview text;
-    WebView.set_options webview (WebviewOptions.create ~enableScripts:true ());
-    let thisArgs, disposables = Ojs.null, [] in
-    let _ : Disposable.t =
-      WebviewPanel.onDidDispose webviewPanel ()
-        ~listener:(fun () -> debugWebviewPanelRef:=None)
-        ~thisArgs ~disposables in
-    let listener arg =
-      let typ = Ojs.type_of arg in
-      let com = Ojs.get_prop_ascii arg "command" |> Ojs.string_of_js in
-      let message = "Listener clicked " ^ typ ^ "    " ^ com in
-      let _ : _ option Promise.t = Window.showErrorMessage () ~message in
-      ()
-    in
-    let _ : Disposable.t =
-      WebView.onDidReceiveMessage webview ()
-        ~listener ~thisArgs:Ojs.null ~disposables:[] in
-    WebviewPanel.reveal webviewPanel ~preserveFocus:true ();
-    Promise.return ()
-  in
-  let current_text ?text_editor () =
-    match
-      match text_editor with None -> Window.activeTextEditor () | e -> e
-    with
-    | None -> None
-    | Some e -> Some (TextDocument.getText (TextEditor.document e) ())
-  in
-  match Superbol_instance.client instance, current_text ?text_editor () with
-  | Some client, Some text ->
-    open_cfg_for ~text client
-  | _ ->
-    (* TODO: is there a way to activate the extension from here?  Starting the
-       client/instance seems to launch two distinct LSP server processes. *)
-    Promise.(then_ ~fulfilled:(fun _ -> return ())) @@
-    Window.showErrorMessage ()
-      ~message:"The SuperBOL LSP client is not running; please retry after a \
-                COBOL file has been opened"
-
diff --git a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.mli b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.mli
index dc9a5685..eeafc925 100644
--- a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.mli
+++ b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.mli
@@ -13,12 +13,7 @@
 (**************************************************************************)
 
 val open_cfg
-  : ?typ: [< `D3 | `Dot > `Dot]
+  : ?typ: [< `Arc | `Dot > `Dot]
   -> ?text_editor: Vscode.TextEditor.t
   -> Superbol_instance.t
   -> unit Promise.t
-
-val open_webview
-  : ?text_editor: Vscode.TextEditor.t
-  -> Superbol_instance.t
-  -> unit Promise.t
diff --git a/src/vscode/superbol-vscode-platform/superbol_commands.ml b/src/vscode/superbol-vscode-platform/superbol_commands.ml
index 461d9b94..c5ef4d90 100644
--- a/src/vscode/superbol-vscode-platform/superbol_commands.ml
+++ b/src/vscode/superbol-vscode-platform/superbol_commands.ml
@@ -44,24 +44,13 @@ let _open_cfg =
       ()
     end
 
-let _open_cfg_d3 =
-  command "superbol.cfg.open.d3" @@ Instance
+let _open_cfg_arc =
+  command "superbol.cfg.open.arc" @@ Instance
     begin fun _instance ~args:_ ->
-      let _ : unit Promise.t = Superbol_cfg_explorer.open_cfg ~typ:`D3 _instance in
+      let _ : unit Promise.t = Superbol_cfg_explorer.open_cfg ~typ:`Arc _instance in
       ()
     end
 
-
-
-let _open_cfg2 =
-  command "superbol.cfg.test" @@ Instance
-    begin fun _instance ~args:_ ->
-      let _ : unit Promise.t = Superbol_cfg_explorer.open_webview _instance in
-      ()
-    end
-
-
-
 let _editor_action_findReferences =
   let command_name = "superbol.editor.action.findReferences"  in
   command command_name @@ Instance