diff --git a/.drom b/.drom index 54e0b4697..436351bbd 100644 --- a/.drom +++ b/.drom @@ -5,13 +5,12 @@ version:0.9.0 # hash of toml configuration files # used for generation of all files -770715578d99cec11afe5b129aa5930f:. +d3322e46fe7329e9bbda1b7042625e6a:. # end context for . # begin context for .github/workflows/workflow.yml # file .github/workflows/workflow.yml -5714f81b8a12cefeab3bd452453832b5:.github/workflows/workflow.yml -aedabb02434649b101d3db2436821c08:.github/workflows/workflow.yml +225f4c9dec0def7b46e5d3bc522e7dc7:.github/workflows/workflow.yml # end context for .github/workflows/workflow.yml # begin context for .gitignore @@ -26,7 +25,7 @@ aedabb02434649b101d3db2436821c08:.github/workflows/workflow.yml # begin context for Makefile # file Makefile -0195ab922c6b2c04b5cc71036d59fe5e:Makefile +0c73865932c3fbfc726666210af7def2:Makefile # end context for Makefile # begin context for README.md @@ -77,8 +76,19 @@ c8281f46ba9a11d0b61bc8ef67eaa357:docs/style.css # begin context for dune-project # file dune-project bbe93981f3f89550246d41f768f73a28:dune-project +c375da381bfae0c77c7af1cb51f96580:dune-project +cde29409c1d991e499786d56924f8fc9:dune-project +68f1f36e943a31bcb34b9b97f6830817:dune-project +afd60e19795dd45cbf2d203174f50a68:dune-project +68f1f36e943a31bcb34b9b97f6830817:dune-project +f3f8f40142982198dd2b7096346d98e4:dune-project # end context for dune-project +# begin context for opam/cobol_cfg.opam +# file opam/cobol_cfg.opam +535909f451064f672cd8c6a798512ba1:opam/cobol_cfg.opam +# end context for opam/cobol_cfg.opam + # begin context for opam/cobol_common.opam # file opam/cobol_common.opam b27c1951ae8db0dd9b7f141bff20f8d4:opam/cobol_common.opam @@ -106,7 +116,7 @@ d7c870139778d0a6e34395be1ea0c85b:opam/cobol_indent_old.opam # begin context for opam/cobol_lsp.opam # file opam/cobol_lsp.opam -f1979dd618dbe096cbf3f6ebd7b764ad:opam/cobol_lsp.opam +c8462fb8a72ea1c6c9ef4ad6aea10b73:opam/cobol_lsp.opam # end context for opam/cobol_lsp.opam # begin context for opam/cobol_parser.opam @@ -284,6 +294,16 @@ c882aea48ff6d4b120283f41153810ee:sphinx/about.rst 13af61ba0b28e7fcb749a0c3b34e2322:sphinx/license.rst # end context for sphinx/license.rst +# begin context for src/lsp/cobol_cfg/dune +# file src/lsp/cobol_cfg/dune +c6c7cd50f0ebff63bab991bf9a1633e6:src/lsp/cobol_cfg/dune +# end context for src/lsp/cobol_cfg/dune + +# begin context for src/lsp/cobol_cfg/version.mlt +# file src/lsp/cobol_cfg/version.mlt +de6c46a271140f4f52b2580e0d876351:src/lsp/cobol_cfg/version.mlt +# end context for src/lsp/cobol_cfg/version.mlt + # begin context for src/lsp/cobol_common/dune # file src/lsp/cobol_common/dune 9edd2c6c082e67ed0b683e87e60c485e:src/lsp/cobol_common/dune @@ -336,7 +356,7 @@ de6c46a271140f4f52b2580e0d876351:src/lsp/cobol_indent_old/version.mlt # begin context for src/lsp/cobol_lsp/dune # file src/lsp/cobol_lsp/dune -9d53073ccf454b19436ec96ace43b740:src/lsp/cobol_lsp/dune +0930647d8c6aee7065011a0501e050ac:src/lsp/cobol_lsp/dune # end context for src/lsp/cobol_lsp/dune # begin context for src/lsp/cobol_lsp/version.mlt diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index d5fda1042..c8e3193c8 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -61,7 +61,7 @@ jobs: - run: opam pin add . -y --no-action - - run: opam depext -y superbol-studio-oss superbol-vscode-platform polka-js-stubs interop-js-stubs node-js-stubs vscode-js-stubs vscode-languageclient-js-stubs vscode-json vscode-debugadapter vscode-debugprotocol superbol-free superbol_free_lib superbol_preprocs superbol_project cobol_common cobol_parser cobol_ptree ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_indent cobol_indent_old cobol_preproc cobol_data cobol_typeck cobol_unit ez_toml ezr_toml sql_ast sql_parser + - run: opam depext -y superbol-studio-oss superbol-vscode-platform polka-js-stubs interop-js-stubs node-js-stubs vscode-js-stubs vscode-languageclient-js-stubs vscode-json vscode-debugadapter vscode-debugprotocol superbol-free superbol_free_lib superbol_preprocs superbol_project cobol_common cobol_parser cobol_ptree ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_indent cobol_indent_old cobol_preproc cobol_data cobol_typeck cobol_unit ez_toml ezr_toml sql_ast sql_parser cobol_cfg # if: steps.cache-opam.outputs.cache-hit != 'true' - run: opam install -y opam/*.opam --deps-only --with-test diff --git a/CHANGELOG.md b/CHANGELOG.md index 7ad0b843f..e28a069aa 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,7 @@ ## [0.1.4] Next release ### Added +- CFG explorer for COBOL programs [368](https://github.com/OCamlPro/superbol-studio-oss/pull/368) - Detection of copybooks based on contents prefix and configured search path [373](https://github.com/OCamlPro/superbol-studio-oss/pull/373) - Support for connecting to the LSP server remotely (TCP only) [#102](https://github.com/OCamlPro/superbol-studio-oss/pull/102) - Support for Symbol Renaming command [#351](https://github.com/OCamlPro/superbol-studio-oss/pull/351) diff --git a/Makefile b/Makefile index 3a7bbf10f..78fdca31b 100644 --- a/Makefile +++ b/Makefile @@ -31,7 +31,7 @@ ifeq ($(TARGET_PLAT)_$(BUILD_STATIC_EXECS),linux_true) ./scripts/static-build.sh else ${DUNE} build ${DUNE_ARGS} ${DUNE_CROSS_ARGS} @install - ./scripts/copy-bin.sh superbol-studio-oss superbol-vscode-platform polka-js-stubs interop-js-stubs node-js-stubs vscode-js-stubs vscode-languageclient-js-stubs vscode-json vscode-debugadapter vscode-debugprotocol superbol-free superbol_free_lib superbol_preprocs superbol_project cobol_common cobol_parser cobol_ptree ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_indent cobol_indent_old cobol_preproc cobol_data cobol_typeck cobol_unit ez_toml ezr_toml sql_ast sql_parser + ./scripts/copy-bin.sh superbol-studio-oss superbol-vscode-platform polka-js-stubs interop-js-stubs node-js-stubs vscode-js-stubs vscode-languageclient-js-stubs vscode-json vscode-debugadapter vscode-debugprotocol superbol-free superbol_free_lib superbol_preprocs superbol_project cobol_common cobol_parser cobol_ptree ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_indent cobol_indent_old cobol_preproc cobol_data cobol_typeck cobol_unit ez_toml ezr_toml sql_ast sql_parser cobol_cfg endif ./scripts/after.sh build diff --git a/assets/cfg-arc-renderer.html b/assets/cfg-arc-renderer.html new file mode 100644 index 000000000..35696008a --- /dev/null +++ b/assets/cfg-arc-renderer.html @@ -0,0 +1,27 @@ + + + + + + + + + + + + + + + + + + + + +

Title

+
+ +
+ +
+ diff --git a/assets/cfg-arc.css b/assets/cfg-arc.css new file mode 100644 index 000000000..e272a31e2 --- /dev/null +++ b/assets/cfg-arc.css @@ -0,0 +1,43 @@ +/* ----------------------------------------------------------------------- + * + * SuperBOL OSS Studio + * + * + * Copyright (c) 2024 OCamlPro SAS + * + * All rights reserved. + * This source code is licensed under the MIT license found in the + * LICENSE.md file in the root directory of this source tree. + * + * ----------------------------------------------------------------------- + */ + +html, body { + height: 100%; +} +text { + font: 12px monospace; + pointer-events: none; +} +svg { + background-color: white; +} +path { + animation: dash 1.5s linear infinite; + animation-play-state: paused; +} +.animated { + animation-play-state: running; +} + +@keyframes dash { + to { + stroke-dashoffset: -51; // lcm of sum of dasharray values to avoid flicker + } +} +.hidden { + display: none !important; +} +#title { + margin-block: .2em; +} diff --git a/assets/cfg-arc.js b/assets/cfg-arc.js new file mode 100644 index 000000000..51e2b8377 --- /dev/null +++ b/assets/cfg-arc.js @@ -0,0 +1,356 @@ +// ----------------------------------------------------------------------- +// +// SuperBOL OSS Studio +// +// +// Copyright (c) 2024 OCamlPro SAS +// +// All rights reserved. +// This source code is licensed under the MIT license found in the +// LICENSE.md file in the root directory of this source tree. +// +// ----------------------------------------------------------------------- +// +// JS file attached to cfg-arc-renderer.html + +const vscode = acquireVsCodeApi() + +const elementLegend = document.getElementById('legend'); + +function toggleLegend() { + if(elementLegend.classList.contains("hidden")) { + elementLegend.classList.remove("hidden"); + } + else elementLegend.classList.add("hidden"); +} + +var graph = undefined; + nodes = undefined, + links = undefined, + y = undefined, + clickedNode = undefined + nodeColor = undefined; + +function addNeighbours(nodes, links) { + nodes.forEach(n => { + neigh = [] + links.forEach(l => { + if(l.source == n.id) { + neigh.push(l.target) + } + else if (l.target == n.id) { + neigh.push(l.source) + } + }) + n.neigh = Array.from(new Set(neigh)) + }) + return nodes; +} + +// set the dimensions and margins of the graph +var rect = document.getElementById("graph").getBoundingClientRect(); +const margin = {top: 20, right: 30, bottom: 20, left: 30}, + width = rect.width; + +function getShortenName(n) { + var name = n.name.split(" IN ")[0] + if(name.length > 14) { + return name.slice(0, 12) + ".." + } + return name +} + +function getDasharray(l) { + if(l.type === "g") + return "45,6" + if(l.type === "p") + return "12,5" + return "" +} + +function getNodeColor(color) { + return function (n) { + return color(n.section ? n.section : n.name) + } +} +const NODE_CENTER_X = 100 + NODE_RADIUS = 12, + LINK_MAX_SPREAD = width - NODE_CENTER_X - NODE_RADIUS - margin.right - margin.left + half_spread = LINK_MAX_SPREAD/2; +function map_to_max_spread(val, k) { + c = LINK_MAX_SPREAD + b = half_spread; + return b + (c-b)*Math.atan(k*(val-b))*2/Math.PI +} + +function getLinkPath(y) { + return function (l) { + start = y(l.source) + end = y(l.target) + if(l.type === "f") { + return `M ${NODE_CENTER_X} ${start+NODE_RADIUS} V ${end - NODE_RADIUS}` + } else { + path_x_offset = NODE_CENTER_X + NODE_RADIUS; + half_distance = Math.abs((start-end)/2) + map = map_to_max_spread(half_distance, .001) + x_furthest = path_x_offset + (half_distance > half_spread ? map : half_distance) + radius = half_distance > half_spread ? (half_distance**2 + map**2)/(2*map) : half_distance + return `M ${path_x_offset} ${start}\ + A ${radius},${radius} 0 0,${start < end?1:0} ${x_furthest},${(start+end)/2}\ + A ${radius},${radius} 0 0,${start < end?1:0} ${path_x_offset},${end}` + } + } +} + +var unfocusTimeout = undefined; +function focusNode(focused) { + clickedNode = undefined; + if(unfocusTimeout) { + clearTimeout(unfocusTimeout) + unfocusTimeout = undefined; + } + nodes.style("opacity", n => + !focused.neigh.includes(n.id) && n.id != focused.id + ? .4 + : 1) + .style("stroke", n => n.id === focused.id ? "black" : "none") + + links.filter(l => l.source !== focused.id && l.target !== focused.id) + .style("stroke", "#5553") + .style("stroke-width", 1) + .classed("animated", false) + .attr("marker-mid", "") + links.filter(l => l.source === focused.id || l.target === focused.id) + .style("stroke", l => (l.source === focused.id) ? "#7bb" : "#b7b") + .style("stroke-width", 3) + .attr("marker-mid", l => `url(#arrow-${(l.source===focused.id)?"out":"in"})`) + .classed("animated", true) +} + +function unfocus(delay, n) { + if(n.id == clickedNode?.id) return; + unfocusTimeout = setTimeout(() => { + unfocusTimeout = undefined; + nodes.style("opacity", 1) + .style("stroke", "none") + links + .style("stroke", "black") + .style("stroke-width", 1) + .attr("marker-mid", "url(#arrow)") + .classed("animated", false) + }, delay) +} + +function buildSVG(data) { + + const height = data.nodes.length * 32; + + data.nodes = addNeighbours(data.nodes, data.links) + + d3.select("#graph svg").remove() + // append the svg object to the body of the page + const svg = d3.select("#graph") + .append("svg") + .attr("width", width) + .attr("height", height + margin.top + margin.bottom) + + const defs = svg.append("defs") + const svg_g = svg.append("g") + .attr("transform",`translate(${margin.left},${margin.top})`); + + function appendMarker(defs, id, fill, big) { + defs.append("marker") + .attr("id", id) + .attr("viewBox", "0 -5 10 10") + .attr("refX", 4) + .attr("refY", 0) + .attr("markerUnits", "userSpaceOnUse") + .attr("markerWidth", big ? 12 : 8) + .attr("markerHeight", big ? 12 : 8) + .attr("orient", "auto") + .append("path") + .attr("fill", fill) + .attr("d", "M0,-5L10,0L0,5") + } + appendMarker(defs, "arrow", "black", false) + appendMarker(defs, "arrow-in", "#a6a", true) + appendMarker(defs, "arrow-out", "#6aa", true) + + + // List of node names + const allNodes = data.nodes.map(n => n.id).sort((a,b)=> a-b) + const sectionNodes = data.nodes.filter(n => n.section === n.name) + + const colorDiffNames = + Array.from(new Set(data.nodes.map(n => n.section ? n.section : n.name))) + const color = d3.scaleOrdinal(colorDiffNames, d3.schemeCategory10) + + // A linear scale to position the nodes on the X axis + y = d3.scalePoint() + .range([0, height]) + .domain(allNodes) + + nodeColor = getNodeColor(color); + + // And give them a label + const labels = svg_g + .selectAll("mylabels") + .data(data.nodes) + .join("g") + + labels.append("rect") + .attr("x", -margin.left) + .attr("y", n => y(n.id) - 6) + .attr("width", NODE_CENTER_X - NODE_RADIUS - 10 + margin.left) + .attr("height", "1em") + .attr("fill", "#fff") + + labels.append("text").text(getShortenName) + .attr("x", NODE_CENTER_X - NODE_RADIUS - 10) + .attr("y", n => y(n.id)) + .style("text-anchor", "end") + .style("alignment-baseline", "middle") + labels.append("title").text(n => n.name) + + // Add the links + links = svg_g + .selectAll("mylinks") + .data(data.links) + .join("path") + .attr("d", getLinkPath(y)) + .style("fill", "none") + .style("stroke", "black") + .style("stroke-dasharray", getDasharray) + .attr("marker-mid", "url(#arrow)") + + // Add the circle for the nodes + nodes = svg_g + .selectAll("mynodes") + .data(data.nodes) + .join("circle") + .attr("cx", NODE_CENTER_X) + .attr("cy", n => y(n.id)) + .attr("r", NODE_RADIUS) + .style("fill", nodeColor) + .style("stroke-width", 4) + + svg_g + .selectAll("sectionnodes") + .data(sectionNodes) + .join("circle") + .attr("cx", NODE_CENTER_X) + .attr("cy", n => y(n.id)) + .attr("r", 2) + .style("fill", "white") + + // Add the highlighting functionality + nodes + .on("mouseover", (_, n) => focusNode(n)) + .on("mouseout", (_, n) => unfocus(300, n)) + + nodes.on("click", (_, n) => { + clickedNode = n + vscode.postMessage({ + type: "click", + node: n.id + }) + }) +} + +function buildLegend() { + d3.select("#legend svg").remove() + const svg = d3.select("#legend") + .append("svg") + .attr("width", 400) + .attr("height", 260) + + const svg_g = svg.append("g") + + svg_g.append("path") + .attr("d", "M 100 20 v 20") + .attr("stroke", "black") + + svg_g.append("text") + .attr("x", 130).attr("y", 35) + .text("Fallthrough transition") + + + svg_g.append("path") + .attr("d", "M 50 70 h 60") + .attr("stroke", "black") + .classed("animated", true) + .attr("stroke-dasharray", getDasharray({ type: "g" })) + + svg_g.append("text") + .attr("x", 130).attr("y", 75) + .text("GO statement") + + svg_g.append("path") + .attr('d', 'M 50 110 h 60') + .classed("animated", true) + .attr("stroke", "black") + .attr("stroke-dasharray", getDasharray({ type: "p" })) + + svg_g.append("text") + .attr("x", 130).attr("y", 115) + .text("PERFORM statement") + + svg_g.append("circle") + .attr("cx", 100).attr("cy", 150).attr("r", NODE_RADIUS) + .style("fill", "red") + + svg_g.append("circle") + .attr("cx", 100).attr("cy", 150).attr("r", 2) + .style("fill", "white") + + svg_g.append("circle") + .attr("cx", 100).attr("cy", 190).attr("r", NODE_RADIUS) + .style("fill", "red") + + svg_g.append("text") + .attr("x", 130).attr("y", 155) + .text("SECTION") + + svg_g.append("text") + .attr("x", 130).attr("y", 195) + .text("PARAGRAPH IN SECTION") + + svg_g.append("circle") + .attr("cx", 100).attr("cy", 230).attr("r", NODE_RADIUS) + .style("fill", "green") + + svg_g.append("text") + .attr("x", 130).attr("y", 235) + .text("PARAGRAPH IN ANOTHER-SECTION") + +} + +function removeEntryStmt() { + removedIds = graph.nodes + .filter(n => n.name.startsWith("ENTRY ")) + .map(n => n.id) + graph.nodes = graph.nodes.filter(n => !removedIds.includes(n.id)) + graph.links = graph.links.filter(l => + !removedIds.includes(l.source) && !removedIds.includes(l.target)) +} + +window.addEventListener("message", event => { + if(event.data.type === "focused_proc") { + clickedNode = undefined; + 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) + } else if(event.data.type === "graph_content" + || event.data.type === "new_graph_content"){ + d3.select("#graph svg").remove() + graph = JSON.parse(event.data.graph) + document.getElementById("title").innerText = event.data.graph_name; + removeEntryStmt() + buildSVG(graph) + buildLegend() + } + }) + +vscode.postMessage({type: "ready"}) + diff --git a/assets/cfg-dot-renderer.html b/assets/cfg-dot-renderer.html new file mode 100644 index 000000000..6f8da98c3 --- /dev/null +++ b/assets/cfg-dot-renderer.html @@ -0,0 +1,74 @@ + + + + + + + + + + + + + + + + + + + + + + + +
+ +
+

Title

+
+ + + + + +
+
+ + + +
+
+ Rendering… Please wait
+ If this takes too long, you can try changing the + : + +
+
+ + diff --git a/assets/cfg-dot.css b/assets/cfg-dot.css new file mode 100644 index 000000000..076df7a4b --- /dev/null +++ b/assets/cfg-dot.css @@ -0,0 +1,100 @@ +/* ----------------------------------------------------------------------- + * + * SuperBOL OSS Studio + * + * + * Copyright (c) 2024 OCamlPro SAS + * + * All rights reserved. + * This source code is licensed under the MIT license found in the + * LICENSE.md file in the root directory of this source tree. + * + * ----------------------------------------------------------------------- + */ + +html, body { + height: 100%; +} +body { + display: flex; + flex-flow: column; + gap: .5em; +} + +#title { + margin-block: .2em; +} + +#app { + flex-grow: 1; +} +#modals { + height: 0; +} + +#rendering { + position: absolute; + top: 50%; + left: 50%; + transform: translate(-50%, -50%); + text-align: center; +} +.hidden { + display: none !important; +} +.modal { + position: absolute; + background-color: var(--vscode-sideBar-background); + border: var(--vscode-focusBorder) 1px solid; +} +#legend { + padding: 2px 2px 0 2px; + width: 500px; +} +#render-options { + display: flex; + flex-flow: column; + padding: .5em .2em; +} +#hubcount { + width: 50px; +} +#context-menu-background { + display: none; + position: absolute; + top: 0; + bottom: 0; + left: 0; + right: 0; + background-color: #0000; +} +#context-menu { + z-index: 10; + padding-block: .25em; +} +#context-menu p { + margin: 0; + padding-inline: .5em; + padding-block : .25em; +} +#context-menu p:hover { + background-color: var(--vscode-list-hoverBackground); +} +hr { + margin: 0; + border-color: var(--vscode-editor-foreground); +} +#render-btn { + align-self:center; + margin-block-start:.5em; +} +.nodes-list { + padding-block: .5em; + margin: 0; +} +.nodes-list > p { + margin: 0; +} +.nodes-list > p:hover { + background-color: var(--vscode-list-hoverBackground); +} diff --git a/assets/cfg-dot.js b/assets/cfg-dot.js new file mode 100644 index 000000000..93d63e8c9 --- /dev/null +++ b/assets/cfg-dot.js @@ -0,0 +1,307 @@ +// ----------------------------------------------------------------------- +// +// SuperBOL OSS Studio +// +// +// Copyright (c) 2024 OCamlPro SAS +// +// All rights reserved. +// This source code is licensed under the MIT license found in the +// LICENSE.md file in the root directory of this source tree. +// +// ----------------------------------------------------------------------- +// +// JS file attached to cfg-dot-renderer.html + +const legend = `digraph legend { + 1 [shape=doubleoctagon; label="An entry point\nof the program"] + 2 [shape=rect; label="A section or paragraph"] + 3 [shape=record; label="{2 collapsed paragraphs or sections|linked by a fallthrough transition}"] + 4 [shape=rect; style=dashed; label="A copy of a split hub"] + + 10 [shape=plaintext; label=""] + 11 [shape=plaintext; label=""] + 12 [shape=plaintext; label=""] + 13 [shape=plaintext; label=""] + + 10 -> 11 [style=solid; label="GO"] + 11 -> 12 [style=dashed; label="PERFORM"] + 12 -> 13 [style=dotted; label="fallthrough"] + + {rank=source; 2; 1;} + {rank=same; 3; 4 } + {rank=sink; 10; 11; 12; 13 } +}` +d3.select("#legend").graphviz().renderDot(legend) + .zoom(false) + .width("100%") + .fit(true) + .on("end", () => d3.select("#legend svg").attr("height", null)) + +const elementContextMenu = document.getElementById('context-menu'), + elementContextMenuBack = document.getElementById('context-menu-background'), + elementLegend = document.getElementById('legend'), + elementOptions = document.getElementById('render-options'); + +const vscode = acquireVsCodeApi() +var graphviz = undefined; +var graph = undefined; +var contextNode = undefined; +const defaultOptions = { + hidden_nodes: [], + split_nodes: [], + hide_unreachable: false, + collapse_fallthru: false, + in_degree_upper_limit: undefined, +} +var renderOptions = defaultOptions; +var rendering = d3.select('#rendering') +var dataHistory = [] + +/// MODAL MANAGEMENT + +function hideContextMenu() { + elementContextMenuBack.style.display = "none"; +} + +elementContextMenuBack.onclick = hideContextMenu; +elementContextMenuBack.oncontextmenu = hideContextMenu; + +function showContextMenu(x, y) { + hideModals() + elementContextMenuBack.style.display = "block"; + elementContextMenu.style.left = `${x}px`; + elementContextMenu.style.top = `${y}px`; +} + +function toggleLegend() { + if(elementLegend.classList.contains("hidden")) { + hideModals(); + elementLegend.classList.remove("hidden"); + } + else hideModals() +} + +function toggleRenderOptions() { + if(elementOptions.classList.contains("hidden")) { + hideModals(); + elementOptions.classList.remove("hidden"); + } + else hideModals() +} + +function hideModals() { + elementOptions.classList.add("hidden"); + elementLegend.classList.add("hidden"); +} + +/// RENDER OPTION MANAGEMENT + +function createClickableElement(node, parentId) { + const el = document.createElement("p") + if(parentId == "hidden_nodes") { + el.append(`Show "${node.name}" `) + } + else el.append(`Join "${node.name}" `); + const linkedNodeId = node.id; + el.onclick = (ev) => { + ev.target.remove() + if(parentId == "hidden_nodes") { + renderOptions.hidden_nodes.splice( + renderOptions.hidden_nodes.findIndex(i => i == linkedNodeId), + 1) + } else { + renderOptions.split_nodes.splice( + renderOptions.split_nodes.findIndex(i => i == linkedNodeId), + 1) + } + } + document.getElementById(parentId).append(el) +} + +function setRenderOptions(renderOptions_) { + renderOptions = { ...renderOptions, ...renderOptions_ }; + document.getElementById("unreachable").checked = + renderOptions.hide_unreachable; + document.getElementById("fallthru").checked = + renderOptions.collapse_fallthru; + document.getElementById("in_degree_upper_limit").checked = + renderOptions.in_degree_upper_limit != undefined; + document.getElementById("hubcount").value = + renderOptions.in_degree_upper_limit == undefined + ? "20" + : String(renderOptions.in_degree_upper_limit); + const nodeElements = document.querySelectorAll(".nodes-list > p"); + for (let p of nodeElements) { + p.remove(); + } + for (let id of renderOptions.hidden_nodes) { + const node = graph.nodes.find(n => n.id === id); + createClickableElement(node, "hidden_nodes") + } + for (let id of renderOptions.split_nodes) { + const node = graph.nodes.find(n => n.id === id); + createClickableElement(node, "split_nodes") + } +} + +/// RERENDERERS + +function rerender() { + var collapse_fallthru = document.getElementById('fallthru').checked; + var hide_unreachable = document.getElementById('unreachable').checked; + if(document.getElementById('in_degree_upper_limit').checked) { + var in_degree_upper_limit = Number(document.getElementById('hubcount').value) + } + else { + var in_degree_upper_limit = undefined; + } + renderOptions = { + ...renderOptions, + hide_unreachable, + collapse_fallthru, + in_degree_upper_limit, + }; + vscode.postMessage({ type: 'graph_update', renderOptions }) +} + +function rerenderWithDefault() { + renderOptions = defaultOptions; + vscode.postMessage({ type: 'graph_update', renderOptions }) +} + +function actionDescendents() { + renderOptions.action = "descendents"; + renderOptions.id = contextNode.id; + vscode.postMessage({ type: 'graph_update', renderOptions }) +} + +function actionNeighborhood() { + renderOptions.action = "neighborhood"; + renderOptions.id = contextNode.id; + vscode.postMessage({ type: 'graph_update', renderOptions }) +} + +function actionHideNode() { + renderOptions.hidden_nodes.push(contextNode.id) + createClickableElement(contextNode, "hidden_nodes") + vscode.postMessage({ type: "graph_update", renderOptions }) +} + +function actionSplitNode() { + renderOptions.split_nodes.push(contextNode.id) + createClickableElement(contextNode, "split_nodes"); + vscode.postMessage({ type: "graph_update", renderOptions }) +} + +/// OTHER OPTIONS MANAGEMENT + +function reset() { + graphviz?.resetZoom() +} + +function historyGoBack() { + dataHistory.pop(); + const [dot, graph, options, name] = JSON.parse(dataHistory[dataHistory.length - 1]); + document.getElementById('title').innerText = name; + renderGraph(dot, graph) + setRenderOptions(options) + if(dataHistory.length == 1) { + document.getElementById("history-btn").disabled = true + } +} + +/// GRAPH MANAGEMENT + +function focus(name) { + d3.selectAll('svg .node polygon').attr("fill", "none") + d3.selectAll('svg .node text') + .filter(function () { return this.textContent === name}) + .select(function () { return this.parentNode }) + .select("polygon") + .attr("fill", "red") +} + +function updateTitle(graph, graph_name) { + const node = graph.nodes.find(n => n.id === renderOptions.id); + switch (renderOptions.action) { + case "neighborhood": + title = `${graph_name} : Neighborhood of ${node.name}` + break; + case "descendents": + title = `${graph_name} : Descendents of ${node.name}` + break; + default: + title = graph_name; + break; + } + document.getElementById('title').innerText = title; +} + +function setupOnEnd() { + rendering.classed("hidden", true); + d3.selectAll("svg g title").remove() + d3.selectAll("svg text") + .on("click", (_, e) => { + 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 + }) + }) + .on("contextmenu", (ev, el) => { + const clickedName = el.children[0].text; + if(!clickedName) { contextNode = undefined; return; } + const node = + graph.nodes + .find(n => clickedName === n.name + || n.name.startsWith(clickedName + " IN ") ) + if(!node) { contextNode = undefined; return; } + contextNode = node; + showContextMenu(ev.clientX, ev.clientY); + }) +} + +function renderGraph(dot, _graph) { + if(graphviz) { + graphviz.destroy() + d3.select('#app svg').remove() + } + graphviz = d3.select('#app').graphviz().fit(true); + graphviz.zoomScaleExtent([0.1, 50]) + var rect = document.getElementById('app').getBoundingClientRect(); + graphviz.width(rect.width).height(rect.height) + graphviz.renderDot(dot) + .on('end', setupOnEnd) + rendering.classed("hidden", false); + graph = _graph +} + +/// MAIN LISTENER + +window.addEventListener('message', event => { + if(event.data.type === "focused_proc") { + focus(event.data.procedure) + } + else if (event.data.type === "graph_content" + || event.data.type === "new_graph_content") { + graph = JSON.parse(event.data.graph) + setRenderOptions(event.data.render_options || {}) + renderGraph(event.data.dot, graph) + updateTitle(graph, event.data.graph_name) + hideModals() + if(event.data.type.startsWith("new")) { + dataHistory = []; + } + dataHistory.push(JSON.stringify([event.data.dot, graph, renderOptions, event.data.graph_name])) + document.getElementById('history-btn').disabled = dataHistory.length <= 1 + } + }) +vscode.postMessage({type: 'ready'}) diff --git a/drom.toml b/drom.toml index 684d3a0bb..baa534e51 100644 --- a/drom.toml +++ b/drom.toml @@ -235,3 +235,6 @@ dir = "src/lsp/sql_ast" [[package]] dir = "src/lsp/sql_parser" # edit 'src/lsp/sql_parser/package.toml' for package-specific options + +[[package]] +dir = "src/lsp/cobol_cfg" diff --git a/dune-project b/dune-project index a869420bc..419cc40b2 100644 --- a/dune-project +++ b/dune-project @@ -304,6 +304,7 @@ (cobol_data (= version)) (cobol_config (= version)) (cobol_common (= version)) + (cobol_cfg (= version)) odoc ) ) @@ -493,4 +494,16 @@ ) ) +(package + (name cobol_cfg) + (synopsis "SuperBOL Studio OSS Project") + (description "SuperBOL Studio OSS is a new platform for COBOL") + (depends + (ocaml (>= 4.14.0)) + (ocamlgraph (and (>= 2.1.0) (< 3.0.0))) + (cobol_typeck (= version)) + odoc + ) + ) + diff --git a/opam/cobol_cfg.opam b/opam/cobol_cfg.opam new file mode 100644 index 000000000..accd08164 --- /dev/null +++ b/opam/cobol_cfg.opam @@ -0,0 +1,54 @@ +# This file was generated by `drom` from `drom.toml`. +# Do not modify, or add to the `skip` field of `drom.toml`. +opam-version: "2.0" +name: "cobol_cfg" +version: "0.1.4" +license: "MIT" +synopsis: "SuperBOL Studio OSS Project" +description: "SuperBOL Studio OSS is a new platform for COBOL" +authors: [ + "Nicolas Berthier " + "David Declerck " + "Boris Eng " + "Fabrice Le Fessant " + "Emilien Lemaire " +] +maintainer: [ + "Nicolas Berthier " + "David Declerck " + "Boris Eng " + "Fabrice Le Fessant " + "Emilien Lemaire " +] +homepage: "https://ocamlpro.github.io/superbol-studio-oss" +doc: "https://ocamlpro.github.io/superbol-studio-oss/sphinx" +bug-reports: "https://github.com/ocamlpro/superbol-studio-oss/issues" +dev-repo: "git+https://github.com/ocamlpro/superbol-studio-oss.git" +tags: "org:ocamlpro" +build: [ + ["dune" "subst"] {dev} + ["sh" "-c" "./scripts/before.sh build '%{name}%'"] + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] + ["sh" "-c" "./scripts/after.sh build '%{name}%'"] +] +install: [ + ["sh" "-c" "./scripts/before.sh install '%{name}%'"] +] +depends: [ + "ocaml" {>= "4.14.0"} + "dune" {>= "2.8.0"} + "ocamlgraph" {>= "2.1.0" & < "3.0.0"} + "cobol_typeck" {= version} + "odoc" {with-doc} +] +# Content of `opam-trailer` field: \ No newline at end of file diff --git a/opam/cobol_lsp.opam b/opam/cobol_lsp.opam index 7cf909c44..28b7ef8f1 100644 --- a/opam/cobol_lsp.opam +++ b/opam/cobol_lsp.opam @@ -59,6 +59,7 @@ depends: [ "cobol_data" {= version} "cobol_config" {= version} "cobol_common" {= version} + "cobol_cfg" {= version} "odoc" {with-doc} ] # Content of `opam-trailer` field: \ No newline at end of file diff --git a/opam/osx/cobol_cfg-osx.opam b/opam/osx/cobol_cfg-osx.opam new file mode 100644 index 000000000..5558101d5 --- /dev/null +++ b/opam/osx/cobol_cfg-osx.opam @@ -0,0 +1,56 @@ +# This file was generated by `drom` from `drom.toml`. +# Do not modify, or add to the `skip` field of `drom.toml`. +opam-version: "2.0" +name: "cobol_cfg" +version: "0.1.4" +license: "MIT" +synopsis: "SuperBOL Studio OSS Project" +description: "SuperBOL Studio OSS is a new platform for COBOL" +authors: [ + "Nicolas Berthier " + "David Declerck " + "Boris Eng " + "Fabrice Le Fessant " + "Emilien Lemaire " +] +maintainer: [ + "Nicolas Berthier " + "David Declerck " + "Boris Eng " + "Fabrice Le Fessant " + "Emilien Lemaire " +] +homepage: "https://ocamlpro.github.io/superbol-studio-oss" +doc: "https://ocamlpro.github.io/superbol-studio-oss/sphinx" +bug-reports: "https://github.com/ocamlpro/superbol-studio-oss/issues" +dev-repo: "git+https://github.com/ocamlpro/superbol-studio-oss.git" +tags: "org:ocamlpro" +build: [ + ["dune" "subst"] {dev} + ["sh" "-c" "./scripts/before.sh build '%{name}%'"] + [ + "dune" + "build" + "-p" + "cobol_cfg" + "-x" + "osx" + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] + ["sh" "-c" "./scripts/after.sh build '%{name}%'"] +] +install: [ + ["sh" "-c" "./scripts/before.sh install '%{name}%'"] +] +depends: [ + "ocaml" {>= "4.14.0"} + "dune" {>= "2.8.0"} + "ocamlgraph-osx" {>= "2.1.0" & < "3.0.0"} + "cobol_typeck-osx" {= version} + "odoc" {with-doc} +] +# Content of `opam-trailer` field: \ No newline at end of file diff --git a/opam/osx/cobol_lsp-osx.opam b/opam/osx/cobol_lsp-osx.opam index a814d2dac..757292239 100644 --- a/opam/osx/cobol_lsp-osx.opam +++ b/opam/osx/cobol_lsp-osx.opam @@ -61,6 +61,7 @@ depends: [ "cobol_data-osx" {= version} "cobol_config-osx" {= version} "cobol_common-osx" {= version} + "cobol_cfg-osx" {= version} "odoc" {with-doc} ] # Content of `opam-trailer` field: \ No newline at end of file diff --git a/opam/windows/cobol_cfg-windows.opam b/opam/windows/cobol_cfg-windows.opam new file mode 100644 index 000000000..27370d92e --- /dev/null +++ b/opam/windows/cobol_cfg-windows.opam @@ -0,0 +1,56 @@ +# This file was generated by `drom` from `drom.toml`. +# Do not modify, or add to the `skip` field of `drom.toml`. +opam-version: "2.0" +name: "cobol_cfg" +version: "0.1.4" +license: "MIT" +synopsis: "SuperBOL Studio OSS Project" +description: "SuperBOL Studio OSS is a new platform for COBOL" +authors: [ + "Nicolas Berthier " + "David Declerck " + "Boris Eng " + "Fabrice Le Fessant " + "Emilien Lemaire " +] +maintainer: [ + "Nicolas Berthier " + "David Declerck " + "Boris Eng " + "Fabrice Le Fessant " + "Emilien Lemaire " +] +homepage: "https://ocamlpro.github.io/superbol-studio-oss" +doc: "https://ocamlpro.github.io/superbol-studio-oss/sphinx" +bug-reports: "https://github.com/ocamlpro/superbol-studio-oss/issues" +dev-repo: "git+https://github.com/ocamlpro/superbol-studio-oss.git" +tags: "org:ocamlpro" +build: [ + ["dune" "subst"] {dev} + ["sh" "-c" "./scripts/before.sh build '%{name}%'"] + [ + "dune" + "build" + "-p" + "cobol_cfg" + "-x" + "windows" + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] + ["sh" "-c" "./scripts/after.sh build '%{name}%'"] +] +install: [ + ["sh" "-c" "./scripts/before.sh install '%{name}%'"] +] +depends: [ + "ocaml" {>= "4.14.0"} + "dune" {>= "2.8.0"} + "ocamlgraph-windows" {>= "2.1.0" & < "3.0.0"} + "cobol_typeck-windows" {= version} + "odoc" {with-doc} +] +# Content of `opam-trailer` field: \ No newline at end of file diff --git a/opam/windows/cobol_lsp-windows.opam b/opam/windows/cobol_lsp-windows.opam index b7b6abd90..ef35232bf 100644 --- a/opam/windows/cobol_lsp-windows.opam +++ b/opam/windows/cobol_lsp-windows.opam @@ -61,6 +61,7 @@ depends: [ "cobol_data-windows" {= version} "cobol_config-windows" {= version} "cobol_common-windows" {= version} + "cobol_cfg-windows" {= version} "odoc" {with-doc} ] # Content of `opam-trailer` field: \ No newline at end of file diff --git a/package.json b/package.json index 1bf34db1d..79e69f195 100644 --- a/package.json +++ b/package.json @@ -38,6 +38,16 @@ "command": "superbol.coverage.reload", "title": "Update Coverage", "category": "SuperBOL" + }, + { + "command": "superbol.cfg.open", + "title": "Show control-flow", + "category": "SuperBOL" + }, + { + "command": "superbol.cfg.open.arc", + "title": "Show control-flow as an arc-diagram", + "category": "SuperBOL" } ], "configuration": { @@ -445,6 +455,20 @@ "configuration": "./syntaxes/list-n-dump-configuration.json" } ], + "menus": { + "editor/context": [ + { + "command": "superbol.cfg.open", + "group": "superbol", + "when": "editorTextFocus && editorLangId == 'cobol'" + }, + { + "command": "superbol.cfg.open.arc", + "group": "superbol", + "when": "editorTextFocus && editorLangId == 'cobol'" + } + ] + }, "problemMatchers": [ { "name": "gnucobol", diff --git a/src/lsp/cobol_cfg/README.md b/src/lsp/cobol_cfg/README.md new file mode 100644 index 000000000..1cd375546 --- /dev/null +++ b/src/lsp/cobol_cfg/README.md @@ -0,0 +1,5 @@ +# Cobol_cfg package + +This package contains all the logic for control flow representation of COBOL programs. + +For API documentation, please see [index.mld]. diff --git a/src/lsp/cobol_cfg/cfg_builder.ml b/src/lsp/cobol_cfg/cfg_builder.ml new file mode 100644 index 000000000..178393154 --- /dev/null +++ b/src/lsp/cobol_cfg/cfg_builder.ml @@ -0,0 +1,424 @@ +(******************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(******************************************************************************) + +open Cobol_unit +open Cobol_common.Srcloc.INFIX +open Cobol_common.Srcloc.TYPES +open Cobol_unit.Types +open Cfg_jumps +open Cfg_types +module NEL = Cobol_common.Basics.NEL + +(* TYPES AND HELPERS *) + +type display_name_type = + | Full + | Short + +let qn_to_strings : qualname -> string * string = function + | Name { payload; _ } -> payload, "" + | Qual({ payload = para; _ }, Name { payload = sec; _ }) -> para, sec + | _ -> raise @@ Invalid_argument + "qn with more than 2 qualification levels cannot \ + come from a paragraph or section" + +let qn_to_fullname qn = + let name, qual = qn_to_strings qn in + if qual == "" + then name + else name ^ " IN " ^ qual + +let prefix_to_string prefix = + begin match prefix with + | Cobol_ptree.CallGeneral i -> + Pretty.to_string "CALL %a" Cobol_ptree.pp_ident_or_strlit i + | CallProto { prototype = CallProtoNested; _ }-> "CALL NESTED" + | CallProto { called; prototype = CallProtoIdent i }-> + Pretty.to_string "CALL %a AS %a" + Fmt.(option Cobol_ptree.pp_ident_or_strlit) called + Cobol_ptree.pp_ident i + end |> Str.global_replace (Str.regexp "\"") "\\\"" + +let entry_stmt_to_string_loc = function + | Cobol_ptree.EntryForGoTo { payload; loc } + | Cobol_ptree.EntryUsing { entry_name={ payload; loc }; _ } + | Cobol_ptree.EntrySimple { payload; loc } -> + Str.global_replace (Str.regexp "\"") "\\\"" + (Pretty.to_string "ENTRY %a" Cobol_ptree.pp_alphanum payload), + loc + +(* CFG MODULE *) + +let is_entry n = + match n.typ with + | External _ | Normal _ | Collapsed _ | Split _ -> false + | Entry _ -> true + +(* DEFAULT CFG BUILDER FUNCTION *) + +let node_idx = ref 0 +let next_node_idx () = + node_idx := !node_idx + 1; + !node_idx + +let call_stmt_section_name = "__CALL_STMT__" + +let reset_global_counter () = + node_idx := 0 + +let build_node ?(is_section=false) ?(display_name_type=Full) ~cu paragraph = + let { jumps; will_fallthru; terminal; skip_remaining = _ } + : JumpsCollector.acc = Visitor.fold_procedure_paragraph' + (JumpsCollector.folder ~cu) paragraph JumpsCollector.init in + let typ, loc, section_name = match ~¶graph.paragraph_name with + | None -> Entry `Paragraph, ~@paragraph, "" + | Some qn -> + let fullqn = full_qn' ~cu qn in + let full_name = qn_to_fullname fullqn in + let short_name, section_name = + let name, qualifier = qn_to_strings fullqn in + name, if is_section then name else qualifier + in + let display_name = match display_name_type with + | Full -> full_name + | Short -> short_name + in Normal (full_name, display_name), ~@qn, section_name + in { + id = next_node_idx (); + section_name; + loc = Some loc; + jumps; + will_fallthru; + terminal; + typ; + } + +let new_node ~typ = + let loc_of ~(qn: qualname) = match qn with + | Cobol_ptree.Name name + | Qual (name, _) -> ~@name in + let typ, loc, section_name = match typ with + | `External qn -> + let _para, section = qn_to_strings qn in + External (qn_to_fullname qn), Some (loc_of ~qn), section + | `EntryPoint -> Entry `Point, None, "" + | `EntryStmt ({ payload; loc }, id) -> + Entry (`Statement payload), Some loc, id + | `Call s -> + External s, None, call_stmt_section_name + in { + id = next_node_idx (); + section_name; + loc; + jumps = Jumps.empty; + will_fallthru = true; + terminal = false; + typ; + } + +let build_edges nodes = + let module StringMap = Map.Make(String) in + let find_or_add smap ~typ = + let string_id = match typ with + | `External qn -> qn_to_fullname qn + | `EntryStmt ({ payload; _ }, _) -> payload + | `Call name -> name in + match StringMap.find_opt string_id smap with + | Some node -> smap, node + | None -> + let node = new_node ~typ in + StringMap.add string_id node smap, node + in + let rec edge_builder_aux ~vertexes g nodes = + let g, vertexes = match nodes with + | ({ jumps; _ } as current)::_ -> + Jumps.fold begin fun uncond (g, vertexes) -> + match uncond with + | GoDepending qn + | Go qn -> + let vertexes, next = find_or_add vertexes ~typ:(`External qn) in + Cfg.add_edge_e g (current, Go, next), + vertexes + | Perform qn -> + let vertexes, next = find_or_add vertexes ~typ:(`External qn) in + Cfg.add_edge_e g (current, Perform, next), + vertexes + | Call prefix -> + let vertexes, next = + find_or_add vertexes ~typ:(`Call (prefix_to_string prefix)) in + Cfg.add_edge_e g (current, Perform, next), + vertexes + | Entry entry_stmt -> + let name, loc = entry_stmt_to_string_loc entry_stmt in + let vertexes, next = + find_or_add vertexes ~typ:(`EntryStmt (name &@ loc, current.section_name)) in + Cfg.add_edge_e g (next, FallThrough, current), + vertexes + end jumps (g, vertexes) + | [] -> g, vertexes + in + match nodes with + | ({ will_fallthru; _ } as current)::next::tl + when will_fallthru -> + edge_builder_aux ~vertexes (Cfg.add_edge g current next) (next::tl) + | _::tl -> edge_builder_aux ~vertexes g tl + | [] -> g + in + let g, vertexes = List.fold_left begin fun (g, vertexes) node -> + Cfg.add_vertex g node, + match node.typ with + | Normal (full_name, _) -> StringMap.add full_name node vertexes + | _ -> vertexes + end (Cfg.empty, StringMap.empty) nodes + in + edge_builder_aux ~vertexes g nodes + +let cfg_of ~(cu: cobol_unit) = + reset_global_counter (); + let nodes = List.fold_left begin fun acc block -> + match block with + | Paragraph para -> + build_node ~cu para :: acc + | Section { payload = { section_paragraphs; _ }; _ } -> + fst @@ List.fold_left begin fun (acc, is_section) p -> + build_node ~is_section ~cu p :: acc, + false + end (acc, true) section_paragraphs.list + end [] cu.unit_procedure.list + in + List.rev nodes + |> begin function (* adding entry point if not already present *) + | ({ typ = Entry _; _ } as hd )::tl -> { hd with id=0 }::tl + | l -> { (new_node ~typ:`EntryPoint) with id=0 } :: l + end + |> build_edges + +let cfg_of_section ~cu ({ section_paragraphs; _ }: procedure_section) = + reset_global_counter (); + let nodes = + List.fold_left begin fun (acc, is_section) p -> + build_node ~is_section ~display_name_type:Short ~cu p :: acc, + false + end ([], true) section_paragraphs.list + |> fst + |> List.rev in + begin match nodes with + | ({ typ = Normal (_, name); _ } as entry)::tl -> + { entry with typ = Entry (`Section name) }::tl + | l -> l end + |> build_edges + +let graph_material_of_doc ({ group; _ }: Cobol_typeck.Outputs.t) = + Cobol_unit.Collections.SET.fold + begin fun { payload = cu; _ } acc -> + let section_graphs = List.filter_map begin function + | Paragraph _ -> None + | Section sec -> + let name = Pretty.to_string "%a (%s)" + Cobol_ptree.pp_qualname' ~&sec.section_name + ((~&) cu.unit_name) in + Some (name, `Section (cu, ~&sec)) + end cu.unit_procedure.list in + let cu_name = (~&)cu.unit_name in + (cu_name, `Cu cu) :: section_graphs @ acc + end group [] + +let cfg_of_doc ~name checked_doc = + graph_material_of_doc checked_doc + |> List.find_opt + begin fun (corr_name, _) -> String.equal name corr_name end + |> function + | None -> raise @@ + Pretty.invalid_arg "%s is invalid for requested document" name + | Some (_, `Cu cu) -> cfg_of ~cu + | Some (_, `Section (cu, sec)) -> cfg_of_section ~cu sec + +let possible_cfgs_of_doc checked_doc = + graph_material_of_doc checked_doc + |> List.map fst + +(* CFG OPTIONS HANDLER *) + +let do_collapse_fallthru g = + let module IdMap = Map.Make(Int) in + let get_names_if_collapsable { typ; _ } = + match typ with + | Collapsed names -> Some names + | Normal (_, name) -> Some (NEL.One name) + | Entry _ | External _ | Split _ -> None in + let collapse_node ~cfg ~id_map ~node ~pred n_names pred_names = + let cfg = Cfg.fold_succ_e begin fun (_, e, next) cfg -> + match next.typ with + | Split next_name + (* when the same split node already exist, remove the duplicate one *) + when + Cfg.fold_succ_e begin fun pred_edge acc -> + acc || match pred_edge with + | (_, pred_e, { typ = Split name; _ }) -> + Stdlib.(=) pred_e e && + String.equal name next_name + | _ -> false + end cfg pred false + -> Cfg.remove_vertex cfg next + | _ -> Cfg.add_edge_e cfg (pred, e, next) + end cfg node cfg in + let id_map = IdMap.update pred.id + begin function + | None -> Some NEL.(n_names @ pred_names) + | Some names -> Some NEL.(n_names @ names) + end id_map in + Cfg.remove_vertex cfg node, id_map + in + let id_map = IdMap.empty in + let cfg, id_map = + Cfg.fold_vertex begin fun node (cfg, id_map) -> + match get_names_if_collapsable node with + | None -> (cfg, id_map) + | Some n_names -> + match Cfg.pred_e cfg node with + | [(({ typ = Normal (_, pred_name); _ } as pred), FallThrough, _)] -> + collapse_node ~cfg ~id_map ~node ~pred n_names (NEL.One pred_name) + | [(({ typ = Collapsed pred_names ; _ } as pred), FallThrough, _)] -> + collapse_node ~cfg ~id_map ~node ~pred n_names pred_names + | _ -> cfg, id_map + end g (g, id_map) in + Cfg.map_vertex begin fun node -> + match IdMap.find_opt node.id id_map with + | None -> node + | Some names -> { node with typ = Collapsed (NEL.rev names) } + end cfg + +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 (is_entry n) + then true, Cfg.remove_vertex cfg n + else did_remove, cfg + end cfg (false, cfg) + in + if did_remove then aux cfg else cfg + in aux g + +let clone_node node = + { node with id = next_node_idx (); } + +let do_split_nodes ~ids ~limit g = + let split_typ { typ; _ } = + match typ with + | External name -> Some (External name, true) + | Normal (_, name) -> Some (Split name, false) + | Entry _ | Split _ | Collapsed _ -> None + in + let is_above_limit n = + match limit with + | Some limit -> Cfg.in_degree g n >= limit + | None -> false + in + Cfg.fold_vertex begin fun n cfg -> + match split_typ n with + | Some (typ, remove_original) + when is_above_limit n || List.mem n.id ids -> + let cfg = Cfg.fold_pred_e begin fun edge cfg -> + let cfg = Cfg.remove_edge_e cfg edge in + let n_clone = { (clone_node n) with typ } in + let (pred, edge, _) = edge in + let cfg = Cfg.add_edge_e cfg (pred, edge, n_clone) in + cfg + end cfg n cfg in + if remove_original + then Cfg.remove_vertex cfg n + else cfg + | _ -> cfg + end g g + +let find_node_with ~id cfg = + Cfg.fold_vertex begin fun node -> function + | None when node.id == id -> Some node + | acc -> acc + end cfg None + +let restrict_to_descendents id cfg = + let module Ids = Set.Make(Int) in + match find_node_with ~id cfg with + | None -> cfg + | Some node -> + let ids = Ids.singleton node.id in + let module Dfs = Graph.Traverse.Dfs(Cfg) in + let ids = Dfs.fold_component begin fun node ids -> + Ids.add node.id ids + end ids cfg node in + Cfg.fold_vertex begin fun node cfg -> + if Ids.mem node.id ids + then cfg + else Cfg.remove_vertex cfg node + end cfg cfg + + +let max_depth = 3 +let restrict_to_neighborhood id cfg = + let module Nodes = Set.Make(Node) in + match find_node_with ~id cfg with + | None -> cfg + | Some node -> + let nodes = Nodes.singleton node in + let rec explore prev_depth_nodes explored_nodes depth = + if depth > max_depth + then explored_nodes + else + let next_depth_nodes = Nodes.fold begin fun node new_nodes -> + Cfg.fold_succ begin fun succ new_nodes -> + if Nodes.mem succ explored_nodes + then new_nodes + else Nodes.add succ new_nodes + end cfg node new_nodes + end prev_depth_nodes Nodes.empty in + let explored_nodes = Nodes.union explored_nodes prev_depth_nodes in + explore next_depth_nodes explored_nodes (depth+1) + in + let reachables = explore nodes nodes 0 in + let all_nodes = Cfg.fold_pred begin fun pred reachables -> + Nodes.add pred reachables + end cfg node reachables in + Cfg.fold_vertex begin fun node cfg -> + if Nodes.mem node all_nodes + then cfg + else Cfg.remove_vertex cfg node + end cfg cfg + +let remove_nodes ids cfg = + List.fold_left begin fun cfg id -> + match find_node_with ~id cfg with + | None -> cfg + | Some node -> Cfg.remove_vertex cfg node + end cfg ids + +let handle_cfg_options ~(options: Cfg_options.t) cfg = + cfg + |> (match options.transformation with + | Some Cfg_options.Descendents id -> restrict_to_descendents id + | Some Cfg_options.Neighborhood id -> restrict_to_neighborhood id + | _ -> Fun.id) + |> (if options.hide_unreachable && Option.is_none options.transformation + then do_hide_unreachable else Fun.id) + |> (match options.hidden_nodes with + | [] -> Fun.id + | l -> remove_nodes l) + |> do_split_nodes + ~ids:options.split_nodes + ~limit:options.in_degree_upper_limit + |> (if options.collapse_fallthru then do_collapse_fallthru else Fun.id) + +(* GRAPH OUTPUT FORMAT *) + +let make ~(options: Cfg_options.t) ~name (checked_doc: Cobol_typeck.Outputs.t) = + let cfg = cfg_of_doc ~name checked_doc in + let cfg_with_options = handle_cfg_options ~options cfg in + (cfg, cfg_with_options) diff --git a/src/lsp/cobol_cfg/cfg_builder.mli b/src/lsp/cobol_cfg/cfg_builder.mli new file mode 100644 index 000000000..817f9c84c --- /dev/null +++ b/src/lsp/cobol_cfg/cfg_builder.mli @@ -0,0 +1,21 @@ +(******************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(******************************************************************************) + +open Cfg_types + +val make + : options:Cfg_options.t + -> name:string + -> Cobol_typeck.Outputs.t + -> Cfg.t * Cfg.t + +val possible_cfgs_of_doc + : Cobol_typeck.Outputs.t + -> string list diff --git a/src/lsp/cobol_cfg/cfg_jumps.ml b/src/lsp/cobol_cfg/cfg_jumps.ml new file mode 100644 index 000000000..80765b4be --- /dev/null +++ b/src/lsp/cobol_cfg/cfg_jumps.ml @@ -0,0 +1,162 @@ +(******************************************************************************) +(* *) +(* Copyright (c) 2021-2024 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(******************************************************************************) + +open Cobol_unit +open Cobol_unit.Types +open Cobol_common.Visitor +open Cobol_common.Srcloc.INFIX + +type qualname = Cobol_ptree.qualname + +type jumps = + | Go of qualname + | GoDepending of qualname + | Perform of qualname + | Call of Cobol_ptree.call_prefix + | Entry of Cobol_ptree.entry_stmt + +module Jumps = Set.Make(struct + type t = jumps + let compare j1 j2 = + let to_int = function + | Go _ -> 0 + | GoDepending _ -> 1 + | Perform _ -> 2 + | Call _ -> 3 + | Entry _ -> 4 + in + match j1, j2 with + | Go qn1, Go qn2 + | GoDepending qn1, GoDepending qn2 + | Perform qn1, Perform qn2 -> Cobol_ptree.compare_qualname qn1 qn2 + | Call cp1, Call cp2 -> Cobol_ptree.compare_call_prefix cp1 cp2 + | Entry en1 , Entry en2 -> Cobol_ptree.compare_entry_stmt en1 en2 + | _ -> to_int j2 - to_int j1 + end) + +let full_qn ~cu qn = + (Qualmap.find_binding qn cu.unit_procedure.named).full_qn + +let full_qn' ~cu qn = full_qn ~cu ~&qn + + +module JumpsCollector = struct + type acc = { + jumps: Jumps.t; + will_fallthru: bool; + terminal: bool; + skip_remaining: bool; + } + + let init = { jumps = Jumps.empty; + terminal = false; + will_fallthru = true; + skip_remaining = false; + } + + let folder ~cu = object (v) + inherit [acc] Visitor.folder + + method! fold_goback' _ acc = + skip @@ { acc with terminal = true; + will_fallthru = false; + skip_remaining = true } + + method! fold_stop' _ acc = + skip @@ { acc with terminal = true; + will_fallthru = false; + skip_remaining = true } + + method! fold_exit' { payload = exit_stmt; _ } acc = + skip @@ + match exit_stmt with + | ExitSimple + | ExitPerform _ -> acc + | ExitMethod _ + | ExitProgram _ (* if in main program, does nothing, if in a called program, exit *) + | ExitFunction _ -> { acc with terminal = true; skip_remaining = true } + | ExitParagraph -> { acc with skip_remaining = true } (* TODO add a goto next para ? *) + | ExitSection -> { acc with skip_remaining = true } (* TODO: go to next section ? *) + + method! fold_evaluate' { payload; _ } acc = + let acc_list_split l = + List.fold_left begin fun + (a_acc, b_acc, c_acc, d_acc) + { jumps; terminal; will_fallthru; skip_remaining } -> + (jumps::a_acc, + terminal::b_acc, + will_fallthru::c_acc, + skip_remaining::d_acc) + end ([], [], [], []) l in + let { eval_branches; eval_otherwise; _ }: Cobol_ptree.evaluate_stmt = + payload in + let jumps, terminals, unreachables, skips = List.map begin fun branch -> + Cobol_ptree.Visitor.fold_evaluate_branch v branch init + end eval_branches |> acc_list_split in + let other = + Cobol_ptree.Visitor.fold_statements v eval_otherwise init in + skip { + jumps = List.fold_left Jumps.union acc.jumps (other.jumps::jumps); + will_fallthru = List.fold_left (||) other.will_fallthru unreachables; + terminal = List.fold_left (||) other.terminal terminals; + skip_remaining = List.fold_left (&&) other.skip_remaining skips; + } + + method! fold_statement' _ ({ skip_remaining; _ } as acc) = + if skip_remaining + then skip acc + else do_children acc + + method! fold_if' { payload = { then_branch; else_branch; _ }; _ } acc = + let { jumps; terminal; will_fallthru; skip_remaining } = + Cobol_ptree.Visitor.fold_statements v then_branch acc in + let { jumps = else_jumps; + terminal = else_terminal; + will_fallthru = else_fallthru; + skip_remaining = else_skip } = + Cobol_ptree.Visitor.fold_statements v else_branch init in + skip { + jumps = Jumps.union jumps else_jumps; + will_fallthru = will_fallthru || else_fallthru; + terminal = terminal || else_terminal; + skip_remaining = skip_remaining && else_skip; + } + + method! fold_goto' { payload; _ } acc = + skip @@ + match payload with + | GoToEntry _ -> acc (* TODO couldn't find doc *) + | GoToSimple { target } -> + { + acc with + jumps = Jumps.add (Go (full_qn' ~cu target)) acc.jumps; + will_fallthru = false; + skip_remaining = true; + } + | GoToDepending { targets; _ } -> + Cobol_common.Basics.NEL.( + targets + |> map ~f:(full_qn' ~cu) + |> fold_left ~f:begin fun acc target -> + Jumps.add (GoDepending target) acc + end acc.jumps) + |> begin fun jumps -> { acc with jumps } end + + method! fold_perform_target' { payload; _ } acc = + let start = full_qn' ~cu payload.perform_target.procedure_start in + skip { acc with jumps = Jumps.add (Perform start) acc.jumps } + + method! fold_call' { payload = { call_prefix; _ }; _ } acc = + skip { acc with jumps = Jumps.add (Call call_prefix) acc.jumps } + + method! fold_entry' { payload; _ } acc = + skip { acc with jumps = Jumps.add (Entry payload) acc.jumps } + end +end diff --git a/src/lsp/cobol_cfg/cfg_options.ml b/src/lsp/cobol_cfg/cfg_options.ml new file mode 100644 index 000000000..3413122b5 --- /dev/null +++ b/src/lsp/cobol_cfg/cfg_options.ml @@ -0,0 +1,26 @@ +(******************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(******************************************************************************) + +type transformation = + | Descendents of int + | Neighborhood of int + +type t = { + hide_unreachable: bool; + collapse_fallthru: bool; + in_degree_upper_limit: int option; + transformation: transformation option; + hidden_nodes: int list; (* id list *) + split_nodes: int list; (* id list *) +} +(* NOTE: the ids of hidden_nodes and split_nodes params come from the builder + before any option-related modification occurs, if the file is unchanged, + those id will always be synced with the correct underlying paragraph *) + diff --git a/src/lsp/cobol_cfg/cfg_types.ml b/src/lsp/cobol_cfg/cfg_types.ml new file mode 100644 index 000000000..3f7e69982 --- /dev/null +++ b/src/lsp/cobol_cfg/cfg_types.ml @@ -0,0 +1,50 @@ +(******************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(******************************************************************************) + +open Cobol_common.Srcloc.TYPES +open Cfg_jumps +module NEL = Cobol_common.Basics.NEL + +type node_type = + | External of string + | Entry of [`Point | `Paragraph | `Section of string | `Statement of string] + | Normal of string * string (* fullname * display_name *) + | Collapsed of string NEL.t + | Split of string + +type node = { + id: int; + section_name: string; + loc: srcloc option; + typ: node_type; + jumps: Jumps.t; + will_fallthru: bool; + terminal: bool; (* unused atm *) +} + +type edge = + | FallThrough + | Perform + | Go + +module Node = struct + type t = node + let compare node other = Int.compare node.id other.id + let hash node = Hashtbl.hash node.id + let equal node other = Int.equal node.id other.id +end + +module Edge = struct + type t = edge + let compare = Stdlib.compare + let default = FallThrough +end + +module Cfg = Graph.Persistent.Digraph.ConcreteLabeled(Node)(Edge) diff --git a/src/lsp/cobol_cfg/cobol_cfg.ml b/src/lsp/cobol_cfg/cobol_cfg.ml new file mode 100644 index 000000000..14d741ad9 --- /dev/null +++ b/src/lsp/cobol_cfg/cobol_cfg.ml @@ -0,0 +1,13 @@ +(******************************************************************************) +(* *) +(* Copyright (c) 2021-2024 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(******************************************************************************) + +module Types = Cfg_types +module Options = Cfg_options +module Builder = Cfg_builder diff --git a/src/lsp/cobol_cfg/dune b/src/lsp/cobol_cfg/dune new file mode 100644 index 000000000..1c748901d --- /dev/null +++ b/src/lsp/cobol_cfg/dune @@ -0,0 +1,26 @@ +; generated by drom from package skeleton 'library' + +(library + (name cobol_cfg) + (public_name cobol_cfg) + (wrapped true) + ; use field 'dune-libraries' to add libraries without opam deps + (libraries ocamlgraph cobol_typeck ) + ; use field 'dune-flags' to set this value + (flags (:standard)) + ; use field 'dune-stanzas' to add more stanzas here + (preprocess (pps ppx_deriving.show)) + + ) + + +(rule + (targets version.ml) + (deps (:script version.mlt) package.toml) + (action (with-stdout-to %{targets} (run %{ocaml} unix.cma %{script})))) + +(documentation + (package cobol_cfg)) + +; use field 'dune-trailer' to add more stuff here + diff --git a/src/lsp/cobol_cfg/index.mld b/src/lsp/cobol_cfg/index.mld new file mode 100644 index 000000000..f20f8b0a8 --- /dev/null +++ b/src/lsp/cobol_cfg/index.mld @@ -0,0 +1,9 @@ +{1 Library cobol_cfg} + +Superbol is a set of utilities for COBOL developers, +that can be selected by sub-commands. + +This package is gives control flow representation for COBOL programs. + +The entry point of this library is the module: {!Cobol_cfg}. + diff --git a/src/lsp/cobol_cfg/package.toml b/src/lsp/cobol_cfg/package.toml new file mode 100644 index 000000000..a5f2f8b8a --- /dev/null +++ b/src/lsp/cobol_cfg/package.toml @@ -0,0 +1,74 @@ + +# name of package +name = "cobol_cfg" +skeleton = "library" + +# version if different from project version +# version = "0.1.0" + +# synopsis if different from project synopsis +# synopsis = ... + +# description if different from project description +# description = ... + +# kind is either "library", "program" or "virtual" +kind = "library" + +# authors if different from project authors +# authors = [ "Me " ] + +# name of a file to generate with the current version +gen-version = "version.ml" + +# supported file generators are "ocamllex", "ocamlyacc" and "menhir" +# default is [ "ocamllex", "ocamlyacc" ] +# generators = [ "ocamllex", "menhir" ] + +# menhir options for the package +#Example: +#version = "2.0" +#parser = { modules = ["parser"]; tokens = "Tokens" } +#tokens = { modules = ["tokens"]} +# menhir = ... + +# whether all modules should be packed/wrapped (default is true) +# pack-modules = false + +# whether the package can be silently skipped if missing deps (default is false) +# optional = true + +# module name used to pack modules (if pack-modules is true) +# pack = "Mylib" + +# preprocessing options +# preprocess = "per-module (((action (run ./toto.sh %{input-file})) mod))" +preprocess = "pps ppx_deriving.show" + +# files to skip while updating at package level +skip = ["index.mld"] + +# package library dependencies +# [dependencies] +# ez_file = ">=0.1 <1.3" +# base-unix = { libname = "unix", version = ">=base" } +[dependencies] +cobol_typeck = "version" +ocamlgraph = "2.1.0" + +# package tools dependencies +[tools] + +# package fields (depends on package skeleton) +#Examples: +# dune-stanzas = "(preprocess (pps ppx_deriving_encoding))" +# dune-libraries = "bigstring" +# dune-trailer = "(install (..))" +# opam-trailer = "pin-depends: [..]" +# no-opam-test = "yes" +# no-opam-doc = "yes" +# gen-opam = "some" | "all" +# dune-stanzas = "(flags (:standard (:include linking.sexp)))" +# static-clibs = "unix" +[fields] +# ... diff --git a/src/lsp/cobol_cfg/version.mlt b/src/lsp/cobol_cfg/version.mlt new file mode 100644 index 000000000..53cdfe262 --- /dev/null +++ b/src/lsp/cobol_cfg/version.mlt @@ -0,0 +1,35 @@ +#!/usr/bin/env ocaml +;; +#load "unix.cma" + +let query cmd = + let chan = Unix.open_process_in cmd in + try + let out = input_line chan in + if Unix.close_process_in chan = Unix.WEXITED 0 then + Some out + else None + with End_of_file -> None + +let gitdir = + try Sys.getenv "DUNE_SOURCEROOT" with Not_found -> "" + +let commit_hash = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%H") +let commit_date = + query ("git -C \""^gitdir^"\" show -s --pretty=format:%ci") +let version = "0.1.4" + +let string_option = function + | None -> "None" + | Some s -> Printf.sprintf "Some %S" s + +let () = + Format.printf "@["; + Format.printf "let version = %S@," version; + Format.printf + "let commit_hash = %s@," (string_option commit_hash); + Format.printf + "let commit_date = %s@," (string_option commit_date); + Format.printf "@]@."; + () diff --git a/src/lsp/cobol_common/basics.ml b/src/lsp/cobol_common/basics.ml index 9e9923f83..df464a9ae 100644 --- a/src/lsp/cobol_common/basics.ml +++ b/src/lsp/cobol_common/basics.ml @@ -110,6 +110,18 @@ module NEL = struct | x :: tl -> aux (List.cons x acc) tl in aux [] l + let rev = function + | One x -> One x + | hd :: tl -> + let rec aux acc = function + | One x -> x :: acc + | x :: tl -> aux (x::acc) tl + in aux (One hd) tl + let ( @ ) a b = + let rec aux b = function + | One x -> x :: b + | x :: tl -> x :: aux b tl + in aux b a let rev_to_list l = let rec aux acc = function | One x -> List.cons x acc diff --git a/src/lsp/cobol_lsp/dune b/src/lsp/cobol_lsp/dune index 4ef95dd30..38a087235 100644 --- a/src/lsp/cobol_lsp/dune +++ b/src/lsp/cobol_lsp/dune @@ -5,7 +5,7 @@ (public_name cobol_lsp) (wrapped true) ; use field 'dune-libraries' to add libraries without opam deps - (libraries toml superbol_project superbol_preprocs pretty lsp jsonrpc cobol_typeck cobol_parser cobol_indent cobol_data cobol_config cobol_common ) + (libraries toml superbol_project superbol_preprocs pretty lsp jsonrpc cobol_typeck cobol_parser cobol_indent cobol_data cobol_config cobol_common cobol_cfg ) ; use field 'dune-flags' to set this value (flags (:standard)) ; use field 'dune-stanzas' to add more stanzas here diff --git a/src/lsp/cobol_lsp/lsp_cfg.ml b/src/lsp/cobol_lsp/lsp_cfg.ml new file mode 100644 index 000000000..7bbb595f7 --- /dev/null +++ b/src/lsp/cobol_lsp/lsp_cfg.ml @@ -0,0 +1,134 @@ +(* what licence here ? *) + +open Cobol_cfg.Types +open Cobol_cfg.Builder + +let create_cfg_options o = + let open Yojson.Safe.Util in + let hide_unreachable = + try + List.assoc "hide_unreachable" o |> to_bool + with Not_found -> false + in + let collapse_fallthru = + try + List.assoc "collapse_fallthru" o |> to_bool + with Not_found -> false + in + let in_degree_upper_limit = + List.assoc_opt "in_degree_upper_limit" o |> Option.map to_int in + let transformation = + let id = + List.assoc_opt "id" o |> Option.map to_int in + let action = List.assoc_opt "action" o |> Option.map to_string in + match action, id with + | Some "descendents", Some id -> + Some (Cobol_cfg.Options.Descendents id) + | Some "neighborhood", Some id -> + Some (Cobol_cfg.Options.Neighborhood id) + | _ -> None + in + let hidden_nodes = + try + List.assoc "hidden_nodes" o |> to_list |> (List.map to_int) + with Not_found -> [] + in + let split_nodes = + try + List.assoc "split_nodes" o |> to_list |> (List.map to_int) + with Not_found -> [] + in + ({ + hide_unreachable; + collapse_fallthru; + in_degree_upper_limit; + transformation; + hidden_nodes; + split_nodes; + }: Cobol_cfg.Options.t) + +let vertex_name_record names = + Pretty.to_string "%a" + (Cobol_common.Basics.NEL.pp ~fopen:"{" ~fclose:"}" ~fsep:"|" Fmt.string) + names + +module Dot = Graph.Graphviz.Dot(struct + include Cobol_cfg.Types.Cfg + let edge_attributes (_,s,_) = + [`Style (match s with + | FallThrough -> `Dotted + | Perform -> `Dashed + | Go -> `Solid)] + let default_edge_attributes _ = [] + let get_subgraph _ = None + let vertex_attributes { typ; _ } = + let label, attributes = + match typ with + | Entry (`Section name) -> name, [`Shape `Doubleoctagon] + | Entry (`Statement name) -> name, [`Shape `Doubleoctagon] + | Entry `Point -> "Entry\npoint", [`Shape `Doubleoctagon] + | Entry `Paragraph -> "Entry\nparagraph", [`Shape `Doubleoctagon] + | External name -> name, [`Shape `Plaintext] + | Split name -> name, [`Style `Dashed] + | Normal (_, name) -> name, [] + | Collapsed names -> vertex_name_record names, [`Shape `Record] + in `Label label :: attributes + let default_vertex_attributes _ = [`Shape `Box] + let graph_attributes _ = [] + let vertex_name { id; _ } = string_of_int id + end) + +let edge_to_string = function + | FallThrough -> "f" + | Perform -> "p" + | Go -> "g" + +let to_dot_string g = + Pretty.to_string "%a" Dot.fprint_graph g + +let to_d3_string cfg = + let cfg_edges = Cfg.fold_edges_e + begin fun (n1, e, n2) acc -> + Pretty.to_string "{\"source\":%d,\"target\":%d,\"type\":\"%s\"}" + n1.id n2.id (edge_to_string e) + ::acc + end cfg [] in + let cfg_nodes = Cfg.fold_vertex + begin fun n acc -> + let name = + match n.typ with + | Normal (_, name) + | Entry (`Statement name) | Entry (`Section name) + | External name | Split name -> name + | Collapsed _ -> + raise @@ Invalid_argument + "Impossible to provide d3 string with collapsed node" + | Entry `Point -> "Entry point" + | Entry `Paragraph -> "Entry paragraph" + in Pretty.to_string "{\"id\":%d,\"name\":\"%s\",\"section\":\"%s\"}" + n.id name n.section_name + :: acc + end cfg [] in + let str_nodes = String.concat "," cfg_nodes in + let str_edges = String.concat "," cfg_edges in + Pretty.to_string "{\"links\":[%s],\"nodes\":[%s]}" str_edges str_nodes + +let nodes_pos ~filename cfg = + let assoc = Cfg.fold_vertex begin fun n acc -> + match n.loc with + | None -> acc + | Some loc -> + let range = Lsp_position.range_of_srcloc_in ~filename loc in + (string_of_int n.id, Lsp.Types.Range.yojson_of_t range)::acc + end cfg [] + in `Assoc assoc + +let doc_to_cfg_jsoono ~filename ~name ~options checked_doc = + let options = create_cfg_options options in + let (cfg, cfg_with_options) = + make ~options ~name checked_doc in + `Assoc [ + ("string_repr_d3", `String (to_d3_string cfg)); + ("string_repr_dot", `String (to_dot_string cfg_with_options)); + ("nodes_pos", nodes_pos ~filename cfg); + ("name", `String name);] diff --git a/src/lsp/cobol_lsp/lsp_lookup.ml b/src/lsp/cobol_lsp/lsp_lookup.ml index 2fc7a2d0c..73b9e7d26 100644 --- a/src/lsp/cobol_lsp/lsp_lookup.ml +++ b/src/lsp/cobol_lsp/lsp_lookup.ml @@ -67,6 +67,12 @@ module TYPES = struct | NumericEdited | ObjectRef | Pointer + + type procedure_at_position = + { + cu: Cobol_unit.Types.cobol_unit option; + proc_name: Cobol_ptree.qualname option; + } end open TYPES @@ -499,3 +505,23 @@ let type_at_pos ~filename (pos: Lsp.Types.Position.t) group : approx_typing_info |> skip end group init |> result + +let proc_at_pos ~filename (pos: Lsp.Types.Position.t) group : procedure_at_position = + let open Cobol_common.Visitor in + Cobol_unit.Visitor.fold_unit_group object + inherit [_] Cobol_unit.Visitor.folder + inherit! [_] Lsp_position.sieve ~filename ~pos + + method! fold_cobol_unit cu acc = + do_children { acc with cu = Some cu } + + method! fold_procedure_paragraph { paragraph_name; _ } { cu; _ } = + let proc_name = match cu, paragraph_name with + | Some cu, Some qn -> + Some (Cobol_unit.Qualmap.find_binding + ~&qn cu.unit_procedure.named).full_qn + | _ -> None + in + skip { cu; proc_name } + + end group { cu = None; proc_name = None } diff --git a/src/lsp/cobol_lsp/lsp_request.ml b/src/lsp/cobol_lsp/lsp_request.ml index 05ff4c06b..ee2ff8296 100644 --- a/src/lsp/cobol_lsp/lsp_request.ml +++ b/src/lsp/cobol_lsp/lsp_request.ml @@ -133,6 +133,55 @@ let handle_get_project_config_command param registry = Lsp_error.invalid_params "param = %s (association list with \"uri\" key \ expected)" Yojson.Safe.(to_string (param :> t)) +let handle_get_cfg registry params = + let params = Jsonrpc.Structured.yojson_of_t params in + let uri, name, options = Yojson.Safe.Util.( + to_string @@ member "uri" params, + to_string @@ member "name" params, + try to_assoc @@ member "render_options" params with Type_error _ -> []) + in + let textDoc = TextDocumentIdentifier.create ~uri:(DocumentUri.of_path uri) in + try_with_main_document_data registry textDoc + ~f:begin fun ~doc:_ checked_doc -> + let jsoono = + Lsp_cfg.doc_to_cfg_jsoono ~filename:uri ~name ~options checked_doc + in Some jsoono + end |> + Option.get + +let handle_get_possible_cfg registry params = + let params = Jsonrpc.Structured.yojson_of_t params in + let uri = Yojson.Safe.Util.(to_string @@ member "uri" params) in + let textDoc = TextDocumentIdentifier.create ~uri:(DocumentUri.of_path uri) in + try_with_main_document_data registry textDoc + ~f:begin fun ~doc:_ checked_doc -> + let open Cobol_cfg.Builder in + let possibles = possible_cfgs_of_doc checked_doc in + let yojsonify cfg_name = `String cfg_name in + Some (`List (List.map yojsonify possibles)) + end |> + Option.get + + +let handle_find_procedure registry params = + let params = Jsonrpc.Structured.yojson_of_t params in + let filename = Yojson.Safe.Util.to_string @@ Yojson.Safe.Util.member "uri" params in + let line = Yojson.Safe.Util.to_int @@ Yojson.Safe.Util.member "line" params in + let character = Yojson.Safe.Util.to_int @@ Yojson.Safe.Util.member "character" params in + let textDoc = TextDocumentIdentifier.create ~uri:(DocumentUri.of_path filename) in + try_with_main_document_data registry textDoc + ~f:begin fun ~doc:_ checked_doc -> + let pos = Position.create ~character ~line in + let { cu; proc_name } = + Lsp_lookup.proc_at_pos ~filename pos checked_doc.group in + let proc = match proc_name, cu with + | Some qn, _ -> Pretty.to_string "%a" Cobol_ptree.pp_qualname qn + |> Str.global_replace (Str.regexp "\n") " " + | _ -> raise Not_found in + Some (`String proc) + end |> + Option.get + (** {3 Definitions} *) @@ -825,6 +874,15 @@ let on_request | UnknownRequest { meth = "superbol/getProjectConfiguration"; params = Some param } -> handle_get_project_config_command param registry + | UnknownRequest { meth = "superbol/getCFG"; + params = Some param } -> + Ok (handle_get_cfg registry param, state) + | UnknownRequest { meth = "superbol/getPossibleCFG"; + params = Some param } -> + Ok (handle_get_possible_cfg registry param, state) + | UnknownRequest { meth = "superbol/findProcedure"; + params = Some param } -> + Ok (handle_find_procedure registry param, state) | UnknownRequest { meth; _ } -> Lsp_debug.message "Lsp_request: unknown request (%s)" meth; Error (UnknownRequest meth) diff --git a/src/lsp/cobol_lsp/package.toml b/src/lsp/cobol_lsp/package.toml index 7d8e9de48..da762715e 100644 --- a/src/lsp/cobol_lsp/package.toml +++ b/src/lsp/cobol_lsp/package.toml @@ -53,6 +53,7 @@ skip = ["index.mld"] # ez_file = ">=0.1 <1.3" # base-unix = { libname = "unix", version = ">=base" } [dependencies] +cobol_cfg = "version" cobol_common = "version" cobol_config = "version" cobol_data = "version" diff --git a/src/lsp/superbol_free_lib/vscode_extension.ml b/src/lsp/superbol_free_lib/vscode_extension.ml index 7fc8e6217..a1b1bd5fa 100644 --- a/src/lsp/superbol_free_lib/vscode_extension.ml +++ b/src/lsp/superbol_free_lib/vscode_extension.ml @@ -583,6 +583,14 @@ let contributes = ~command:"superbol.coverage.reload" ~title:"Update Coverage" ~category:"SuperBOL"; + Manifest.command () + ~command:"superbol.cfg.open" + ~title:"Show control-flow" + ~category:"SuperBOL"; + Manifest.command () + ~command:"superbol.cfg.open.arc" + ~title:"Show control-flow as an arc-diagram" + ~category:"SuperBOL"; ] ~tomlValidation: [ Manifest.tomlValidation @@ -590,6 +598,13 @@ let contributes = (* TODO: change this address to a more permanent one; also, substitute `master` for a version tag *) ~url:"https://raw.githubusercontent.com/OCamlPro/superbol-studio-oss/master/schemas/superbol-schema-0.1.4.json"; ] + ~menus: [ + "editor/context", + [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 = Manifest.vscode diff --git a/src/vendor/vscode-ocaml-platform/src-bindings/vscode/vscode.ml b/src/vendor/vscode-ocaml-platform/src-bindings/vscode/vscode.ml index d619d19c7..d6ab969e6 100644 --- a/src/vendor/vscode-ocaml-platform/src-bindings/vscode/vscode.ml +++ b/src/vendor/vscode-ocaml-platform/src-bindings/vscode/vscode.ml @@ -759,6 +759,24 @@ module TextEditor = struct insertSnippet this ~snippet ?location options end +module TextEditorSelectionChangeKind = struct + type t = + | Keyboard [@js 1] + | Mouse [@js 2] + | Command [@js 3] + [@@js.enum] [@@js] +end + +module TextEditorSelectionChangeEvent = struct + include Class.Make () + + include + [%js: + val kind: t -> TextEditorSelectionChangeKind.t [@@js.get] + val selections: t -> Selection.t list [@@js.get] + val textEditor: t -> TextEditor.t [@@js.get]] +end + module ConfigurationTarget = struct type t = | Global [@js 1] @@ -2984,6 +3002,7 @@ end module Window = struct module OnDidChangeActiveTextEditor = Event.Make (TextEditor) module OnDidChangeVisibleTextEditors = Event.Make (Js.List (TextEditor)) + module OnDidChangeTextEditorSelection = Event.Make (TextEditorSelectionChangeEvent) module OnDidChangeActiveTerminal = Event.Make (Js.Or_undefined (Terminal)) module OnDidOpenTerminal = Event.Make (Terminal) module OnDidCloseTerminal = Event.Make (Terminal) @@ -3002,6 +3021,9 @@ module Window = struct val onDidChangeVisibleTextEditors : unit -> OnDidChangeVisibleTextEditors.t [@@js.get "vscode.window.onDidChangeVisibleTextEditors"] + val onDidChangeTextEditorSelection : unit -> OnDidChangeTextEditorSelection.t + [@@js.get "vscode.window.onDidChangeTextEditorSelection"] + val terminals : unit -> Terminal.t list [@@js.get "vscode.window.terminals"] val activeTerminal : unit -> Terminal.t or_undefined @@ -3092,6 +3114,11 @@ module Window = struct -> StatusBarItem.t [@@js.global "vscode.window.createStatusBarItem"] + val createTextEditorDecorationType : + options:Ojs.t + -> TextEditorDecorationType.t + [@@js.global "vscode.window.createTextEditorDecorationType"] + val createTerminal : ?name:string -> ?shellPath:string diff --git a/src/vendor/vscode-ocaml-platform/src-bindings/vscode/vscode.mli b/src/vendor/vscode-ocaml-platform/src-bindings/vscode/vscode.mli index 27d69e81f..da4f1b93a 100644 --- a/src/vendor/vscode-ocaml-platform/src-bindings/vscode/vscode.mli +++ b/src/vendor/vscode-ocaml-platform/src-bindings/vscode/vscode.mli @@ -605,6 +605,23 @@ module TextEditor : sig t -> range:Range.t -> ?revealType:TextEditorRevealType.t -> unit -> unit end +module TextEditorSelectionChangeKind : sig + type t = + | Keyboard + | Mouse + | Command + + include Js.T with type t := t +end + +module TextEditorSelectionChangeEvent : sig + include Js.T + + val kind: t -> TextEditorSelectionChangeKind.t + val selections: t -> Selection.t list + val textEditor: t -> TextEditor.t +end + module ConfigurationTarget : sig type t = | Global @@ -2298,6 +2315,8 @@ module Window : sig val onDidChangeActiveTextEditor : unit -> TextEditor.t Event.t + val onDidChangeTextEditorSelection : unit -> TextEditorSelectionChangeEvent.t Event.t + val onDidChangeVisibleTextEditors : unit -> TextEditor.t list Event.t val terminals : unit -> Terminal.t List.t @@ -2372,6 +2391,9 @@ module Window : sig val createStatusBarItem : ?alignment:StatusBarAlignment.t -> ?priority:int -> unit -> StatusBarItem.t + val createTextEditorDecorationType : + options:Ojs.t -> TextEditorDecorationType.t + val createTerminal : ?name:string -> ?shellPath:string diff --git a/src/vscode/superbol-vscode-platform/package.toml b/src/vscode/superbol-vscode-platform/package.toml index 4268858ab..6acb4a872 100644 --- a/src/vscode/superbol-vscode-platform/package.toml +++ b/src/vscode/superbol-vscode-platform/package.toml @@ -21,8 +21,8 @@ kind = "program" # name of a file to generate with the current version gen-version = "version.ml" -# supported file generators are "ocamllex", "ocamlyacc" and "menhir" -# default is [ "ocamllex", "ocamlyacc" ] +# supported file generators are "ocamllex", "ocamlyacc" and "menhir" +# default is [ "ocamllex", "ocamlyacc" ] # generators = [ "ocamllex", "menhir" ] # menhir options for the package @@ -42,7 +42,7 @@ gen-version = "version.ml" # pack = "Mylib" # preprocessing options -# preprocess = "per-module (((action (run ./toto.sh %{input-file})) mod))" +# preprocess = "per-module (((action (run ./toto.sh %{input-file})) mod))" preprocess = "pps gen_js_api.ppx" # files to skip while updating at package level @@ -51,7 +51,7 @@ skip = [] # package library dependencies # [dependencies] # ez_file = ">=0.1 <1.3" -# base-unix = { libname = "unix", version = ">=base" } +# base-unix = { libname = "unix", version = ">=base" } [dependencies] gen_js_api = "1.1.1" js_of_ocaml = ">=4" @@ -69,15 +69,15 @@ js_of_ocaml-ppx = ">=4" # package fields (depends on package skeleton) #Examples: -# dune-stanzas = "(preprocess (pps ppx_deriving_encoding))" -# dune-libraries = "bigstring" -# dune-trailer = "(install (..))" -# opam-trailer = "pin-depends: [..]" -# no-opam-test = "yes" -# no-opam-doc = "yes" -# gen-opam = "some" | "all" -# dune-stanzas = "(flags (:standard (:include linking.sexp)))" -# static-clibs = "unix" +# dune-stanzas = "(preprocess (pps ppx_deriving_encoding))" +# dune-libraries = "bigstring" +# dune-trailer = "(install (..))" +# opam-trailer = "pin-depends: [..]" +# no-opam-test = "yes" +# no-opam-doc = "yes" +# gen-opam = "some" | "all" +# dune-stanzas = "(flags (:standard (:include linking.sexp)))" +# static-clibs = "unix" [fields] dune-stanzas = """ (js_of_ocaml (flags --source-map --pretty)) diff --git a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml new file mode 100644 index 000000000..c81ca4011 --- /dev/null +++ b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml @@ -0,0 +1,402 @@ +(**************************************************************************) +(* *) +(* SuperBOL OSS Studio *) +(* *) +(* *) +(* Copyright (c) 2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This source code is licensed under the MIT license found in the *) +(* LICENSE.md file in the root directory of this source tree. *) +(* *) +(* *) +(**************************************************************************) + +module VS = Vscode + +type cfg_type = Graphviz | D3_arc_diagram + +let read_whole_file filename = + (* open_in_bin works correctly on Unix and Windows *) + let ch = open_in_bin filename + in Fun.protect + begin fun () -> really_input_string ch (in_channel_length ch) end + ~finally:begin fun () -> close_in ch end + +let graphviz_html = ref None +let d3_arc_html = ref None +let get_html_js_content ~extension_uri typ = + match typ, !graphviz_html, !d3_arc_html with + | D3_arc_diagram, _, Some value + | Graphviz, Some value, _ -> Ok(`CompleteHtml value) + | _ -> + let html_uri = VS.Uri.joinPath extension_uri + ~pathSegments: + ["assets"; match typ with + | Graphviz -> "cfg-dot-renderer.html" + | D3_arc_diagram -> "cfg-arc-renderer.html"] + in + try + let html = read_whole_file @@ VS.Uri.fsPath html_uri in + let file_name = match typ with + | Graphviz -> "cfg-dot" + | D3_arc_diagram -> "cfg-arc" + in + let localResource = + VS.Uri.joinPath extension_uri ~pathSegments:["assets"; file_name ^ ".js"] + in + let localResource2 = + VS.Uri.joinPath extension_uri ~pathSegments:["assets"; file_name ^ ".css"] + in Ok( `IncompleteHtml (html, localResource, localResource2)) + with Sys_error e -> Error(e) + | End_of_file -> Error("End_of_file") + +let setup_html_js_content ~webview ~typ html_js = + match html_js with + | `CompleteHtml html -> html + | `IncompleteHtml (html, js_path, css_path) -> + let html_content = + let js_path = VS.Uri.toString + (VS.WebView.asWebviewUri webview ~localResource:js_path) () + in + let css_path = VS.Uri.toString + (VS.WebView.asWebviewUri webview ~localResource:css_path) () + in Printf.sprintf "%s\ + " + html js_path css_path + in + begin match typ with + | Graphviz -> graphviz_html := Some (html_content) + | D3_arc_diagram -> d3_arc_html := Some (html_content) end; + html_content + + +let _log message = ignore(VS.Window.showInformationMessage () ~message) + +(* DECORATION TYPE *) +(* TODO: we might want to do this via CSS tags to enable user customization *) +let decorationType = + let backgroundColor = Ojs.string_to_js "#75ff3388" in + let options = Ojs.obj [|("backgroundColor", backgroundColor)|] in + VS.Window.createTextEditorDecorationType ~options + +(* PERSISTENT OPTION MANAGEMENT *) + +let state = ref None + +let update_state ~key value = + match !state with + | None -> () + | Some state -> + let _ : Promise.void = VS.Memento.update state ~key ~value + in () + +let get_state_value ~key = + match !state with + | None -> None + | Some state -> VS.Memento.get ~key state + +(* GRAPH FROM LSP *) + +type graph = { + string_repr_dot: string; + string_repr_d3: string; + nodes_pos: (string * Jsonoo.t) list; + name: string; +} + +let decode_graph res = + let string_repr_dot = + Jsonoo.Decode.field "string_repr_dot" Jsonoo.Decode.string res + in + let string_repr_d3 = + Jsonoo.Decode.field "string_repr_d3" Jsonoo.Decode.string res + in + let nodes_pos = Jsonoo.Decode.field "nodes_pos" Jsonoo.Decode.(dict id) res + in + let nodes_pos = Hashtbl.to_seq nodes_pos |> List.of_seq in + let name = Jsonoo.Decode.field "name" Jsonoo.Decode.string res in + { name; nodes_pos; string_repr_dot; string_repr_d3 } + +let callGetCFG ?render_options ~uri ~name client = + let path = VS.Uri.path uri in + let data = + let base = ["uri", Jsonoo.Encode.string path; + "name", Jsonoo.Encode.string name] + in + let full = + match render_options, + get_state_value ~key:(path ^ ":" ^ name) with + | Some options, _ -> ("render_options", options) :: base + | _, Some options -> ("render_options", Jsonoo.t_of_js options) :: base + | _ -> base + in Jsonoo.Encode.object_ full + in + Vscode_languageclient.LanguageClient.sendRequest client () + ~meth:"superbol/getCFG" ~data |> + Promise.then_ + ~rejected:begin fun _ -> + VS.Window.showErrorMessage + ~message:"Impossible to render graph, \ + try closing and reopening the webview" () + end + ~fulfilled:begin fun jsonoo -> + Promise.return (Some (decode_graph jsonoo)) + end + +(* WEBVIEW MANAGEMENT *) + +type stored_data = { + webview_panel: VS.WebviewPanel.t; + graph: graph; + render_options: Jsonoo.t; +} + +let webview_panels = Hashtbl.create 1 +let window_listener = ref None + +let webviewpanel_disposal ~filename ~typ () = + Hashtbl.remove webview_panels (filename, typ); + if Hashtbl.length webview_panels == 0 + then begin + (match !window_listener with + | Some listener -> VS.Disposable.dispose listener + | None -> ()); + window_listener := None; + end; + match VS.Window.activeTextEditor () with + | None -> () + | Some text_editor -> + let uri = VS.TextEditor.document text_editor |> VS.TextDocument.uri in + if String.equal filename @@ VS.Uri.path uri + then VS.TextEditor.setDecorations text_editor + ~decorationType ~rangesOrOptions:(`Ranges []) + +let create_or_get_webview ~graph ~uri ~typ = + let render_options = Jsonoo.Encode.object_ [] in + let filename = VS.Uri.path uri in + match Hashtbl.find_opt webview_panels (filename, typ) with + | Some { webview_panel; render_options; _ } -> + VS.WebviewPanel.reveal webview_panel (); + Hashtbl.replace webview_panels (filename, typ) + { webview_panel; graph; render_options }; + VS.WebviewPanel.webview webview_panel, false + | None -> + let viewType = match typ with + | Graphviz -> "superbol.cfg.dot" + | D3_arc_diagram -> "superbol.cfg.arc" + in + let webview_panel = VS.Window.createWebviewPanel ~viewType + ~title:"SuperBOL CFG Viewer" ~showOptions:(VS.ViewColumn.Beside) + in + let _ : VS.Disposable.t = + VS.WebviewPanel.onDidDispose webview_panel () + ~listener:(webviewpanel_disposal ~filename ~typ) + ~thisArgs:Ojs.null ~disposables:[] + in + let webview = VS.WebviewPanel.webview webview_panel in + VS.WebView.set_options webview (VS.WebviewOptions.create ~enableScripts:true ()); + Hashtbl.add webview_panels (filename, typ) + { webview_panel; graph; render_options }; + webview, true + +let webview_data_find_opt ~uri ~typ = + match Hashtbl.find_opt webview_panels (VS.Uri.path uri, typ) with + | None -> + None + | Some { webview_panel; graph; render_options } -> + Some (VS.WebviewPanel.webview webview_panel, graph, render_options) + +let update_webview_data ~uri ~typ ?graph ?render_options () = + let filename = VS.Uri.path uri in + match Hashtbl.find_opt webview_panels (filename, typ) with + | Some { webview_panel; render_options=current_ro; graph=current_g } -> + let render_options = Option.value ~default:current_ro render_options in + let graph = Option.value ~default:current_g graph in + Hashtbl.replace webview_panels (filename, typ) + { webview_panel; graph; render_options } + | None -> () + +(* CLICK ON NODE *) + +let on_click ~nodes_pos ~text_editor arg = + let uri = VS.TextDocument.uri @@ VS.TextEditor.document text_editor in + let column = VS.TextEditor.viewColumn text_editor in + let node = Ojs.get_prop_ascii arg "node" |> Ojs.int_of_js |> string_of_int in + try + let jsonoo_range = List.assoc node nodes_pos in + let range = VS.Range.t_of_js @@ Jsonoo.t_to_js jsonoo_range in + let _ : unit Promise.t = + VS.Window.showTextDocument ~document:(`Uri uri) ?column () |> + Promise.then_ ~fulfilled:(fun text_editor -> + let selection = VS.Selection.makePositions + ~anchor:(VS.Range.start range) ~active:(VS.Range.start range) + in + VS.TextEditor.revealRange text_editor ~range + ~revealType:VS.TextEditorRevealType.InCenterIfOutsideViewport (); + VS.TextEditor.set_selection text_editor selection; + VS.TextEditor.setDecorations text_editor ~decorationType + ~rangesOrOptions:(`Ranges [range]); + Promise.return ()) + in () + with Not_found -> () + +let setup_window_listener ~client = + let listener event = + if VS.TextEditorSelectionChangeEvent.kind event == + VS.TextEditorSelectionChangeKind.Command + then () + else + match VS.TextEditorSelectionChangeEvent.selections event with + | [] -> () + | selection::_ -> + let text_editor = VS.TextEditorSelectionChangeEvent.textEditor event in + VS.TextEditor.setDecorations text_editor ~decorationType + ~rangesOrOptions:(`Ranges []); + let uri = VS.TextEditor.document text_editor |> VS.TextDocument.uri in + let process_selection_change webview = + let pos_start = VS.Selection.start selection in + let data = + let uri = Jsonoo.Encode.string @@ VS.Uri.path uri in + Jsonoo.Encode.object_ + ["uri", uri; + "line", Jsonoo.Encode.int @@ VS.Position.line pos_start; + "character", Jsonoo.Encode.int @@ VS.Position.character pos_start] + in + let _ : bool Promise.t = + Vscode_languageclient.LanguageClient.sendRequest client () + ~meth:"superbol/findProcedure" ~data |> + Promise.then_ + ~rejected:begin fun _ -> Promise.return false end + ~fulfilled:begin fun res -> + let ojs = Ojs.empty_obj () in + Ojs.set_prop_ascii ojs "type" (Ojs.string_to_js "focused_proc"); + Ojs.set_prop_ascii ojs "procedure" @@ Jsonoo.t_to_js res; + VS.WebView.postMessage webview ojs + end + in () + in + let webview = webview_data_find_opt ~uri ~typ:Graphviz in + begin match webview with + | None -> () + | Some (webview, _, _) -> process_selection_change webview end; + let webview = webview_data_find_opt ~uri ~typ:D3_arc_diagram in + match webview with + | None -> () + | Some (webview, _, _) -> process_selection_change webview + in + let disposable_listener = + match !window_listener with + | Some listener -> + listener + | None -> VS.Window.onDidChangeTextEditorSelection () () + ~listener ~thisArgs:Ojs.null ~disposables:[] + in window_listener := Some disposable_listener + +(* MESSAGE MANAGER *) + +let send_graph ?(as_new_graph=false) ~uri ~typ webview graph = + let message_type = if as_new_graph + then "new_graph_content" + else "graph_content" + in + let ojs = Ojs.empty_obj () in + (match get_state_value ~key:(VS.Uri.path uri ^ ":" ^ graph.name) with + | None -> () + | Some options -> Ojs.set_prop_ascii ojs "render_options" options); + Ojs.set_prop_ascii ojs "type" (Ojs.string_to_js message_type); + if typ == Graphviz + then Ojs.set_prop_ascii ojs "dot" (Ojs.string_to_js graph.string_repr_dot); + Ojs.set_prop_ascii ojs "graph" (Ojs.string_to_js graph.string_repr_d3); + Ojs.set_prop_ascii ojs "graph_name" (Ojs.string_to_js graph.name); + let _ : bool Promise.t = VS.WebView.postMessage webview ojs + in () + +let on_graph_update ~webview ~client ~uri ~typ name arg = + let render_options_ojs = Ojs.get_prop_ascii arg "renderOptions" in + let render_options = Jsonoo.t_of_js render_options_ojs in + let path = VS.Uri.path uri in + let _ : unit Promise.t = Promise.then_ + (callGetCFG ~uri ~name ~render_options client) + ~fulfilled:begin function + | None -> + Promise.return () + | Some graph -> + update_webview_data ~uri ~typ ~graph ~render_options (); + update_state ~key:(path ^ ":" ^ name) render_options_ojs; + send_graph ~typ ~uri webview graph; + Promise.return () + end + in () + +let on_message ~client ~text_editor ~typ arg = + let uri = VS.TextEditor.document text_editor |> VS.TextDocument.uri in + let request_type = Ojs.get_prop_ascii arg "type" |> Ojs.string_of_js in + match webview_data_find_opt ~uri ~typ with + | None -> + () + | Some (webview, graph, _) -> + match request_type with + | "click" -> + on_click ~nodes_pos:graph.nodes_pos ~text_editor arg + | "graph_update" -> + on_graph_update ~client ~webview ~uri ~typ graph.name arg + | "ready" -> + send_graph ~as_new_graph:true ~typ ~uri webview graph + | _ -> () + +(* USER REQUEST LOGIC *) + +let open_cfg_for ~typ ~text_editor ~extension_uri client = + let open Promise in + let uri = VS.TextEditor.document text_editor |> VS.TextDocument.uri in + let data = + let uri = Jsonoo.Encode.string @@ VS.Uri.path uri in + Jsonoo.Encode.object_ ["uri", uri] + in + match get_html_js_content ~extension_uri typ with + | Error e -> + let _ : _ option Promise.t = VS.Window.showErrorMessage + ~message:("Unable to display control-flow: " ^ e) () + in return () + | Ok html_js -> + Vscode_languageclient.LanguageClient.sendRequest client () + ~meth:"superbol/getPossibleCFG" ~data |> + then_ ~fulfilled:begin fun jsonoo_graph_names -> + let items = Jsonoo.Decode.(list string) jsonoo_graph_names in + VS.Window.showQuickPick ~items () |> + then_ ~fulfilled:begin function + | None -> return () + | Some name -> + then_ (callGetCFG ~uri ~name client) ~fulfilled:begin function + | None -> return () + | Some graph -> + let webview, is_new = create_or_get_webview ~graph ~typ ~uri in + let html_content = setup_html_js_content ~webview ~typ html_js in + let _ : VS.Disposable.t = + VS.WebView.onDidReceiveMessage webview () + ~listener:(on_message ~client ~text_editor ~typ) + ~thisArgs:Ojs.null ~disposables:[] + in + if is_new + then VS.WebView.set_html webview html_content + else send_graph ~as_new_graph:true ~typ ~uri webview graph; + setup_window_listener ~client; + return () + end + end + end + +let open_cfg ?text_editor ~typ instance = + let text_editor = match text_editor with + | None -> VS.Window.activeTextEditor () + | e -> e + in + match Superbol_instance.client instance, text_editor with + | Some client, Some text_editor -> + let extension_uri = VS.ExtensionContext.extensionUri + @@ Superbol_instance.context instance + in state := Some (VS.ExtensionContext.workspaceState + @@ Superbol_instance.context instance); + open_cfg_for ~typ ~extension_uri ~text_editor client + | _ -> Promise.return () diff --git a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.mli b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.mli new file mode 100644 index 000000000..cbf0eef51 --- /dev/null +++ b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.mli @@ -0,0 +1,30 @@ +(**************************************************************************) +(* *) +(* SuperBOL OSS Studio *) +(* *) +(* *) +(* Copyright (c) 2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This source code is licensed under the MIT license found in the *) +(* LICENSE.md file in the root directory of this source tree. *) +(* *) +(* *) +(**************************************************************************) + +type cfg_type = Graphviz | D3_arc_diagram + +(* + [open_cfg ~text_editor typ instance] will load a CFG of type [typ] after the user + has selected the CFG scope (which program or which section of the program). + The different scopes are listed based on the code of [text_editor], or + the active text editor if no editor is given. + The CFG are computed via the LSP [instance] given. + Calling [open_cfg] twice with the same arguments will simply reload the CFG + and refocus the existing webview. + *) +val open_cfg + : ?text_editor: Vscode.TextEditor.t + -> typ:cfg_type + -> 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 fa3576378..6dfd4d5ad 100644 --- a/src/vscode/superbol-vscode-platform/superbol_commands.ml +++ b/src/vscode/superbol-vscode-platform/superbol_commands.ml @@ -37,6 +37,22 @@ let command id handler = commands := command :: !commands; command +let _open_cfg = + command "superbol.cfg.open" @@ Instance + begin fun _instance ~args:_ -> + let _ : unit Promise.t = Superbol_cfg_explorer.open_cfg + ~typ:Graphviz _instance in + () + end + +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_arc_diagram _instance in + () + end + let _editor_action_findReferences = let command_name = "superbol.editor.action.findReferences" in command command_name @@ Instance diff --git a/src/vscode/superbol-vscode-platform/superbol_instance.ml b/src/vscode/superbol-vscode-platform/superbol_instance.ml index 9bac74ab3..2c1559564 100644 --- a/src/vscode/superbol-vscode-platform/superbol_instance.ml +++ b/src/vscode/superbol-vscode-platform/superbol_instance.ml @@ -28,6 +28,9 @@ let name = "SuperBOL Language Server" let make ~context = { context; language_client = None } let client { language_client; _ } = language_client + +let context { context; _ } = context + let subscribe_disposable { context; _ } disposable = Vscode.ExtensionContext.subscribe context ~disposable diff --git a/src/vscode/superbol-vscode-platform/superbol_instance.mli b/src/vscode/superbol-vscode-platform/superbol_instance.mli index 062303865..52f89f64f 100644 --- a/src/vscode/superbol-vscode-platform/superbol_instance.mli +++ b/src/vscode/superbol-vscode-platform/superbol_instance.mli @@ -18,6 +18,9 @@ type client = Vscode_languageclient.LanguageClient.t val make: context:Vscode.ExtensionContext.t -> t val subscribe_disposable: t -> Vscode.Disposable.t -> unit +val client: t -> client option +val context: t -> Vscode.ExtensionContext.t + val stop_language_server: t -> unit Promise.t val start_language_server: t -> unit Promise.t