From c14456ff0188a31db796ef61c0d61a49587b37c9 Mon Sep 17 00:00:00 2001 From: Mateo Date: Wed, 14 Aug 2024 09:58:29 +0200 Subject: [PATCH 01/40] feat: added cobol_cfg package --- .drom | 24 +++++++-- .github/workflows/workflow.yml | 2 +- Makefile | 2 +- drom.toml | 3 ++ dune-project | 22 ++++++++ opam/cobol_cfg.opam | 64 ++++++++++++++++++++++ opam/osx/cobol_cfg-osx.opam | 66 +++++++++++++++++++++++ opam/windows/cobol_cfg-windows.opam | 66 +++++++++++++++++++++++ src/lsp/cobol_cfg/README.md | 5 ++ src/lsp/cobol_cfg/cobol_cfg.ml | 17 ++++++ src/lsp/cobol_cfg/dune | 26 +++++++++ src/lsp/cobol_cfg/index.mld | 9 ++++ src/lsp/cobol_cfg/package.toml | 84 +++++++++++++++++++++++++++++ src/lsp/cobol_cfg/version.mlt | 35 ++++++++++++ 14 files changed, 419 insertions(+), 6 deletions(-) create mode 100644 opam/cobol_cfg.opam create mode 100644 opam/osx/cobol_cfg-osx.opam create mode 100644 opam/windows/cobol_cfg-windows.opam create mode 100644 src/lsp/cobol_cfg/README.md create mode 100644 src/lsp/cobol_cfg/cobol_cfg.ml create mode 100644 src/lsp/cobol_cfg/dune create mode 100644 src/lsp/cobol_cfg/index.mld create mode 100644 src/lsp/cobol_cfg/package.toml create mode 100644 src/lsp/cobol_cfg/version.mlt diff --git a/.drom b/.drom index 54e0b4697..e2bef4a43 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:. +2ba85fda382f3e9534366a30e92a3d99:. # 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,15 @@ c8281f46ba9a11d0b61bc8ef67eaa357:docs/style.css # begin context for dune-project # file dune-project bbe93981f3f89550246d41f768f73a28:dune-project +c375da381bfae0c77c7af1cb51f96580:dune-project +cde29409c1d991e499786d56924f8fc9:dune-project # end context for dune-project +# begin context for opam/cobol_cfg.opam +# file opam/cobol_cfg.opam +a7d72990bb64c714f9edad8a708695a1: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 @@ -284,6 +290,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 +4c4e485ad53793d3adbea7e96daab3bc: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 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/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/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..84b058f6a 100644 --- a/dune-project +++ b/dune-project @@ -493,4 +493,26 @@ ) ) +(package + (name cobol_cfg) + (synopsis "SuperBOL Studio OSS Project") + (description "SuperBOL Studio OSS is a new platform for COBOL") + (depends + (ocaml (>= 4.14.0)) + (toml (and (>= 7.1.0) (< 8.0.0))) + (superbol_project (= version)) + (superbol_preprocs (= version)) + (pretty (= version)) + (lsp (and ( >= 1.18 )( < 1.19 ))) + (jsonrpc ( >= 1.15 )) + (cobol_typeck (= version)) + (cobol_parser (= version)) + (cobol_indent (= version)) + (cobol_data (= version)) + (cobol_config (= version)) + (cobol_common (= version)) + odoc + ) + ) + diff --git a/opam/cobol_cfg.opam b/opam/cobol_cfg.opam new file mode 100644 index 000000000..a8c3372b2 --- /dev/null +++ b/opam/cobol_cfg.opam @@ -0,0 +1,64 @@ +# 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"} + "toml" {>= "7.1.0" & < "8.0.0"} + "superbol_project" {= version} + "superbol_preprocs" {= version} + "pretty" {= version} + "lsp" {>= "1.18" & < "1.19"} + "jsonrpc" {>= "1.15"} + "cobol_typeck" {= version} + "cobol_parser" {= version} + "cobol_indent" {= version} + "cobol_data" {= version} + "cobol_config" {= version} + "cobol_common" {= 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..ba65a8687 --- /dev/null +++ b/opam/osx/cobol_cfg-osx.opam @@ -0,0 +1,66 @@ +# 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"} + "toml-osx" {>= "7.1.0" & < "8.0.0"} + "superbol_project-osx" {= version} + "superbol_preprocs-osx" {= version} + "pretty-osx" {= version} + "lsp-osx" {>= "1.18" & < "1.19"} + "jsonrpc-osx" {>= "1.15"} + "cobol_typeck-osx" {= version} + "cobol_parser-osx" {= version} + "cobol_indent-osx" {= version} + "cobol_data-osx" {= version} + "cobol_config-osx" {= version} + "cobol_common-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..c1d4abb11 --- /dev/null +++ b/opam/windows/cobol_cfg-windows.opam @@ -0,0 +1,66 @@ +# 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"} + "toml-windows" {>= "7.1.0" & < "8.0.0"} + "superbol_project-windows" {= version} + "superbol_preprocs-windows" {= version} + "pretty-windows" {= version} + "lsp-windows" {>= "1.18" & < "1.19"} + "jsonrpc-windows" {>= "1.15"} + "cobol_typeck-windows" {= version} + "cobol_parser-windows" {= version} + "cobol_indent-windows" {= version} + "cobol_data-windows" {= version} + "cobol_config-windows" {= version} + "cobol_common-windows" {= version} + "odoc" {with-doc} +] +# Content of `opam-trailer` field: \ No newline at end of file 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/cobol_cfg.ml b/src/lsp/cobol_cfg/cobol_cfg.ml new file mode 100644 index 000000000..1e511fcd5 --- /dev/null +++ b/src/lsp/cobol_cfg/cobol_cfg.ml @@ -0,0 +1,17 @@ +(**************************************************************************) +(* *) +(* SuperBOL OSS Studio *) +(* *) +(* Copyright (c) 2022-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This source code is licensed under the GNU Affero General Public *) +(* License version 3 found in the LICENSE.md file in the root directory *) +(* of this source tree. *) +(* *) +(**************************************************************************) + +module INTERNAL = struct + module Types = struct + end +end diff --git a/src/lsp/cobol_cfg/dune b/src/lsp/cobol_cfg/dune new file mode 100644 index 000000000..9c629a244 --- /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 toml superbol_project superbol_preprocs pretty lsp jsonrpc cobol_typeck cobol_parser cobol_indent cobol_data cobol_config cobol_common ) + ; 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..c67cc1bd9 --- /dev/null +++ b/src/lsp/cobol_cfg/package.toml @@ -0,0 +1,84 @@ + +# 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_common = "version" +cobol_config = "version" +cobol_data = "version" +cobol_indent = "version" +cobol_parser = "version" +cobol_typeck = "version" +superbol_preprocs = "version" +superbol_project = "version" +jsonrpc = ">=1.15" +lsp = ">=1.18 <1.19" +pretty = "version" +toml = "7.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 "@]@."; + () From 3beba632c47e2e521a50af4d92de4d6d39522dfe Mon Sep 17 00:00:00 2001 From: Mateo Date: Wed, 14 Aug 2024 13:24:38 +0200 Subject: [PATCH 02/40] feat: add an Open CFG entry to context menu --- .drom | 11 +++--- dune-project | 2 ++ opam/cobol_cfg.opam | 1 + opam/cobol_lsp.opam | 1 + opam/osx/cobol_cfg-osx.opam | 1 + opam/osx/cobol_lsp-osx.opam | 1 + opam/windows/cobol_cfg-windows.opam | 1 + opam/windows/cobol_lsp-windows.opam | 1 + package.json | 16 ++++++++- src/lsp/cobol_cfg/dune | 2 +- src/lsp/cobol_cfg/package.toml | 1 + src/lsp/cobol_lsp/dune | 2 +- src/lsp/cobol_lsp/lsp_request.ml | 15 ++++++++ src/lsp/cobol_lsp/package.toml | 1 + .../superbol_commands.ml | 8 +++++ .../superbol_instance.ml | 34 +++++++++++++++++++ .../superbol_instance.mli | 5 +++ 17 files changed, 95 insertions(+), 8 deletions(-) diff --git a/.drom b/.drom index e2bef4a43..dc05c1d9f 100644 --- a/.drom +++ b/.drom @@ -5,7 +5,7 @@ version:0.9.0 # hash of toml configuration files # used for generation of all files -2ba85fda382f3e9534366a30e92a3d99:. +b90f497bb0b77cfd3ae180d69673ad76:. # end context for . # begin context for .github/workflows/workflow.yml @@ -78,11 +78,12 @@ c8281f46ba9a11d0b61bc8ef67eaa357:docs/style.css bbe93981f3f89550246d41f768f73a28:dune-project c375da381bfae0c77c7af1cb51f96580:dune-project cde29409c1d991e499786d56924f8fc9:dune-project +68f1f36e943a31bcb34b9b97f6830817:dune-project # end context for dune-project # begin context for opam/cobol_cfg.opam # file opam/cobol_cfg.opam -a7d72990bb64c714f9edad8a708695a1:opam/cobol_cfg.opam +5b0d97854c33a01ceaa5eebf37fed47d:opam/cobol_cfg.opam # end context for opam/cobol_cfg.opam # begin context for opam/cobol_common.opam @@ -112,7 +113,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 @@ -292,7 +293,7 @@ c882aea48ff6d4b120283f41153810ee:sphinx/about.rst # begin context for src/lsp/cobol_cfg/dune # file src/lsp/cobol_cfg/dune -4c4e485ad53793d3adbea7e96daab3bc:src/lsp/cobol_cfg/dune +0719aadf966f84be3629fc49a10309d0:src/lsp/cobol_cfg/dune # end context for src/lsp/cobol_cfg/dune # begin context for src/lsp/cobol_cfg/version.mlt @@ -352,7 +353,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/dune-project b/dune-project index 84b058f6a..71afc2fae 100644 --- a/dune-project +++ b/dune-project @@ -304,6 +304,7 @@ (cobol_data (= version)) (cobol_config (= version)) (cobol_common (= version)) + (cobol_cfg (= version)) odoc ) ) @@ -503,6 +504,7 @@ (superbol_project (= version)) (superbol_preprocs (= version)) (pretty (= version)) + (ocamlgraph (and (>= 2.1.0) (< 3.0.0))) (lsp (and ( >= 1.18 )( < 1.19 ))) (jsonrpc ( >= 1.15 )) (cobol_typeck (= version)) diff --git a/opam/cobol_cfg.opam b/opam/cobol_cfg.opam index a8c3372b2..911a68aef 100644 --- a/opam/cobol_cfg.opam +++ b/opam/cobol_cfg.opam @@ -51,6 +51,7 @@ depends: [ "superbol_project" {= version} "superbol_preprocs" {= version} "pretty" {= version} + "ocamlgraph" {>= "2.1.0" & < "3.0.0"} "lsp" {>= "1.18" & < "1.19"} "jsonrpc" {>= "1.15"} "cobol_typeck" {= version} 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 index ba65a8687..db42881c3 100644 --- a/opam/osx/cobol_cfg-osx.opam +++ b/opam/osx/cobol_cfg-osx.opam @@ -53,6 +53,7 @@ depends: [ "superbol_project-osx" {= version} "superbol_preprocs-osx" {= version} "pretty-osx" {= version} + "ocamlgraph-osx" {>= "2.1.0" & < "3.0.0"} "lsp-osx" {>= "1.18" & < "1.19"} "jsonrpc-osx" {>= "1.15"} "cobol_typeck-osx" {= version} 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 index c1d4abb11..92ba763db 100644 --- a/opam/windows/cobol_cfg-windows.opam +++ b/opam/windows/cobol_cfg-windows.opam @@ -53,6 +53,7 @@ depends: [ "superbol_project-windows" {= version} "superbol_preprocs-windows" {= version} "pretty-windows" {= version} + "ocamlgraph-windows" {>= "2.1.0" & < "3.0.0"} "lsp-windows" {>= "1.18" & < "1.19"} "jsonrpc-windows" {>= "1.15"} "cobol_typeck-windows" {= version} 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..7b78644c0 100644 --- a/package.json +++ b/package.json @@ -38,6 +38,11 @@ "command": "superbol.coverage.reload", "title": "Update Coverage", "category": "SuperBOL" + }, + { + "command": "superbol.cfg.open", + "title": "Open CFG of current file", + "category": "SuperBOL" } ], "configuration": { @@ -565,7 +570,16 @@ ] } } - ] + ], + "menus": { + "editor/context": [ + { + "command": "superbol.cfg.open", + "group": "superbol", + "when": "editorTextFocus" + } + ] + } }, "extensionKind": [ "workspace" diff --git a/src/lsp/cobol_cfg/dune b/src/lsp/cobol_cfg/dune index 9c629a244..f36103ad4 100644 --- a/src/lsp/cobol_cfg/dune +++ b/src/lsp/cobol_cfg/dune @@ -5,7 +5,7 @@ (public_name cobol_cfg) (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 ocamlgraph lsp jsonrpc cobol_typeck cobol_parser cobol_indent cobol_data cobol_config cobol_common ) ; 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_cfg/package.toml b/src/lsp/cobol_cfg/package.toml index c67cc1bd9..459bfbbdb 100644 --- a/src/lsp/cobol_cfg/package.toml +++ b/src/lsp/cobol_cfg/package.toml @@ -65,6 +65,7 @@ jsonrpc = ">=1.15" lsp = ">=1.18 <1.19" pretty = "version" toml = "7.1.0" +ocamlgraph = "2.1.0" # package tools dependencies [tools] 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_request.ml b/src/lsp/cobol_lsp/lsp_request.ml index 05ff4c06b..8a54d1097 100644 --- a/src/lsp/cobol_lsp/lsp_request.ml +++ b/src/lsp/cobol_lsp/lsp_request.ml @@ -133,6 +133,18 @@ 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_open_cfg registry params = + let args = Yojson.Safe.Util.to_list @@ Jsonrpc.Structured.yojson_of_t params in + let uri = Yojson.Safe.Util.to_string @@ List.hd args in + let textDoc = TextDocumentIdentifier.create ~uri:(DocumentUri.of_path uri) in + try_main_doc registry textDoc + ~f:begin fun ~doc -> + let uri = Lsp.Text_document.documentUri doc.textdoc in + Lsp_io.log_debug "CFG of %s" (DocumentUri.to_path uri); + Some (`String "temp") + end + |> Option.value ~default:(`String "") + (** {3 Definitions} *) @@ -825,6 +837,9 @@ let on_request | UnknownRequest { meth = "superbol/getProjectConfiguration"; params = Some param } -> handle_get_project_config_command param registry + | UnknownRequest { meth = "superbol/openCFG"; + params = Some param } -> + Ok (handle_open_cfg 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/vscode/superbol-vscode-platform/superbol_commands.ml b/src/vscode/superbol-vscode-platform/superbol_commands.ml index fa3576378..212dd9936 100644 --- a/src/vscode/superbol-vscode-platform/superbol_commands.ml +++ b/src/vscode/superbol-vscode-platform/superbol_commands.ml @@ -37,6 +37,14 @@ let command id handler = commands := command :: !commands; command +let _open_cfg = + command "superbol.cfg.open" @@ Instance + begin fun _instance ~args:_ -> + let _ = Superbol_instance.open_cfg _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..c3618fd53 100644 --- a/src/vscode/superbol-vscode-platform/superbol_instance.ml +++ b/src/vscode/superbol-vscode-platform/superbol_instance.ml @@ -127,3 +127,37 @@ let get_project_config instance = ])) in Promise.Result.return @@ Jsonoo.Decode.(dict id) assoc + + +let open_cfg ?text_editor instance = + let open_cfg_for ?uri client = + let uri = match uri with + | Some uri -> + Jsonoo.Encode.string @@ Vscode.Uri.path uri + | None -> + Jsonoo.Encode.string "" + in + Vscode_languageclient.LanguageClient.sendRequest client () + ~meth:"superbol/openCFG" + ~data:uri |> + Promise.(then_ ~fulfilled:(fun res -> + let dotfile = Jsonoo.Decode.string res in + let webviewpanel = Vscode.Window.createWebviewPanel ~viewType:"cfg" ~title:"CFG webview" + ~showOptions:(Vscode.ViewColumn.Two) in + let webview = Vscode.WebviewPanel.webview webviewpanel in + Vscode.WebView.set_html webview dotfile; + return () + )) + in + match client instance, current_document_uri ?text_editor () with + | Some client, uri -> + open_cfg_for ?uri client + | None, _ -> + (* TODO: is there a way to activate the extension from here? Starting the + client/instance seems to launch two distinct LSP server processes. *) + Promise.(then_ ~fulfilled:(fun _ -> return ())) @@ + Vscode.Window.showErrorMessage () + ~message:"The SuperBOL LSP client is not running; please retry after a \ + COBOL file has been opened" + + diff --git a/src/vscode/superbol-vscode-platform/superbol_instance.mli b/src/vscode/superbol-vscode-platform/superbol_instance.mli index 062303865..edfb2fd0b 100644 --- a/src/vscode/superbol-vscode-platform/superbol_instance.mli +++ b/src/vscode/superbol-vscode-platform/superbol_instance.mli @@ -26,6 +26,11 @@ val write_project_config -> t -> unit Promise.t +val open_cfg + : ?text_editor: Vscode.TextEditor.t + -> t + -> unit Promise.t + val get_project_config : t -> ((string, Jsonoo.t) Hashtbl.t, string) result Promise.t From d022d2b68b198fb90981d3afbc25650dd75dc05c Mon Sep 17 00:00:00 2001 From: Mateo Date: Fri, 16 Aug 2024 11:53:01 +0200 Subject: [PATCH 03/40] feat: wip cfg with goto stmt fix package.json --- package.json | 22 +-- src/lsp/cobol_cfg/cfg_builder.ml | 152 ++++++++++++++++++ src/lsp/cobol_cfg/cobol_cfg.ml | 2 + src/lsp/cobol_lsp/lsp_request.ml | 16 +- src/lsp/superbol_free_lib/vscode_extension.ml | 8 + .../superbol_instance.ml | 35 ++-- 6 files changed, 201 insertions(+), 34 deletions(-) create mode 100644 src/lsp/cobol_cfg/cfg_builder.ml diff --git a/package.json b/package.json index 7b78644c0..93a0e2ed9 100644 --- a/package.json +++ b/package.json @@ -41,7 +41,7 @@ }, { "command": "superbol.cfg.open", - "title": "Open CFG of current file", + "title": "Open CFG", "category": "SuperBOL" } ], @@ -450,6 +450,15 @@ "configuration": "./syntaxes/list-n-dump-configuration.json" } ], + "menus": { + "editor/context": [ + { + "command": "superbol.cfg.open", + "group": "superbol", + "when": "editorTextFocus" + } + ] + }, "problemMatchers": [ { "name": "gnucobol", @@ -570,16 +579,7 @@ ] } } - ], - "menus": { - "editor/context": [ - { - "command": "superbol.cfg.open", - "group": "superbol", - "when": "editorTextFocus" - } - ] - } + ] }, "extensionKind": [ "workspace" diff --git a/src/lsp/cobol_cfg/cfg_builder.ml b/src/lsp/cobol_cfg/cfg_builder.ml new file mode 100644 index 000000000..a93c5a09e --- /dev/null +++ b/src/lsp/cobol_cfg/cfg_builder.ml @@ -0,0 +1,152 @@ +(******************************************************************************) +(* *) +(* Copyright (c) 2021-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(******************************************************************************) + +(* representation of a node -- must be hashable *) +module Node = struct + type t = Cobol_ptree.qualname + let compare = Cobol_ptree.compare_qualname + let hash = Hashtbl.hash + let equal a b = Cobol_ptree.compare_qualname a b == 0 +end + +(* (* representation of an edge -- must be comparable *) *) +(* module Edge = struct *) +(* type t = string *) +(* let compare = Stdlib.compare *) +(* let equal = (=) *) +(* let default = "" *) +(* end *) + +(* a functional/persistent graph *) + +module Cfg = Graph.Persistent.Digraph.Concrete(Node) + +module Dot = Graph.Graphviz.Dot(struct + include Cfg + let edge_attributes _ = [] + let default_edge_attributes _ = [] + let get_subgraph _ = None + let vertex_attributes _ = [] + let default_vertex_attributes _ = [`Shape `Box] + let graph_attributes _ = [] + let vertex_name qn = + Pretty.to_string "\"%a\""Cobol_ptree.pp_qualname qn + |> Str.global_replace (Str.regexp "\n") " " + + end) + +open Cobol_unit +open Cobol_common.Srcloc.INFIX +open Cobol_common.Srcloc.TYPES +open Cobol_unit.Types +open Cobol_common.Visitor + +type 'a node = { + name: 'a; + has_unconditial_jump: bool; + jumps_to: 'a list; +} + +let full_qn ~cu qn = + (Qualmap.find_binding qn cu.unit_procedure.named).full_qn + + +let build_jump_list ~cu paragraph = + Visitor.fold_procedure_paragraph' + object + inherit [_] Visitor.folder + method! fold_goback' _ (_, jumps) = skip (true, jumps) + method! fold_goto' { payload; _ } (unconditiona_jump, jumps) = + skip @@ + match payload with + | GoToEntry _ -> (unconditiona_jump, jumps) (* TODO couldn't find doc *) + | GoToSimple { targets; depending_on } -> + ( + unconditiona_jump || Option.is_none depending_on, + (Cobol_common.Basics.NEL.to_list targets + |> List.map (~&) + |> List.map (full_qn ~cu)) + @ jumps + ) + + end + paragraph (false, []) + +let rec build_edges g = function + | { name = current; jumps_to; has_unconditial_jump }::next::tl -> + let g = List.fold_left (Fun.flip Cfg.add_edge current) g jumps_to in + if has_unconditial_jump + then build_edges g (next::tl) + else build_edges (Cfg.add_edge g current next.name) (next::tl) + | [{ name = current; jumps_to; has_unconditial_jump = _ }] -> + List.fold_left (Fun.flip Cfg.add_edge current) g jumps_to + | [] -> g + +let cfg_of ~(cu: cobol_unit) = + let graph_name = Cobol_ptree.Name cu.unit_name in + let nodes = List.fold_left begin fun acc block -> + match block with + | Paragraph para -> + let name = + match block_name block with + | None -> graph_name + | Some { payload = qn; _ } -> full_qn ~cu qn + in + let has_unconditial_jump, jumps_to = build_jump_list ~cu para in + let node = { name; has_unconditial_jump ; jumps_to } + in [node] :: acc + | Section { payload = { section_paragraphs; _ }; _ } -> + Fun.flip List.cons acc @@ + List.filter_map (fun p -> + match block_name @@ Paragraph p with + | None -> None + | Some { payload = qn; _ } -> + let has_unconditial_jump, jumps_to = build_jump_list ~cu p in + Some { name = full_qn ~cu qn; has_unconditial_jump; jumps_to }) + section_paragraphs.list + end [] cu.unit_procedure.list + |> List.rev |> List.flatten + in + let g = List.fold_left begin fun g node -> + Cfg.add_vertex g node.name + end Cfg.empty nodes + in build_edges g nodes + +let string_of g = + Pretty.to_string "%a" Dot.fprint_graph g + +let make (checked_doc: Cobol_typeck.Outputs.t) = + let graphs = Cobol_unit.Collections.SET.fold + begin fun { payload = cu; _ } acc -> + acc ^ "\n" ^ (string_of @@ cfg_of ~cu) + end checked_doc.group "" + in + graphs + +(* + +List of node (sections & paragraphs) +Visitor over procedure + - perform + - go to + - output_or_giving + - input_or_using + - alter + - resume + - declaratives + - debug_target + - if else + - evaluate + + paragraph lié au suivant + section lié au suivant + +pp_dot_format => Graph.Graphviz.Dot +*) diff --git a/src/lsp/cobol_cfg/cobol_cfg.ml b/src/lsp/cobol_cfg/cobol_cfg.ml index 1e511fcd5..93cb64bc1 100644 --- a/src/lsp/cobol_cfg/cobol_cfg.ml +++ b/src/lsp/cobol_cfg/cobol_cfg.ml @@ -15,3 +15,5 @@ module INTERNAL = struct module Types = struct end end + +let make = Cfg_builder.make diff --git a/src/lsp/cobol_lsp/lsp_request.ml b/src/lsp/cobol_lsp/lsp_request.ml index 8a54d1097..8743090b2 100644 --- a/src/lsp/cobol_lsp/lsp_request.ml +++ b/src/lsp/cobol_lsp/lsp_request.ml @@ -137,13 +137,15 @@ let handle_open_cfg registry params = let args = Yojson.Safe.Util.to_list @@ Jsonrpc.Structured.yojson_of_t params in let uri = Yojson.Safe.Util.to_string @@ List.hd args in let textDoc = TextDocumentIdentifier.create ~uri:(DocumentUri.of_path uri) in - try_main_doc registry textDoc - ~f:begin fun ~doc -> - let uri = Lsp.Text_document.documentUri doc.textdoc in - Lsp_io.log_debug "CFG of %s" (DocumentUri.to_path uri); - Some (`String "temp") - end - |> Option.value ~default:(`String "") + try_with_main_document_data registry textDoc + ~f:begin fun ~doc checked_doc -> + let uri = Lsp.Text_document.documentUri doc.textdoc in + Lsp_io.log_debug "CFG of %s" (DocumentUri.to_path uri); + let cfg_as_str = Str.global_replace (Str.regexp "\n") "
" + @@ Cobol_cfg.make checked_doc + in Some (`String cfg_as_str) + end + |> Option.value ~default:(`String "") (** {3 Definitions} *) diff --git a/src/lsp/superbol_free_lib/vscode_extension.ml b/src/lsp/superbol_free_lib/vscode_extension.ml index 7fc8e6217..21dd2a111 100644 --- a/src/lsp/superbol_free_lib/vscode_extension.ml +++ b/src/lsp/superbol_free_lib/vscode_extension.ml @@ -583,6 +583,10 @@ let contributes = ~command:"superbol.coverage.reload" ~title:"Update Coverage" ~category:"SuperBOL"; + Manifest.command () + ~command:"superbol.cfg.open" + ~title:"Open CFG" + ~category:"SuperBOL"; ] ~tomlValidation: [ Manifest.tomlValidation @@ -590,6 +594,10 @@ 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" ()] + ] let manifest = Manifest.vscode diff --git a/src/vscode/superbol-vscode-platform/superbol_instance.ml b/src/vscode/superbol-vscode-platform/superbol_instance.ml index c3618fd53..194590992 100644 --- a/src/vscode/superbol-vscode-platform/superbol_instance.ml +++ b/src/vscode/superbol-vscode-platform/superbol_instance.ml @@ -128,36 +128,39 @@ let get_project_config instance = in Promise.Result.return @@ Jsonoo.Decode.(dict id) assoc - let open_cfg ?text_editor instance = let open_cfg_for ?uri client = let uri = match uri with | Some uri -> - Jsonoo.Encode.string @@ Vscode.Uri.path uri + Jsonoo.Encode.string @@ Vscode.Uri.path uri | None -> - Jsonoo.Encode.string "" + Jsonoo.Encode.string "" in Vscode_languageclient.LanguageClient.sendRequest client () ~meth:"superbol/openCFG" ~data:uri |> Promise.(then_ ~fulfilled:(fun res -> - let dotfile = Jsonoo.Decode.string res in - let webviewpanel = Vscode.Window.createWebviewPanel ~viewType:"cfg" ~title:"CFG webview" - ~showOptions:(Vscode.ViewColumn.Two) in - let webview = Vscode.WebviewPanel.webview webviewpanel in - Vscode.WebView.set_html webview dotfile; - return () + (* TODO? Vscode.Workspace.openTextDocument `Interactive *) + (* TODO: do not reopen a different window for each call *) + let dot_content = Jsonoo.Decode.string res in + let newWebviewPanel = + Vscode.Window.createWebviewPanel + ~viewType:"cfg" ~title:"CFG webview" + ~showOptions:(Vscode.ViewColumn.Two) in + let webview = Vscode.WebviewPanel.webview newWebviewPanel in + Vscode.WebView.set_html webview dot_content; + return () )) in match client instance, current_document_uri ?text_editor () with | Some client, uri -> - open_cfg_for ?uri client + open_cfg_for ?uri client | None, _ -> - (* TODO: is there a way to activate the extension from here? Starting the - client/instance seems to launch two distinct LSP server processes. *) - Promise.(then_ ~fulfilled:(fun _ -> return ())) @@ - Vscode.Window.showErrorMessage () - ~message:"The SuperBOL LSP client is not running; please retry after a \ - COBOL file has been opened" + (* TODO: is there a way to activate the extension from here? Starting the + client/instance seems to launch two distinct LSP server processes. *) + Promise.(then_ ~fulfilled:(fun _ -> return ())) @@ + Vscode.Window.showErrorMessage () + ~message:"The SuperBOL LSP client is not running; please retry after a \ + COBOL file has been opened" From 02b263c598c0f5a27d6380ed1669d6fac49a0bd1 Mon Sep 17 00:00:00 2001 From: Mateo Date: Fri, 16 Aug 2024 17:25:51 +0200 Subject: [PATCH 04/40] feat: cfg with perform and cleanup --- src/lsp/cobol_cfg/cfg_builder.ml | 240 +++++++++++------- src/lsp/cobol_lsp/lsp_request.ml | 10 +- .../superbol_instance.ml | 27 +- 3 files changed, 180 insertions(+), 97 deletions(-) diff --git a/src/lsp/cobol_cfg/cfg_builder.ml b/src/lsp/cobol_cfg/cfg_builder.ml index a93c5a09e..dce23ed21 100644 --- a/src/lsp/cobol_cfg/cfg_builder.ml +++ b/src/lsp/cobol_cfg/cfg_builder.ml @@ -8,130 +8,192 @@ (* *) (******************************************************************************) -(* representation of a node -- must be hashable *) -module Node = struct - type t = Cobol_ptree.qualname - let compare = Cobol_ptree.compare_qualname - let hash = Hashtbl.hash - let equal a b = Cobol_ptree.compare_qualname a b == 0 -end - -(* (* representation of an edge -- must be comparable *) *) -(* module Edge = struct *) -(* type t = string *) -(* let compare = Stdlib.compare *) -(* let equal = (=) *) -(* let default = "" *) -(* end *) - -(* a functional/persistent graph *) - -module Cfg = Graph.Persistent.Digraph.Concrete(Node) - -module Dot = Graph.Graphviz.Dot(struct - include Cfg - let edge_attributes _ = [] - let default_edge_attributes _ = [] - let get_subgraph _ = None - let vertex_attributes _ = [] - let default_vertex_attributes _ = [`Shape `Box] - let graph_attributes _ = [] - let vertex_name qn = - Pretty.to_string "\"%a\""Cobol_ptree.pp_qualname qn - |> Str.global_replace (Str.regexp "\n") " " - - end) - open Cobol_unit open Cobol_common.Srcloc.INFIX open Cobol_common.Srcloc.TYPES open Cobol_unit.Types open Cobol_common.Visitor +type qualname = Cobol_ptree.qualname + +type unconditional_jumps = + | Goback + | Go of qualname -type 'a node = { - name: 'a; - has_unconditial_jump: bool; - jumps_to: 'a list; +type node = { + name: qualname; + conditional_jumps: qualname list; + unconditional_jumps: unconditional_jumps list; } let full_qn ~cu qn = (Qualmap.find_binding qn cu.unit_procedure.named).full_qn +let full_qn' ~cu qn = full_qn ~cu ~&qn + + +let build_node ~default_name ~cu paragraph = + let open struct + type acc = { + conditionals: qualname list; + unconditional: unconditional_jumps list; + } + let add_unconditional uncond acc = + { acc with unconditional = uncond :: acc.unconditional } + let add_conditionals acc qn_to_jump = + { acc with conditionals = qn_to_jump :: acc.conditionals } + end in + let { conditionals; unconditional } = + Visitor.fold_procedure_paragraph' + object + inherit [acc] Visitor.folder + method! fold_goback' _ acc = skip @@ add_unconditional Goback acc + method! fold_goto' { payload; _ } acc = + skip @@ + match payload with + | GoToEntry _ -> acc (* TODO couldn't find doc *) + | GoToSimple { targets; depending_on } -> + let targets = Cobol_common.Basics.NEL.to_list targets in + if Option.is_none depending_on + then + add_unconditional (Go (full_qn' ~cu @@ List.hd targets)) acc + else + targets + |> List.map (full_qn' ~cu) + |> List.fold_left add_conditionals acc + method! fold_perform_target' { payload; _ } acc = + skip @@ + let { payload = start; _ } = payload.perform_target.procedure_start in + (* TODO: check that where we jump has no unconditional_jumps, /!\ cycle` *) + add_conditionals acc (full_qn ~cu start) + end + paragraph {conditionals = []; unconditional = [] } + in + let name = Option.fold + ~none:default_name + ~some:(full_qn' ~cu) + ~¶graph.paragraph_name + in { + name; + conditional_jumps = conditionals; + unconditional_jumps = unconditional; + } -let build_jump_list ~cu paragraph = - Visitor.fold_procedure_paragraph' - object - inherit [_] Visitor.folder - method! fold_goback' _ (_, jumps) = skip (true, jumps) - method! fold_goto' { payload; _ } (unconditiona_jump, jumps) = - skip @@ - match payload with - | GoToEntry _ -> (unconditiona_jump, jumps) (* TODO couldn't find doc *) - | GoToSimple { targets; depending_on } -> - ( - unconditiona_jump || Option.is_none depending_on, - (Cobol_common.Basics.NEL.to_list targets - |> List.map (~&) - |> List.map (full_qn ~cu)) - @ jumps - ) +module Node = struct + type t = node + let compare node other = + Cobol_ptree.compare_qualname node.name other.name + let hash node = + Hashtbl.hash node.name + let equal node other = + Cobol_ptree.compare_qualname node.name other.name == 0 +end + +type edge = + | Default + | Conditional + | Unconditional + +module Edge = struct + type t = edge + let compare = Stdlib.compare + let equal = (=) + let default = Default +end + +module Cfg = Graph.Persistent.Digraph.ConcreteLabeled(Node)(Edge) +module Qmap = Map.Make(struct + type t = qualname + let compare = Cobol_ptree.compare_qualname + end) + +let rec build_edges ~vertexes g = function + | ({ conditional_jumps; unconditional_jumps; _ } as current)::next::tl -> + let g = List.fold_left begin fun g jump_to -> + let next = Qmap.find jump_to vertexes in + Cfg.add_edge_e g (current, Conditional, next) + end g conditional_jumps in + begin match unconditional_jumps with + | [] -> + build_edges ~vertexes (Cfg.add_edge g current next) (next::tl) + | _ -> + let g = List.fold_left begin fun g -> function + | Goback -> g + | Go jump_to -> + let next = Qmap.find jump_to vertexes in + Cfg.add_edge_e g (current, Unconditional, next) + end g unconditional_jumps in + build_edges ~vertexes g (next::tl) + end + | [{ conditional_jumps; unconditional_jumps; _ } as current] -> + let g = List.fold_left begin fun g jump_to -> + let next = Qmap.find jump_to vertexes in + Cfg.add_edge_e g (current, Conditional, next) + end g conditional_jumps in + begin match unconditional_jumps with + | [] -> g + | _ -> + List.fold_left begin fun g -> function + | Goback -> g + | Go jump_to -> + let next = Qmap.find jump_to vertexes in + Cfg.add_edge_e g (current, Unconditional, next) + end g unconditional_jumps end - paragraph (false, []) - -let rec build_edges g = function - | { name = current; jumps_to; has_unconditial_jump }::next::tl -> - let g = List.fold_left (Fun.flip Cfg.add_edge current) g jumps_to in - if has_unconditial_jump - then build_edges g (next::tl) - else build_edges (Cfg.add_edge g current next.name) (next::tl) - | [{ name = current; jumps_to; has_unconditial_jump = _ }] -> - List.fold_left (Fun.flip Cfg.add_edge current) g jumps_to | [] -> g let cfg_of ~(cu: cobol_unit) = - let graph_name = Cobol_ptree.Name cu.unit_name in + let default_name = Cobol_ptree.Name cu.unit_name in let nodes = List.fold_left begin fun acc block -> match block with | Paragraph para -> - let name = - match block_name block with - | None -> graph_name - | Some { payload = qn; _ } -> full_qn ~cu qn - in - let has_unconditial_jump, jumps_to = build_jump_list ~cu para in - let node = { name; has_unconditial_jump ; jumps_to } - in [node] :: acc + build_node ~default_name ~cu para :: acc | Section { payload = { section_paragraphs; _ }; _ } -> - Fun.flip List.cons acc @@ - List.filter_map (fun p -> - match block_name @@ Paragraph p with - | None -> None - | Some { payload = qn; _ } -> - let has_unconditial_jump, jumps_to = build_jump_list ~cu p in - Some { name = full_qn ~cu qn; has_unconditial_jump; jumps_to }) - section_paragraphs.list - end [] cu.unit_procedure.list - |> List.rev |> List.flatten + List.fold_left begin fun acc p -> + build_node ~default_name ~cu p :: acc + end acc section_paragraphs.list + end [] cu.unit_procedure.list |> List.rev in - let g = List.fold_left begin fun g node -> - Cfg.add_vertex g node.name - end Cfg.empty nodes - in build_edges g nodes + let g, vertexes = List.fold_left begin fun (g, vertexes) node -> + Cfg.add_vertex g node, + Qmap.add node.name node vertexes + end (Cfg.empty, Qmap.empty) nodes + in build_edges ~vertexes g nodes + +module Dot = Graph.Graphviz.Dot(struct + include Cfg + let edge_attributes (_,s,_) = + match s with + | Default -> [`Style `Dotted] + | Conditional -> [`Style `Dashed] + | Unconditional -> [`Style `Solid] + let default_edge_attributes _ = [] + let get_subgraph _ = None + let vertex_attributes { unconditional_jumps; _ } = + if List.exists ((=) Goback) unconditional_jumps + then [`Style `Bold] + else [] + let default_vertex_attributes _ = [`Shape `Box] + let graph_attributes _ = [] + let vertex_name { name = qn; _} = + Pretty.to_string "\"%a\""Cobol_ptree.pp_qualname qn + |> Str.global_replace (Str.regexp "\n") " " + end) let string_of g = Pretty.to_string "%a" Dot.fprint_graph g let make (checked_doc: Cobol_typeck.Outputs.t) = + try let graphs = Cobol_unit.Collections.SET.fold begin fun { payload = cu; _ } acc -> acc ^ "\n" ^ (string_of @@ cfg_of ~cu) end checked_doc.group "" in graphs + with _ -> "no graph failed" (* - List of node (sections & paragraphs) Visitor over procedure - perform diff --git a/src/lsp/cobol_lsp/lsp_request.ml b/src/lsp/cobol_lsp/lsp_request.ml index 8743090b2..4061cad1c 100644 --- a/src/lsp/cobol_lsp/lsp_request.ml +++ b/src/lsp/cobol_lsp/lsp_request.ml @@ -138,12 +138,10 @@ let handle_open_cfg registry params = let uri = Yojson.Safe.Util.to_string @@ List.hd args 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 uri = Lsp.Text_document.documentUri doc.textdoc in - Lsp_io.log_debug "CFG of %s" (DocumentUri.to_path uri); - let cfg_as_str = Str.global_replace (Str.regexp "\n") "
" - @@ Cobol_cfg.make checked_doc - in Some (`String cfg_as_str) + ~f:begin fun ~doc:_ checked_doc -> + let cfg = Cobol_cfg.make checked_doc in + Lsp_io.log_debug "making cfg %s" cfg; + Some (`String cfg) end |> Option.value ~default:(`String "") diff --git a/src/vscode/superbol-vscode-platform/superbol_instance.ml b/src/vscode/superbol-vscode-platform/superbol_instance.ml index 194590992..8d2313dfb 100644 --- a/src/vscode/superbol-vscode-platform/superbol_instance.ml +++ b/src/vscode/superbol-vscode-platform/superbol_instance.ml @@ -128,6 +128,29 @@ let get_project_config instance = in Promise.Result.return @@ Jsonoo.Decode.(dict id) assoc +(** Credit @beiclause in https://github.com/beicause/call-graph/blob/master/src/html.ts *) +let html dot = Printf.sprintf {| + + + + + + + Call Graph + + + + + + +
+ + + ` + |} dot + let open_cfg ?text_editor instance = let open_cfg_for ?uri client = let uri = match uri with @@ -140,7 +163,6 @@ let open_cfg ?text_editor instance = ~meth:"superbol/openCFG" ~data:uri |> Promise.(then_ ~fulfilled:(fun res -> - (* TODO? Vscode.Workspace.openTextDocument `Interactive *) (* TODO: do not reopen a different window for each call *) let dot_content = Jsonoo.Decode.string res in let newWebviewPanel = @@ -148,7 +170,8 @@ let open_cfg ?text_editor instance = ~viewType:"cfg" ~title:"CFG webview" ~showOptions:(Vscode.ViewColumn.Two) in let webview = Vscode.WebviewPanel.webview newWebviewPanel in - Vscode.WebView.set_html webview dot_content; + Vscode.WebView.set_html webview (html dot_content); + Vscode.WebView.set_options webview (Vscode.WebviewOptions.create ~enableScripts:true ()); return () )) in From 09062a0fc7aaf26ae72fb4d562b9013e50a20fb7 Mon Sep 17 00:00:00 2001 From: Mateo Date: Fri, 23 Aug 2024 16:03:01 +0200 Subject: [PATCH 05/40] feat: wip improved cfg interaction, started using d3 --- package.json | 15 + src/lsp/cobol_cfg/cfg_builder.ml | 99 ++++-- src/lsp/cobol_cfg/cobol_cfg.ml | 5 +- src/lsp/cobol_lsp/lsp_request.ml | 19 +- src/lsp/superbol_free_lib/vscode_extension.ml | 11 +- .../src-bindings/vscode/vscode.ml | 5 + .../src-bindings/vscode/vscode.mli | 3 + .../superbol_commands.ml | 17 + .../superbol_instance.ml | 320 +++++++++++++++++- .../superbol_instance.mli | 6 + 10 files changed, 458 insertions(+), 42 deletions(-) diff --git a/package.json b/package.json index 93a0e2ed9..cf14b11d9 100644 --- a/package.json +++ b/package.json @@ -43,6 +43,16 @@ "command": "superbol.cfg.open", "title": "Open CFG", "category": "SuperBOL" + }, + { + "command": "superbol.cfg.open.d3", + "title": "Open CFG D3", + "category": "SuperBOL" + }, + { + "command": "superbol.cfg.test", + "title": "Open as WEbview", + "category": "SuperBOL" } ], "configuration": { @@ -456,6 +466,11 @@ "command": "superbol.cfg.open", "group": "superbol", "when": "editorTextFocus" + }, + { + "command": "superbol.cfg.open.d3", + "group": "superbol", + "when": "editorTextFocus" } ] }, diff --git a/src/lsp/cobol_cfg/cfg_builder.ml b/src/lsp/cobol_cfg/cfg_builder.ml index dce23ed21..2c6bd472d 100644 --- a/src/lsp/cobol_cfg/cfg_builder.ml +++ b/src/lsp/cobol_cfg/cfg_builder.ml @@ -20,7 +20,9 @@ type unconditional_jumps = | Go of qualname type node = { + num: int; name: qualname; + loc: srcloc; conditional_jumps: qualname list; unconditional_jumps: unconditional_jumps list; } @@ -30,6 +32,7 @@ let full_qn ~cu qn = let full_qn' ~cu qn = full_qn ~cu ~&qn +let id = ref 0 let build_node ~default_name ~cu paragraph = let open struct @@ -51,15 +54,12 @@ let build_node ~default_name ~cu paragraph = skip @@ match payload with | GoToEntry _ -> acc (* TODO couldn't find doc *) - | GoToSimple { targets; depending_on } -> - let targets = Cobol_common.Basics.NEL.to_list targets in - if Option.is_none depending_on - then - add_unconditional (Go (full_qn' ~cu @@ List.hd targets)) acc - else - targets - |> List.map (full_qn' ~cu) - |> List.fold_left add_conditionals acc + | GoToSimple { target } -> + add_unconditional (Go (full_qn' ~cu target)) acc + | GoToDepending { targets; _ } -> + Cobol_common.Basics.NEL.to_list targets + |> List.map (full_qn' ~cu) + |> List.fold_left add_conditionals acc method! fold_perform_target' { payload; _ } acc = skip @@ let { payload = start; _ } = payload.perform_target.procedure_start in @@ -68,15 +68,17 @@ let build_node ~default_name ~cu paragraph = end paragraph {conditionals = []; unconditional = [] } in - let name = Option.fold - ~none:default_name - ~some:(full_qn' ~cu) - ~¶graph.paragraph_name + id:=!id+1; + let name, loc = match ~¶graph.paragraph_name with + | None -> default_name, ~@paragraph + | Some name -> full_qn' ~cu name, ~@name in { - name; - conditional_jumps = conditionals; - unconditional_jumps = unconditional; - } + num = !id; + name; + loc; + conditional_jumps = conditionals; + unconditional_jumps = unconditional; + } module Node = struct type t = node @@ -160,6 +162,14 @@ let cfg_of ~(cu: cobol_unit) = end (Cfg.empty, Qmap.empty) nodes in build_edges ~vertexes g nodes +let vertex_name_quoted { name = qn; _ } = + Pretty.to_string "\"%a\""Cobol_ptree.pp_qualname qn + |> Str.global_replace (Str.regexp "\n") " " + +let vertex_name { name = qn; _ } = + Pretty.to_string "%a"Cobol_ptree.pp_qualname qn + |> Str.global_replace (Str.regexp "\n") " " + module Dot = Graph.Graphviz.Dot(struct include Cfg let edge_attributes (_,s,_) = @@ -175,23 +185,53 @@ module Dot = Graph.Graphviz.Dot(struct else [] let default_vertex_attributes _ = [`Shape `Box] let graph_attributes _ = [] - let vertex_name { name = qn; _} = - Pretty.to_string "\"%a\""Cobol_ptree.pp_qualname qn - |> Str.global_replace (Str.regexp "\n") " " + let vertex_name = vertex_name_quoted end) let string_of g = Pretty.to_string "%a" Dot.fprint_graph g -let make (checked_doc: Cobol_typeck.Outputs.t) = - try - let graphs = Cobol_unit.Collections.SET.fold - begin fun { payload = cu; _ } acc -> - acc ^ "\n" ^ (string_of @@ cfg_of ~cu) - end checked_doc.group "" - in - graphs - with _ -> "no graph failed" +type graph = { + string_repr: string; + nodes_pos: (string * srcloc) list +} + +let make_dot ({ group; _ }: Cobol_typeck.Outputs.t) = + Cobol_unit.Collections.SET.fold + begin fun { payload = cu; _ } acc -> + let cfg = cfg_of ~cu in + let nodes_pos = Cfg.fold_vertex begin fun n acc -> + (vertex_name n, n.loc)::acc + end cfg [] in + { + string_repr = string_of cfg; + nodes_pos; + } :: acc + end group [] + +(* let make_d3 ({ group; _ }: Cobol_typeck.Outputs.t) = *) +(* Cobol_unit.Collections.SET.fold *) +(* begin fun { payload = cu; _ } acc -> *) +(* let cfg = cfg_of ~cu in *) +(* let cfg_edges = Cfg.fold_edges_e *) +(* begin fun (n1, _, n2) links -> *) +(* links *) +(* ^ Pretty.to_string "{source: '%s', target:'%s'}," *) +(* (vertex_name n1) (vertex_name n2) *) +(* end cfg "[" ^ "]" in *) +(* let cfg_nodes = Cfg.fold_vertex *) +(* begin fun n nodes -> *) +(* nodes *) +(* ^ Pretty.to_string "{id:'%s',size:%d}," *) +(* (vertex_name n) (Cfg.in_degree cfg n + Cfg.out_degree cfg n) *) +(* end cfg "[" ^ "]" in *) +(* acc ^ Pretty.to_string "{links:%s, nodes:%s}," cfg_edges cfg_nodes *) +(* end group "[" ^ "]" *) + +let make ?(d3=false) (checked_doc: Cobol_typeck.Outputs.t) = + if d3 + then make_dot checked_doc + else make_dot checked_doc (* List of node (sections & paragraphs) @@ -206,6 +246,7 @@ Visitor over procedure - debug_target - if else - evaluate + - exit paragraph lié au suivant section lié au suivant diff --git a/src/lsp/cobol_cfg/cobol_cfg.ml b/src/lsp/cobol_cfg/cobol_cfg.ml index 93cb64bc1..5e0aa801f 100644 --- a/src/lsp/cobol_cfg/cobol_cfg.ml +++ b/src/lsp/cobol_cfg/cobol_cfg.ml @@ -16,4 +16,7 @@ module INTERNAL = struct end end -let make = Cfg_builder.make +module Builder = struct + type graph = Cfg_builder.graph + let make = Cfg_builder.make +end diff --git a/src/lsp/cobol_lsp/lsp_request.ml b/src/lsp/cobol_lsp/lsp_request.ml index 4061cad1c..3ef3a1571 100644 --- a/src/lsp/cobol_lsp/lsp_request.ml +++ b/src/lsp/cobol_lsp/lsp_request.ml @@ -134,14 +134,23 @@ let handle_get_project_config_command param registry = expected)" Yojson.Safe.(to_string (param :> t)) let handle_open_cfg registry params = - let args = Yojson.Safe.Util.to_list @@ Jsonrpc.Structured.yojson_of_t params in - let uri = Yojson.Safe.Util.to_string @@ List.hd args in + let params = Jsonrpc.Structured.yojson_of_t params in + let uri = Yojson.Safe.Util.to_string @@ Yojson.Safe.Util.member "uri" params in + let d3 = Yojson.Safe.Util.to_bool @@ Yojson.Safe.Util.member "is_d3" 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 cfg = Cobol_cfg.make checked_doc in - Lsp_io.log_debug "making cfg %s" cfg; - Some (`String cfg) + let open Cobol_cfg.Builder in + let graphs = make ~d3 checked_doc in + let { string_repr; nodes_pos }: graph = List.hd graphs in + let nodes_pos = List.map begin fun (n,loc) -> + let range = Lsp_position.range_of_srcloc_in ~filename:uri loc in + (n, Range.yojson_of_t range) + end nodes_pos in + Lsp_io.log_debug "making cfg %s" string_repr; + let res = `Assoc [("string_repr", `String string_repr); ("nodes_pos", `Assoc nodes_pos)] + in + Some res end |> Option.value ~default:(`String "") diff --git a/src/lsp/superbol_free_lib/vscode_extension.ml b/src/lsp/superbol_free_lib/vscode_extension.ml index 21dd2a111..7578d759f 100644 --- a/src/lsp/superbol_free_lib/vscode_extension.ml +++ b/src/lsp/superbol_free_lib/vscode_extension.ml @@ -587,6 +587,14 @@ let contributes = ~command:"superbol.cfg.open" ~title:"Open CFG" ~category:"SuperBOL"; + Manifest.command () + ~command:"superbol.cfg.open.d3" + ~title:"Open CFG D3" + ~category:"SuperBOL"; + Manifest.command () + ~command:"superbol.cfg.test" + ~title:"Open as WEbview" + ~category:"SuperBOL"; ] ~tomlValidation: [ Manifest.tomlValidation @@ -596,7 +604,8 @@ let contributes = ] ~menus: [ "editor/context", - [menu ~command:"superbol.cfg.open" ~group:"superbol" ~when_:"editorTextFocus" ()] + [menu ~command:"superbol.cfg.open" ~group:"superbol" ~when_:"editorTextFocus" (); + menu ~command:"superbol.cfg.open.d3" ~group:"superbol" ~when_:"editorTextFocus" ()] ] let manifest = 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..86268a547 100644 --- a/src/vendor/vscode-ocaml-platform/src-bindings/vscode/vscode.ml +++ b/src/vendor/vscode-ocaml-platform/src-bindings/vscode/vscode.ml @@ -3092,6 +3092,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..0d14ad033 100644 --- a/src/vendor/vscode-ocaml-platform/src-bindings/vscode/vscode.mli +++ b/src/vendor/vscode-ocaml-platform/src-bindings/vscode/vscode.mli @@ -2372,6 +2372,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/superbol_commands.ml b/src/vscode/superbol-vscode-platform/superbol_commands.ml index 212dd9936..3ee280dba 100644 --- a/src/vscode/superbol-vscode-platform/superbol_commands.ml +++ b/src/vscode/superbol-vscode-platform/superbol_commands.ml @@ -44,6 +44,23 @@ let _open_cfg = () end +let _open_cfg_d3 = + command "superbol.cfg.open.d3" @@ Instance + begin fun _instance ~args:_ -> + let _ = Superbol_instance.open_cfg ~d3:true _instance in + () + end + + + +let _open_cfg2 = + command "superbol.cfg.test" @@ Instance + begin fun _instance ~args:_ -> + let _ = Superbol_instance.open_webview _instance in + () + end + + let _editor_action_findReferences = let command_name = "superbol.editor.action.findReferences" in diff --git a/src/vscode/superbol-vscode-platform/superbol_instance.ml b/src/vscode/superbol-vscode-platform/superbol_instance.ml index 8d2313dfb..0fc5725cf 100644 --- a/src/vscode/superbol-vscode-platform/superbol_instance.ml +++ b/src/vscode/superbol-vscode-platform/superbol_instance.ml @@ -146,18 +146,33 @@ let html dot = Printf.sprintf {|
- ` + |} dot -let open_cfg ?text_editor instance = +let _open_cfg ?text_editor instance = let open_cfg_for ?uri client = - let uri = match uri with + let uri, uri_ojs = match uri with | Some uri -> - Jsonoo.Encode.string @@ Vscode.Uri.path uri + Jsonoo.Encode.string @@ Vscode.Uri.path uri, + Vscode.Uri.t_to_js uri | None -> - Jsonoo.Encode.string "" + Jsonoo.Encode.string "", Ojs.null in Vscode_languageclient.LanguageClient.sendRequest client () ~meth:"superbol/openCFG" @@ -172,6 +187,21 @@ let open_cfg ?text_editor instance = let webview = Vscode.WebviewPanel.webview newWebviewPanel in Vscode.WebView.set_html webview (html dot_content); Vscode.WebView.set_options webview (Vscode.WebviewOptions.create ~enableScripts:true ()); + let listener arg = + let node = Ojs.get_prop_ascii arg "node" |> Ojs.string_of_js in + let message = "Heard click on node: " ^ node in + let _ = Vscode.Window.showErrorMessage () ~message in + let pos = Vscode.Position.t_to_js @@ Vscode.Position.make ~line:12 ~character:20 in + let args = Ojs.empty_obj () in + Ojs.set_prop_ascii pos "position" args; + let _ = Vscode.Commands.executeCommand + ~command:"editor.action.goToLocations" + (* ~args:[uri_ojs; pos] *) + ~args:[uri_ojs; pos; Ojs.array_make 0] + in + () + in + let _ = Vscode.WebView.onDidReceiveMessage webview ~listener ~thisArgs:Ojs.null ~disposables:[] () in return () )) in @@ -186,4 +216,282 @@ let open_cfg ?text_editor instance = ~message:"The SuperBOL LSP client is not running; please retry after a \ COBOL file has been opened" +let html_d3 = Printf.sprintf {| + + + + + + + + + + + |} + +let webview_panels = Hashtbl.create 1 +let create_or_get_webview ~uri = + let filename = Vscode.Uri.path uri in + Vscode.WebviewPanel.webview @@ + match Hashtbl.find_opt webview_panels filename with + | Some webview_panel -> + Vscode.WebviewPanel.reveal webview_panel (); + webview_panel + | None -> + let webview_panel = Vscode.Window.createWebviewPanel + ~viewType:"CFG" ~title:"COBOL CFG Viewer" + ~showOptions:(Vscode.ViewColumn.Beside) in + ignore( + Vscode.WebviewPanel.onDidDispose webview_panel () + ~listener:(fun () -> Hashtbl.remove webview_panels filename) + ~thisArgs:Ojs.null ~disposables:[]); + Hashtbl.add webview_panels filename webview_panel; + webview_panel + +let _log message = ignore(Vscode.Window.showInformationMessage () ~message) + +let create_decoration_type () = + let backgroundColor = Ojs.string_to_js "#75ff3388" in + let options = Ojs.obj [|("backgroundColor", backgroundColor)|] in + Vscode.Window.createTextEditorDecorationType ~options + +let on_click ~nodes_pos ~decorationType ~text_editor arg = + let open Vscode in + let uri = TextDocument.uri @@ TextEditor.document text_editor in + let column = TextEditor.viewColumn text_editor in + let node = Ojs.get_prop_ascii arg "node" |> Ojs.string_of_js in + match Hashtbl.find_opt nodes_pos node with + | None -> () + | Some range -> + let range = Range.t_of_js @@ Jsonoo.t_to_js range in + let _ = + Window.showTextDocument ~document:(`Uri uri) ?column () + |> Promise.then_ ~fulfilled:(fun text_editor -> + let selection = Selection.makePositions + ~anchor:(Range.start range) ~active:(Range.start range) in + TextEditor.revealRange text_editor ~range + ~revealType:TextEditorRevealType.InCenterIfOutsideViewport (); + TextEditor.set_selection text_editor selection; + TextEditor.setDecorations text_editor ~decorationType + ~rangesOrOptions:(`Ranges [range]); + Promise.return ()) + in () + +let open_cfg_for ?(d3=false) ~text_editor client = + let open Vscode in + let uri = TextEditor.document text_editor |> TextDocument.uri in + let data = + let uri = Jsonoo.Encode.string @@ Vscode.Uri.path uri in + Jsonoo.Encode.object_ ["uri", uri; "is_d3", Jsonoo.Encode.bool d3] + in + let decorationType = create_decoration_type () in + Vscode_languageclient.LanguageClient.sendRequest client () + ~meth:"superbol/openCFG" ~data + |> Promise.(then_ ~fulfilled:(fun res -> + let graph_content = + Jsonoo.Decode.field "string_repr" Jsonoo.Decode.string res in + let nodes_pos = Jsonoo.Decode.field "nodes_pos" Jsonoo.Decode.(dict id) res in + let webview = create_or_get_webview ~uri in + let html = (if d3 then html_d3 else html) graph_content in + WebView.set_html webview html; + WebView.set_options webview (WebviewOptions.create ~enableScripts:true ()); + ignore( + WebView.onDidReceiveMessage webview () + ~listener:(on_click ~text_editor ~decorationType ~nodes_pos) + ~thisArgs:Ojs.null ~disposables:[]); + return () + )) + +let open_cfg ?(d3=false) ?text_editor instance = + let text_editor = match text_editor with + | None -> Vscode.Window.activeTextEditor () + | e -> e in + match client instance, text_editor with + | Some client, Some text_editor -> + open_cfg_for ~d3 ~text_editor client + | _ -> Promise.return () + +(* debug TO REMOVE *) +let debugWebviewPanelRef = ref None +let open_webview ?text_editor instance = + let open Vscode in + let open_cfg_for ~text _client = + let webviewPanel = match !debugWebviewPanelRef with + | None -> + Window.createWebviewPanel + ~viewType:"cfg" ~title:"Tester webview" + ~showOptions:(Vscode.ViewColumn.Two) + | Some wvp -> wvp in + debugWebviewPanelRef := Some webviewPanel; + let webview = Vscode.WebviewPanel.webview webviewPanel in + Vscode.WebView.set_html webview text; + Vscode.WebView.set_options webview (Vscode.WebviewOptions.create ~enableScripts:true ()); + let thisArgs, disposables = Ojs.null, [] in + ignore( + WebviewPanel.onDidDispose webviewPanel () + ~listener:(fun () -> debugWebviewPanelRef:=None) + ~thisArgs ~disposables); + let listener arg = + let typ = Ojs.type_of arg in + let com = Ojs.get_prop_ascii arg "command" |> Ojs.string_of_js in + let message = "Listener clicked " ^ typ ^ " " ^ com in + let _ = Vscode.Window.showErrorMessage () ~message in + () + in + let _ = Vscode.WebView.onDidReceiveMessage webview ~listener ~thisArgs:Ojs.null ~disposables:[] () in + (* let onDidReceiveMessage ~listener ?thisArgs ?disposables () = *) + (* ignore(listener, thisArgs, disposables); *) + (* Vscode.Disposable.make ~dispose:Fun.id *) + (* in *) + (* let postMessage _ojs = Promise.return true in *) + (* let webview = Vscode.WebView.create *) + (* ~onDidReceiveMessage *) + (* ~cspSource:"" *) + (* ~close:Fun.id *) + (* ~asWebviewUri:Fun.id *) + (* ~html:text *) + (* ~postMessage *) + (* ~options:(Vscode.WebviewOptions.create ~enableScripts:true ()) *) + (* in *) + (* Vscode.WebviewPanel.set_webview newWebviewPanel webview; *) + WebviewPanel.reveal webviewPanel ~preserveFocus:true (); + Promise.return () + in + let current_text ?text_editor () = + match + match text_editor with None -> Vscode.Window.activeTextEditor () | e -> e + with + | None -> None + | Some e -> Some (Vscode.TextDocument.getText (Vscode.TextEditor.document e) ()) + in + match client instance, current_text ?text_editor () with + | Some client, Some text -> + open_cfg_for ~text client + | _ -> + (* TODO: is there a way to activate the extension from here? Starting the + client/instance seems to launch two distinct LSP server processes. *) + Promise.(then_ ~fulfilled:(fun _ -> return ())) @@ + Vscode.Window.showErrorMessage () + ~message:"The SuperBOL LSP client is not running; please retry after a \ + COBOL file has been opened" + + diff --git a/src/vscode/superbol-vscode-platform/superbol_instance.mli b/src/vscode/superbol-vscode-platform/superbol_instance.mli index edfb2fd0b..264f6dc9f 100644 --- a/src/vscode/superbol-vscode-platform/superbol_instance.mli +++ b/src/vscode/superbol-vscode-platform/superbol_instance.mli @@ -27,6 +27,12 @@ val write_project_config -> unit Promise.t val open_cfg + : ?d3: bool + -> ?text_editor: Vscode.TextEditor.t + -> t + -> unit Promise.t + +val open_webview : ?text_editor: Vscode.TextEditor.t -> t -> unit Promise.t From 47540ebb035274a466465e08cb80071b97b718b7 Mon Sep 17 00:00:00 2001 From: Mateo Date: Tue, 27 Aug 2024 10:01:35 +0200 Subject: [PATCH 06/40] feat: isolated html and change d3-force layout --- .drom | 7 +- assets/cfg-d3-renderer.html | 221 ++++++++++++++++ assets/cfg-dot-renderer.html | 32 +++ dune-project | 1 + opam/superbol-vscode-platform.opam | 1 + src/lsp/cobol_cfg/cfg_builder.ml | 46 ++-- src/vscode/superbol-vscode-platform/dune | 2 +- .../superbol-vscode-platform/package.toml | 27 +- .../superbol_instance.ml | 237 ++---------------- 9 files changed, 316 insertions(+), 258 deletions(-) create mode 100644 assets/cfg-d3-renderer.html create mode 100644 assets/cfg-dot-renderer.html diff --git a/.drom b/.drom index dc05c1d9f..362c7b829 100644 --- a/.drom +++ b/.drom @@ -5,7 +5,7 @@ version:0.9.0 # hash of toml configuration files # used for generation of all files -b90f497bb0b77cfd3ae180d69673ad76:. +a685c8c5646668394452a38d355e52d1:. # end context for . # begin context for .github/workflows/workflow.yml @@ -79,6 +79,7 @@ bbe93981f3f89550246d41f768f73a28:dune-project c375da381bfae0c77c7af1cb51f96580:dune-project cde29409c1d991e499786d56924f8fc9:dune-project 68f1f36e943a31bcb34b9b97f6830817:dune-project +afd60e19795dd45cbf2d203174f50a68:dune-project # end context for dune-project # begin context for opam/cobol_cfg.opam @@ -203,7 +204,7 @@ ec375db9ddc4ed967f4099edcb93ea4e:opam/pretty.opam # begin context for opam/superbol-vscode-platform.opam # file opam/superbol-vscode-platform.opam -696cf15f5579572d1a87320947a9413e:opam/superbol-vscode-platform.opam +70ed3832042952f1fb3dd86f38ec4759:opam/superbol-vscode-platform.opam # end context for opam/superbol-vscode-platform.opam # begin context for opam/superbol_free_lib.opam @@ -588,7 +589,7 @@ de6c46a271140f4f52b2580e0d876351:src/vendor/vscode-ocaml-platform/src-bindings/v # begin context for src/vscode/superbol-vscode-platform/dune # file src/vscode/superbol-vscode-platform/dune -664342638a68e3f2f79d39343772e32f:src/vscode/superbol-vscode-platform/dune +0e68ee450858b5a156784dda22a7c39a:src/vscode/superbol-vscode-platform/dune # end context for src/vscode/superbol-vscode-platform/dune # begin context for src/vscode/superbol-vscode-platform/version.mlt diff --git a/assets/cfg-d3-renderer.html b/assets/cfg-d3-renderer.html new file mode 100644 index 000000000..10cf8f761 --- /dev/null +++ b/assets/cfg-d3-renderer.html @@ -0,0 +1,221 @@ + + + + + + + + + + + diff --git a/assets/cfg-dot-renderer.html b/assets/cfg-dot-renderer.html new file mode 100644 index 000000000..c080d2198 --- /dev/null +++ b/assets/cfg-dot-renderer.html @@ -0,0 +1,32 @@ + + + + + + + COBOL CFG + + + + + +
+ + + diff --git a/dune-project b/dune-project index 71afc2fae..c0e1e8b6e 100644 --- a/dune-project +++ b/dune-project @@ -35,6 +35,7 @@ (jsonoo (and (>= 0.2.1) (< 1.0.0))) (js_of_ocaml ( >= 4 )) (gen_js_api (and (>= 1.1.1) (< 2.0.0))) + (ez_subst ( >= 0.2.1 )) (js_of_ocaml-ppx ( >= 4 )) odoc ) diff --git a/opam/superbol-vscode-platform.opam b/opam/superbol-vscode-platform.opam index b14389630..509590fa7 100644 --- a/opam/superbol-vscode-platform.opam +++ b/opam/superbol-vscode-platform.opam @@ -56,6 +56,7 @@ depends: [ "jsonoo" {>= "0.2.1" & < "1.0.0"} "js_of_ocaml" {>= "4"} "gen_js_api" {>= "1.1.1" & < "2.0.0"} + "ez_subst" {>= "0.2.1"} "js_of_ocaml-ppx" {>= "4"} "odoc" {with-doc} ] diff --git a/src/lsp/cobol_cfg/cfg_builder.ml b/src/lsp/cobol_cfg/cfg_builder.ml index 2c6bd472d..7a803899d 100644 --- a/src/lsp/cobol_cfg/cfg_builder.ml +++ b/src/lsp/cobol_cfg/cfg_builder.ml @@ -100,6 +100,10 @@ module Edge = struct let compare = Stdlib.compare let equal = (=) let default = Default + let to_string = function + | Default -> "d" + | Conditional -> "c" + | Unconditional -> "u" end module Cfg = Graph.Persistent.Digraph.ConcreteLabeled(Node)(Edge) @@ -209,28 +213,32 @@ let make_dot ({ group; _ }: Cobol_typeck.Outputs.t) = } :: acc end group [] -(* let make_d3 ({ group; _ }: Cobol_typeck.Outputs.t) = *) -(* Cobol_unit.Collections.SET.fold *) -(* begin fun { payload = cu; _ } acc -> *) -(* let cfg = cfg_of ~cu in *) -(* let cfg_edges = Cfg.fold_edges_e *) -(* begin fun (n1, _, n2) links -> *) -(* links *) -(* ^ Pretty.to_string "{source: '%s', target:'%s'}," *) -(* (vertex_name n1) (vertex_name n2) *) -(* end cfg "[" ^ "]" in *) -(* let cfg_nodes = Cfg.fold_vertex *) -(* begin fun n nodes -> *) -(* nodes *) -(* ^ Pretty.to_string "{id:'%s',size:%d}," *) -(* (vertex_name n) (Cfg.in_degree cfg n + Cfg.out_degree cfg n) *) -(* end cfg "[" ^ "]" in *) -(* acc ^ Pretty.to_string "{links:%s, nodes:%s}," cfg_edges cfg_nodes *) -(* end group "[" ^ "]" *) +let make_d3 ({ group; _ }: Cobol_typeck.Outputs.t) = + Cobol_unit.Collections.SET.fold + begin fun { payload = cu; _ } acc -> + let cfg = cfg_of ~cu in + let cfg_edges = Cfg.fold_edges_e + begin fun (n1, e, n2) links -> + links + ^ Pretty.to_string "{source: '%s', target:'%s', type:'%s'}," + (vertex_name n1) (vertex_name n2) (Edge.to_string e) + end cfg "[" ^ "]" in + let cfg_nodes = Cfg.fold_vertex + begin fun n nodes -> + nodes + ^ Pretty.to_string "{id:'%s'}," (vertex_name n) + end cfg "[" ^ "]" in + { + string_repr = Pretty.to_string "{links:%s, nodes:%s}" cfg_edges cfg_nodes; + nodes_pos = Cfg.fold_vertex begin fun n acc -> + (vertex_name n, n.loc)::acc + end cfg [] + } :: acc + end group [] let make ?(d3=false) (checked_doc: Cobol_typeck.Outputs.t) = if d3 - then make_dot checked_doc + then make_d3 checked_doc else make_dot checked_doc (* diff --git a/src/vscode/superbol-vscode-platform/dune b/src/vscode/superbol-vscode-platform/dune index 169b623f9..68ab89178 100644 --- a/src/vscode/superbol-vscode-platform/dune +++ b/src/vscode/superbol-vscode-platform/dune @@ -2,7 +2,7 @@ (executable (name superbol_vscode_platform) - (libraries vscode-languageclient-js-stubs vscode-js-stubs promise_jsoo polka-js-stubs ocplib_stuff node-js-stubs jsonoo js_of_ocaml gen_js_api ) + (libraries vscode-languageclient-js-stubs vscode-js-stubs promise_jsoo polka-js-stubs ocplib_stuff node-js-stubs jsonoo js_of_ocaml gen_js_api ez_subst ) (modes js) (preprocess (pps gen_js_api.ppx)) (js_of_ocaml (flags --source-map --pretty)) diff --git a/src/vscode/superbol-vscode-platform/package.toml b/src/vscode/superbol-vscode-platform/package.toml index 4268858ab..e1a922b4b 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" @@ -62,6 +62,7 @@ polka-js-stubs = "version" promise_jsoo = "0.3.1" vscode-js-stubs = "version" vscode-languageclient-js-stubs = "version" +ez_subst = ">=0.2.1" # package tools dependencies [tools] @@ -69,15 +70,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_instance.ml b/src/vscode/superbol-vscode-platform/superbol_instance.ml index 0fc5725cf..4fed16fee 100644 --- a/src/vscode/superbol-vscode-platform/superbol_instance.ml +++ b/src/vscode/superbol-vscode-platform/superbol_instance.ml @@ -128,225 +128,6 @@ let get_project_config instance = in Promise.Result.return @@ Jsonoo.Decode.(dict id) assoc -(** Credit @beiclause in https://github.com/beicause/call-graph/blob/master/src/html.ts *) -let html dot = Printf.sprintf {| - - - - - - - Call Graph - - - - - - -
- - - - |} dot - -let _open_cfg ?text_editor instance = - let open_cfg_for ?uri client = - let uri, uri_ojs = match uri with - | Some uri -> - Jsonoo.Encode.string @@ Vscode.Uri.path uri, - Vscode.Uri.t_to_js uri - | None -> - Jsonoo.Encode.string "", Ojs.null - in - Vscode_languageclient.LanguageClient.sendRequest client () - ~meth:"superbol/openCFG" - ~data:uri |> - Promise.(then_ ~fulfilled:(fun res -> - (* TODO: do not reopen a different window for each call *) - let dot_content = Jsonoo.Decode.string res in - let newWebviewPanel = - Vscode.Window.createWebviewPanel - ~viewType:"cfg" ~title:"CFG webview" - ~showOptions:(Vscode.ViewColumn.Two) in - let webview = Vscode.WebviewPanel.webview newWebviewPanel in - Vscode.WebView.set_html webview (html dot_content); - Vscode.WebView.set_options webview (Vscode.WebviewOptions.create ~enableScripts:true ()); - let listener arg = - let node = Ojs.get_prop_ascii arg "node" |> Ojs.string_of_js in - let message = "Heard click on node: " ^ node in - let _ = Vscode.Window.showErrorMessage () ~message in - let pos = Vscode.Position.t_to_js @@ Vscode.Position.make ~line:12 ~character:20 in - let args = Ojs.empty_obj () in - Ojs.set_prop_ascii pos "position" args; - let _ = Vscode.Commands.executeCommand - ~command:"editor.action.goToLocations" - (* ~args:[uri_ojs; pos] *) - ~args:[uri_ojs; pos; Ojs.array_make 0] - in - () - in - let _ = Vscode.WebView.onDidReceiveMessage webview ~listener ~thisArgs:Ojs.null ~disposables:[] () in - return () - )) - in - match client instance, current_document_uri ?text_editor () with - | Some client, uri -> - open_cfg_for ?uri client - | None, _ -> - (* TODO: is there a way to activate the extension from here? Starting the - client/instance seems to launch two distinct LSP server processes. *) - Promise.(then_ ~fulfilled:(fun _ -> return ())) @@ - Vscode.Window.showErrorMessage () - ~message:"The SuperBOL LSP client is not running; please retry after a \ - COBOL file has been opened" - -let html_d3 = Printf.sprintf {| - - - - - - - - - - - |} - let webview_panels = Hashtbl.create 1 let create_or_get_webview ~uri = let filename = Vscode.Uri.path uri in @@ -395,7 +176,14 @@ let on_click ~nodes_pos ~decorationType ~text_editor arg = Promise.return ()) in () -let open_cfg_for ?(d3=false) ~text_editor client = +let read_whole_file filename = + (* open_in_bin works correctly on Unix and Windows *) + let ch = open_in_bin filename in + let s = really_input_string ch (in_channel_length ch) in + close_in ch; + s + +let open_cfg_for ?(d3=false) ~text_editor ~extension_uri client = let open Vscode in let uri = TextEditor.document text_editor |> TextDocument.uri in let data = @@ -410,7 +198,11 @@ let open_cfg_for ?(d3=false) ~text_editor client = Jsonoo.Decode.field "string_repr" Jsonoo.Decode.string res in let nodes_pos = Jsonoo.Decode.field "nodes_pos" Jsonoo.Decode.(dict id) res in let webview = create_or_get_webview ~uri in - let html = (if d3 then html_d3 else html) graph_content in + let img_uri = Uri.joinPath extension_uri + ~pathSegments:["assets"; if d3 then "cfg-d3-renderer.html" else "cfg-dot-renderer.html"] in + let html_file = + read_whole_file @@ Uri.fsPath img_uri in + let html = Ez_subst.V2.EZ_SUBST.string ~sep:'%' ~brace:(fun () _ -> graph_content) ~ctxt:() html_file in WebView.set_html webview html; WebView.set_options webview (WebviewOptions.create ~enableScripts:true ()); ignore( @@ -426,7 +218,8 @@ let open_cfg ?(d3=false) ?text_editor instance = | e -> e in match client instance, text_editor with | Some client, Some text_editor -> - open_cfg_for ~d3 ~text_editor client + let extension_uri = Vscode.ExtensionContext.extensionUri instance.context in + open_cfg_for ~d3 ~extension_uri ~text_editor client | _ -> Promise.return () (* debug TO REMOVE *) From 287d945d332ab281edd0a6f70f99704d860f9433 Mon Sep 17 00:00:00 2001 From: Mateo Date: Tue, 27 Aug 2024 12:53:15 +0200 Subject: [PATCH 07/40] feat: goto cfg node from file cursor pos --- assets/cfg-d3-renderer.html | 109 ++++++++++-------- src/lsp/cobol_lsp/lsp_lookup.ml | 25 ++++ src/lsp/cobol_lsp/lsp_request.ml | 23 ++++ .../src-bindings/vscode/vscode.ml | 22 ++++ .../src-bindings/vscode/vscode.mli | 19 +++ .../superbol_instance.ml | 53 ++++++++- 6 files changed, 199 insertions(+), 52 deletions(-) diff --git a/assets/cfg-d3-renderer.html b/assets/cfg-d3-renderer.html index 10cf8f761..68499064b 100644 --- a/assets/cfg-d3-renderer.html +++ b/assets/cfg-d3-renderer.html @@ -26,7 +26,7 @@ - + diff --git a/src/lsp/cobol_lsp/lsp_lookup.ml b/src/lsp/cobol_lsp/lsp_lookup.ml index 2fc7a2d0c..af7d40f86 100644 --- a/src/lsp/cobol_lsp/lsp_lookup.ml +++ b/src/lsp/cobol_lsp/lsp_lookup.ml @@ -67,6 +67,11 @@ 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 +504,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 3ef3a1571..904d29a69 100644 --- a/src/lsp/cobol_lsp/lsp_request.ml +++ b/src/lsp/cobol_lsp/lsp_request.ml @@ -154,6 +154,26 @@ let handle_open_cfg registry params = end |> Option.value ~default:(`String "") +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") " " + | None, Some cu -> ~&(cu.unit_name) + | _ -> "" in + Some (`String proc) + end + |> Option.value ~default:(`String "") + (** {3 Definitions} *) @@ -849,6 +869,9 @@ let on_request | UnknownRequest { meth = "superbol/openCFG"; params = Some param } -> Ok (handle_open_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/vendor/vscode-ocaml-platform/src-bindings/vscode/vscode.ml b/src/vendor/vscode-ocaml-platform/src-bindings/vscode/vscode.ml index 86268a547..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 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 0d14ad033..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 diff --git a/src/vscode/superbol-vscode-platform/superbol_instance.ml b/src/vscode/superbol-vscode-platform/superbol_instance.ml index 4fed16fee..579284eda 100644 --- a/src/vscode/superbol-vscode-platform/superbol_instance.ml +++ b/src/vscode/superbol-vscode-platform/superbol_instance.ml @@ -128,13 +128,18 @@ let get_project_config instance = in Promise.Result.return @@ Jsonoo.Decode.(dict id) assoc +let _log message = ignore(Vscode.Window.showInformationMessage () ~message) + let webview_panels = Hashtbl.create 1 +let window_listener = ref None let create_or_get_webview ~uri = let filename = Vscode.Uri.path uri in Vscode.WebviewPanel.webview @@ match Hashtbl.find_opt webview_panels filename with | Some webview_panel -> Vscode.WebviewPanel.reveal webview_panel (); + let webview = Vscode.WebviewPanel.webview webview_panel in + let _ = Vscode.WebView.postMessage webview (Ojs.int_to_js 2) in webview_panel | None -> let webview_panel = Vscode.Window.createWebviewPanel @@ -142,12 +147,19 @@ let create_or_get_webview ~uri = ~showOptions:(Vscode.ViewColumn.Beside) in ignore( Vscode.WebviewPanel.onDidDispose webview_panel () - ~listener:(fun () -> Hashtbl.remove webview_panels filename) - ~thisArgs:Ojs.null ~disposables:[]); + ~listener:begin fun () -> + Hashtbl.remove webview_panels filename; + if Hashtbl.length webview_panels == 0 + then ( + ignore(Option.map Vscode.Disposable.dispose !window_listener); + window_listener := None) + end ~thisArgs:Ojs.null ~disposables:[]); Hashtbl.add webview_panels filename webview_panel; webview_panel -let _log message = ignore(Vscode.Window.showInformationMessage () ~message) +let webview_find_opt ~uri = + Hashtbl.find_opt webview_panels @@ Vscode.Uri.path uri + |> Option.map Vscode.WebviewPanel.webview let create_decoration_type () = let backgroundColor = Ojs.string_to_js "#75ff3388" in @@ -176,6 +188,40 @@ let on_click ~nodes_pos ~decorationType ~text_editor arg = Promise.return ()) in () +let setup_window_listener ~client = + let open Vscode in + let listener event = + let text_editor = TextEditorSelectionChangeEvent.textEditor event in + let uri = TextEditor.document text_editor |> TextDocument.uri in + let webview = webview_find_opt ~uri in + match webview with + | None -> () + | Some webview -> + match TextEditorSelectionChangeEvent.selections event with + | [] -> () + | selection::_ -> + let pos_start = Selection.start selection in + let data = + let uri = Jsonoo.Encode.string @@ Vscode.Uri.path uri in + Jsonoo.Encode.object_ + ["uri", uri; + "line", Jsonoo.Encode.int @@ Position.line pos_start; + "character", Jsonoo.Encode.int @@ Position.character pos_start] + in + ignore( + Vscode_languageclient.LanguageClient.sendRequest client () + ~meth:"superbol/findProcedure" ~data + |> Promise.(then_ ~fulfilled:begin fun res -> + WebView.postMessage webview @@ Jsonoo.t_to_js res + end)) + in + let disposable_listener = + match !window_listener with + | Some listener -> listener + | None -> Window.onDidChangeTextEditorSelection () () + ~listener ~thisArgs:Ojs.null ~disposables:[] in + window_listener := Some disposable_listener + let read_whole_file filename = (* open_in_bin works correctly on Unix and Windows *) let ch = open_in_bin filename in @@ -209,6 +255,7 @@ let open_cfg_for ?(d3=false) ~text_editor ~extension_uri client = WebView.onDidReceiveMessage webview () ~listener:(on_click ~text_editor ~decorationType ~nodes_pos) ~thisArgs:Ojs.null ~disposables:[]); + setup_window_listener ~client; return () )) From b7a91030aca9dd60d38775fe6d1b5b04e949fffa Mon Sep 17 00:00:00 2001 From: Mateo Date: Tue, 27 Aug 2024 14:28:53 +0200 Subject: [PATCH 08/40] feat: add d3-zoom fix coloration when closing cfg --- assets/cfg-d3-renderer.html | 17 ++++++++--------- .../superbol_instance.ml | 14 +++++++++++--- 2 files changed, 19 insertions(+), 12 deletions(-) diff --git a/assets/cfg-d3-renderer.html b/assets/cfg-d3-renderer.html index 68499064b..f061dc806 100644 --- a/assets/cfg-d3-renderer.html +++ b/assets/cfg-d3-renderer.html @@ -16,16 +16,9 @@ height: 100%; width: 100%; } -button#refresh { - position: absolute; - margin: 5px; -} - - - - + +
+ +
diff --git a/dune-project b/dune-project index c0e1e8b6e..71afc2fae 100644 --- a/dune-project +++ b/dune-project @@ -35,7 +35,6 @@ (jsonoo (and (>= 0.2.1) (< 1.0.0))) (js_of_ocaml ( >= 4 )) (gen_js_api (and (>= 1.1.1) (< 2.0.0))) - (ez_subst ( >= 0.2.1 )) (js_of_ocaml-ppx ( >= 4 )) odoc ) diff --git a/opam/superbol-vscode-platform.opam b/opam/superbol-vscode-platform.opam index 509590fa7..b14389630 100644 --- a/opam/superbol-vscode-platform.opam +++ b/opam/superbol-vscode-platform.opam @@ -56,7 +56,6 @@ depends: [ "jsonoo" {>= "0.2.1" & < "1.0.0"} "js_of_ocaml" {>= "4"} "gen_js_api" {>= "1.1.1" & < "2.0.0"} - "ez_subst" {>= "0.2.1"} "js_of_ocaml-ppx" {>= "4"} "odoc" {with-doc} ] diff --git a/src/lsp/cobol_cfg/cfg_builder.ml b/src/lsp/cobol_cfg/cfg_builder.ml index 355a786bf..c1f49543c 100644 --- a/src/lsp/cobol_cfg/cfg_builder.ml +++ b/src/lsp/cobol_cfg/cfg_builder.ml @@ -68,31 +68,35 @@ let build_node ~default_name ~cu paragraph = type acc = { conditionals: Qualnames.t; unconditional: Unconditionals.t; + unreachable: bool; } - let init = {conditionals = Qualnames.empty; unconditional = Unconditionals.empty } + let init = {conditionals = Qualnames.empty; + unconditional = Unconditionals.empty; + unreachable = false; } let add_unconditional uncond acc = - { acc with unconditional = Unconditionals.add uncond acc.unconditional } + { acc with unconditional = Unconditionals.add uncond acc.unconditional; + unreachable = true; } let add_conditionals acc qn_to_jump = { acc with conditionals = Qualnames.add qn_to_jump acc.conditionals } end in - let { conditionals; unconditional } = + let { conditionals; unconditional; unreachable = _ } = Visitor.fold_procedure_paragraph' object (v) inherit [acc] Visitor.folder method! fold_goback' _ acc = skip @@ add_unconditional Goback acc - method! fold_statement' _ ({ unconditional; _ } as acc) = - match unconditional with - | u when Unconditionals.is_empty u -> do_children acc - | _ -> skip acc - + method! fold_statement' _ ({ unreachable; _ } as acc) = + if unreachable + then skip acc + else do_children acc method! fold_if' { payload = { then_branch; else_branch; _ }; _ } acc = - let { conditionals; unconditional } = + let { conditionals; unconditional; unreachable } = Cobol_ptree.Visitor.fold_statements v then_branch acc in - let { conditionals = else_cond; unconditional = else_uncond } = + let { conditionals = else_cond; unconditional = else_uncond; unreachable = else_unreach } = Cobol_ptree.Visitor.fold_statements v else_branch init in skip { conditionals = Qualnames.union conditionals else_cond; unconditional = Unconditionals.union unconditional else_uncond; + unreachable = unreachable && else_unreach } method! fold_goto' { payload; _ } acc = diff --git a/src/vscode/superbol-vscode-platform/dune b/src/vscode/superbol-vscode-platform/dune index 68ab89178..169b623f9 100644 --- a/src/vscode/superbol-vscode-platform/dune +++ b/src/vscode/superbol-vscode-platform/dune @@ -2,7 +2,7 @@ (executable (name superbol_vscode_platform) - (libraries vscode-languageclient-js-stubs vscode-js-stubs promise_jsoo polka-js-stubs ocplib_stuff node-js-stubs jsonoo js_of_ocaml gen_js_api ez_subst ) + (libraries vscode-languageclient-js-stubs vscode-js-stubs promise_jsoo polka-js-stubs ocplib_stuff node-js-stubs jsonoo js_of_ocaml gen_js_api ) (modes js) (preprocess (pps gen_js_api.ppx)) (js_of_ocaml (flags --source-map --pretty)) diff --git a/src/vscode/superbol-vscode-platform/package.toml b/src/vscode/superbol-vscode-platform/package.toml index e1a922b4b..6acb4a872 100644 --- a/src/vscode/superbol-vscode-platform/package.toml +++ b/src/vscode/superbol-vscode-platform/package.toml @@ -62,7 +62,6 @@ polka-js-stubs = "version" promise_jsoo = "0.3.1" vscode-js-stubs = "version" vscode-languageclient-js-stubs = "version" -ez_subst = ">=0.2.1" # package tools dependencies [tools] diff --git a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml index fa967097c..4c187df6a 100644 --- a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml +++ b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml @@ -12,8 +12,32 @@ (* *) (**************************************************************************) +let read_whole_file filename = + (* open_in_bin works correctly on Unix and Windows *) + let ch = open_in_bin filename in + let s = really_input_string ch (in_channel_length ch) in + close_in ch; + s + let _log message = ignore(Vscode.Window.showInformationMessage () ~message) +(* GRAPH FROM LSP *) + +type graph = { + string_repr: string; + nodes_pos: (string, Jsonoo.t) Hashtbl.t; + name: string; +} +let decode_graph res = + let string_repr = + Jsonoo.Decode.field "string_repr" Jsonoo.Decode.string res in + let nodes_pos = Jsonoo.Decode.field "nodes_pos" Jsonoo.Decode.(dict id) res in + let name = Jsonoo.Decode.field "name" Jsonoo.Decode.string res in + { name; nodes_pos; string_repr } + + +(* WEBVIEW MANAGEMENT *) + let webview_panels = Hashtbl.create 1 let window_listener = ref None let create_or_get_webview ~decorationType ~uri = @@ -53,6 +77,8 @@ let webview_find_opt ~uri = Hashtbl.find_opt webview_panels @@ Vscode.Uri.path uri |> Option.map Vscode.WebviewPanel.webview +(* CLICK ON NODE *) + let create_decoration_type () = let backgroundColor = Ojs.string_to_js "#75ff3388" in let options = Ojs.obj [|("backgroundColor", backgroundColor)|] in @@ -115,24 +141,21 @@ let setup_window_listener ~client = ~listener ~thisArgs:Ojs.null ~disposables:[] in window_listener := Some disposable_listener -let read_whole_file filename = - (* open_in_bin works correctly on Unix and Windows *) - let ch = open_in_bin filename in - let s = really_input_string ch (in_channel_length ch) in - close_in ch; - s +(* MESSAGE MANAGER *) + +let on_message ~webview ~graph ~decorationType ~text_editor arg = + let typ = Ojs.get_prop_ascii arg "type" |> Ojs.string_of_js in + match typ with + | "click" -> + on_click ~nodes_pos:graph.nodes_pos ~decorationType ~text_editor arg + | "ready" -> + let ojs = Ojs.empty_obj () in + Ojs.set_prop_ascii ojs "type" (Ojs.string_to_js "graph_content"); + Ojs.set_prop_ascii ojs "graph" (Ojs.string_to_js graph.string_repr); + let _ : bool Promise.t = Vscode.WebView.postMessage webview ojs in + () + | _ -> () -type graph = { - string_repr: string; - nodes_pos: (string, Jsonoo.t) Hashtbl.t; - name: string; -} -let decode_graph res = - let string_repr = - Jsonoo.Decode.field "string_repr" Jsonoo.Decode.string res in - let nodes_pos = Jsonoo.Decode.field "nodes_pos" Jsonoo.Decode.(dict id) res in - let name = Jsonoo.Decode.field "name" Jsonoo.Decode.string res in - { name; nodes_pos; string_repr } let open_cfg_for ?(d3=false) ~text_editor ~extension_uri client = let open Vscode in @@ -151,21 +174,19 @@ let open_cfg_for ?(d3=false) ~text_editor ~extension_uri client = |> then_ ~fulfilled:begin function | None -> return () | Some name -> - let { string_repr; nodes_pos; name = _ } = Stdlib.List.find begin fun g -> + let graph = Stdlib.List.find begin fun g -> String.equal g.name name end graphs in let webview = create_or_get_webview ~decorationType ~uri in let html_uri = Uri.joinPath extension_uri ~pathSegments: ["assets"; if d3 then "cfg-d3-renderer.html" else "cfg-dot-renderer.html"] in - let html_file = - read_whole_file @@ Uri.fsPath html_uri in - let html = Ez_subst.V2.EZ_SUBST.string ~sep:'%' ~brace:(fun () _ -> string_repr) ~ctxt:() html_file in - WebView.set_html webview html; + let html_file = read_whole_file @@ Uri.fsPath html_uri in + WebView.set_html webview html_file; WebView.set_options webview (WebviewOptions.create ~enableScripts:true ()); let _ : Disposable.t = WebView.onDidReceiveMessage webview () - ~listener:(on_click ~text_editor ~decorationType ~nodes_pos) + ~listener:(on_message ~webview ~text_editor ~decorationType ~graph) ~thisArgs:Ojs.null ~disposables:[] in setup_window_listener ~client; return () From bfd1f07fc488a82fe51eb8b085cfe3e6ce723e36 Mon Sep 17 00:00:00 2001 From: Mateo Date: Tue, 3 Sep 2024 17:45:34 +0200 Subject: [PATCH 13/40] feat: added customizable option to generate cfg --- assets/cfg-dot-renderer.html | 124 +++++++- src/lsp/cobol_cfg/cfg_builder.ml | 277 ++++++++++++------ src/lsp/cobol_cfg/cobol_cfg.ml | 1 + src/lsp/cobol_lsp/lsp_request.ml | 17 +- .../superbol_cfg_explorer.ml | 225 ++++++++------ 5 files changed, 447 insertions(+), 197 deletions(-) diff --git a/assets/cfg-dot-renderer.html b/assets/cfg-dot-renderer.html index 80b5b8c83..5f93d3944 100644 --- a/assets/cfg-dot-renderer.html +++ b/assets/cfg-dot-renderer.html @@ -5,31 +5,118 @@ COBOL CFG - - - + + + + -
+
+ + +
+
+ Rendering... Please wait
+ If this takes too much time, the CFG is probably too big to render. +
diff --git a/src/lsp/cobol_cfg/cfg_builder.ml b/src/lsp/cobol_cfg/cfg_builder.ml index c1f49543c..11698c5ca 100644 --- a/src/lsp/cobol_cfg/cfg_builder.ml +++ b/src/lsp/cobol_cfg/cfg_builder.ml @@ -15,26 +15,68 @@ open Cobol_unit.Types open Cobol_common.Visitor module NEL = Cobol_common.Basics.NEL +module Options = struct + type t = { + graph_name: string option; + hide_unreachable: bool; + collapse_fallthru: bool; + shatter_hubs: int option; + } + + let create + ?(graph_name=None) + ?(hide_unreachable=false) + ?(collapse_fallthru=true) + ?(shatter_hubs=None) + () + = { hide_unreachable; collapse_fallthru; graph_name; shatter_hubs } + +let from_yojson_assoc o = + let graph_name = + try Some (List.assoc "graph_name" o |> Yojson.Safe.Util.to_string) + with Not_found -> None in + let hide_unreachable = + try Some (List.assoc "hide_unreachable" o |> Yojson.Safe.Util.to_bool) + with Not_found -> None in + let collapse_fallthru = + try Some (List.assoc "collapse_fallthru" o |> Yojson.Safe.Util.to_bool) + with Not_found -> None in + let shatter_hubs = + try Some (List.assoc "shatter_hubs" o |> Yojson.Safe.Util.to_int) + with Not_found -> None in + create ~graph_name ?hide_unreachable ?collapse_fallthru ~shatter_hubs () +end + type qualname = Cobol_ptree.qualname -type unconditional_jumps = +type jumps = | Goback | Go of qualname + | Conditional of qualname (* includes perform, go ... depending *) module Qualnames = Set.Make(struct type t = qualname let compare = Cobol_ptree.compare_qualname end) -module Unconditionals = Set.Make(struct - type t = unconditional_jumps - let compare u1 u2 = - match u1, u2 with - | Goback, Goback -> 0 - | Go qn1, Go qn2 -> Cobol_ptree.compare_qualname qn1 qn2 - | Go _, Goback -> -1 - | Goback, Go _ -> 1 -end) +module Jumps = struct + include Set.Make(struct + type t = jumps + let compare j1 j2 = + let to_int = function + | Goback -> 0 + | Go _ -> 1 + | Conditional _ -> 2 in + match j1, j2 with + | Go qn1, Go qn2 -> Cobol_ptree.compare_qualname qn1 qn2 + | Conditional qn1, Conditional qn2 -> Cobol_ptree.compare_qualname qn1 qn2 + | _ -> to_int j2 - to_int j1 + end) + let only_conditional : t -> bool = + for_all begin function + | Conditional _ -> true | _ -> false + end +end module Qmap = Map.Make(struct type t = qualname @@ -47,8 +89,8 @@ type node = { mutable names: string NEL.t; loc: srcloc option; entry: bool; - conditional_jumps: Qualnames.t; - unconditional_jumps: Unconditionals.t; + jumps: Jumps.t; + is_external: bool; } let qn_to_string qn = @@ -66,20 +108,18 @@ let node_idx = ref 0 let build_node ~default_name ~cu paragraph = let open struct type acc = { - conditionals: Qualnames.t; - unconditional: Unconditionals.t; + jumps: Jumps.t; unreachable: bool; } - let init = {conditionals = Qualnames.empty; - unconditional = Unconditionals.empty; - unreachable = false; } + let init = { jumps = Jumps.empty; + unreachable = false; } let add_unconditional uncond acc = - { acc with unconditional = Unconditionals.add uncond acc.unconditional; - unreachable = true; } + { jumps = Jumps.add uncond acc.jumps; + unreachable = true; } let add_conditionals acc qn_to_jump = - { acc with conditionals = Qualnames.add qn_to_jump acc.conditionals } + { acc with jumps = Jumps.add (Conditional qn_to_jump) acc.jumps } end in - let { conditionals; unconditional; unreachable = _ } = + let { jumps; unreachable = _ } = Visitor.fold_procedure_paragraph' object (v) inherit [acc] Visitor.folder @@ -89,16 +129,14 @@ let build_node ~default_name ~cu paragraph = then skip acc else do_children acc method! fold_if' { payload = { then_branch; else_branch; _ }; _ } acc = - let { conditionals; unconditional; unreachable } = + let { jumps; unreachable } = Cobol_ptree.Visitor.fold_statements v then_branch acc in - let { conditionals = else_cond; unconditional = else_uncond; unreachable = else_unreach } = + let { jumps = else_j; unreachable = else_unreach } = Cobol_ptree.Visitor.fold_statements v else_branch init in skip { - conditionals = Qualnames.union conditionals else_cond; - unconditional = Unconditionals.union unconditional else_uncond; + jumps = Jumps.union jumps else_j; unreachable = unreachable && else_unreach } - method! fold_goto' { payload; _ } acc = skip @@ match payload with @@ -112,7 +150,6 @@ let build_node ~default_name ~cu paragraph = method! fold_perform_target' { payload; _ } acc = skip @@ let { payload = start; _ } = payload.perform_target.procedure_start in - (* TODO: check that where we jump has no unconditional_jumps, /!\ cycle` *) add_conditionals acc (full_qn ~cu start) end paragraph init @@ -128,8 +165,8 @@ let build_node ~default_name ~cu paragraph = names = NEL.One name; loc = Some loc; entry = false; - conditional_jumps = conditionals; - unconditional_jumps = unconditional; + jumps; + is_external = false; } module Node = struct @@ -177,6 +214,7 @@ let vertex_name_no_newline { names; _ } = (NEL.rev names) |> Str.global_replace (Str.regexp "\n") " " + (* Graph.Graphviz.DotAttributes *) module Dot = Graph.Graphviz.Dot(struct include Cfg let edge_attributes (_,s,_) = @@ -186,12 +224,13 @@ module Dot = Graph.Graphviz.Dot(struct | Unconditional -> `Solid)] let default_edge_attributes _ = [] let get_subgraph _ = None - let vertex_attributes ({ unconditional_jumps; entry; _ } as n) = + let vertex_attributes ({ entry; is_external; _ } as n) = [`Label (if entry then vertex_name n else vertex_name_record n)] - @ (if Unconditionals.mem Goback unconditional_jumps - then [`Style `Bold] - else []) - @ (if entry then [`Shape `Doubleoctagon] else []) + @ (if entry + then [`Shape `Doubleoctagon] + else if is_external + then [`Shape `Plaintext] + else []) let default_vertex_attributes _ = [`Shape `Record] let graph_attributes _ = [] let vertex_name { id; _ } = string_of_int id @@ -208,62 +247,101 @@ let dummy_node qn = loc = None; entry = false; names = NEL.One (qn_to_string qn); - unconditional_jumps = Unconditionals.empty; - conditional_jumps = Qualnames.empty; + jumps = Jumps.empty; + is_external = true; } -let qmap_find_or_add cfg qn qmap = +let clone_node node = + node_idx:= !node_idx + 1; + { node with id = !node_idx; } + +let qmap_find_or_add qmap qn = match Qmap.find_opt qn qmap with | None -> let node = dummy_node qn in - node, Cfg.add_vertex cfg node - | Some node -> node, cfg + (* qmap, node *) + Qmap.add qn node qmap, node + | Some node -> qmap, node let rec build_edges ~vertexes g nodes = - let g = match nodes with - | ({ conditional_jumps; unconditional_jumps; _ } as current)::_ -> - Qualnames.fold begin fun jump_to g -> - let next, g = qmap_find_or_add g jump_to vertexes in - Cfg.add_edge_e g (current, Conditional, next) - end conditional_jumps g - |> Unconditionals.fold begin fun uncond g -> + let g, vertexes = match nodes with + | ({ jumps; _ } as current)::_ -> + Jumps.fold begin fun uncond (g, vertexes) -> match uncond with - | Goback -> g + | Goback -> g, vertexes | Go jump_to -> - let next, g = qmap_find_or_add g jump_to vertexes in - Cfg.add_edge_e g (current, Unconditional, next) - end unconditional_jumps - | [] -> g + let vertexes, next = qmap_find_or_add vertexes jump_to in + Cfg.add_edge_e g (current, Unconditional, next), + vertexes + | Conditional jump_to -> + let vertexes, next = qmap_find_or_add vertexes jump_to in + Cfg.add_edge_e g (current, Conditional, next), + vertexes + end jumps (g, vertexes) + | [] -> g, vertexes in match nodes with - | ({ unconditional_jumps; _ } as current)::next::tl - when Unconditionals.is_empty unconditional_jumps -> + | ({ jumps; _ } as current)::next::tl + when Jumps.only_conditional jumps -> build_edges ~vertexes (Cfg.add_edge g current next) (next::tl) | _::tl -> build_edges ~vertexes g tl | [] -> g -let cfg_of_nodes ~fall_thru_compact nodes = + +let do_collapse_fallthru g = + Cfg.fold_vertex begin fun n cfg -> + match Cfg.pred_e cfg n with + | [(({ entry = false; _ } as pred), FallThrough, _)] -> + let cfg = Cfg.fold_succ_e begin fun (_, e, next) cfg -> + if List.exists + begin fun succ -> qn_equal succ.qid next.qid end + (Cfg.succ cfg pred) + then cfg + else Cfg.add_edge_e cfg (pred, e, next) + end cfg n cfg in + pred.names <- NEL.(n.names @ pred.names); + Cfg.remove_vertex cfg n + | _ -> cfg + end g g + +let do_hide_unreachable g = + let rec aux cfg = + let did_remove, cfg = + Cfg.fold_vertex begin fun n (did_remove, cfg) -> + if Cfg.in_degree cfg n <= 0 && not n.entry + 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 do_shatter_hubs ?(limit=20) g = + Cfg.fold_vertex begin fun n cfg -> + if Cfg.in_degree cfg n >= limit && not n.entry + then begin + Cfg.fold_pred_e begin fun edge cfg -> + let cfg = Cfg.remove_edge_e cfg edge in + let n_clone = clone_node n in + let (pred, edge, _) = edge in + let cfg = Cfg.add_edge_e cfg (pred, edge, n_clone) in + cfg + end cfg n cfg + end + else cfg + end g g + +let cfg_of_nodes ~(options: Options.t) nodes = let g, vertexes = List.fold_left begin fun (g, vertexes) node -> Cfg.add_vertex g node, Qmap.add node.qid node vertexes end (Cfg.empty, Qmap.empty) nodes in - let g = build_edges ~vertexes g nodes in - if not fall_thru_compact - then g - else Cfg.fold_vertex begin fun n cfg -> - match Cfg.pred_e cfg n with - | [(({ entry = false; _ } as pred), FallThrough, _)] -> - let cfg = Cfg.fold_succ_e begin fun (_, e, next) cfg -> - if List.exists - begin fun succ -> qn_equal succ.qid next.qid end - (Cfg.succ cfg pred) - then cfg - else Cfg.add_edge_e cfg (pred, e, next) - end cfg n cfg in - pred.names <- NEL.(n.names @ pred.names); - Cfg.remove_vertex cfg n - | _ -> cfg - end g g + build_edges ~vertexes g nodes + |> (if options.collapse_fallthru then do_collapse_fallthru else Fun.id) + |> (match options.shatter_hubs with + | Some limit -> do_shatter_hubs ~limit + | _ -> Fun.id) + |> (if options.hide_unreachable then do_hide_unreachable else Fun.id) let cfg_of ~(cu: cobol_unit) = node_idx := 0; @@ -295,7 +373,10 @@ let cfg_of_section ~cu ({ section_paragraphs; section_name }: procedure_section) List.fold_left begin fun acc p -> build_node ~default_name ~cu p :: acc end [] section_paragraphs.list - |> List.rev + |> List.rev in + let nodes = match nodes with + | entry::tl -> { entry with entry = true }::tl + | [] -> [] in cfg_of_nodes nodes type graph = { @@ -311,33 +392,47 @@ let nodes_pos cfg = | Some loc -> (n.id, loc)::acc end cfg [] -let make_dot ({ group; _ }: Cobol_typeck.Outputs.t) = +let make_dot ~(options: Options.t) ({ group; _ }: Cobol_typeck.Outputs.t) = + let is_to_include : string -> bool = + match options.graph_name with + | None -> Fun.const true + | Some name -> String.equal name in Cobol_unit.Collections.SET.fold begin fun { payload = cu; _ } acc -> let section_graphs = List.filter_map begin function | Paragraph _ -> None - | Section sec -> Some ( - let name = - Pretty.to_string "%a" Cobol_ptree.pp_qualname' ~&sec.section_name in - let cfg = cfg_of_section ~fall_thru_compact:true ~cu ~&sec in - let nodes_pos = nodes_pos cfg in { - name; - string_repr = string_of cfg; - nodes_pos; - }) + | Section sec -> + let name = Pretty.to_string "%a (%s)" + Cobol_ptree.pp_qualname' ~&sec.section_name + ((~&) cu.unit_name) in + if not (is_to_include name) + then None + else Some ( + let cfg = cfg_of_section ~options ~cu ~&sec in + let nodes_pos = nodes_pos cfg in { + name; + string_repr = string_of cfg; + nodes_pos; + }) end cu.unit_procedure.list in - let cfg = cfg_of ~fall_thru_compact:true ~cu in - { - name = (~&)cu.unit_name; - string_repr = string_of cfg; - nodes_pos = nodes_pos cfg; - } :: section_graphs @ acc + let cu_graph = + if is_to_include ((~&) cu.unit_name) + then + let cfg = cfg_of ~options ~cu in + [{ + name = (~&)cu.unit_name; + string_repr = string_of cfg; + nodes_pos = nodes_pos cfg; + }] + else [] + in cu_graph @ section_graphs @ acc end group [] let make_d3 ({ group; _ }: Cobol_typeck.Outputs.t) = + let options = Options.create ~collapse_fallthru:false () in Cobol_unit.Collections.SET.fold begin fun { payload = cu; _ } acc -> - let cfg = cfg_of ~fall_thru_compact:false ~cu in + let cfg = cfg_of ~options ~cu in let cfg_edges = Cfg.fold_edges_e begin fun (n1, e, n2) links -> links @@ -356,10 +451,10 @@ let make_d3 ({ group; _ }: Cobol_typeck.Outputs.t) = } :: acc end group [] -let make ?(d3=false) (checked_doc: Cobol_typeck.Outputs.t) = +let make ?(d3=false) ~options (checked_doc: Cobol_typeck.Outputs.t) = if d3 then make_d3 checked_doc - else make_dot checked_doc + else make_dot ~options checked_doc (* List of node (sections & paragraphs) diff --git a/src/lsp/cobol_cfg/cobol_cfg.ml b/src/lsp/cobol_cfg/cobol_cfg.ml index 5e0aa801f..2b6739014 100644 --- a/src/lsp/cobol_cfg/cobol_cfg.ml +++ b/src/lsp/cobol_cfg/cobol_cfg.ml @@ -18,5 +18,6 @@ end module Builder = struct type graph = Cfg_builder.graph + module Options = Cfg_builder.Options let make = Cfg_builder.make end diff --git a/src/lsp/cobol_lsp/lsp_request.ml b/src/lsp/cobol_lsp/lsp_request.ml index c1ab10229..75c3709a9 100644 --- a/src/lsp/cobol_lsp/lsp_request.ml +++ b/src/lsp/cobol_lsp/lsp_request.ml @@ -135,27 +135,28 @@ let handle_get_project_config_command param registry = let handle_open_cfg registry params = let params = Jsonrpc.Structured.yojson_of_t params in - let uri = Yojson.Safe.Util.to_string @@ Yojson.Safe.Util.member "uri" params in - let d3 = Yojson.Safe.Util.to_bool @@ Yojson.Safe.Util.member "is_d3" params in + let uri, d3, options = Yojson.Safe.Util.( + to_string @@ member "uri" params, + to_bool @@ member "is_d3" 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 open Cobol_cfg.Builder in - let graphs = make ~d3 checked_doc in + let options = Options.from_yojson_assoc options in + let graphs = make ~d3 ~options checked_doc in let yojsonify ({ string_repr; name; nodes_pos } : graph) = - Lsp_io.log_debug "%s %s" name string_repr; let nodes_pos = List.map begin fun (n,loc) -> let range = Lsp_position.range_of_srcloc_in ~filename:uri loc in (string_of_int n, Range.yojson_of_t range) end nodes_pos in - Lsp_io.log_debug "%s" name; `Assoc [ ("string_repr", `String string_repr); ("nodes_pos", `Assoc nodes_pos); ("name", `String name);] in - let res = Some (`List (List.map yojsonify graphs)) in - Lsp_io.log_debug "seding"; res + Some (`List (List.map yojsonify graphs)) end |> Option.value ~default:(`List []) @@ -871,7 +872,7 @@ let on_request | UnknownRequest { meth = "superbol/getProjectConfiguration"; params = Some param } -> handle_get_project_config_command param registry - | UnknownRequest { meth = "superbol/openCFG"; + | UnknownRequest { meth = "superbol/CFG"; params = Some param } -> Ok (handle_open_cfg registry param, state) | UnknownRequest { meth = "superbol/findProcedure"; diff --git a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml index 4c187df6a..c9d5a5e23 100644 --- a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml +++ b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml @@ -12,6 +12,8 @@ (* *) (**************************************************************************) +open Vscode + let read_whole_file filename = (* open_in_bin works correctly on Unix and Windows *) let ch = open_in_bin filename in @@ -19,19 +21,27 @@ let read_whole_file filename = close_in ch; s -let _log message = ignore(Vscode.Window.showInformationMessage () ~message) +let _log message = ignore(Window.showInformationMessage () ~message) + +(* DECORATION TYPE *) + +let decorationType = + let backgroundColor = Ojs.string_to_js "#75ff3388" in + let options = Ojs.obj [|("backgroundColor", backgroundColor)|] in + Window.createTextEditorDecorationType ~options (* GRAPH FROM LSP *) type graph = { string_repr: string; - nodes_pos: (string, Jsonoo.t) Hashtbl.t; + nodes_pos: (string * Jsonoo.t) list; name: string; } let decode_graph res = let string_repr = Jsonoo.Decode.field "string_repr" 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 } @@ -40,58 +50,70 @@ let decode_graph res = let webview_panels = Hashtbl.create 1 let window_listener = ref None -let create_or_get_webview ~decorationType ~uri = - let filename = Vscode.Uri.path uri in - Vscode.WebviewPanel.webview @@ + +let webviewpanel_disposal ~filename () = + Hashtbl.remove webview_panels filename; + if Hashtbl.length webview_panels == 0 + then ( + Option.iter Disposable.dispose !window_listener; + window_listener := None); + match Window.activeTextEditor () with + | None -> () + | Some text_editor -> + let uri = TextEditor.document text_editor + |> TextDocument.uri in + if String.equal filename @@ Uri.path uri + then TextEditor.setDecorations text_editor + ~decorationType ~rangesOrOptions:(`Ranges []) + +let create_or_get_webview ~graph ~uri = + let filename = Uri.path uri in match Hashtbl.find_opt webview_panels filename with - | Some webview_panel -> - Vscode.WebviewPanel.reveal webview_panel (); - let webview = Vscode.WebviewPanel.webview webview_panel in - let _ : bool Promise.t = Vscode.WebView.postMessage webview (Ojs.int_to_js 2) in - webview_panel + | Some (webview_panel, _) -> + WebviewPanel.reveal webview_panel (); + Hashtbl.replace webview_panels filename (webview_panel, graph); + WebviewPanel.webview webview_panel, false | None -> - let webview_panel = Vscode.Window.createWebviewPanel + let webview_panel = Window.createWebviewPanel ~viewType:"CFG" ~title:"COBOL CFG Viewer" - ~showOptions:(Vscode.ViewColumn.Beside) in - let _ : Vscode.Disposable.t = - Vscode.WebviewPanel.onDidDispose webview_panel () - ~listener:begin fun () -> - Hashtbl.remove webview_panels filename; - if Hashtbl.length webview_panels == 0 - then ( - Option.iter Vscode.Disposable.dispose !window_listener; - window_listener := None); - match Vscode.Window.activeTextEditor () with - | None -> () - | Some text_editor -> - let uri = Vscode.TextEditor.document text_editor - |> Vscode.TextDocument.uri in - if String.equal filename @@ Vscode.Uri.path uri - then Vscode.TextEditor.setDecorations text_editor - ~decorationType ~rangesOrOptions:(`Ranges []); - end ~thisArgs:Ojs.null ~disposables:[] in - Hashtbl.add webview_panels filename webview_panel; - webview_panel + ~showOptions:(ViewColumn.Beside) in + let _ : Disposable.t = + WebviewPanel.onDidDispose webview_panel () + ~listener:(webviewpanel_disposal ~filename) + ~thisArgs:Ojs.null ~disposables:[] in + let webview = WebviewPanel.webview webview_panel in + WebView.set_options webview (WebviewOptions.create ~enableScripts:true ()); + Hashtbl.add webview_panels filename (webview_panel, graph); + webview, true -let webview_find_opt ~uri = - Hashtbl.find_opt webview_panels @@ Vscode.Uri.path uri - |> Option.map Vscode.WebviewPanel.webview +let webview_n_graph_find_opt ~uri = + Hashtbl.find_opt webview_panels @@ Uri.path uri + |> Option.map begin fun (w,g) -> WebviewPanel.webview w, g end -(* CLICK ON NODE *) +let update_graph ~uri graph = + let filename = Uri.path uri in + match Hashtbl.find_opt webview_panels filename with + | Some (wvp, _) -> + Hashtbl.add webview_panels filename (wvp, graph) + | None -> () -let create_decoration_type () = - let backgroundColor = Ojs.string_to_js "#75ff3388" in - let options = Ojs.obj [|("backgroundColor", backgroundColor)|] in - Vscode.Window.createTextEditorDecorationType ~options +(* CLICK ON NODE *) -let on_click ~nodes_pos ~decorationType ~text_editor arg = +let on_click ~nodes_pos ~text_editor arg = let open Vscode in let uri = TextDocument.uri @@ TextEditor.document text_editor in let column = TextEditor.viewColumn text_editor in let node = Ojs.get_prop_ascii arg "node" |> Ojs.string_of_js in - match Hashtbl.find_opt nodes_pos node with - | None -> () +let message = List.split nodes_pos |> fst |> String.concat " " in + match List.assoc_opt node nodes_pos with + | None -> + + let message = "NOT found " ^ node ^ " $$$ " ^ message in + let _ = Window.showErrorMessage ~message () in + () | Some range -> + let message = "found " ^ node ^ " $$$ " ^ message in + let _ = Window.showErrorMessage ~message () in let range = Range.t_of_js @@ Jsonoo.t_to_js range in let _ : unit Promise.t = Window.showTextDocument ~document:(`Uri uri) ?column () @@ -107,20 +129,19 @@ let on_click ~nodes_pos ~decorationType ~text_editor arg = in () let setup_window_listener ~client = - let open Vscode in let listener event = let text_editor = TextEditorSelectionChangeEvent.textEditor event in let uri = TextEditor.document text_editor |> TextDocument.uri in - let webview = webview_find_opt ~uri in + let webview = webview_n_graph_find_opt ~uri in match webview with | None -> () - | Some webview -> + | Some (webview, _) -> match TextEditorSelectionChangeEvent.selections event with | [] -> () | selection::_ -> let pos_start = Selection.start selection in let data = - let uri = Jsonoo.Encode.string @@ Vscode.Uri.path uri in + let uri = Jsonoo.Encode.string @@ Uri.path uri in Jsonoo.Encode.object_ ["uri", uri; "line", Jsonoo.Encode.int @@ Position.line pos_start; @@ -143,31 +164,63 @@ let setup_window_listener ~client = (* MESSAGE MANAGER *) -let on_message ~webview ~graph ~decorationType ~text_editor arg = - let typ = Ojs.get_prop_ascii arg "type" |> Ojs.string_of_js in - match typ with - | "click" -> - on_click ~nodes_pos:graph.nodes_pos ~decorationType ~text_editor arg - | "ready" -> - let ojs = Ojs.empty_obj () in - Ojs.set_prop_ascii ojs "type" (Ojs.string_to_js "graph_content"); - Ojs.set_prop_ascii ojs "graph" (Ojs.string_to_js graph.string_repr); - let _ : bool Promise.t = Vscode.WebView.postMessage webview ojs in - () - | _ -> () +let send_graph webview graph = + let ojs = Ojs.empty_obj () in + Ojs.set_prop_ascii ojs "type" (Ojs.string_to_js "graph_content"); + Ojs.set_prop_ascii ojs "graph" (Ojs.string_to_js graph.string_repr); + let _ : bool Promise.t = WebView.postMessage webview ojs + in () + +let on_message ~client ~text_editor arg = + let uri = TextEditor.document text_editor |> TextDocument.uri in + match webview_n_graph_find_opt ~uri with + | None -> () + | Some (webview, graph) -> + let typ = Ojs.get_prop_ascii arg "type" |> Ojs.string_of_js in + match typ with + | "click" -> + on_click ~nodes_pos:graph.nodes_pos ~text_editor arg + | "graph_update" -> + let options = + Ojs.get_prop_ascii arg "renderOptions" + |> begin fun ojs -> + Ojs.set_prop_ascii ojs "graph_name" @@ Ojs.string_to_js graph.name; + ojs end + |> Jsonoo.t_of_js in + let data = + let uri = Jsonoo.Encode.string @@ Uri.path uri in + Jsonoo.Encode.object_ ["uri", uri; + "is_d3", Jsonoo.Encode.bool false; + "render_options", options;] in + let _ : unit Promise.t = + Vscode_languageclient.LanguageClient.sendRequest client () + ~meth:"superbol/CFG" ~data + |> Promise.then_ ~fulfilled:begin fun jsonoo_graphs -> + let graphs = Jsonoo.Decode.list decode_graph jsonoo_graphs in + match graphs with + | [] -> + Window.showErrorMessage () + ~message:"Unable to perform operation, try reloading the CFG" + |> Promise.map (Fun.const ()) + | graph::_ -> + update_graph ~uri graph; + send_graph webview graph; + Promise.return () + end + in () + | "ready" -> send_graph webview graph + | _ -> () let open_cfg_for ?(d3=false) ~text_editor ~extension_uri client = - let open Vscode in let open Promise in let uri = TextEditor.document text_editor |> TextDocument.uri in let data = - let uri = Jsonoo.Encode.string @@ Vscode.Uri.path uri in + let uri = Jsonoo.Encode.string @@ Uri.path uri in Jsonoo.Encode.object_ ["uri", uri; "is_d3", Jsonoo.Encode.bool d3] in - let decorationType = create_decoration_type () in Vscode_languageclient.LanguageClient.sendRequest client () - ~meth:"superbol/openCFG" ~data + ~meth:"superbol/CFG" ~data |> then_ ~fulfilled:begin fun jsonoo_graphs -> let graphs = Jsonoo.Decode.list decode_graph jsonoo_graphs in Window.showQuickPick ~items:(Stdlib.List.map (fun g -> g.name) graphs) () @@ -176,18 +229,23 @@ let open_cfg_for ?(d3=false) ~text_editor ~extension_uri client = | Some name -> let graph = Stdlib.List.find begin fun g -> String.equal g.name name end graphs in - let webview = create_or_get_webview ~decorationType ~uri in - let html_uri = Uri.joinPath extension_uri - ~pathSegments: - ["assets"; - if d3 then "cfg-d3-renderer.html" else "cfg-dot-renderer.html"] in - let html_file = read_whole_file @@ Uri.fsPath html_uri in - WebView.set_html webview html_file; - WebView.set_options webview (WebviewOptions.create ~enableScripts:true ()); + let webview, is_new = create_or_get_webview ~graph ~uri in let _ : Disposable.t = WebView.onDidReceiveMessage webview () - ~listener:(on_message ~webview ~text_editor ~decorationType ~graph) - ~thisArgs:Ojs.null ~disposables:[] in + ~listener:(on_message ~client ~text_editor) + ~thisArgs:Ojs.null ~disposables:[] + in + if is_new + then begin + let html_uri = Uri.joinPath extension_uri + ~pathSegments: + ["assets"; + if d3 then "cfg-d3-renderer.html" + else "cfg-dot-renderer.html"] in + let html_file = read_whole_file @@ Uri.fsPath html_uri in + WebView.set_html webview html_file; + end + else send_graph webview graph; setup_window_listener ~client; return () end @@ -195,11 +253,11 @@ let open_cfg_for ?(d3=false) ~text_editor ~extension_uri client = let open_cfg ?(d3=false) ?text_editor instance = let text_editor = match text_editor with - | None -> Vscode.Window.activeTextEditor () + | None -> Window.activeTextEditor () | e -> e in match Superbol_instance.client instance, text_editor with | Some client, Some text_editor -> - let extension_uri = Vscode.ExtensionContext.extensionUri + let extension_uri = ExtensionContext.extensionUri @@ Superbol_instance.context instance in open_cfg_for ~d3 ~extension_uri ~text_editor client | _ -> Promise.return () @@ -207,18 +265,17 @@ let open_cfg ?(d3=false) ?text_editor instance = (* debug TO REMOVE *) let debugWebviewPanelRef = ref None let open_webview ?text_editor instance = - let open Vscode in let open_cfg_for ~text _client = let webviewPanel = match !debugWebviewPanelRef with | None -> Window.createWebviewPanel ~viewType:"cfg" ~title:"Tester webview" - ~showOptions:(Vscode.ViewColumn.Two) + ~showOptions:(ViewColumn.Two) | Some wvp -> wvp in debugWebviewPanelRef := Some webviewPanel; - let webview = Vscode.WebviewPanel.webview webviewPanel in - Vscode.WebView.set_html webview text; - Vscode.WebView.set_options webview (Vscode.WebviewOptions.create ~enableScripts:true ()); + let webview = WebviewPanel.webview webviewPanel in + WebView.set_html webview text; + WebView.set_options webview (WebviewOptions.create ~enableScripts:true ()); let thisArgs, disposables = Ojs.null, [] in let _ : Disposable.t = WebviewPanel.onDidDispose webviewPanel () @@ -228,21 +285,21 @@ let open_webview ?text_editor instance = let typ = Ojs.type_of arg in let com = Ojs.get_prop_ascii arg "command" |> Ojs.string_of_js in let message = "Listener clicked " ^ typ ^ " " ^ com in - let _ : _ option Promise.t = Vscode.Window.showErrorMessage () ~message in + let _ : _ option Promise.t = Window.showErrorMessage () ~message in () in let _ : Disposable.t = - Vscode.WebView.onDidReceiveMessage webview () + WebView.onDidReceiveMessage webview () ~listener ~thisArgs:Ojs.null ~disposables:[] in WebviewPanel.reveal webviewPanel ~preserveFocus:true (); Promise.return () in let current_text ?text_editor () = match - match text_editor with None -> Vscode.Window.activeTextEditor () | e -> e + match text_editor with None -> Window.activeTextEditor () | e -> e with | None -> None - | Some e -> Some (Vscode.TextDocument.getText (Vscode.TextEditor.document e) ()) + | Some e -> Some (TextDocument.getText (TextEditor.document e) ()) in match Superbol_instance.client instance, current_text ?text_editor () with | Some client, Some text -> @@ -251,7 +308,7 @@ let open_webview ?text_editor instance = (* TODO: is there a way to activate the extension from here? Starting the client/instance seems to launch two distinct LSP server processes. *) Promise.(then_ ~fulfilled:(fun _ -> return ())) @@ - Vscode.Window.showErrorMessage () + Window.showErrorMessage () ~message:"The SuperBOL LSP client is not running; please retry after a \ COBOL file has been opened" From c44e2147c0c04841397fe4fd907b7b2cbbe07707 Mon Sep 17 00:00:00 2001 From: Mateo Date: Thu, 5 Sep 2024 11:45:52 +0200 Subject: [PATCH 14/40] feat: add arc cfg diagram --- assets/cfg-arc-renderer.html | 234 ++++++++++++++++++ assets/cfg-dot-renderer.html | 3 +- src/lsp/cobol_cfg/cfg_builder.ml | 97 ++++---- src/lsp/cobol_lsp/lsp_request.ml | 14 +- .../superbol_cfg_explorer.ml | 55 ++-- .../superbol_cfg_explorer.mli | 2 +- .../superbol_commands.ml | 2 +- 7 files changed, 323 insertions(+), 84 deletions(-) create mode 100644 assets/cfg-arc-renderer.html diff --git a/assets/cfg-arc-renderer.html b/assets/cfg-arc-renderer.html new file mode 100644 index 000000000..ce73dac92 --- /dev/null +++ b/assets/cfg-arc-renderer.html @@ -0,0 +1,234 @@ + + + + + +
+ + diff --git a/assets/cfg-dot-renderer.html b/assets/cfg-dot-renderer.html index 5f93d3944..69d76e7f2 100644 --- a/assets/cfg-dot-renderer.html +++ b/assets/cfg-dot-renderer.html @@ -101,6 +101,7 @@ } vscode.postMessage({ type: 'graph_update', + graph_type: 'dot', renderOptions: { hide_unreachable, collapse_fallthru, @@ -142,6 +143,6 @@ break; } }) - vscode.postMessage({type: 'ready'}) + vscode.postMessage({type: 'ready', graph_type: 'dot'}) diff --git a/src/lsp/cobol_cfg/cfg_builder.ml b/src/lsp/cobol_cfg/cfg_builder.ml index 11698c5ca..5f0a0564c 100644 --- a/src/lsp/cobol_cfg/cfg_builder.ml +++ b/src/lsp/cobol_cfg/cfg_builder.ml @@ -190,7 +190,7 @@ module Edge = struct let equal = (=) let default = FallThrough let to_string = function - | FallThrough -> "d" + | FallThrough -> "f" | Conditional -> "c" | Unconditional -> "u" end @@ -208,11 +208,8 @@ let vertex_name { names; _ } = (NEL.rev names) -let vertex_name_no_newline { names; _ } = - Pretty.to_string "%a" - (NEL.pp ~fopen:"" ~fclose:"" ~fsep:";" Fmt.string) - (NEL.rev names) - |> Str.global_replace (Str.regexp "\n") " " +let qid_to_string { qid; _ } = + Pretty.to_string "%a" Cobol_ptree.pp_qualname qid (* Graph.Graphviz.DotAttributes *) module Dot = Graph.Graphviz.Dot(struct @@ -236,7 +233,7 @@ module Dot = Graph.Graphviz.Dot(struct let vertex_name { id; _ } = string_of_int id end) -let string_of g = +let to_dot_string g = Pretty.to_string "%a" Dot.fprint_graph g let dummy_node qn = @@ -330,13 +327,16 @@ let do_shatter_hubs ?(limit=20) g = else cfg end g g -let cfg_of_nodes ~(options: Options.t) nodes = +let cfg_of_nodes nodes = let g, vertexes = List.fold_left begin fun (g, vertexes) node -> Cfg.add_vertex g node, Qmap.add node.qid node vertexes end (Cfg.empty, Qmap.empty) nodes in build_edges ~vertexes g nodes + +let handle_cfg_options ~(options: Options.t) cfg = + cfg |> (if options.collapse_fallthru then do_collapse_fallthru else Fun.id) |> (match options.shatter_hubs with | Some limit -> do_shatter_hubs ~limit @@ -360,9 +360,9 @@ let cfg_of ~(cu: cobol_unit) = |> begin function (* adding entry point if not already present *) | ({ qid; _ } as hd )::tl when qn_equal qid default_name -> - { hd with entry = true; names = NEL.One "Entry\nparagraph" }::tl + { hd with id=0; entry = true; names = NEL.One "Entry\nparagraph" }::tl | l -> - { (dummy_node default_name) with entry = true; names = NEL.One "Entry\npoint" } :: l + { (dummy_node default_name) with id=0; entry = true; names = NEL.One "Entry\npoint" } :: l end |> cfg_of_nodes @@ -381,7 +381,8 @@ let cfg_of_section ~cu ({ section_paragraphs; section_name }: procedure_section) type graph = { name: string; - string_repr: string; + string_repr_dot: string; + string_repr_d3: string; nodes_pos: (int * srcloc) list } @@ -392,9 +393,25 @@ let nodes_pos cfg = | Some loc -> (n.id, loc)::acc end cfg [] -let make_dot ~(options: Options.t) ({ group; _ }: Cobol_typeck.Outputs.t) = +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 -> + Pretty.to_string "{\"id\":%d,\"name\":\"%s\"}" n.id (qid_to_string n) + :: 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 make_cfg ?(graph_name=None) ({ group; _ }: Cobol_typeck.Outputs.t) = let is_to_include : string -> bool = - match options.graph_name with + match graph_name with | None -> Fun.const true | Some name -> String.equal name in Cobol_unit.Collections.SET.fold @@ -407,54 +424,26 @@ let make_dot ~(options: Options.t) ({ group; _ }: Cobol_typeck.Outputs.t) = ((~&) cu.unit_name) in if not (is_to_include name) then None - else Some ( - let cfg = cfg_of_section ~options ~cu ~&sec in - let nodes_pos = nodes_pos cfg in { - name; - string_repr = string_of cfg; - nodes_pos; - }) + else Some ( name, cfg_of_section ~cu ~&sec) end cu.unit_procedure.list in let cu_graph = if is_to_include ((~&) cu.unit_name) - then - let cfg = cfg_of ~options ~cu in - [{ - name = (~&)cu.unit_name; - string_repr = string_of cfg; - nodes_pos = nodes_pos cfg; - }] + then [((~&)cu.unit_name, cfg_of ~cu)] else [] in cu_graph @ section_graphs @ acc end group [] -let make_d3 ({ group; _ }: Cobol_typeck.Outputs.t) = - let options = Options.create ~collapse_fallthru:false () in - Cobol_unit.Collections.SET.fold - begin fun { payload = cu; _ } acc -> - let cfg = cfg_of ~options ~cu in - let cfg_edges = Cfg.fold_edges_e - begin fun (n1, e, n2) links -> - links - ^ Pretty.to_string "{source: %d, target:%d, type:'%s'}," - n1.id n2.id (Edge.to_string e) - end cfg "[" ^ "]" in - let cfg_nodes = Cfg.fold_vertex - begin fun n nodes -> - nodes - ^ Pretty.to_string "{id:%d, name: '%s'}," n.id (vertex_name_no_newline n) - end cfg "[" ^ "]" in - { - name = (~&)cu.unit_name; - string_repr = Pretty.to_string "{links:%s, nodes:%s}" cfg_edges cfg_nodes; - nodes_pos = nodes_pos cfg - } :: acc - end group [] - -let make ?(d3=false) ~options (checked_doc: Cobol_typeck.Outputs.t) = - if d3 - then make_d3 checked_doc - else make_dot ~options checked_doc +let make ~(options: Options.t) (checked_doc: Cobol_typeck.Outputs.t) = + make_cfg ~graph_name:options.graph_name checked_doc + |> List.map begin fun (name, cfg) -> + let cfg_with_options = handle_cfg_options ~options cfg in + { + name; + string_repr_dot = to_dot_string cfg_with_options; + string_repr_d3 = to_d3_string cfg; + nodes_pos = nodes_pos cfg; + } + end (* List of node (sections & paragraphs) diff --git a/src/lsp/cobol_lsp/lsp_request.ml b/src/lsp/cobol_lsp/lsp_request.ml index 75c3709a9..27d0ab6c1 100644 --- a/src/lsp/cobol_lsp/lsp_request.ml +++ b/src/lsp/cobol_lsp/lsp_request.ml @@ -135,24 +135,24 @@ let handle_get_project_config_command param registry = let handle_open_cfg registry params = let params = Jsonrpc.Structured.yojson_of_t params in - let uri, d3, options = Yojson.Safe.Util.( + let uri, options = Yojson.Safe.Util.( to_string @@ member "uri" params, - to_bool @@ member "is_d3" params, - try to_assoc @@ member "render_options" params with Type_error _ -> [] - ) in + 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 open Cobol_cfg.Builder in let options = Options.from_yojson_assoc options in - let graphs = make ~d3 ~options checked_doc in - let yojsonify ({ string_repr; name; nodes_pos } : graph) = + let graphs = make ~options checked_doc in + let yojsonify ({ string_repr_dot; string_repr_d3; name; nodes_pos } : graph) = let nodes_pos = List.map begin fun (n,loc) -> let range = Lsp_position.range_of_srcloc_in ~filename:uri loc in (string_of_int n, Range.yojson_of_t range) end nodes_pos in `Assoc [ - ("string_repr", `String string_repr); + ("string_repr_d3", `String string_repr_d3); + ("string_repr_dot", `String string_repr_dot); ("nodes_pos", `Assoc nodes_pos); ("name", `String name);] in diff --git a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml index c9d5a5e23..22accfab6 100644 --- a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml +++ b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml @@ -30,20 +30,29 @@ let decorationType = let options = Ojs.obj [|("backgroundColor", backgroundColor)|] in Window.createTextEditorDecorationType ~options +(* GRAPH TYPE*) + +let typ_of_string = function + | "d3" -> `D3 + | _ -> `Dot + (* GRAPH FROM LSP *) type graph = { - string_repr: string; + string_repr_dot: string; + string_repr_d3: string; nodes_pos: (string * Jsonoo.t) list; name: string; } let decode_graph res = - let string_repr = - Jsonoo.Decode.field "string_repr" Jsonoo.Decode.string res in + 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 } + { name; nodes_pos; string_repr_dot; string_repr_d3 } (* WEBVIEW MANAGEMENT *) @@ -164,14 +173,18 @@ let setup_window_listener ~client = (* MESSAGE MANAGER *) -let send_graph webview graph = +let send_graph ~typ webview graph = + let string_repr = match typ with + | `Dot -> graph.string_repr_dot + | `D3 -> graph.string_repr_d3 + in let ojs = Ojs.empty_obj () in Ojs.set_prop_ascii ojs "type" (Ojs.string_to_js "graph_content"); - Ojs.set_prop_ascii ojs "graph" (Ojs.string_to_js graph.string_repr); + Ojs.set_prop_ascii ojs "graph" (Ojs.string_to_js string_repr); let _ : bool Promise.t = WebView.postMessage webview ojs in () -let on_message ~client ~text_editor arg = +let on_message ~client ~text_editor arg = let uri = TextEditor.document text_editor |> TextDocument.uri in match webview_n_graph_find_opt ~uri with | None -> () @@ -189,9 +202,7 @@ let on_message ~client ~text_editor arg = |> Jsonoo.t_of_js in let data = let uri = Jsonoo.Encode.string @@ Uri.path uri in - Jsonoo.Encode.object_ ["uri", uri; - "is_d3", Jsonoo.Encode.bool false; - "render_options", options;] in + Jsonoo.Encode.object_ ["uri", uri; "render_options", options;] in let _ : unit Promise.t = Vscode_languageclient.LanguageClient.sendRequest client () ~meth:"superbol/CFG" ~data @@ -204,20 +215,24 @@ let on_message ~client ~text_editor arg = |> Promise.map (Fun.const ()) | graph::_ -> update_graph ~uri graph; - send_graph webview graph; + let typ = Ojs.get_prop_ascii arg "graph_type" + |> Ojs.string_of_js |> typ_of_string in + send_graph ~typ webview graph; Promise.return () end in () - | "ready" -> send_graph webview graph + | "ready" -> + let typ = Ojs.get_prop_ascii arg "graph_type" |> Ojs.string_of_js in + send_graph ~typ:(typ_of_string typ) webview graph | _ -> () -let open_cfg_for ?(d3=false) ~text_editor ~extension_uri client = +let open_cfg_for ?(typ=`Dot) ~text_editor ~extension_uri client = let open Promise in let uri = TextEditor.document text_editor |> TextDocument.uri in let data = let uri = Jsonoo.Encode.string @@ Uri.path uri in - Jsonoo.Encode.object_ ["uri", uri; "is_d3", Jsonoo.Encode.bool d3] + Jsonoo.Encode.object_ ["uri", uri] in Vscode_languageclient.LanguageClient.sendRequest client () ~meth:"superbol/CFG" ~data @@ -239,19 +254,19 @@ let open_cfg_for ?(d3=false) ~text_editor ~extension_uri client = then begin let html_uri = Uri.joinPath extension_uri ~pathSegments: - ["assets"; - if d3 then "cfg-d3-renderer.html" - else "cfg-dot-renderer.html"] in + ["assets"; match typ with + | `Dot -> "cfg-dot-renderer.html" + | `D3 -> "cfg-arc-renderer.html"] in let html_file = read_whole_file @@ Uri.fsPath html_uri in WebView.set_html webview html_file; end - else send_graph webview graph; + else send_graph ~typ webview graph; setup_window_listener ~client; return () end end -let open_cfg ?(d3=false) ?text_editor instance = +let open_cfg ?(typ=`Dot) ?text_editor instance = let text_editor = match text_editor with | None -> Window.activeTextEditor () | e -> e in @@ -259,7 +274,7 @@ let open_cfg ?(d3=false) ?text_editor instance = | Some client, Some text_editor -> let extension_uri = ExtensionContext.extensionUri @@ Superbol_instance.context instance in - open_cfg_for ~d3 ~extension_uri ~text_editor client + open_cfg_for ~typ ~extension_uri ~text_editor client | _ -> Promise.return () (* debug TO REMOVE *) diff --git a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.mli b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.mli index d4ecb972e..dc9a56855 100644 --- a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.mli +++ b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.mli @@ -13,7 +13,7 @@ (**************************************************************************) val open_cfg - : ?d3: bool + : ?typ: [< `D3 | `Dot > `Dot] -> ?text_editor: Vscode.TextEditor.t -> Superbol_instance.t -> unit Promise.t diff --git a/src/vscode/superbol-vscode-platform/superbol_commands.ml b/src/vscode/superbol-vscode-platform/superbol_commands.ml index 4fb903150..461d9b944 100644 --- a/src/vscode/superbol-vscode-platform/superbol_commands.ml +++ b/src/vscode/superbol-vscode-platform/superbol_commands.ml @@ -47,7 +47,7 @@ let _open_cfg = let _open_cfg_d3 = command "superbol.cfg.open.d3" @@ Instance begin fun _instance ~args:_ -> - let _ : unit Promise.t = Superbol_cfg_explorer.open_cfg ~d3:true _instance in + let _ : unit Promise.t = Superbol_cfg_explorer.open_cfg ~typ:`D3 _instance in () end From e07fd9003e13b40b6df88f0d2ec738368cfdeb8f Mon Sep 17 00:00:00 2001 From: Mateo Date: Thu, 5 Sep 2024 15:35:54 +0200 Subject: [PATCH 15/40] feat: improved arc and add evaluate stmt --- assets/cfg-arc-renderer.html | 61 +++++----- src/lsp/cobol_cfg/cfg_builder.ml | 200 ++++++++++++++++++------------- 2 files changed, 151 insertions(+), 110 deletions(-) diff --git a/assets/cfg-arc-renderer.html b/assets/cfg-arc-renderer.html index ce73dac92..41f0893a8 100644 --- a/assets/cfg-arc-renderer.html +++ b/assets/cfg-arc-renderer.html @@ -9,7 +9,6 @@ text { font: 12px monospace; pointer-events: none; - text-shadow: 0 1px 0 #fff, 1px 0 0 #fff, 0 -1px 0 #fff, -1px 0 0 #fff; } svg { background-color: white; @@ -24,7 +23,7 @@ @keyframes dash { to { - stroke-dashoffset: -60; + stroke-dashoffset: -50; // lcm of sum of dasharray values to avoid flicker } } @@ -112,9 +111,9 @@ function getDasharray(l) { if(l.type === "u") - return "55,5" + return "45,5" if(l.type === "c") - return "15,5" + return "18,7" return "" } @@ -197,38 +196,40 @@ } }) + var timeout = undefined; // Add the highlighting functionality nodes .on('mouseover', function (e, d) { - nodes.filter(n=> !d.neigh.includes(n.id) && n.id != d.id) - .style('fill', "#B8B8B8") - - links - .style('stroke', function (l) { - if(l.source === d.id) { - return '#69b3b2' - } else if (l.target === d.id) { - return '#b369b2' - } - return '#b8b8b855'; - }) - .style('stroke-width', function (l) { return l.source === d.id || l.target === d.id ? 4 : 1;}) - .attr('class', l => { - if(l.source === d.id) { - return "animated" - } else if (l.target === d.id) { - return "animated" - } - return "" - }) + if(timeout) { + clearTimeout(timeout) + timeout = undefined; + } + nodes + .style('fill', n => + !d.neigh.includes(n.id) && n.id != d.id + ? "#B8B8B8" + : getNodeColor(n)) + + links.filter(l => l.source !== d.id && l.target !== d.id) + .style('stroke', '#b8b8b855') + .style('stroke-width', '1') + .classed('animated', false) + + links.filter(l => l.source === d.id || l.target === d.id) + .style('stroke', l => (l.source === d.id) ? '#69b3b2' : '#b369b2') + .style('stroke-width', 4) + .classed('animated', true) }) .on('mouseout', function (d) { - nodes.style('fill', getNodeColor) - links - .style('stroke', 'black') - .style('stroke-width', '1') - .classed('animated', false) + timeout = setTimeout(() => { + timeout = undefined; + nodes.style('fill', getNodeColor) + links + .style('stroke', 'black') + .style('stroke-width', '1') + .classed('animated', false) + }, 300) }) } diff --git a/src/lsp/cobol_cfg/cfg_builder.ml b/src/lsp/cobol_cfg/cfg_builder.ml index 5f0a0564c..c9981cd59 100644 --- a/src/lsp/cobol_cfg/cfg_builder.ml +++ b/src/lsp/cobol_cfg/cfg_builder.ml @@ -50,33 +50,28 @@ end type qualname = Cobol_ptree.qualname type jumps = - | Goback | Go of qualname - | Conditional of qualname (* includes perform, go ... depending *) + | GoDepending of qualname + | Perform of qualname module Qualnames = Set.Make(struct type t = qualname let compare = Cobol_ptree.compare_qualname end) -module Jumps = struct - include Set.Make(struct - type t = jumps - let compare j1 j2 = - let to_int = function - | Goback -> 0 - | Go _ -> 1 - | Conditional _ -> 2 in - match j1, j2 with - | Go qn1, Go qn2 -> Cobol_ptree.compare_qualname qn1 qn2 - | Conditional qn1, Conditional qn2 -> Cobol_ptree.compare_qualname qn1 qn2 - | _ -> to_int j2 - to_int j1 - end) - let only_conditional : t -> bool = - for_all begin function - | Conditional _ -> true | _ -> false - end -end +module Jumps = Set.Make(struct + type t = jumps + let compare j1 j2 = + let to_int = function + | Go _ -> 0 + | GoDepending _ -> 1 + | Perform _ -> 2 in + match j1, j2 with + | Go qn1, Go qn2 + | GoDepending qn1, GoDepending qn2 + | Perform qn1, Perform qn2 -> Cobol_ptree.compare_qualname qn1 qn2 + | _ -> to_int j2 - to_int j1 + end) module Qmap = Map.Make(struct type t = qualname @@ -90,6 +85,8 @@ type node = { loc: srcloc option; entry: bool; jumps: Jumps.t; + will_fallthru: bool; + terminal: bool; is_external: bool; } @@ -105,55 +102,94 @@ let full_qn' ~cu qn = full_qn ~cu ~&qn let node_idx = ref 0 -let build_node ~default_name ~cu paragraph = - let open struct - type acc = { - jumps: Jumps.t; - unreachable: bool; +let listsplit3 l = + List.fold_left begin fun (a_acc, b_acc, c_acc) (a, b, c) -> + (a::a_acc, b::b_acc, c::c_acc) + end ([], [], []) l + +module JumpCollector = struct + type acc = { + jumps: Jumps.t; + will_fallthru: bool; + terminal: bool; + } + let init = { jumps = Jumps.empty; + terminal = false; + will_fallthru = true; } + let add_unconditional uncond acc = + { + jumps = Jumps.add uncond acc.jumps; + terminal = false; + will_fallthru = true; } - let init = { jumps = Jumps.empty; - unreachable = false; } - let add_unconditional uncond acc = - { jumps = Jumps.add uncond acc.jumps; - unreachable = true; } - let add_conditionals acc qn_to_jump = - { acc with jumps = Jumps.add (Conditional qn_to_jump) acc.jumps } - end in - let { jumps; unreachable = _ } = - Visitor.fold_procedure_paragraph' - object (v) - inherit [acc] Visitor.folder - method! fold_goback' _ acc = skip @@ add_unconditional Goback acc - method! fold_statement' _ ({ unreachable; _ } as acc) = - if unreachable - then skip acc - else do_children acc - method! fold_if' { payload = { then_branch; else_branch; _ }; _ } acc = - let { jumps; unreachable } = - Cobol_ptree.Visitor.fold_statements v then_branch acc in - let { jumps = else_j; unreachable = else_unreach } = - Cobol_ptree.Visitor.fold_statements v else_branch init in - skip { - jumps = Jumps.union jumps else_j; - unreachable = unreachable && else_unreach - } - method! fold_goto' { payload; _ } acc = - skip @@ - match payload with - | GoToEntry _ -> acc (* TODO couldn't find doc *) - | GoToSimple { target } -> - add_unconditional (Go (full_qn' ~cu target)) acc - | GoToDepending { targets; _ } -> - Cobol_common.Basics.NEL.to_list targets - |> List.map (full_qn' ~cu) - |> List.fold_left add_conditionals acc - method! fold_perform_target' { payload; _ } acc = - skip @@ - let { payload = start; _ } = payload.perform_target.procedure_start in - add_conditionals acc (full_qn ~cu start) - end - paragraph init - in + let folder ~cu = object (v) + inherit [acc] Visitor.folder + method! fold_goback' _ acc = skip @@ { acc with terminal = true; will_fallthru = false } + method! fold_stop' _ acc = skip @@ { acc with terminal = true; will_fallthru = false } + method! fold_exit' { payload = exit_stmt; _ } acc = + skip @@ + match exit_stmt with + | ExitSimple | ExitPerform _ + | ExitMethod _ | ExitProgram _ | ExitFunction _ -> acc + | ExitParagraph -> { acc with will_fallthru = true } + | ExitSection -> { acc with will_fallthru = true } (* TODO: go to next section ? *) + method! fold_evaluate' { payload; _ } acc = + let { eval_branches; eval_otherwise; _ }: Cobol_ptree.evaluate_stmt = + payload in + let jumps, terminals, unreachables = List.map begin fun branch -> + let { jumps; terminal; will_fallthru } = + Cobol_ptree.Visitor.fold_evaluate_branch v branch init in + (jumps, terminal, will_fallthru) + end eval_branches |> listsplit3 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; + } + method! fold_statement' _ ({ will_fallthru; _ } as acc) = + if will_fallthru then do_children acc else skip acc + method! fold_if' { payload = { then_branch; else_branch; _ }; _ } acc = + let { jumps; terminal; will_fallthru } = + Cobol_ptree.Visitor.fold_statements v then_branch acc in + let { jumps = else_jumps; + terminal = else_terminal; + will_fallthru = else_fallthru } = + 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; + } + 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; + } + | 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 } + end +end + +let build_node ~default_name ~cu paragraph = + let open JumpCollector in + let { jumps; will_fallthru; terminal; } = + Visitor.fold_procedure_paragraph' (folder ~cu) paragraph init in node_idx:=!node_idx+1; let qid, loc = match ~¶graph.paragraph_name with | None -> default_name, ~@paragraph @@ -166,6 +202,8 @@ let build_node ~default_name ~cu paragraph = loc = Some loc; entry = false; jumps; + will_fallthru; + terminal; is_external = false; } @@ -181,8 +219,8 @@ end type edge = | FallThrough - | Conditional - | Unconditional + | Perform + | Go module Edge = struct type t = edge @@ -191,8 +229,8 @@ module Edge = struct let default = FallThrough let to_string = function | FallThrough -> "f" - | Conditional -> "c" - | Unconditional -> "u" + | Perform -> "c" + | Go -> "u" end module Cfg = Graph.Persistent.Digraph.ConcreteLabeled(Node)(Edge) @@ -217,8 +255,8 @@ module Dot = Graph.Graphviz.Dot(struct let edge_attributes (_,s,_) = [`Style (match s with | FallThrough -> `Dotted - | Conditional -> `Dashed - | Unconditional -> `Solid)] + | Perform -> `Dashed + | Go -> `Solid)] let default_edge_attributes _ = [] let get_subgraph _ = None let vertex_attributes ({ entry; is_external; _ } as n) = @@ -245,6 +283,8 @@ let dummy_node qn = entry = false; names = NEL.One (qn_to_string qn); jumps = Jumps.empty; + will_fallthru = false; + terminal = false; is_external = true; } @@ -264,21 +304,21 @@ let rec build_edges ~vertexes g nodes = | ({ jumps; _ } as current)::_ -> Jumps.fold begin fun uncond (g, vertexes) -> match uncond with - | Goback -> g, vertexes + | GoDepending jump_to | Go jump_to -> let vertexes, next = qmap_find_or_add vertexes jump_to in - Cfg.add_edge_e g (current, Unconditional, next), + Cfg.add_edge_e g (current, Go, next), vertexes - | Conditional jump_to -> + | Perform jump_to -> let vertexes, next = qmap_find_or_add vertexes jump_to in - Cfg.add_edge_e g (current, Conditional, next), + Cfg.add_edge_e g (current, Perform, next), vertexes end jumps (g, vertexes) | [] -> g, vertexes in match nodes with - | ({ jumps; _ } as current)::next::tl - when Jumps.only_conditional jumps -> + | ({ will_fallthru; _ } as current)::next::tl + when will_fallthru -> build_edges ~vertexes (Cfg.add_edge g current next) (next::tl) | _::tl -> build_edges ~vertexes g tl | [] -> g From 25b65728643f0bf316a07225f758a1d493bfcd15 Mon Sep 17 00:00:00 2001 From: Mateo Date: Thu, 5 Sep 2024 17:32:11 +0200 Subject: [PATCH 16/40] refactor: cleanup and add onclick to arc nodes --- assets/cfg-arc-renderer.html | 227 +++++++++--------- src/lsp/cobol_cfg/cfg_builder.ml | 2 +- .../superbol_cfg_explorer.ml | 82 +++---- 3 files changed, 150 insertions(+), 161 deletions(-) diff --git a/assets/cfg-arc-renderer.html b/assets/cfg-arc-renderer.html index 41f0893a8..ed9d0f390 100644 --- a/assets/cfg-arc-renderer.html +++ b/assets/cfg-arc-renderer.html @@ -63,23 +63,69 @@ }) vscode.postMessage({type: 'ready', graph_type: 'd3'}) +// 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(d) { + var name = d.name.split(" IN ")[0] + if(name.length > 14) { + return name.slice(0, 12) + ".." + } + return name +} + +function getDasharray(l) { + if(l.type === "u") + return "45,5" + if(l.type === "c") + return "18,7" + return "" +} + +function getNodeColor(color) { + return function (d) { + const name = d.name.split(" IN "); + if(name.length > 1) { + return color(name[1]) + } + return color(d.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 (d) { + start = y(d.source) + end = y(d.target) + if(d.type === 'f') { + return `M ${NODE_CENTER_X} ${start+NODE_RADIUS} V ${end - NODE_RADIUS}` + } else { + half_distance = Math.abs((start-end)/2) + map = map_to_max_spread(half_distance, .001) + radius = half_distance > half_spread ? (half_distance**2 + map**2)/(2*map) : half_distance + return `M ${NODE_CENTER_X+NODE_RADIUS} ${start}\ + A ${radius},${radius} 0 0,${start < end?1:0} ${NODE_CENTER_X+NODE_RADIUS},${end}` + } + } +} function buildSVG(data) { - var rect = document.getElementById('graph').getBoundingClientRect(); - console.log(data) + const height = data.nodes.length * 32; + data.nodes = addNeighbours(data.nodes, data.links) - data.links.sort((l1,l2) => { - if(l1.source < l2.source) { - return -1; - } else if(l1.target < l2.target) { - return - } - }) - // set the dimensions and margins of the graph - const margin = {top: 20, right: 30, bottom: 20, left: 30}, - width = rect.width, - height = data.nodes.length * 32; + console.log(data) + // append the svg object to the body of the page const svg = d3.select("#graph") .append("svg") @@ -93,60 +139,12 @@ const sectionNames = data.nodes.filter(d=> !d.name.includes(" IN ")) const color = d3.scaleOrdinal(sectionNames, d3.schemeCategory10) - function getNodeColor(d) { - const name = d.name.split(" IN "); - if(name.length > 1) { - return color(name[1]) - } - return color(d.name) - } - - function getName(d) { - var name = d.name.split(" IN ")[0] - if(name.length > 14) { - return name.slice(0, 12) + ".." - } - return name - } - - function getDasharray(l) { - if(l.type === "u") - return "45,5" - if(l.type === "c") - return "18,7" - return "" - } - // A linear scale to position the nodes on the X axis const y = d3.scalePoint() .range([0, height]) .domain(allNodes) - 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 c * (1-Math.exp(-k*(val - b))/2) - return b + (c-b)*Math.atan(k*(val-b))*2/Math.PI - - } - - function getLinkPath(d) { - start = y(d.source) - end = y(d.target) - if(d.type === 'f') { - return `M ${NODE_CENTER_X} ${start+NODE_RADIUS} V ${end - NODE_RADIUS}` - } else { - half_distance = Math.abs((start-end)/2) - map = map_to_max_spread(half_distance, .001) - radius = half_distance > half_spread ? (half_distance**2 + map**2)/(2*map) : half_distance - return `M ${NODE_CENTER_X+NODE_RADIUS} ${start}\ - A ${radius},${radius} 0 0,${start < end?1:0} ${NODE_CENTER_X+NODE_RADIUS},${end}` - } - } + const nodeColor = getNodeColor(color); // Add the circle for the nodes const nodes = svg @@ -156,80 +154,77 @@ .attr("cx", NODE_CENTER_X) .attr("cy", d=>y(d.id)) .attr("r", 12) - .style("fill", getNodeColor) + .style("fill", nodeColor) // And give them a label const labels = svg .selectAll("mylabels") .data(data.nodes) - .join("text") + .join("g") + + labels.append("rect") + .attr("x", -margin.left) + .attr("y", d => y(d.id) - 6) + .attr("width", NODE_CENTER_X-NODE_RADIUS + margin.left) + .attr("height", "1em") + .attr("fill", "#fff") + // .text(getShortenName) + + labels.append("text").text(getShortenName) .attr("x", NODE_CENTER_X - NODE_RADIUS - 10) .attr("y", d=>y(d.id)) - .text(getName) .style("text-anchor", "end") .style("alignment-baseline", "middle") + labels.append("title").text(n => n.name) // Add the links const links = svg .selectAll('mylinks') .data(data.links) .join('path') - .attr('d', getLinkPath) + .attr('d', getLinkPath(y)) .style("fill", "none") .attr("stroke", "black") .attr("stroke-dasharray", getDasharray) - links.select('path') - .attr('d', d => { - console.log('link log ?', d) - start = y(d.source) - end = y(d.target) - if(d.type === 'f') { - return `M ${NODE_CENTER_X} ${start+NODE_RADIUS} V ${end - NODE_RADIUS}` - } else { - max_width = width - NODE_CENTER_X - NODE_RADIUS - mid_point = (start-end)/2 - map = max_width * (1-Math.exp(-(mid_point - max_width/2))/2) - radius = mid_point > max_width/2 ? (mid_point**2 + map**2)/(2*map) : mid_point - return `M ${NODE_CENTER_X+NODE_RADIUS} ${start}\ - A ${radius},${radius} 0 0,${start < end?1:0} ${NODE_CENTER_X+NODE_RADIUS},${end}` - } - }) - var timeout = undefined; + // Add the highlighting functionality + nodes.on('mouseover', function (e, d) { + if(timeout) { + clearTimeout(timeout) + timeout = undefined; + } + nodes.style('fill', n => + !d.neigh.includes(n.id) && n.id != d.id + ? "#BBB" + : nodeColor(n)) + + links.filter(l => l.source !== d.id && l.target !== d.id) + .style('stroke', '#5553') + .style('stroke-width', '1') + .classed('animated', false) + + links.filter(l => l.source === d.id || l.target === d.id) + .style('stroke', l => (l.source === d.id) ? '#7bb' : '#b7b') + .style('stroke-width', 4) + .classed('animated', true) + }) + .on('mouseout', d => { + timeout = setTimeout(() => { + timeout = undefined; + nodes.style('fill', nodeColor) + links + .style('stroke', 'black') + .style('stroke-width', '1') + .classed('animated', false) + }, 300) + }) - // Add the highlighting functionality - nodes - .on('mouseover', function (e, d) { - if(timeout) { - clearTimeout(timeout) - timeout = undefined; - } - nodes - .style('fill', n => - !d.neigh.includes(n.id) && n.id != d.id - ? "#B8B8B8" - : getNodeColor(n)) - - links.filter(l => l.source !== d.id && l.target !== d.id) - .style('stroke', '#b8b8b855') - .style('stroke-width', '1') - .classed('animated', false) - - links.filter(l => l.source === d.id || l.target === d.id) - .style('stroke', l => (l.source === d.id) ? '#69b3b2' : '#b369b2') - .style('stroke-width', 4) - .classed('animated', true) - }) - .on('mouseout', function (d) { - timeout = setTimeout(() => { - timeout = undefined; - nodes.style('fill', getNodeColor) - links - .style('stroke', 'black') - .style('stroke-width', '1') - .classed('animated', false) - }, 300) - }) + nodes.on("click", (_, n) => { + vscode.postMessage({ + type: 'click', + node: String(n.id) + }) + }) } diff --git a/src/lsp/cobol_cfg/cfg_builder.ml b/src/lsp/cobol_cfg/cfg_builder.ml index c9981cd59..07562b51c 100644 --- a/src/lsp/cobol_cfg/cfg_builder.ml +++ b/src/lsp/cobol_cfg/cfg_builder.ml @@ -283,7 +283,7 @@ let dummy_node qn = entry = false; names = NEL.One (qn_to_string qn); jumps = Jumps.empty; - will_fallthru = false; + will_fallthru = true; terminal = false; is_external = true; } diff --git a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml index 22accfab6..5a9e97367 100644 --- a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml +++ b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml @@ -113,16 +113,8 @@ let on_click ~nodes_pos ~text_editor arg = let uri = TextDocument.uri @@ TextEditor.document text_editor in let column = TextEditor.viewColumn text_editor in let node = Ojs.get_prop_ascii arg "node" |> Ojs.string_of_js in -let message = List.split nodes_pos |> fst |> String.concat " " in - match List.assoc_opt node nodes_pos with - | None -> - - let message = "NOT found " ^ node ^ " $$$ " ^ message in - let _ = Window.showErrorMessage ~message () in - () - | Some range -> - let message = "found " ^ node ^ " $$$ " ^ message in - let _ = Window.showErrorMessage ~message () in + List.assoc_opt node nodes_pos + |> Option.iter begin fun range -> let range = Range.t_of_js @@ Jsonoo.t_to_js range in let _ : unit Promise.t = Window.showTextDocument ~document:(`Uri uri) ?column () @@ -136,6 +128,7 @@ let message = List.split nodes_pos |> fst |> String.concat " " in ~rangesOrOptions:(`Ranges [range]); Promise.return ()) in () + end let setup_window_listener ~client = let listener event = @@ -184,47 +177,50 @@ let send_graph ~typ webview graph = let _ : bool Promise.t = WebView.postMessage webview ojs in () +let on_graph_update ~webview ~client ~uri name arg = + let options = + Ojs.get_prop_ascii arg "renderOptions" + |> begin fun ojs -> + Ojs.set_prop_ascii ojs "graph_name" @@ Ojs.string_to_js name; + ojs end + |> Jsonoo.t_of_js in + let data = + let uri = Jsonoo.Encode.string @@ Uri.path uri in + Jsonoo.Encode.object_ ["uri", uri; "render_options", options;] in + let _ : unit Promise.t = + Vscode_languageclient.LanguageClient.sendRequest client () + ~meth:"superbol/CFG" ~data + |> Promise.then_ ~fulfilled:begin fun jsonoo_graphs -> + let graphs = Jsonoo.Decode.list decode_graph jsonoo_graphs in + match graphs with + | [] -> + Window.showErrorMessage () + ~message:"Unable to perform operation, try reloading the CFG" + |> Promise.map (Fun.const ()) + | graph::_ -> + update_graph ~uri graph; + let typ = Ojs.get_prop_ascii arg "graph_type" + |> Ojs.string_of_js |> typ_of_string in + send_graph ~typ webview graph; + Promise.return () + end + in () + let on_message ~client ~text_editor arg = let uri = TextEditor.document text_editor |> TextDocument.uri in - match webview_n_graph_find_opt ~uri with - | None -> () - | Some (webview, graph) -> - let typ = Ojs.get_prop_ascii arg "type" |> Ojs.string_of_js in - match typ with + let request_type = Ojs.get_prop_ascii arg "type" |> Ojs.string_of_js in + webview_n_graph_find_opt ~uri + |> Option.iter begin fun (webview, graph) -> + match request_type with | "click" -> on_click ~nodes_pos:graph.nodes_pos ~text_editor arg | "graph_update" -> - let options = - Ojs.get_prop_ascii arg "renderOptions" - |> begin fun ojs -> - Ojs.set_prop_ascii ojs "graph_name" @@ Ojs.string_to_js graph.name; - ojs end - |> Jsonoo.t_of_js in - let data = - let uri = Jsonoo.Encode.string @@ Uri.path uri in - Jsonoo.Encode.object_ ["uri", uri; "render_options", options;] in - let _ : unit Promise.t = - Vscode_languageclient.LanguageClient.sendRequest client () - ~meth:"superbol/CFG" ~data - |> Promise.then_ ~fulfilled:begin fun jsonoo_graphs -> - let graphs = Jsonoo.Decode.list decode_graph jsonoo_graphs in - match graphs with - | [] -> - Window.showErrorMessage () - ~message:"Unable to perform operation, try reloading the CFG" - |> Promise.map (Fun.const ()) - | graph::_ -> - update_graph ~uri graph; - let typ = Ojs.get_prop_ascii arg "graph_type" - |> Ojs.string_of_js |> typ_of_string in - send_graph ~typ webview graph; - Promise.return () - end - in () + on_graph_update ~client ~webview ~uri graph.name arg | "ready" -> let typ = Ojs.get_prop_ascii arg "graph_type" |> Ojs.string_of_js in send_graph ~typ:(typ_of_string typ) webview graph | _ -> () + end let open_cfg_for ?(typ=`Dot) ~text_editor ~extension_uri client = @@ -327,5 +323,3 @@ let open_webview ?text_editor instance = ~message:"The SuperBOL LSP client is not running; please retry after a \ COBOL file has been opened" - - From 6796108210aa21693b017de8eba0f29831076fb2 Mon Sep 17 00:00:00 2001 From: Mateo Date: Fri, 6 Sep 2024 11:29:30 +0200 Subject: [PATCH 17/40] feat: improve on click effect for dot --- assets/cfg-arc-renderer.html | 2 +- assets/cfg-dot-renderer.html | 25 +++++++++++++------ .../superbol_cfg_explorer.ml | 10 +++----- 3 files changed, 22 insertions(+), 15 deletions(-) diff --git a/assets/cfg-arc-renderer.html b/assets/cfg-arc-renderer.html index ed9d0f390..df8f83fc1 100644 --- a/assets/cfg-arc-renderer.html +++ b/assets/cfg-arc-renderer.html @@ -223,7 +223,7 @@ nodes.on("click", (_, n) => { vscode.postMessage({ type: 'click', - node: String(n.id) + node: n.id }) }) } diff --git a/assets/cfg-dot-renderer.html b/assets/cfg-dot-renderer.html index 69d76e7f2..5be3b0d86 100644 --- a/assets/cfg-dot-renderer.html +++ b/assets/cfg-dot-renderer.html @@ -72,6 +72,7 @@ const vscode = acquireVsCodeApi() var defaultTransform = undefined; var graphviz = undefined; + var graph = undefined; var rendering = document.getElementById('rendering') function reset() { @@ -115,14 +116,20 @@ if(defaultTransform === undefined) { defaultTransform = d3.select('#app g').attr('transform') } - d3.selectAll('.node') - .on("click", function () { - var title = d3.select(this).selectAll('title').text().trim(); - vscode.postMessage({ - type: 'click', - node:title + d3.selectAll('svg text') + .on("click", (ev, e) => { + console.log(ev) + if(e.children[0].text) { + const node = + graph.nodes.find((n) => e.children[0].text === n.name) + if(node) { + vscode.postMessage({ + type: 'click', + node: node.id + }) + } + } }) - }) } window.addEventListener('message', event => { @@ -137,9 +144,11 @@ graphviz.zoomScaleExtent([0.1, 50]) var rect = document.getElementById('app').getBoundingClientRect(); graphviz.width(rect.width).height(rect.height) - graphviz.renderDot(event.data.graph) + graphviz.renderDot(event.data.dot) .on('end', setupOnEnd) rendering.classList= ""; + graph = JSON.parse(event.data.graph) + console.log(event.data.dot) break; } }) diff --git a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml index 5a9e97367..a7f5dd708 100644 --- a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml +++ b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml @@ -112,7 +112,7 @@ let on_click ~nodes_pos ~text_editor arg = let open Vscode in let uri = TextDocument.uri @@ TextEditor.document text_editor in let column = TextEditor.viewColumn text_editor in - let node = Ojs.get_prop_ascii arg "node" |> Ojs.string_of_js in + let node = Ojs.get_prop_ascii arg "node" |> Ojs.int_of_js |> string_of_int in List.assoc_opt node nodes_pos |> Option.iter begin fun range -> let range = Range.t_of_js @@ Jsonoo.t_to_js range in @@ -167,13 +167,11 @@ let setup_window_listener ~client = (* MESSAGE MANAGER *) let send_graph ~typ webview graph = - let string_repr = match typ with - | `Dot -> graph.string_repr_dot - | `D3 -> graph.string_repr_d3 - in let ojs = Ojs.empty_obj () in Ojs.set_prop_ascii ojs "type" (Ojs.string_to_js "graph_content"); - Ojs.set_prop_ascii ojs "graph" (Ojs.string_to_js string_repr); + if typ == `Dot + 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); let _ : bool Promise.t = WebView.postMessage webview ojs in () From aa34b8d3ea82ecd723a63cff4ab32b4e096c2f3b Mon Sep 17 00:00:00 2001 From: Mateo Date: Fri, 6 Sep 2024 14:59:49 +0200 Subject: [PATCH 18/40] feat: added feedback between text_doc and cfg --- assets/cfg-arc-renderer.html | 140 ++++++++++-------- assets/cfg-dot-renderer.html | 24 ++- .../superbol_cfg_explorer.ml | 62 ++++---- 3 files changed, 134 insertions(+), 92 deletions(-) diff --git a/assets/cfg-arc-renderer.html b/assets/cfg-arc-renderer.html index df8f83fc1..f77ba5ecb 100644 --- a/assets/cfg-arc-renderer.html +++ b/assets/cfg-arc-renderer.html @@ -32,6 +32,12 @@ diff --git a/assets/cfg-dot-renderer.html b/assets/cfg-dot-renderer.html index 5be3b0d86..dba06a286 100644 --- a/assets/cfg-dot-renderer.html +++ b/assets/cfg-dot-renderer.html @@ -73,7 +73,7 @@ var defaultTransform = undefined; var graphviz = undefined; var graph = undefined; - var rendering = document.getElementById('rendering') + var rendering = d3.select('#rendering') function reset() { graphviz?.resetZoom() @@ -111,18 +111,28 @@ }) } + 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 setupOnEnd() { - rendering.classList= "hidden"; + rendering.classed("hidden", true); if(defaultTransform === undefined) { defaultTransform = d3.select('#app g').attr('transform') } + d3.selectAll('svg g title').remove() d3.selectAll('svg text') - .on("click", (ev, e) => { - console.log(ev) + .on("click", (_, e) => { if(e.children[0].text) { const node = graph.nodes.find((n) => e.children[0].text === n.name) if(node) { + focus(node.name) vscode.postMessage({ type: 'click', node: node.id @@ -146,9 +156,11 @@ graphviz.width(rect.width).height(rect.height) graphviz.renderDot(event.data.dot) .on('end', setupOnEnd) - rendering.classList= ""; + rendering.classed("hidden", false); graph = JSON.parse(event.data.graph) - console.log(event.data.dot) + break; + case "focused_proc": + focus(event.data.procedure) break; } }) diff --git a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml index a7f5dd708..5d3516968 100644 --- a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml +++ b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml @@ -103,11 +103,13 @@ let update_graph ~uri graph = let filename = Uri.path uri in match Hashtbl.find_opt webview_panels filename with | Some (wvp, _) -> - Hashtbl.add webview_panels filename (wvp, graph) + Hashtbl.replace webview_panels filename (wvp, graph) | None -> () (* CLICK ON NODE *) +let ignore_next_selection_change = ref false + let on_click ~nodes_pos ~text_editor arg = let open Vscode in let uri = TextDocument.uri @@ TextEditor.document text_editor in @@ -126,36 +128,46 @@ let on_click ~nodes_pos ~text_editor arg = TextEditor.set_selection text_editor selection; TextEditor.setDecorations text_editor ~decorationType ~rangesOrOptions:(`Ranges [range]); + (* Avoids triggering selection change with previous set_selection *) + ignore_next_selection_change := true; Promise.return ()) in () end let setup_window_listener ~client = let listener event = - let text_editor = TextEditorSelectionChangeEvent.textEditor event in - let uri = TextEditor.document text_editor |> TextDocument.uri in - let webview = webview_n_graph_find_opt ~uri in - match webview with - | None -> () - | Some (webview, _) -> - match TextEditorSelectionChangeEvent.selections event with - | [] -> () - | selection::_ -> - let pos_start = Selection.start selection in - let data = - let uri = Jsonoo.Encode.string @@ Uri.path uri in - Jsonoo.Encode.object_ - ["uri", uri; - "line", Jsonoo.Encode.int @@ Position.line pos_start; - "character", Jsonoo.Encode.int @@ Position.character pos_start] - in - let _ : bool Promise.t = - Vscode_languageclient.LanguageClient.sendRequest client () - ~meth:"superbol/findProcedure" ~data - |> Promise.(then_ ~fulfilled:begin fun res -> - WebView.postMessage webview @@ Jsonoo.t_to_js res - end) - in () + if !ignore_next_selection_change + then ignore_next_selection_change := false + else + let text_editor = TextEditorSelectionChangeEvent.textEditor event in + TextEditor.setDecorations text_editor ~decorationType + ~rangesOrOptions:(`Ranges []); + let uri = TextEditor.document text_editor |> TextDocument.uri in + let webview = webview_n_graph_find_opt ~uri in + match webview with + | None -> () + | Some (webview, _) -> + match TextEditorSelectionChangeEvent.selections event with + | [] -> () + | selection::_ -> + let pos_start = Selection.start selection in + let data = + let uri = Jsonoo.Encode.string @@ Uri.path uri in + Jsonoo.Encode.object_ + ["uri", uri; + "line", Jsonoo.Encode.int @@ Position.line pos_start; + "character", Jsonoo.Encode.int @@ Position.character pos_start] + in + let _ : bool Promise.t = + Vscode_languageclient.LanguageClient.sendRequest client () + ~meth:"superbol/findProcedure" ~data + |> Promise.(then_ ~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; + WebView.postMessage webview ojs + end) + in () in let disposable_listener = match !window_listener with From 3ba939acd7a4ef9a82c22c1a5ca3471e0ece33b3 Mon Sep 17 00:00:00 2001 From: Mateo Date: Mon, 9 Sep 2024 13:59:07 +0200 Subject: [PATCH 19/40] refactor: cleanup code --- assets/cfg-arc-renderer.html | 31 +++--- assets/cfg-dot-renderer.html | 28 +++--- package.json | 17 ++-- src/lsp/cobol_cfg/cfg_builder.ml | 97 ++++++++----------- src/lsp/cobol_cfg/cobol_cfg.ml | 5 - src/lsp/superbol_free_lib/vscode_extension.ml | 14 +-- .../superbol_cfg_explorer.ml | 62 +----------- .../superbol_cfg_explorer.mli | 7 +- .../superbol_commands.ml | 17 +--- 9 files changed, 89 insertions(+), 189 deletions(-) diff --git a/assets/cfg-arc-renderer.html b/assets/cfg-arc-renderer.html index f77ba5ecb..ee13d23d3 100644 --- a/assets/cfg-arc-renderer.html +++ b/assets/cfg-arc-renderer.html @@ -161,13 +161,13 @@ // List of node names const allNodes = data.nodes.map(d=>d.id).sort((a,b)=> a-b) - const sectionNames = data.nodes.filter(d=> !d.name.includes(" IN ")) + const sectionNames = data.nodes.filter(d => !d.name.includes(" IN ")) const color = d3.scaleOrdinal(sectionNames, d3.schemeCategory10) // A linear scale to position the nodes on the X axis y = d3.scalePoint() - .range([0, height]) - .domain(allNodes) + .range([0, height]) + .domain(allNodes) nodeColor = getNodeColor(color); @@ -199,8 +199,8 @@ .join('path') .attr('d', getLinkPath(y)) .style("fill", "none") - .attr("stroke", "black") - .attr("stroke-dasharray", getDasharray) + .style("stroke", "black") + .style("stroke-dasharray", getDasharray) // Add the circle for the nodes nodes = svg @@ -208,11 +208,20 @@ .data(data.nodes) .join("circle") .attr("cx", NODE_CENTER_X) - .attr("cy", d=>y(d.id)) + .attr("cy", d => y(d.id)) .attr("r", NODE_RADIUS) .style("fill", nodeColor) .style('stroke-width', 4) + svg + .selectAll("sectionnodes") + .data(sectionNames) + .join("circle") + .attr("cx", NODE_CENTER_X) + .attr("cy", d => y(d.id)) + .attr("r", 2) + .style("fill", "white") + // Add the highlighting functionality nodes .on('mouseover', (_, n) => focusNode(n)) @@ -233,13 +242,13 @@ graph = JSON.parse(event.data.graph) buildSVG(graph) break; - case "focused_proc": - const node = graph.nodes - .find(n => { return n.name === event.data.procedure }) - window.scroll(0, y(node.id)-window.innerHeight/3) + case "focused_proc": + const node = graph.nodes.find(n => n.name === event.data.procedure) + if(!node) return; + window.scroll(0, y(node.id) - window.innerHeight/3) focusNode(node) unfocus(5000) - break; + break; } }) diff --git a/assets/cfg-dot-renderer.html b/assets/cfg-dot-renderer.html index dba06a286..d8ebb7650 100644 --- a/assets/cfg-dot-renderer.html +++ b/assets/cfg-dot-renderer.html @@ -70,7 +70,6 @@ diff --git a/assets/cfg-dot-renderer.html b/assets/cfg-dot-renderer.html index d8ebb7650..0a248a3a1 100644 --- a/assets/cfg-dot-renderer.html +++ b/assets/cfg-dot-renderer.html @@ -25,8 +25,8 @@ #rendering { position: absolute; top: 50%; - left: 0; - right: 0; + left: 50%; + transform: translate(-50%, -50%); text-align: center; z-index: -1; } @@ -38,6 +38,7 @@ flex-flow: column; position: absolute; margin-block-start: .5em; + padding: .5em .2em; background-color: var(--vscode-editor-background); border: var(--vscode-focusBorder) 1px solid; } @@ -49,23 +50,27 @@
- - +
Rendering... Please wait
- If this takes too much time, the CFG is probably too big to render. + If this takes too long, you can try changing the Render Options : +
    +
  • Reduce the incoming edge requirement for spliting hubs
    • +
  • Collapse nodes that are only linked via a fallthrough edge
    • +
diff --git a/src/lsp/cobol_cfg/cfg_builder.ml b/src/lsp/cobol_cfg/cfg_builder.ml index ccfcc1388..7e5322db1 100644 --- a/src/lsp/cobol_cfg/cfg_builder.ml +++ b/src/lsp/cobol_cfg/cfg_builder.ml @@ -51,12 +51,17 @@ type node = { qid: qualname; mutable names: string NEL.t; loc: srcloc option; - typ: [`External | `EntryPoint | `EntryPara | `EntrySection | `Internal ]; + typ: [`External | `EntryPoint | `EntryPara | `EntrySection | `Internal | `SplitHub ]; jumps: Jumps.t; will_fallthru: bool; terminal: bool; } +let is_entry n = + match n.typ with + | `EntryPara | `EntryPoint | `EntrySection -> true + | `External | `Internal | `SplitHub -> false + let fullqn_to_string qn = Pretty.to_string "%a" Cobol_ptree.pp_qualname qn @@ -98,8 +103,8 @@ module JumpCollector = struct match exit_stmt with | ExitSimple | ExitPerform _ | ExitMethod _ | ExitProgram _ | ExitFunction _ -> acc - | ExitParagraph -> { acc with will_fallthru = true } - | ExitSection -> { acc with will_fallthru = true } (* TODO: go to next section ? *) + | ExitParagraph -> { acc with will_fallthru = true } (* TODO change this to a goto next para *) + | ExitSection -> { acc with will_fallthru = false } (* TODO: go to next section ? *) method! fold_evaluate' { payload; _ } acc = let { eval_branches; eval_otherwise; _ }: Cobol_ptree.evaluate_stmt = payload in @@ -222,6 +227,7 @@ module Dot = Graph.Graphviz.Dot(struct | `EntryPoint -> "Entry\npoint", [`Shape `Doubleoctagon] | `EntrySection -> NEL.hd n.names, [`Shape `Doubleoctagon] | `External -> NEL.hd n.names, [`Shape `Plaintext] + | `SplitHub -> vertex_name_record n, [`Style `Dashed] | `Internal -> vertex_name_record n, [] in `Label label :: shape let default_vertex_attributes _ = [`Shape `Record] @@ -303,7 +309,7 @@ let do_hide_unreachable g = let rec aux cfg = let did_remove, cfg = Cfg.fold_vertex begin fun n (did_remove, cfg) -> - if Cfg.in_degree cfg n <= 0 && n.typ == `Internal + 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) @@ -317,7 +323,7 @@ let do_shatter_hubs ?(limit=20) g = then begin Cfg.fold_pred_e begin fun edge cfg -> let cfg = Cfg.remove_edge_e cfg edge in - let n_clone = clone_node n in + let n_clone = { (clone_node n) with typ = `SplitHub } in let (pred, edge, _) = edge in let cfg = Cfg.add_edge_e cfg (pred, edge, n_clone) in cfg @@ -337,10 +343,10 @@ let cfg_of_nodes nodes = let handle_cfg_options ~(options: Cfg_options.t) cfg = cfg |> (if options.collapse_fallthru then do_collapse_fallthru else Fun.id) + |> (if options.hide_unreachable then do_hide_unreachable else Fun.id) |> (match options.shatter_hubs with | Some limit -> do_shatter_hubs ~limit | _ -> Fun.id) - |> (if options.hide_unreachable then do_hide_unreachable else Fun.id) let cfg_of ~(cu: cobol_unit) = node_idx := 0; From 3c71a23eedfa669d6854c8b4f13b2f698a66291a Mon Sep 17 00:00:00 2001 From: Mateo Date: Wed, 11 Sep 2024 15:12:34 +0200 Subject: [PATCH 23/40] feat: arrow in arc, click behavior changed, unify string --- assets/cfg-arc-renderer.html | 106 +++++++++++++++++++++++------------ 1 file changed, 69 insertions(+), 37 deletions(-) diff --git a/assets/cfg-arc-renderer.html b/assets/cfg-arc-renderer.html index 8cc2320c7..0498df70f 100644 --- a/assets/cfg-arc-renderer.html +++ b/assets/cfg-arc-renderer.html @@ -23,7 +23,7 @@ @keyframes dash { to { - stroke-dashoffset: -50; // lcm of sum of dasharray values to avoid flicker + stroke-dashoffset: -51; // lcm of sum of dasharray values to avoid flicker } } @@ -36,6 +36,7 @@ nodes = undefined, links = undefined, y = undefined, + clickedNode = undefined nodeColor = undefined; function addNeighbours(nodes, links) { @@ -55,7 +56,7 @@ } // set the dimensions and margins of the graph -var rect = document.getElementById('graph').getBoundingClientRect(); +var rect = document.getElementById("graph").getBoundingClientRect(); const margin = {top: 20, right: 30, bottom: 20, left: 30}, width = rect.width; @@ -69,9 +70,9 @@ function getDasharray(l) { if(l.type === "u") - return "45,5" + return "45,6" if(l.type === "c") - return "18,7" + return "12,5" return "" } @@ -98,49 +99,57 @@ return function (d) { start = y(d.source) end = y(d.target) - if(d.type === 'f') { + if(d.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 ${NODE_CENTER_X+NODE_RADIUS} ${start}\ - A ${radius},${radius} 0 0,${start < end?1:0} ${NODE_CENTER_X+NODE_RADIUS},${end}` + 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(d) { + clickedNode = undefined; if(unfocusTimeout) { clearTimeout(unfocusTimeout) unfocusTimeout = undefined; } - nodes.style('opacity', n => + nodes.style("opacity", n => !d.neigh.includes(n.id) && n.id != d.id ? .4 : 1) .style("stroke", n => n.id === d.id ? "black" : "none") links.filter(l => l.source !== d.id && l.target !== d.id) - .style('stroke', '#5553') - .style('stroke-width', '1') - .classed('animated', false) + .style("stroke", "#5553") + .style("stroke-width", 1) + .classed("animated", false) + .attr("marker-mid", "") links.filter(l => l.source === d.id || l.target === d.id) - .style('stroke', l => (l.source === d.id) ? '#7bb' : '#b7b') - .style('stroke-width', 4) - .classed('animated', true) + .style("stroke", l => (l.source === d.id) ? "#7bb" : "#b7b") + .style("stroke-width", 3) + .attr("marker-mid", l => `url(#arrow-${(l.source===d.id)?"out":"in"})`) + .classed("animated", true) } -function unfocus(delay) { +function unfocus(delay, n) { + if(n.id == clickedNode?.id) return; unfocusTimeout = setTimeout(() => { unfocusTimeout = undefined; - nodes.style('opacity', 1) + nodes.style("opacity", 1) .style("stroke", "none") links - .style('stroke', 'black') - .style('stroke-width', '1') - .classed('animated', false) + .style("stroke", "black") + .style("stroke-width", 1) + .attr("marker-mid", "url(#arrow)") + .classed("animated", false) }, delay) } @@ -151,12 +160,33 @@ data.nodes = addNeighbours(data.nodes, data.links) // append the svg object to the body of the page - const svg = d3.select("#graph") +const svg = d3.select("#graph") .append("svg") .attr("width", width) .attr("height", height + margin.top + margin.bottom) - .append("g") - .attr("transform",`translate(${margin.left},${margin.top})`); + + 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(d=>d.id).sort((a,b)=> a-b) @@ -172,7 +202,7 @@ nodeColor = getNodeColor(color); // And give them a label - const labels = svg + const labels = svg_g .selectAll("mylabels") .data(data.nodes) .join("g") @@ -183,7 +213,6 @@ .attr("width", NODE_CENTER_X - NODE_RADIUS - 10 + margin.left) .attr("height", "1em") .attr("fill", "#fff") - // .text(getShortenName) labels.append("text").text(getShortenName) .attr("x", NODE_CENTER_X - NODE_RADIUS - 10) @@ -193,17 +222,18 @@ labels.append("title").text(n => n.name) // Add the links - links = svg - .selectAll('mylinks') + links = svg_g + .selectAll("mylinks") .data(data.links) - .join('path') - .attr('d', getLinkPath(y)) + .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 + nodes = svg_g .selectAll("mynodes") .data(data.nodes) .join("circle") @@ -211,9 +241,9 @@ .attr("cy", d => y(d.id)) .attr("r", NODE_RADIUS) .style("fill", nodeColor) - .style('stroke-width', 4) + .style("stroke-width", 4) - svg + svg_g .selectAll("sectionnodes") .data(sectionNames) .join("circle") @@ -224,25 +254,27 @@ // Add the highlighting functionality nodes - .on('mouseover', (_, n) => focusNode(n)) - .on('mouseout', () => unfocus(300)) + .on("mouseover", (_, n) => focusNode(n)) + .on("mouseout", (_, n) => unfocus(300, n)) nodes.on("click", (_, n) => { + clickedNode = n vscode.postMessage({ - type: 'click', + type: "click", node: n.id }) }) } -window.addEventListener('message', event => { +window.addEventListener("message", event => { switch (event.data.type) { case "graph_content": - d3.select('#graph svg').remove() + d3.select("#graph svg").remove() graph = JSON.parse(event.data.graph) buildSVG(graph) break; case "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) @@ -251,6 +283,6 @@ } }) -vscode.postMessage({type: 'ready'}) +vscode.postMessage({type: "ready"}) From fbb1b76ac94d77a1e0fd87c05e6f25346ea4425a Mon Sep 17 00:00:00 2001 From: Mateo Date: Thu, 12 Sep 2024 10:34:02 +0200 Subject: [PATCH 24/40] feat: added legend to both cfg --- assets/cfg-arc-renderer.html | 91 ++++++++++++++++++- assets/cfg-dot-renderer.html | 64 +++++++++---- src/lsp/cobol_cfg/cfg_builder.ml | 21 +++++ src/lsp/cobol_cfg/cfg_builder.mli | 2 + src/lsp/cobol_lsp/lsp_request.ml | 5 +- .../superbol_cfg_explorer.ml | 23 +++-- 6 files changed, 175 insertions(+), 31 deletions(-) diff --git a/assets/cfg-arc-renderer.html b/assets/cfg-arc-renderer.html index 0498df70f..6a1af6262 100644 --- a/assets/cfg-arc-renderer.html +++ b/assets/cfg-arc-renderer.html @@ -26,12 +26,29 @@ stroke-dashoffset: -51; // lcm of sum of dasharray values to avoid flicker } } +.hidden { + display: none !important; +} -
+ +
+ +
+ +
+ - diff --git a/assets/cfg-arc.js b/assets/cfg-arc.js new file mode 100644 index 000000000..5fe8fff5d --- /dev/null +++ b/assets/cfg-arc.js @@ -0,0 +1,332 @@ +const vscode = acquireVsCodeApi() + +function toggleLegend() { + if(document.getElementById('legend').classList != "") { + document.getElementById('legend').classList = ""; + } + else document.getElementById('legend').classList = "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(d) { + var name = d.name.split(" IN ")[0] + if(name.length > 14) { + return name.slice(0, 12) + ".." + } + return name +} + +function getDasharray(l) { + if(l.type === "u") + return "45,6" + if(l.type === "c") + return "12,5" + return "" +} + +function getNodeColor(color) { + return function (d) { + const name = d.name.split(" IN "); + if(name.length > 1) { + return color(name[1]) + } + return color(d.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 (d) { + start = y(d.source) + end = y(d.target) + if(d.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(d) { + clickedNode = undefined; + if(unfocusTimeout) { + clearTimeout(unfocusTimeout) + unfocusTimeout = undefined; + } + nodes.style("opacity", n => + !d.neigh.includes(n.id) && n.id != d.id + ? .4 + : 1) + .style("stroke", n => n.id === d.id ? "black" : "none") + + links.filter(l => l.source !== d.id && l.target !== d.id) + .style("stroke", "#5553") + .style("stroke-width", 1) + .classed("animated", false) + .attr("marker-mid", "") + links.filter(l => l.source === d.id || l.target === d.id) + .style("stroke", l => (l.source === d.id) ? "#7bb" : "#b7b") + .style("stroke-width", 3) + .attr("marker-mid", l => `url(#arrow-${(l.source===d.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(d=>d.id).sort((a,b)=> a-b) + + const sectionNames = data.nodes.filter(d => !d.name.includes(" IN ")) + const color = d3.scaleOrdinal(sectionNames, d3.schemeCategory10) + + // A linear scale to position the nodes on the X axis + y = d3.scalePoint() + .range([0, height]) + .domain(allNodes) + + 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", d => y(d.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", d=>y(d.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", d => y(d.id)) + .attr("r", NODE_RADIUS) + .style("fill", nodeColor) + .style("stroke-width", 4) + + svg_g + .selectAll("sectionnodes") + .data(sectionNames) + .join("circle") + .attr("cx", NODE_CENTER_X) + .attr("cy", d => y(d.id)) + .attr("r", 2) + .style("fill", "white") + + // Add the highlighting functionality + nodes + .on("mouseover", (_, n) => focusNode(n)) + .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: "u" })) + + 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: "c" })) + + 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") + + 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 from another section") + +} + +window.addEventListener("message", event => { + switch (event.data.type) { + case "graph_content": + d3.select("#graph svg").remove() + graph = JSON.parse(event.data.graph) + buildSVG(graph) + buildLegend() + break; + case "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) + break; + } + }) + +vscode.postMessage({type: "ready"}) + diff --git a/assets/cfg-dot-renderer.html b/assets/cfg-dot-renderer.html index 4f1062938..771b41aab 100644 --- a/assets/cfg-dot-renderer.html +++ b/assets/cfg-dot-renderer.html @@ -1,14 +1,11 @@ - - - - - COBOL CFG - - - - - - -
- - - - - -
-
-
- Rendering... Please wait
- If this takes too long, you can try changing the Render Options : -
    -
  • Reduce the incoming edge requirement for spliting hubs
    • -
  • Collapse nodes that are only linked via a fallthrough edge
    • -
-
- - - + + + +
+ + + + + +
+
+
+ Rendering... Please wait
+ If this takes too long, you can try changing the Render Options : +
    +
  • Reduce the incoming edge requirement for spliting hubs
    • +
  • Collapse nodes that are only linked via a fallthrough edge
    • +
+
+ + diff --git a/assets/cfg-dot.js b/assets/cfg-dot.js new file mode 100644 index 000000000..cf93a40e8 --- /dev/null +++ b/assets/cfg-dot.js @@ -0,0 +1,125 @@ +const vscode = acquireVsCodeApi() +var graphviz = undefined; +var graph = undefined; +var rendering = d3.select('#rendering') + +function reset() { + graphviz?.resetZoom() +} + +function toggleLegend() { + if(document.getElementById('legend').classList != "") { + document.getElementById('options').classList = "hidden"; + document.getElementById('legend').classList = ""; + } + else document.getElementById('legend').classList = "hidden"; +} + +function toggleOptions() { + if(document.getElementById('options').classList != "") { + document.getElementById('options').classList = ""; + document.getElementById('legend').classList = "hidden"; + } + else document.getElementById('options').classList = "hidden"; +} + +function hideOptions() { + document.getElementById('options').classList = "hidden"; +} + +function rerender() { + var collapse_fallthru = document.getElementById('fallthru').checked; + var hide_unreachable = document.getElementById('unreachable').checked; + if(document.getElementById('hubshatter').checked) { + var shatter_hubs = Number(document.getElementById('hubcount').value) + } + else { + var shatter_hubs = undefined; + } + vscode.postMessage({ + type: 'graph_update', + renderOptions: { + hide_unreachable, + collapse_fallthru, + shatter_hubs, + } + }) +} + +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 setupOnEnd() { + rendering.classed("hidden", true); + d3.selectAll("svg g title").remove() + d3.selectAll("svg .node") + .attr("data-vscode-context", '{"node":true}') + 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.ostMessage({ + type: 'click', + node: node.id + }) + }) + .on("contextmenu", (_, 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; + vscode.postMessage({ type: "context-node", node }) + + }) +} + +function updateLegend(legend) { + d3.select("#legend").graphviz().renderDot(legend) + .zoom(false) + .width("100%") + .fit(true) + .on("end", () => d3.select("#legend svg").attr("height", null)) + +} + +window.addEventListener('message', event => { + switch (event.data.type) { + case "graph_content": + if(graphviz) { + graphviz.destroy() + d3.select('#app svg').remove() + } + hideOptions() + if(event.data.legend) { + updateLegend(event.data.legend) + } + 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(event.data.dot) + .on('end', setupOnEnd) + rendering.classed("hidden", false); + graph = JSON.parse(event.data.graph) + break; + case "focused_proc": + focus(event.data.procedure) + break; + } + }) +vscode.postMessage({type: 'ready'}) diff --git a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml index 35c8d6297..5df472282 100644 --- a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml +++ b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml @@ -25,10 +25,10 @@ let read_whole_file filename = let graphviz_html = ref None let d3_arc_html = ref None -let get_html_content ~extension_uri typ = +let get_html_js_content ~extension_uri typ = match typ, !graphviz_html, !d3_arc_html with - | D3_arc_diagram, _, Some html - | Graphviz, Some html, _ -> Ok(html) + | D3_arc_diagram, _, Some value + | Graphviz, Some value, _ -> Ok(`CompleteHtml value) | _ -> let html_uri = Uri.joinPath extension_uri ~pathSegments: @@ -37,13 +37,29 @@ let get_html_content ~extension_uri typ = | D3_arc_diagram -> "cfg-arc-renderer.html"] in try let html = read_whole_file @@ Uri.fsPath html_uri in - begin match typ with - | Graphviz -> graphviz_html := Some html - | D3_arc_diagram -> d3_arc_html := Some html end; - Ok(html) + let js = match typ with + | Graphviz -> "cfg-dot.js" + | D3_arc_diagram -> "cfg-arc.js" in + let localResource = + Uri.joinPath extension_uri ~pathSegments:["assets"; js] in + Ok( `IncompleteHtml (html, localResource)) 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) -> + let html_content = + let path = Uri.toString + (WebView.asWebviewUri webview ~localResource:js_path) () in + Printf.sprintf "%s" + html 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(Window.showInformationMessage () ~message) @@ -101,9 +117,11 @@ let create_or_get_webview ~graph ~uri ~typ = Hashtbl.replace webview_panels (filename, typ) (webview_panel, graph); WebviewPanel.webview webview_panel, false | None -> - let webview_panel = Window.createWebviewPanel - ~viewType:"CFG" ~title:"SuperBOL CFG Viewer" - ~showOptions:(ViewColumn.Beside) in + let viewType = match typ with + | Graphviz -> "superbol.cfg.dot" + | D3_arc_diagram -> "superbol.cfg.arc" in + let webview_panel = Window.createWebviewPanel ~viewType + ~title:"SuperBOL CFG Viewer" ~showOptions:(ViewColumn.Beside) in let _ : Disposable.t = WebviewPanel.onDidDispose webview_panel () ~listener:(webviewpanel_disposal ~filename ~typ) @@ -261,12 +279,12 @@ let open_cfg_for ~typ ~text_editor ~extension_uri client = let uri = Jsonoo.Encode.string @@ Uri.path uri in Jsonoo.Encode.object_ ["uri", uri] in - match get_html_content ~extension_uri typ with + match get_html_js_content ~extension_uri typ with | Error e -> let _ : _ option Promise.t = Window.showErrorMessage ~message:("Unable to display control-flow: " ^ e) () in return () - | Ok html_content -> + | Ok html_js -> Vscode_languageclient.LanguageClient.sendRequest client () ~meth:"superbol/getCFG" ~data |> then_ ~fulfilled:begin fun jsonoo_res -> @@ -281,6 +299,7 @@ let open_cfg_for ~typ ~text_editor ~extension_uri client = let graph = Stdlib.List.find begin fun g -> String.equal g.name name end graphs in 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 _ : Disposable.t = WebView.onDidReceiveMessage webview () ~listener:(on_message ~legend:(Some legend) ~client ~text_editor ~typ) From 798d102d4bfedab324f9b7f779111459ac9e89c4 Mon Sep 17 00:00:00 2001 From: Mateo Date: Mon, 16 Sep 2024 12:23:19 +0200 Subject: [PATCH 26/40] refactor: node type in cfg --- assets/cfg-arc.js | 6 +- assets/cfg-dot.js | 2 +- src/lsp/cobol_cfg/cfg_builder.ml | 159 +++++++++++++++++++------------ 3 files changed, 103 insertions(+), 64 deletions(-) diff --git a/assets/cfg-arc.js b/assets/cfg-arc.js index 5fe8fff5d..51bda50e8 100644 --- a/assets/cfg-arc.js +++ b/assets/cfg-arc.js @@ -44,16 +44,16 @@ function getShortenName(d) { } function getDasharray(l) { - if(l.type === "u") + if(l.type === "g") return "45,6" - if(l.type === "c") + if(l.type === "p") return "12,5" return "" } function getNodeColor(color) { return function (d) { - const name = d.name.split(" IN "); + const name = d.fullname.split(" IN "); if(name.length > 1) { return color(name[1]) } diff --git a/assets/cfg-dot.js b/assets/cfg-dot.js index cf93a40e8..d6fa4d147 100644 --- a/assets/cfg-dot.js +++ b/assets/cfg-dot.js @@ -70,7 +70,7 @@ function setupOnEnd() { || n.name.startsWith(clickedName + " IN ") ) if(!node) return; focus(clickedName) - vscode.ostMessage({ + vscode.postMessage({ type: 'click', node: node.id }) diff --git a/src/lsp/cobol_cfg/cfg_builder.ml b/src/lsp/cobol_cfg/cfg_builder.ml index 0023812fe..68319632a 100644 --- a/src/lsp/cobol_cfg/cfg_builder.ml +++ b/src/lsp/cobol_cfg/cfg_builder.ml @@ -46,12 +46,18 @@ module Qmap = Map.Make(struct let compare = Cobol_ptree.compare_qualname end) +type node_type = + | External of string + | Entry of [`Point | `Paragraph | `Section of string] + | Normal of string + | Collapsed of string NEL.t + | Split of string + type node = { id: int; qid: qualname; - mutable names: string NEL.t; loc: srcloc option; - typ: [`External | `EntryPoint | `EntryPara | `EntrySection | `Internal | `SplitHub ]; + typ: node_type; jumps: Jumps.t; will_fallthru: bool; terminal: bool; @@ -59,8 +65,8 @@ type node = { let is_entry n = match n.typ with - | `EntryPara | `EntryPoint | `EntrySection -> true - | `External | `Internal | `SplitHub -> false + | External _ | Normal _ | Collapsed _ | Split _ -> false + | Entry _ -> true let fullqn_to_string qn = Pretty.to_string "%a" Cobol_ptree.pp_qualname qn @@ -158,7 +164,7 @@ module JumpCollector = struct end end -let build_node ~default_name ~cu paragraph = +let build_node ?(qn_to_string=fullqn_to_string) ~default_name ~cu paragraph = let open JumpCollector in let { jumps; will_fallthru; terminal; } = Visitor.fold_procedure_paragraph' (folder ~cu) paragraph init in @@ -166,16 +172,15 @@ let build_node ~default_name ~cu paragraph = let qid, loc = match ~¶graph.paragraph_name with | None -> default_name, ~@paragraph | Some qn -> full_qn' ~cu qn, ~@qn in - let name = fullqn_to_string qid + let name = qn_to_string qid in { id = !node_idx; qid; - names = NEL.One name; loc = Some loc; jumps; will_fallthru; terminal; - typ = `Internal; + typ = Normal name; } module Node = struct @@ -199,16 +204,16 @@ module Edge = struct let default = FallThrough let to_string = function | FallThrough -> "f" - | Perform -> "c" - | Go -> "u" + | Perform -> "p" + | Go -> "g" end module Cfg = Graph.Persistent.Digraph.ConcreteLabeled(Node)(Edge) -let vertex_name_record { names; _ } = +let vertex_name_record names = Pretty.to_string "%a" (NEL.pp ~fopen:"{" ~fclose:"}" ~fsep:"|" Fmt.string) - (NEL.rev names) + names (* Graph.Graphviz.DotAttributes *) module Dot = Graph.Graphviz.Dot(struct @@ -220,17 +225,18 @@ module Dot = Graph.Graphviz.Dot(struct | Go -> `Solid)] let default_edge_attributes _ = [] let get_subgraph _ = None - let vertex_attributes ({ typ; _ } as n) = - let label, shape = + let vertex_attributes { typ; _ } = + let label, attributes = match typ with - | `EntryPara -> "Entry\nparagraph", [`Shape `Doubleoctagon] - | `EntryPoint -> "Entry\npoint", [`Shape `Doubleoctagon] - | `EntrySection -> NEL.hd n.names, [`Shape `Doubleoctagon] - | `External -> NEL.hd n.names, [`Shape `Plaintext] - | `SplitHub -> vertex_name_record n, [`Style `Dashed] - | `Internal -> vertex_name_record n, [] - in `Label label :: shape - let default_vertex_attributes _ = [`Shape `Record] + | Entry (`Section 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) @@ -238,16 +244,18 @@ module Dot = Graph.Graphviz.Dot(struct let to_dot_string g = Pretty.to_string "%a" Dot.fprint_graph g -let dummy_node ?(typ=`External) (qn: qualname) = +let new_node ~typ (qn: qualname) = let loc = match qn with - | Cobol_ptree.Name name -> ~@name - | Qual (name, _) -> ~@name in + | Cobol_ptree.Name name -> ~@name + | Qual (name, _) -> ~@name in node_idx:= !node_idx + 1; - { + let typ = match typ with + | `External -> External (fullqn_to_string qn) + | `EntryPoint -> Entry `Point + in { id = !node_idx; qid = qn; loc = Some loc; - names = NEL.One (fullqn_to_string qn); jumps = Jumps.empty; will_fallthru = true; terminal = false; @@ -260,7 +268,7 @@ let clone_node node = let qmap_find_or_add qmap qn = match Qmap.find_opt qn qmap with - | None -> let node = dummy_node qn in + | None -> let node = new_node ~typ:`External qn in Qmap.add qn node qmap, node | Some node -> qmap, node @@ -290,20 +298,40 @@ let rec build_edges ~vertexes g nodes = let do_collapse_fallthru g = - Cfg.fold_vertex begin fun n cfg -> - match Cfg.pred_e cfg n with - | [(({ typ = `Internal; _ } as pred), FallThrough, _)] -> - let cfg = Cfg.fold_succ_e begin fun (_, e, next) cfg -> - if List.exists - begin fun succ -> qn_equal succ.qid next.qid end - (Cfg.succ cfg pred) - then cfg - else Cfg.add_edge_e cfg (pred, e, next) - end cfg n cfg in - pred.names <- NEL.(n.names @ pred.names); - Cfg.remove_vertex cfg n - | _ -> cfg - end g g + 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 ~names_map ~node ~pred n_names pred_names = + let cfg = Cfg.fold_succ_e begin fun (_, e, next) cfg -> + Cfg.add_edge_e cfg (pred, e, next) + end cfg node cfg in + let names_map = Qmap.update pred.qid + begin function + | None -> Some NEL.(n_names @ pred_names) + | Some names -> Some NEL.(n_names @ names) + end names_map in + Cfg.remove_vertex cfg node, names_map + in + let names_map = Qmap.empty in + let cfg, names_map = + Cfg.fold_vertex begin fun node (cfg, names_map) -> + match get_names_if_collapsable node with + | None -> (cfg, names_map) + | Some n_names -> + match Cfg.pred_e cfg node with + | [(({ typ = Normal pred_name ; _ } as pred), FallThrough, _)] -> + collapse_node ~cfg ~names_map ~node ~pred n_names (NEL.One pred_name) + | [(({ typ = Collapsed pred_names ; _ } as pred), FallThrough, _)] -> + collapse_node ~cfg ~names_map ~node ~pred n_names pred_names + | _ -> cfg, names_map + end g (g, names_map) in + Cfg.map_vertex begin fun node -> + match Qmap.find_opt node.qid names_map with + | None -> node + | Some names -> { node with typ = Collapsed (NEL.rev names) } + end cfg let do_hide_unreachable g = let rec aux cfg = @@ -318,18 +346,22 @@ let do_hide_unreachable g = in aux g let do_shatter_hubs ?(limit=20) g = + let is_shatterable { typ; _ } = + match typ with + | Normal name -> Some name + | External _ | Entry _ | Split _ | Collapsed _ -> None + in Cfg.fold_vertex begin fun n cfg -> - if Cfg.in_degree cfg n >= limit - then begin + match Cfg.in_degree cfg n >= limit, is_shatterable n with + | true, Some name -> 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 = `SplitHub } in + let n_clone = { (clone_node n) with typ = Split name } in let (pred, edge, _) = edge in let cfg = Cfg.add_edge_e cfg (pred, edge, n_clone) in cfg end cfg n cfg - end - else cfg + | _ -> cfg end g g let cfg_of_nodes nodes = @@ -365,10 +397,9 @@ let cfg_of ~(cu: cobol_unit) = |> begin function (* adding entry point if not already present *) | ({ qid; _ } as hd )::tl when qn_equal qid default_name -> - { hd with id=0; typ = `EntryPara; names = NEL.One "Entry paragraph" }::tl + { hd with id=0; typ = Entry `Paragraph }::tl | l -> - { (dummy_node ~typ:`EntryPoint default_name) - with id=0; names = NEL.One "Entry point" } :: l + { (new_node ~typ:`EntryPoint default_name) with id=0 } :: l end |> cfg_of_nodes @@ -377,15 +408,15 @@ let cfg_of_section ~cu ({ section_paragraphs; section_name }: procedure_section) let default_name = ~§ion_name in let nodes = List.fold_left begin fun acc p -> - let node = build_node ~default_name ~cu p in - let name = name_to_string node.qid in - { node with names = NEL.One name } :: acc + build_node ~qn_to_string:name_to_string ~default_name ~cu p + :: acc end [] section_paragraphs.list |> List.rev in - let nodes = match nodes with - | entry::tl -> { entry with typ = `EntrySection }::tl - | [] -> [] - in cfg_of_nodes nodes + begin match nodes with + | ({ typ = Normal name; _ } as entry)::tl -> + { entry with typ = Entry (`Section name) }::tl + | l -> l end + |> cfg_of_nodes type graph = { name: string; @@ -410,9 +441,17 @@ let to_d3_string cfg = end cfg [] in let cfg_nodes = Cfg.fold_vertex begin fun n acc -> - Pretty.to_string "{\"id\":%d,\"name\":\"%s\"}" - n.id (fullqn_to_string n.qid) - :: acc + let name = + match n.typ with + | Normal name | Entry (`Section name) | External name | Split name -> + name + | Collapsed names -> NEL.hd names + | Entry `Point -> "Entry point" + | Entry `Paragraph -> "Entry paragraph" + in Pretty.to_string + "{\"id\":%d,\"name\":\"%s\",\"fullname\":\"%s\"}" + n.id name (fullqn_to_string n.qid) + :: acc end cfg [] in let str_nodes = String.concat "," cfg_nodes in let str_edges = String.concat "," cfg_edges in From 1f2c418c4dda8425c32eac0aeb5062ac381ee6be Mon Sep 17 00:00:00 2001 From: Mateo Date: Wed, 18 Sep 2024 10:50:45 +0200 Subject: [PATCH 27/40] feat: context menu for nodes with various action - add history to go back to previous graphs --- assets/cfg-dot-renderer.html | 93 ++++++-- assets/cfg-dot.js | 223 ++++++++++++++---- src/lsp/cobol_cfg/cfg_builder.ml | 126 +++++++--- src/lsp/cobol_cfg/cfg_builder.mli | 2 - src/lsp/cobol_cfg/cfg_options.ml | 22 +- src/lsp/cobol_lsp/lsp_request.ml | 50 ++-- .../superbol_cfg_explorer.ml | 86 ++++--- 7 files changed, 442 insertions(+), 160 deletions(-) diff --git a/assets/cfg-dot-renderer.html b/assets/cfg-dot-renderer.html index 771b41aab..a47923617 100644 --- a/assets/cfg-dot-renderer.html +++ b/assets/cfg-dot-renderer.html @@ -18,6 +18,9 @@ #app { flex-grow: 1; } +#modals { + height: 0; +} #rendering { position: absolute; @@ -30,45 +33,101 @@ .hidden { display: none !important; } -#legend { +.modal { position: absolute; - margin-block-start: .5em; + background-color: var(--vscode-sideBar-background); + border: var(--vscode-focusBorder) 1px solid; +} +#legend { padding: 2px 2px 0 2px; width: 500px; - background-color: var(--vscode-editor-background); - border: var(--vscode-focusBorder) 1px solid; } -#options { +#render-options { display: flex; flex-flow: column; - position: absolute; - margin-block-start: .5em; padding: .5em .2em; - background-color: var(--vscode-editor-background); - border: var(--vscode-focusBorder) 1px solid; } #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 index d6fa4d147..2abf37f01 100644 --- a/assets/cfg-dot.js +++ b/assets/cfg-dot.js @@ -1,33 +1,113 @@ +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; +var renderOptions = { ...options(), hidden_nodes: [], split_nodes: [] }; var rendering = d3.select('#rendering') +const history = [] + +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 reset() { graphviz?.resetZoom() } +function historyGoBack() { + history.pop(); + const [dot, graph, options] = JSON.parse(history[history.length - 1]); + renderOptions = options; + renderGraph(dot, graph) + if(history.length == 1) { + document.getElementById("history-btn").disabled = true + } + document.getElementById("unreachable").checked = + renderOptions.hide_unreachable; + document.getElementById("fallthru").checked = + renderOptions.collapse_fallthru; + document.getElementById("hubshatter").checked = + renderOptions.shatter_hubs != undefined; + document.getElementById("hubcount").value = + renderOptions.shatter_hubs == undefined + ? "20" + : String(renderOptions.shatter_hubs); + 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") + } +} + function toggleLegend() { - if(document.getElementById('legend').classList != "") { - document.getElementById('options').classList = "hidden"; - document.getElementById('legend').classList = ""; + if(elementLegend.classList.contains("hidden")) { + hideModals(); + elementLegend.classList.remove("hidden"); } - else document.getElementById('legend').classList = "hidden"; + else hideModals() } -function toggleOptions() { - if(document.getElementById('options').classList != "") { - document.getElementById('options').classList = ""; - document.getElementById('legend').classList = "hidden"; +function toggleRenderOptions() { + if(elementOptions.classList.contains("hidden")) { + hideModals(); + elementOptions.classList.remove("hidden"); } - else document.getElementById('options').classList = "hidden"; + else hideModals() } -function hideOptions() { - document.getElementById('options').classList = "hidden"; +function hideModals() { + elementOptions.classList.add("hidden"); + elementLegend.classList.add("hidden"); } -function rerender() { +function options() { var collapse_fallthru = document.getElementById('fallthru').checked; var hide_unreachable = document.getElementById('unreachable').checked; if(document.getElementById('hubshatter').checked) { @@ -36,14 +116,62 @@ function rerender() { else { var shatter_hubs = undefined; } - vscode.postMessage({ - type: 'graph_update', - renderOptions: { - hide_unreachable, - collapse_fallthru, - shatter_hubs, - } - }) + return { + hide_unreachable, + collapse_fallthru, + shatter_hubs, + } +} + +function rerender() { + renderOptions = { + ...renderOptions, + ...options(), + }; + 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 createClickableElement(node, parentId) { + const el = document.createElement("p") + el.append(`Show "${node.name}" `) + const linkedNodeId = node.id; + el.onclick = (ev) => { + ev.target.remove() + if(id == "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 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 }) } function focus(name) { @@ -58,8 +186,6 @@ function focus(name) { function setupOnEnd() { rendering.classed("hidden", true); d3.selectAll("svg g title").remove() - d3.selectAll("svg .node") - .attr("data-vscode-context", '{"node":true}') d3.selectAll("svg text") .on("click", (_, e) => { const clickedName = e.children[0].text; @@ -75,47 +201,44 @@ function setupOnEnd() { node: node.id }) }) - .on("contextmenu", (_, e) => { - const clickedName = e.children[0].text; - if(!clickedName) return; + .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) return; - vscode.postMessage({ type: "context-node", node }) - + if(!node) { contextNode = undefined; return; } + contextNode = node; + showContextMenu(ev.clientX, ev.clientY); }) } -function updateLegend(legend) { - d3.select("#legend").graphviz().renderDot(legend) - .zoom(false) - .width("100%") - .fit(true) - .on("end", () => d3.select("#legend svg").attr("height", null)) - +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 } window.addEventListener('message', event => { switch (event.data.type) { case "graph_content": - if(graphviz) { - graphviz.destroy() - d3.select('#app svg').remove() - } - hideOptions() - if(event.data.legend) { - updateLegend(event.data.legend) - } - 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(event.data.dot) - .on('end', setupOnEnd) - rendering.classed("hidden", false); graph = JSON.parse(event.data.graph) + renderGraph(event.data.dot, graph) + hideModals() + history.push(JSON.stringify([event.data.dot, graph, renderOptions])) + if(history.length > 1) { + document.getElementById('history-btn').disabled = false + } break; case "focused_proc": focus(event.data.procedure) diff --git a/src/lsp/cobol_cfg/cfg_builder.ml b/src/lsp/cobol_cfg/cfg_builder.ml index 68319632a..ab5445eeb 100644 --- a/src/lsp/cobol_cfg/cfg_builder.ml +++ b/src/lsp/cobol_cfg/cfg_builder.ml @@ -22,11 +22,6 @@ type jumps = | GoDepending of qualname | Perform of qualname -module Qualnames = Set.Make(struct - type t = qualname - let compare = Cobol_ptree.compare_qualname -end) - module Jumps = Set.Make(struct type t = jumps let compare j1 j2 = @@ -333,11 +328,12 @@ let do_collapse_fallthru g = | Some names -> { node with typ = Collapsed (NEL.rev names) } end cfg -let do_hide_unreachable g = +let do_hide_unreachable ~except 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) + && not (List.mem n.id except) then true, Cfg.remove_vertex cfg n else did_remove, cfg end cfg (false, cfg) @@ -345,15 +341,21 @@ let do_hide_unreachable g = if did_remove then aux cfg else cfg in aux g -let do_shatter_hubs ?(limit=20) g = +let do_shatter_nodes ~ids ~limit g = let is_shatterable { typ; _ } = match typ with | Normal name -> Some name | External _ | 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 Cfg.in_degree cfg n >= limit, is_shatterable n with - | true, Some name -> + match is_shatterable n with + | Some name + when is_above_limit n || List.mem n.id ids -> 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 = Split name } in @@ -364,6 +366,64 @@ let do_shatter_hubs ?(limit=20) g = | _ -> 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 Nodes.empty, 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 + Cfg.fold_vertex begin fun node cfg -> + if Nodes.mem node reachables + 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 cfg_of_nodes nodes = let g, vertexes = List.fold_left begin fun (g, vertexes) node -> Cfg.add_vertex g node, @@ -373,12 +433,25 @@ let cfg_of_nodes nodes = build_edges ~vertexes g nodes let handle_cfg_options ~(options: Cfg_options.t) cfg = + let unreachable_expections = + match options.transformation with + | Some Cfg_options.Neighborhood id + | Some Cfg_options.Descendents id -> [id] + | None -> [] in cfg - |> (if options.collapse_fallthru then do_collapse_fallthru else Fun.id) - |> (if options.hide_unreachable then do_hide_unreachable else Fun.id) - |> (match options.shatter_hubs with - | Some limit -> do_shatter_hubs ~limit + |> (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 + then do_hide_unreachable ~except:unreachable_expections else Fun.id) + |> (match options.hidden_nodes with + | [] -> Fun.id + | l -> remove_nodes l) + |> (if options.collapse_fallthru then do_collapse_fallthru else Fun.id) + (* IMPORTANT: shatter needs to be after collapse, or else it's possible + to find a collapsed node linked to duplicate shattered nodes *) + |> do_shatter_nodes ~ids:options.split_nodes ~limit:options.shatter_hubs let cfg_of ~(cu: cobol_unit) = node_idx := 0; @@ -470,9 +543,9 @@ let make_cfg ?(graph_name=None) ({ group; _ }: Cobol_typeck.Outputs.t) = let name = Pretty.to_string "%a (%s)" Cobol_ptree.pp_qualname' ~&sec.section_name ((~&) cu.unit_name) in - if not (is_to_include name) - then None - else Some ( name, cfg_of_section ~cu ~&sec) + if is_to_include name + then Some (name, cfg_of_section ~cu ~&sec) + else None end cu.unit_procedure.list in let cu_graph = if is_to_include ((~&) cu.unit_name) @@ -492,24 +565,3 @@ let make ~(options: Cfg_options.t) (checked_doc: Cobol_typeck.Outputs.t) = nodes_pos = nodes_pos cfg; } end - -let graphviz_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 } -}|} diff --git a/src/lsp/cobol_cfg/cfg_builder.mli b/src/lsp/cobol_cfg/cfg_builder.mli index 9081003f5..607cd18ca 100644 --- a/src/lsp/cobol_cfg/cfg_builder.mli +++ b/src/lsp/cobol_cfg/cfg_builder.mli @@ -19,5 +19,3 @@ val make : options:Cfg_options.t -> Cobol_typeck.Outputs.t -> graph list - -val graphviz_legend : string diff --git a/src/lsp/cobol_cfg/cfg_options.ml b/src/lsp/cobol_cfg/cfg_options.ml index cc1a514b7..cf31eba1f 100644 --- a/src/lsp/cobol_cfg/cfg_options.ml +++ b/src/lsp/cobol_cfg/cfg_options.ml @@ -8,11 +8,18 @@ (* *) (******************************************************************************) +type transformation = + | Descendents of int + | Neighborhood of int + type t = { graph_name: string option; hide_unreachable: bool; collapse_fallthru: bool; shatter_hubs: int option; + transformation: transformation option; + hidden_nodes: int list; + split_nodes: int list; } let create @@ -20,6 +27,17 @@ let create ?(hide_unreachable=false) ?(collapse_fallthru=true) ?(shatter_hubs=None) - () - = { hide_unreachable; collapse_fallthru; graph_name; shatter_hubs } + ?(transformation=None) + ?(hidden_nodes=[]) + ?(split_nodes=[]) + () = + { + hide_unreachable; + collapse_fallthru; + graph_name; + shatter_hubs; + transformation; + hidden_nodes; + split_nodes; + } diff --git a/src/lsp/cobol_lsp/lsp_request.ml b/src/lsp/cobol_lsp/lsp_request.ml index 9e386e123..d2df864c1 100644 --- a/src/lsp/cobol_lsp/lsp_request.ml +++ b/src/lsp/cobol_lsp/lsp_request.ml @@ -134,21 +134,42 @@ let handle_get_project_config_command param registry = expected)" Yojson.Safe.(to_string (param :> t)) let create_cfg_options o = + let open Yojson.Safe.Util in let graph_name = - try Some (List.assoc "graph_name" o |> Yojson.Safe.Util.to_string) - with Not_found -> None in + List.assoc_opt "graph_name" o |> Option.map to_string in let hide_unreachable = - try Some (List.assoc "hide_unreachable" o |> Yojson.Safe.Util.to_bool) - with Not_found -> None in + List.assoc_opt "hide_unreachable" o |> Option.map to_bool in let collapse_fallthru = - try Some (List.assoc "collapse_fallthru" o |> Yojson.Safe.Util.to_bool) - with Not_found -> None in + List.assoc_opt "collapse_fallthru" o |> Option.map to_bool in let shatter_hubs = - try Some (List.assoc "shatter_hubs" o |> Yojson.Safe.Util.to_int) - with Not_found -> None in - Cobol_cfg.Options.create ~graph_name ?hide_unreachable ?collapse_fallthru ~shatter_hubs () - -let handle_open_cfg registry params = + List.assoc_opt "shatter_hubs" 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 = + List.assoc_opt "hidden_nodes" o |> Option.map to_list + |> Option.map (List.map to_int) in + let split_nodes = + List.assoc_opt "split_nodes" o |> Option.map to_list + |> Option.map (List.map to_int) in + Cobol_cfg.Options.create () + ~graph_name + ?hide_unreachable + ?collapse_fallthru + ~shatter_hubs + ~transformation + ?hidden_nodes + ?split_nodes + +let handle_get_cfg registry params = let params = Jsonrpc.Structured.yojson_of_t params in let uri, options = Yojson.Safe.Util.( to_string @@ member "uri" params, @@ -171,10 +192,9 @@ let handle_open_cfg registry params = ("nodes_pos", `Assoc nodes_pos); ("name", `String name);] in - Some (`Assoc ["graphviz_legend", `String graphviz_legend; - "graphs", `List (List.map yojsonify graphs)]) + Some (`List (List.map yojsonify graphs)) end - |> Option.value ~default:(`Assoc []) + |> Option.value ~default:(`List []) let handle_find_procedure registry params = let params = Jsonrpc.Structured.yojson_of_t params in @@ -890,7 +910,7 @@ let on_request handle_get_project_config_command param registry | UnknownRequest { meth = "superbol/getCFG"; params = Some param } -> - Ok (handle_open_cfg registry param, state) + Ok (handle_get_cfg registry param, state) | UnknownRequest { meth = "superbol/findProcedure"; params = Some param } -> Ok (handle_find_procedure registry param, state) diff --git a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml index 5df472282..292b1190a 100644 --- a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml +++ b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml @@ -78,6 +78,7 @@ type graph = { 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 @@ -91,6 +92,12 @@ let decode_graph res = (* WEBVIEW MANAGEMENT *) +type stored_data = { + webview_panel: WebviewPanel.t; + graph: graph; + render_options: Jsonoo.t; +} + let webview_panels = Hashtbl.create 1 let window_listener = ref None @@ -110,11 +117,14 @@ let webviewpanel_disposal ~filename ~typ () = ~decorationType ~rangesOrOptions:(`Ranges []) let create_or_get_webview ~graph ~uri ~typ = + let render_options = Jsonoo.Encode.object_ + ["graph_name", Jsonoo.Encode.string graph.name] in let filename = Uri.path uri in match Hashtbl.find_opt webview_panels (filename, typ) with - | Some (webview_panel, _) -> + | Some { webview_panel; _ } -> WebviewPanel.reveal webview_panel (); - Hashtbl.replace webview_panels (filename, typ) (webview_panel, graph); + Hashtbl.replace webview_panels (filename, typ) + { webview_panel; graph; render_options }; WebviewPanel.webview webview_panel, false | None -> let viewType = match typ with @@ -128,18 +138,24 @@ let create_or_get_webview ~graph ~uri ~typ = ~thisArgs:Ojs.null ~disposables:[] in let webview = WebviewPanel.webview webview_panel in WebView.set_options webview (WebviewOptions.create ~enableScripts:true ()); - Hashtbl.add webview_panels (filename, typ) (webview_panel, graph); + Hashtbl.add webview_panels (filename, typ) + { webview_panel; graph; render_options }; webview, true -let webview_n_graph_find_opt ~uri ~typ = +let webview_data_find_opt ~uri ~typ = Hashtbl.find_opt webview_panels (Uri.path uri, typ) - |> Option.map begin fun (w,g) -> WebviewPanel.webview w, g end + |> Option.map begin fun { webview_panel; graph; render_options } -> + WebviewPanel.webview webview_panel, graph, render_options + end -let update_graph ~uri ~typ graph = +let update_webview_data ~uri ~typ ?graph ?render_options () = let filename = Uri.path uri in match Hashtbl.find_opt webview_panels (filename, typ) with - | Some (wvp, _) -> - Hashtbl.replace webview_panels (filename, typ) (wvp, graph) + | 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 *) @@ -199,14 +215,14 @@ let setup_window_listener ~client = end) in () in - let webview = webview_n_graph_find_opt ~uri ~typ:Graphviz 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_n_graph_find_opt ~uri ~typ:D3_arc_diagram in + | 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 + | Some (webview, _, _) -> process_selection_change webview in let disposable_listener = match !window_listener with @@ -217,58 +233,57 @@ let setup_window_listener ~client = (* MESSAGE MANAGER *) -let send_graph ?(legend=None) ~typ webview graph = +let send_graph ~typ webview graph = let ojs = Ojs.empty_obj () in Ojs.set_prop_ascii ojs "type" (Ojs.string_to_js "graph_content"); 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); - Option.iter begin fun legend -> - Ojs.set_prop_ascii ojs "legend" (Ojs.string_to_js legend) - end legend; let _ : bool Promise.t = WebView.postMessage webview ojs in () -let on_graph_update ~webview ~client ~uri ~typ name arg = - let options = - Ojs.get_prop_ascii arg "renderOptions" - |> begin fun ojs -> - Ojs.set_prop_ascii ojs "graph_name" @@ Ojs.string_to_js name; - ojs end - |> Jsonoo.t_of_js in +let get_and_send_graph ~client ~uri ~typ ~webview ~render_options = let data = let uri = Jsonoo.Encode.string @@ Uri.path uri in - Jsonoo.Encode.object_ ["uri", uri; "render_options", options;] in + Jsonoo.Encode.object_ ["uri", uri; "render_options", render_options] in let _ : unit Promise.t = Vscode_languageclient.LanguageClient.sendRequest client () ~meth:"superbol/getCFG" ~data |> Promise.then_ ~fulfilled:begin fun jsonoo_res -> - let graphs = Jsonoo.Decode.field "graphs" - (Jsonoo.Decode.list decode_graph) jsonoo_res in + let graphs = (Jsonoo.Decode.list decode_graph) jsonoo_res in match graphs with | [] -> Window.showErrorMessage () ~message:"Unable to perform operation, try reloading the CFG" |> Promise.map (Fun.const ()) | graph::_ -> - update_graph ~uri ~typ graph; + update_webview_data ~uri ~typ ~graph ~render_options (); send_graph ~typ webview graph; Promise.return () end in () -let on_message ?(legend=None)~client ~text_editor ~typ arg = +let on_graph_update ~webview ~client ~uri ~typ name arg = + let render_options = + Ojs.get_prop_ascii arg "renderOptions" + |> begin fun ojs -> + Ojs.set_prop_ascii ojs "graph_name" @@ Ojs.string_to_js name; + ojs end + |> Jsonoo.t_of_js in + get_and_send_graph ~client ~uri ~typ ~webview ~render_options + +let on_message ~client ~text_editor ~typ arg = let uri = TextEditor.document text_editor |> TextDocument.uri in let request_type = Ojs.get_prop_ascii arg "type" |> Ojs.string_of_js in - webview_n_graph_find_opt ~uri ~typ - |> Option.iter begin fun (webview, graph) -> + webview_data_find_opt ~uri ~typ + |> Option.iter begin fun (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 ~legend ~typ webview graph + send_graph ~typ webview graph | _ -> () end @@ -287,11 +302,8 @@ let open_cfg_for ~typ ~text_editor ~extension_uri client = | Ok html_js -> Vscode_languageclient.LanguageClient.sendRequest client () ~meth:"superbol/getCFG" ~data - |> then_ ~fulfilled:begin fun jsonoo_res -> - let graphs = Jsonoo.Decode.field "graphs" - (Jsonoo.Decode.list decode_graph) jsonoo_res in - let legend = Jsonoo.Decode.field "graphviz_legend" - Jsonoo.Decode.string jsonoo_res in + |> then_ ~fulfilled:begin fun jsonoo_graphs -> + let graphs = (Jsonoo.Decode.list decode_graph) jsonoo_graphs in Window.showQuickPick ~items:(Stdlib.List.map (fun g -> g.name) graphs) () |> then_ ~fulfilled:begin function | None -> return () @@ -302,7 +314,7 @@ let open_cfg_for ~typ ~text_editor ~extension_uri client = let html_content = setup_html_js_content ~webview ~typ html_js in let _ : Disposable.t = WebView.onDidReceiveMessage webview () - ~listener:(on_message ~legend:(Some legend) ~client ~text_editor ~typ) + ~listener:(on_message ~client ~text_editor ~typ) ~thisArgs:Ojs.null ~disposables:[] in if is_new From c20b4f315091fa7a5dc7681c749ebac152999e1f Mon Sep 17 00:00:00 2001 From: Mateo Date: Wed, 18 Sep 2024 12:30:05 +0200 Subject: [PATCH 28/40] refactor: reorganize cfg module --- src/lsp/cobol_cfg/cfg_builder.ml | 475 +++++++++++++------------------ src/lsp/cobol_cfg/cfg_jumps.ml | 131 +++++++++ 2 files changed, 322 insertions(+), 284 deletions(-) create mode 100644 src/lsp/cobol_cfg/cfg_jumps.ml diff --git a/src/lsp/cobol_cfg/cfg_builder.ml b/src/lsp/cobol_cfg/cfg_builder.ml index ab5445eeb..6eee39a56 100644 --- a/src/lsp/cobol_cfg/cfg_builder.ml +++ b/src/lsp/cobol_cfg/cfg_builder.ml @@ -12,35 +12,29 @@ open Cobol_unit open Cobol_common.Srcloc.INFIX open Cobol_common.Srcloc.TYPES open Cobol_unit.Types -open Cobol_common.Visitor +open Cfg_jumps module NEL = Cobol_common.Basics.NEL -type qualname = Cobol_ptree.qualname +(* TYPES AND HELPERS *) -type jumps = - | Go of qualname - | GoDepending of qualname - | Perform of qualname - -module Jumps = Set.Make(struct - type t = jumps - let compare j1 j2 = - let to_int = function - | Go _ -> 0 - | GoDepending _ -> 1 - | Perform _ -> 2 in - match j1, j2 with - | Go qn1, Go qn2 - | GoDepending qn1, GoDepending qn2 - | Perform qn1, Perform qn2 -> Cobol_ptree.compare_qualname qn1 qn2 - | _ -> to_int j2 - to_int j1 - end) +type qualname = Cobol_ptree.qualname module Qmap = Map.Make(struct type t = qualname let compare = Cobol_ptree.compare_qualname end) +let fullqn_to_string qn = + Pretty.to_string "%a" Cobol_ptree.pp_qualname qn + +let name_to_string (qn: qualname) = + Cobol_ptree.(match qn with + | Name name | Qual (name, _) -> Pretty.to_string "%a" pp_name' name) + +let qn_equal qn1 qn2 = 0 == Cobol_ptree.compare_qualname qn1 qn2 + +(* CFG MODULE *) + type node_type = | External of string | Entry of [`Point | `Paragraph | `Section of string] @@ -63,123 +57,13 @@ let is_entry n = | External _ | Normal _ | Collapsed _ | Split _ -> false | Entry _ -> true -let fullqn_to_string qn = - Pretty.to_string "%a" Cobol_ptree.pp_qualname qn - -let name_to_string (qn: qualname) = - Cobol_ptree.(match qn with - | Name name | Qual (name, _) -> Pretty.to_string "%a" pp_name' name) - -let qn_equal qn1 qn2 = 0 == Cobol_ptree.compare_qualname qn1 qn2 - -let full_qn ~cu qn = - (Qualmap.find_binding qn cu.unit_procedure.named).full_qn - -let full_qn' ~cu qn = full_qn ~cu ~&qn - -let node_idx = ref 0 - -let listsplit3 l = - List.fold_left begin fun (a_acc, b_acc, c_acc) (a, b, c) -> - (a::a_acc, b::b_acc, c::c_acc) - end ([], [], []) l - -module JumpCollector = struct - type acc = { - jumps: Jumps.t; - will_fallthru: bool; - terminal: bool; - } - let init = { jumps = Jumps.empty; - terminal = false; - will_fallthru = true; } - let folder ~cu = object (v) - inherit [acc] Visitor.folder - method! fold_goback' _ acc = - skip @@ { acc with terminal = true; will_fallthru = false } - method! fold_stop' _ acc = - skip @@ { acc with terminal = true; will_fallthru = false } - method! fold_exit' { payload = exit_stmt; _ } acc = - skip @@ - match exit_stmt with - | ExitSimple | ExitPerform _ - | ExitMethod _ | ExitProgram _ | ExitFunction _ -> acc - | ExitParagraph -> { acc with will_fallthru = true } (* TODO change this to a goto next para *) - | ExitSection -> { acc with will_fallthru = false } (* TODO: go to next section ? *) - method! fold_evaluate' { payload; _ } acc = - let { eval_branches; eval_otherwise; _ }: Cobol_ptree.evaluate_stmt = - payload in - let jumps, terminals, unreachables = List.map begin fun branch -> - let { jumps; terminal; will_fallthru } = - Cobol_ptree.Visitor.fold_evaluate_branch v branch init in - (jumps, terminal, will_fallthru) - end eval_branches |> listsplit3 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; - } - method! fold_statement' _ ({ will_fallthru; _ } as acc) = - if will_fallthru then do_children acc else skip acc - method! fold_if' { payload = { then_branch; else_branch; _ }; _ } acc = - let { jumps; terminal; will_fallthru } = - Cobol_ptree.Visitor.fold_statements v then_branch acc in - let { jumps = else_jumps; - terminal = else_terminal; - will_fallthru = else_fallthru } = - 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; - } - 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; - } - | 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 } - end -end - -let build_node ?(qn_to_string=fullqn_to_string) ~default_name ~cu paragraph = - let open JumpCollector in - let { jumps; will_fallthru; terminal; } = - Visitor.fold_procedure_paragraph' (folder ~cu) paragraph init in - node_idx:=!node_idx+1; - let qid, loc = match ~¶graph.paragraph_name with - | None -> default_name, ~@paragraph - | Some qn -> full_qn' ~cu qn, ~@qn in - let name = qn_to_string qid - in { - id = !node_idx; - qid; - loc = Some loc; - jumps; - will_fallthru; - terminal; - typ = Normal name; - } +type edge = + | FallThrough + | Perform + | Go -module Node = struct - type t = node + module Node = struct + type t = node let compare node other = Int.compare node.id other.id let hash node = @@ -188,11 +72,6 @@ module Node = struct Int.equal node.id other.id end -type edge = - | FallThrough - | Perform - | Go - module Edge = struct type t = edge let compare = Stdlib.compare @@ -205,39 +84,27 @@ end module Cfg = Graph.Persistent.Digraph.ConcreteLabeled(Node)(Edge) -let vertex_name_record names = - Pretty.to_string "%a" - (NEL.pp ~fopen:"{" ~fclose:"}" ~fsep:"|" Fmt.string) - names - -(* Graph.Graphviz.DotAttributes *) -module Dot = Graph.Graphviz.Dot(struct - include 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 `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) +(* DEFAULT CFG BUILDER FUNCTION *) -let to_dot_string g = - Pretty.to_string "%a" Dot.fprint_graph g +let node_idx = ref 0 +let build_node ?(qn_to_string=fullqn_to_string) ~default_name ~cu paragraph = + let { jumps; will_fallthru; terminal; }: JumpsCollector.acc = + Visitor.fold_procedure_paragraph' + (JumpsCollector.folder ~cu) paragraph JumpsCollector.init in + node_idx:=!node_idx+1; + let qid, loc = match ~¶graph.paragraph_name with + | None -> default_name, ~@paragraph + | Some qn -> full_qn' ~cu qn, ~@qn in + let name = qn_to_string qid + in { + id = !node_idx; + qid; + loc = Some loc; + jumps; + will_fallthru; + terminal; + typ = Normal name; + } let new_node ~typ (qn: qualname) = let loc = match qn with @@ -257,40 +124,107 @@ let new_node ~typ (qn: qualname) = typ; } -let clone_node node = - node_idx:= !node_idx + 1; - { node with id = !node_idx; } +let build_edges nodes = + let qmap_find_or_add qmap qn = + match Qmap.find_opt qn qmap with + | None -> let node = new_node ~typ:`External qn in + Qmap.add qn node qmap, node + | Some node -> qmap, 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 jump_to + | Go jump_to -> + let vertexes, next = qmap_find_or_add vertexes jump_to in + Cfg.add_edge_e g (current, Go, next), + vertexes + | Perform jump_to -> + let vertexes, next = qmap_find_or_add vertexes jump_to in + Cfg.add_edge_e g (current, Perform, next), + 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, + Qmap.add node.qid node vertexes + end (Cfg.empty, Qmap.empty) nodes + in + edge_builder_aux ~vertexes g nodes -let qmap_find_or_add qmap qn = - match Qmap.find_opt qn qmap with - | None -> let node = new_node ~typ:`External qn in - Qmap.add qn node qmap, node - | Some node -> qmap, node - -let rec build_edges ~vertexes g nodes = - let g, vertexes = match nodes with - | ({ jumps; _ } as current)::_ -> - Jumps.fold begin fun uncond (g, vertexes) -> - match uncond with - | GoDepending jump_to - | Go jump_to -> - let vertexes, next = qmap_find_or_add vertexes jump_to in - Cfg.add_edge_e g (current, Go, next), - vertexes - | Perform jump_to -> - let vertexes, next = qmap_find_or_add vertexes jump_to in - Cfg.add_edge_e g (current, Perform, next), - vertexes - end jumps (g, vertexes) - | [] -> g, vertexes +let cfg_of ~(cu: cobol_unit) = + node_idx := 0; + let default_name = Cobol_ptree.Name cu.unit_name in + let nodes = List.fold_left begin fun acc block -> + match block with + | Paragraph para -> + build_node ~default_name ~cu para :: acc + | Section { payload = { section_paragraphs; _ }; _ } -> + List.fold_left begin fun acc p -> + build_node ~default_name ~cu p :: acc + end acc section_paragraphs.list + end [] cu.unit_procedure.list in - match nodes with - | ({ will_fallthru; _ } as current)::next::tl - when will_fallthru -> - build_edges ~vertexes (Cfg.add_edge g current next) (next::tl) - | _::tl -> build_edges ~vertexes g tl - | [] -> g + List.rev nodes + |> begin function (* adding entry point if not already present *) + | ({ qid; _ } as hd )::tl + when qn_equal qid default_name -> + { hd with id=0; typ = Entry `Paragraph }::tl + | l -> + { (new_node ~typ:`EntryPoint default_name) with id=0 } :: l + end + |> build_edges + +let cfg_of_section ~cu ({ section_paragraphs; section_name }: procedure_section) = + node_idx := 0; + let default_name = ~§ion_name in + let nodes = + List.fold_left begin fun acc p -> + build_node ~qn_to_string:name_to_string ~default_name ~cu p + :: acc + end [] section_paragraphs.list + |> 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 cfgs_of_doc ?(graph_name=None) ({ group; _ }: Cobol_typeck.Outputs.t) = + let is_to_include : string -> bool = + match graph_name with + | None -> Fun.const true + | Some name -> String.equal name in + 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 + if is_to_include name + then Some (name, cfg_of_section ~cu ~&sec) + else None + end cu.unit_procedure.list in + let cu_graph = + if is_to_include ((~&) cu.unit_name) + then [((~&)cu.unit_name, cfg_of ~cu)] + else [] + in cu_graph @ section_graphs @ acc + end group [] + +(* CFG OPTIONS HANDLER *) let do_collapse_fallthru g = let get_names_if_collapsable { typ; _ } = @@ -341,6 +275,10 @@ let do_hide_unreachable ~except g = if did_remove then aux cfg else cfg in aux g +let clone_node node = + node_idx:= !node_idx + 1; + { node with id = !node_idx; } + let do_shatter_nodes ~ids ~limit g = let is_shatterable { typ; _ } = match typ with @@ -424,14 +362,6 @@ let remove_nodes ids cfg = | Some node -> Cfg.remove_vertex cfg node end cfg ids -let cfg_of_nodes nodes = - let g, vertexes = List.fold_left begin fun (g, vertexes) node -> - Cfg.add_vertex g node, - Qmap.add node.qid node vertexes - end (Cfg.empty, Qmap.empty) nodes - in - build_edges ~vertexes g nodes - let handle_cfg_options ~(options: Cfg_options.t) cfg = let unreachable_expections = match options.transformation with @@ -453,57 +383,40 @@ let handle_cfg_options ~(options: Cfg_options.t) cfg = to find a collapsed node linked to duplicate shattered nodes *) |> do_shatter_nodes ~ids:options.split_nodes ~limit:options.shatter_hubs -let cfg_of ~(cu: cobol_unit) = - node_idx := 0; - let default_name = Cobol_ptree.Name cu.unit_name in - let nodes = List.fold_left begin fun acc block -> - match block with - | Paragraph para -> - build_node ~default_name ~cu para :: acc - | Section { payload = { section_paragraphs; _ }; _ } -> - List.fold_left begin fun acc p -> - build_node ~default_name ~cu p :: acc - end acc section_paragraphs.list - end [] cu.unit_procedure.list - in - List.rev nodes - |> begin function (* adding entry point if not already present *) - | ({ qid; _ } as hd )::tl - when qn_equal qid default_name -> - { hd with id=0; typ = Entry `Paragraph }::tl - | l -> - { (new_node ~typ:`EntryPoint default_name) with id=0 } :: l - end - |> cfg_of_nodes +(* CFG TO STRING FORMATTERS *) -let cfg_of_section ~cu ({ section_paragraphs; section_name }: procedure_section) = - node_idx := 0; - let default_name = ~§ion_name in - let nodes = - List.fold_left begin fun acc p -> - build_node ~qn_to_string:name_to_string ~default_name ~cu p - :: acc - end [] section_paragraphs.list - |> List.rev in - begin match nodes with - | ({ typ = Normal name; _ } as entry)::tl -> - { entry with typ = Entry (`Section name) }::tl - | l -> l end - |> cfg_of_nodes +let vertex_name_record names = + Pretty.to_string "%a" + (NEL.pp ~fopen:"{" ~fclose:"}" ~fsep:"|" Fmt.string) + names -type graph = { - name: string; - string_repr_dot: string; - string_repr_d3: string; - nodes_pos: (int * srcloc) list -} +module Dot = Graph.Graphviz.Dot(struct + include 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 `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 nodes_pos cfg = - Cfg.fold_vertex begin fun n acc -> - match n.loc with - | None -> acc - | Some loc -> (n.id, loc)::acc - end cfg [] +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 @@ -522,6 +435,8 @@ let to_d3_string cfg = | Entry `Point -> "Entry point" | Entry `Paragraph -> "Entry paragraph" in Pretty.to_string + (* TODO: fullname is used in cfg-arc.js for correct coloring when displaying + section graphs, it could be refactored to only be a section_id *) "{\"id\":%d,\"name\":\"%s\",\"fullname\":\"%s\"}" n.id name (fullqn_to_string n.qid) :: acc @@ -530,32 +445,24 @@ let to_d3_string cfg = let str_edges = String.concat "," cfg_edges in Pretty.to_string "{\"links\":[%s],\"nodes\":[%s]}" str_edges str_nodes -let make_cfg ?(graph_name=None) ({ group; _ }: Cobol_typeck.Outputs.t) = - let is_to_include : string -> bool = - match graph_name with - | None -> Fun.const true - | Some name -> String.equal name in - 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 - if is_to_include name - then Some (name, cfg_of_section ~cu ~&sec) - else None - end cu.unit_procedure.list in - let cu_graph = - if is_to_include ((~&) cu.unit_name) - then [((~&)cu.unit_name, cfg_of ~cu)] - else [] - in cu_graph @ section_graphs @ acc - end group [] +(* GRAPH OUTPUT FORMAT *) + +let nodes_pos cfg = + Cfg.fold_vertex begin fun n acc -> + match n.loc with + | None -> acc + | Some loc -> (n.id, loc)::acc + end cfg [] + +type graph = { + name: string; + string_repr_dot: string; + string_repr_d3: string; + nodes_pos: (int * srcloc) list +} let make ~(options: Cfg_options.t) (checked_doc: Cobol_typeck.Outputs.t) = - make_cfg ~graph_name:options.graph_name checked_doc + cfgs_of_doc ~graph_name:options.graph_name checked_doc |> List.map begin fun (name, cfg) -> let cfg_with_options = handle_cfg_options ~options cfg in { diff --git a/src/lsp/cobol_cfg/cfg_jumps.ml b/src/lsp/cobol_cfg/cfg_jumps.ml new file mode 100644 index 000000000..359714d94 --- /dev/null +++ b/src/lsp/cobol_cfg/cfg_jumps.ml @@ -0,0 +1,131 @@ +(******************************************************************************) +(* *) +(* 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 + +module Jumps = Set.Make(struct + type t = jumps + let compare j1 j2 = + let to_int = function + | Go _ -> 0 + | GoDepending _ -> 1 + | Perform _ -> 2 in + match j1, j2 with + | Go qn1, Go qn2 + | GoDepending qn1, GoDepending qn2 + | Perform qn1, Perform qn2 -> Cobol_ptree.compare_qualname qn1 qn2 + | _ -> 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 + let listsplit3 l = + List.fold_left begin fun (a_acc, b_acc, c_acc) (a, b, c) -> + (a::a_acc, b::b_acc, c::c_acc) + end ([], [], []) l + + type acc = { + jumps: Jumps.t; + will_fallthru: bool; + terminal: bool; + } + + let init = { jumps = Jumps.empty; + terminal = false; + will_fallthru = true; } + + let folder ~cu = object (v) + inherit [acc] Visitor.folder + + method! fold_goback' _ acc = + skip @@ { acc with terminal = true; will_fallthru = false } + + method! fold_stop' _ acc = + skip @@ { acc with terminal = true; will_fallthru = false } + + method! fold_exit' { payload = exit_stmt; _ } acc = + skip @@ + match exit_stmt with + | ExitSimple | ExitPerform _ + | ExitMethod _ | ExitProgram _ | ExitFunction _ -> acc + | ExitParagraph -> { acc with will_fallthru = true } (* TODO change this to a goto next para *) + | ExitSection -> { acc with will_fallthru = false } (* TODO: go to next section ? *) + + method! fold_evaluate' { payload; _ } acc = + let { eval_branches; eval_otherwise; _ }: Cobol_ptree.evaluate_stmt = + payload in + let jumps, terminals, unreachables = List.map begin fun branch -> + let { jumps; terminal; will_fallthru } = + Cobol_ptree.Visitor.fold_evaluate_branch v branch init in + (jumps, terminal, will_fallthru) + end eval_branches |> listsplit3 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; + } + + method! fold_statement' _ ({ will_fallthru; _ } as acc) = + if will_fallthru then do_children acc else skip acc + + method! fold_if' { payload = { then_branch; else_branch; _ }; _ } acc = + let { jumps; terminal; will_fallthru } = + Cobol_ptree.Visitor.fold_statements v then_branch acc in + let { jumps = else_jumps; + terminal = else_terminal; + will_fallthru = else_fallthru } = + 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; + } + + 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; + } + | 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 } + end +end From 70d97ec94c24d55996e03b8a7a3416131ec5a8dd Mon Sep 17 00:00:00 2001 From: Mateo Date: Wed, 18 Sep 2024 17:50:49 +0200 Subject: [PATCH 29/40] feat: call entry support, various improvements --- assets/cfg-dot-renderer.html | 6 +- assets/cfg-dot.js | 7 +- src/lsp/cobol_cfg/cfg_builder.ml | 205 ++++++++++++++++++------------- src/lsp/cobol_cfg/cfg_jumps.ml | 73 +++++++---- src/lsp/cobol_cfg/cfg_options.ml | 2 +- 5 files changed, 179 insertions(+), 114 deletions(-) diff --git a/assets/cfg-dot-renderer.html b/assets/cfg-dot-renderer.html index a47923617..d40709df4 100644 --- a/assets/cfg-dot-renderer.html +++ b/assets/cfg-dot-renderer.html @@ -28,7 +28,6 @@ left: 50%; transform: translate(-50%, -50%); text-align: center; - z-index: -1; } .hidden { display: none !important; @@ -111,7 +110,7 @@
+

Title

diff --git a/assets/cfg-dot.js b/assets/cfg-dot.js index 1826293c1..040575361 100644 --- a/assets/cfg-dot.js +++ b/assets/cfg-dot.js @@ -56,7 +56,8 @@ function reset() { function historyGoBack() { history.pop(); - const [dot, graph, options] = JSON.parse(history[history.length - 1]); + const [dot, graph, options, name] = JSON.parse(history[history.length - 1]); + document.getElementById('title').innerText = name; renderOptions = options; renderGraph(dot, graph) if(history.length == 1) { @@ -235,10 +236,11 @@ function renderGraph(dot, _graph) { window.addEventListener('message', event => { switch (event.data.type) { case "graph_content": + document.getElementById('title').innerText = event.data.graph_name; graph = JSON.parse(event.data.graph) renderGraph(event.data.dot, graph) hideModals() - history.push(JSON.stringify([event.data.dot, graph, renderOptions])) + history.push(JSON.stringify([event.data.dot, graph, renderOptions, event.data.graph_name])) if(history.length > 1) { document.getElementById('history-btn').disabled = false } diff --git a/src/lsp/cobol_cfg/cfg_builder.ml b/src/lsp/cobol_cfg/cfg_builder.ml index 18d5dd591..0d4cc2180 100644 --- a/src/lsp/cobol_cfg/cfg_builder.ml +++ b/src/lsp/cobol_cfg/cfg_builder.ml @@ -400,7 +400,7 @@ let restrict_to_neighborhood id cfg = let nodes = Nodes.singleton node in let rec explore prev_depth_nodes explored_nodes depth = if depth > max_depth - then Nodes.empty, explored_nodes + then explored_nodes else let next_depth_nodes = Nodes.fold begin fun node new_nodes -> Cfg.fold_succ begin fun succ new_nodes -> @@ -412,9 +412,12 @@ let restrict_to_neighborhood id cfg = 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 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 reachables + if Nodes.mem node all_nodes then cfg else Cfg.remove_vertex cfg node end cfg cfg diff --git a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml index bb287e46e..bcb6cfb40 100644 --- a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml +++ b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml @@ -239,6 +239,7 @@ let send_graph ~typ webview graph = 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 = WebView.postMessage webview ojs in () From 1d54ebee8ac992ce3469e5fe94d2609aea4ec65d Mon Sep 17 00:00:00 2001 From: Mateo Date: Fri, 27 Sep 2024 12:03:05 +0200 Subject: [PATCH 34/40] feat: new workflow and persistant options --- assets/cfg-dot-renderer.html | 1 + assets/cfg-dot.js | 179 +++++++++++------- src/lsp/cobol_cfg/cfg_builder.ml | 51 ++--- src/lsp/cobol_cfg/cfg_builder.mli | 7 +- src/lsp/cobol_lsp/lsp_request.ml | 38 +++- .../superbol_cfg_explorer.ml | 130 ++++++++----- 6 files changed, 257 insertions(+), 149 deletions(-) diff --git a/assets/cfg-dot-renderer.html b/assets/cfg-dot-renderer.html index e66a85c10..8f0de0c14 100644 --- a/assets/cfg-dot-renderer.html +++ b/assets/cfg-dot-renderer.html @@ -107,6 +107,7 @@

Title

+ diff --git a/assets/cfg-dot.js b/assets/cfg-dot.js index 040575361..b1df9f9d0 100644 --- a/assets/cfg-dot.js +++ b/assets/cfg-dot.js @@ -32,9 +32,18 @@ const vscode = acquireVsCodeApi() var graphviz = undefined; var graph = undefined; var contextNode = undefined; -var renderOptions = { ...options(), hidden_nodes: [], split_nodes: [] }; +const defaultOptions = { + hidden_nodes: [], + split_nodes: [], + hide_unreachable: false, + collapse_fallthru: false, + shatter_hubs: undefined, +} +var renderOptions = defaultOptions; var rendering = d3.select('#rendering') -const history = [] +var dataHistory = [] + +/// MODAL MANAGEMENT function hideContextMenu() { elementContextMenuBack.style.display = "none"; @@ -50,19 +59,53 @@ function showContextMenu(x, y) { elementContextMenu.style.top = `${y}px`; } -function reset() { - graphviz?.resetZoom() +function toggleLegend() { + if(elementLegend.classList.contains("hidden")) { + hideModals(); + elementLegend.classList.remove("hidden"); + } + else hideModals() } -function historyGoBack() { - history.pop(); - const [dot, graph, options, name] = JSON.parse(history[history.length - 1]); - document.getElementById('title').innerText = name; - renderOptions = options; - renderGraph(dot, graph) - if(history.length == 1) { - document.getElementById("history-btn").disabled = true +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 = @@ -87,28 +130,9 @@ function historyGoBack() { } } -function toggleLegend() { - if(elementLegend.classList.contains("hidden")) { - hideModals(); - elementLegend.classList.remove("hidden"); - } - else hideModals() -} +/// RERENDERERS -function toggleRenderOptions() { - if(elementOptions.classList.contains("hidden")) { - hideModals(); - elementOptions.classList.remove("hidden"); - } - else hideModals() -} - -function hideModals() { - elementOptions.classList.add("hidden"); - elementLegend.classList.add("hidden"); -} - -function options() { +function rerender() { var collapse_fallthru = document.getElementById('fallthru').checked; var hide_unreachable = document.getElementById('unreachable').checked; if(document.getElementById('hubshatter').checked) { @@ -117,18 +141,17 @@ function options() { else { var shatter_hubs = undefined; } - return { + renderOptions = { + ...renderOptions, hide_unreachable, collapse_fallthru, shatter_hubs, - } + }; + vscode.postMessage({ type: 'graph_update', renderOptions }) } -function rerender() { - renderOptions = { - ...renderOptions, - ...options(), - }; +function rerenderWithDefault() { + renderOptions = defaultOptions; vscode.postMessage({ type: 'graph_update', renderOptions }) } @@ -144,28 +167,6 @@ function actionNeighborhood() { vscode.postMessage({ type: 'graph_update', renderOptions }) } -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 actionHideNode() { renderOptions.hidden_nodes.push(contextNode.id) createClickableElement(contextNode, "hidden_nodes") @@ -178,6 +179,25 @@ function actionSplitNode() { 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') @@ -187,6 +207,22 @@ function focus(name) { .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() @@ -233,15 +269,28 @@ function renderGraph(dot, _graph) { graph = _graph } +/// MAIN LISTENER + window.addEventListener('message', event => { switch (event.data.type) { + case "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() + dataHistory = []; + dataHistory.push(JSON.stringify([event.data.dot, graph, renderOptions, event.data.graph_name])) + document.getElementById('history-btn').disabled = true + break; case "graph_content": - document.getElementById('title').innerText = event.data.graph_name; graph = JSON.parse(event.data.graph) renderGraph(event.data.dot, graph) + updateTitle(graph, event.data.graph_name) + setRenderOptions(event.data.render_options || {}) hideModals() - history.push(JSON.stringify([event.data.dot, graph, renderOptions, event.data.graph_name])) - if(history.length > 1) { + dataHistory.push(JSON.stringify([event.data.dot, graph, renderOptions, event.data.graph_name])) + if(dataHistory.length > 1) { document.getElementById('history-btn').disabled = false } break; diff --git a/src/lsp/cobol_cfg/cfg_builder.ml b/src/lsp/cobol_cfg/cfg_builder.ml index 0d4cc2180..db945fc61 100644 --- a/src/lsp/cobol_cfg/cfg_builder.ml +++ b/src/lsp/cobol_cfg/cfg_builder.ml @@ -260,11 +260,7 @@ let cfg_of_section ~cu ({ section_paragraphs; _ }: procedure_section) = | l -> l end |> build_edges -let cfgs_of_doc ?(graph_name=None) ({ group; _ }: Cobol_typeck.Outputs.t) = - let is_to_include : string -> bool = - match graph_name with - | None -> Fun.const true - | Some name -> String.equal name in +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 @@ -273,17 +269,26 @@ let cfgs_of_doc ?(graph_name=None) ({ group; _ }: Cobol_typeck.Outputs.t) = let name = Pretty.to_string "%a (%s)" Cobol_ptree.pp_qualname' ~&sec.section_name ((~&) cu.unit_name) in - if is_to_include name - then Some (name, cfg_of_section ~cu ~&sec) - else None + Some (name, `Section (cu, ~&sec)) end cu.unit_procedure.list in - let cu_graph = - if is_to_include ((~&) cu.unit_name) - then [((~&)cu.unit_name, cfg_of ~cu)] - else [] - in cu_graph @ section_graphs @ acc + 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 = @@ -529,14 +534,12 @@ type graph = { nodes_pos: (int * srcloc) list } -let make ~(options: Cfg_options.t) (checked_doc: Cobol_typeck.Outputs.t) = - cfgs_of_doc ~graph_name:options.graph_name checked_doc - |> List.map begin fun (name, cfg) -> - let cfg_with_options = handle_cfg_options ~options cfg in - { - name; - string_repr_dot = to_dot_string cfg_with_options; - string_repr_d3 = to_d3_string cfg; - nodes_pos = nodes_pos cfg; - } - end +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 + { + name; + string_repr_dot = to_dot_string cfg_with_options; + string_repr_d3 = to_d3_string cfg; + nodes_pos = nodes_pos cfg; + } diff --git a/src/lsp/cobol_cfg/cfg_builder.mli b/src/lsp/cobol_cfg/cfg_builder.mli index 607cd18ca..581a49a37 100644 --- a/src/lsp/cobol_cfg/cfg_builder.mli +++ b/src/lsp/cobol_cfg/cfg_builder.mli @@ -17,5 +17,10 @@ type graph = { val make : options:Cfg_options.t + -> name:string -> Cobol_typeck.Outputs.t - -> graph list + -> graph + +val possible_cfgs_of_doc + : Cobol_typeck.Outputs.t + -> string list diff --git a/src/lsp/cobol_lsp/lsp_request.ml b/src/lsp/cobol_lsp/lsp_request.ml index d2df864c1..c9eedd747 100644 --- a/src/lsp/cobol_lsp/lsp_request.ml +++ b/src/lsp/cobol_lsp/lsp_request.ml @@ -171,8 +171,9 @@ let create_cfg_options o = let handle_get_cfg registry params = let params = Jsonrpc.Structured.yojson_of_t params in - let uri, options = Yojson.Safe.Util.( + 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 @@ -180,22 +181,36 @@ let handle_get_cfg registry params = ~f:begin fun ~doc:_ checked_doc -> let open Cobol_cfg.Builder in let options = create_cfg_options options in - let graphs = make ~options checked_doc in - let yojsonify ({ string_repr_dot; string_repr_d3; name; nodes_pos } : graph) = + try + let { string_repr_dot; string_repr_d3; name; nodes_pos } : graph = + make ~options ~name checked_doc in let nodes_pos = List.map begin fun (n,loc) -> let range = Lsp_position.range_of_srcloc_in ~filename:uri loc in (string_of_int n, Range.yojson_of_t range) end nodes_pos in - `Assoc [ - ("string_repr_d3", `String string_repr_d3); - ("string_repr_dot", `String string_repr_dot); - ("nodes_pos", `Assoc nodes_pos); - ("name", `String name);] - in - Some (`List (List.map yojsonify graphs)) + Some (`Assoc [ + ("string_repr_d3", `String string_repr_d3); + ("string_repr_dot", `String string_repr_dot); + ("nodes_pos", `Assoc nodes_pos); + ("name", `String name);]) + with Invalid_argument _ -> None + end + |> Option.value ~default:(`Assoc []) + +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.value ~default:(`List []) + 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 @@ -911,6 +926,9 @@ let on_request | 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) diff --git a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml index bcb6cfb40..673d87922 100644 --- a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml +++ b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml @@ -70,6 +70,19 @@ let decorationType = let options = Ojs.obj [|("backgroundColor", backgroundColor)|] in Window.createTextEditorDecorationType ~options +(* PERSISTENT OPTION MANAGEMENT *) + +let state = ref None + +let update_state ~key value = + match !state with + | None -> () + | Some state -> + let _ : Promise.void = + Memento.update state ~key ~value in () + +let get_state_value ~key = Option.bind !state (Memento.get ~key) + (* GRAPH FROM LSP *) type graph = { @@ -89,6 +102,27 @@ let decode_graph res = 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 = 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_ ~fulfilled:begin fun jsonoo -> + try Promise.return (Some (decode_graph jsonoo)) + with Jsonoo.Decode_error _ -> + Window.showErrorMessage + ~message:"Impossible to render graph, \ + try closing and reopening the webview" () + end (* WEBVIEW MANAGEMENT *) @@ -233,9 +267,15 @@ let setup_window_listener ~client = (* MESSAGE MANAGER *) -let send_graph ~typ webview graph = +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 - Ojs.set_prop_ascii ojs "type" (Ojs.string_to_js "graph_content"); + (match get_state_value ~key:(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); @@ -243,35 +283,21 @@ let send_graph ~typ webview graph = let _ : bool Promise.t = WebView.postMessage webview ojs in () -let get_and_send_graph ~client ~uri ~typ ~webview ~render_options = - let data = - let uri = Jsonoo.Encode.string @@ Uri.path uri in - Jsonoo.Encode.object_ ["uri", uri; "render_options", render_options] in - let _ : unit Promise.t = - Vscode_languageclient.LanguageClient.sendRequest client () - ~meth:"superbol/getCFG" ~data - |> Promise.then_ ~fulfilled:begin fun jsonoo_res -> - let graphs = (Jsonoo.Decode.list decode_graph) jsonoo_res in - match graphs with - | [] -> - Window.showErrorMessage () - ~message:"Unable to perform operation, try reloading the CFG" - |> Promise.map (Fun.const ()) - | graph::_ -> - update_webview_data ~uri ~typ ~graph ~render_options (); - send_graph ~typ webview graph; - Promise.return () - end - in () - let on_graph_update ~webview ~client ~uri ~typ name arg = - let render_options = - Ojs.get_prop_ascii arg "renderOptions" - |> begin fun ojs -> - Ojs.set_prop_ascii ojs "graph_name" @@ Ojs.string_to_js name; - ojs end - |> Jsonoo.t_of_js in - get_and_send_graph ~client ~uri ~typ ~webview ~render_options + let render_options_ojs = Ojs.get_prop_ascii arg "renderOptions" in + let render_options = Jsonoo.t_of_js render_options_ojs in + let path = 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 = TextEditor.document text_editor |> TextDocument.uri in @@ -284,10 +310,12 @@ let on_message ~client ~text_editor ~typ arg = | "graph_update" -> on_graph_update ~client ~webview ~uri ~typ graph.name arg | "ready" -> - send_graph ~typ webview graph + send_graph ~as_new_graph:true ~typ ~uri webview graph | _ -> () end +(* USER REQUEST LOGIC *) + let open_cfg_for ~typ ~text_editor ~extension_uri client = let open Promise in let uri = TextEditor.document text_editor |> TextDocument.uri in @@ -302,27 +330,29 @@ let open_cfg_for ~typ ~text_editor ~extension_uri client = return () | Ok html_js -> Vscode_languageclient.LanguageClient.sendRequest client () - ~meth:"superbol/getCFG" ~data - |> then_ ~fulfilled:begin fun jsonoo_graphs -> - let graphs = (Jsonoo.Decode.list decode_graph) jsonoo_graphs in - Window.showQuickPick ~items:(Stdlib.List.map (fun g -> g.name) graphs) () + ~meth:"superbol/getPossibleCFG" ~data + |> then_ ~fulfilled:begin fun jsonoo_graph_names -> + let items = Jsonoo.Decode.(list string) jsonoo_graph_names in + Window.showQuickPick ~items () |> then_ ~fulfilled:begin function | None -> return () | Some name -> - let graph = Stdlib.List.find begin fun g -> - String.equal g.name name end graphs in - 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 _ : Disposable.t = - WebView.onDidReceiveMessage webview () - ~listener:(on_message ~client ~text_editor ~typ) - ~thisArgs:Ojs.null ~disposables:[] - in - if is_new - then WebView.set_html webview html_content - else send_graph ~typ webview graph; - setup_window_listener ~client; - return () + 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 _ : Disposable.t = + WebView.onDidReceiveMessage webview () + ~listener:(on_message ~client ~text_editor ~typ) + ~thisArgs:Ojs.null ~disposables:[] + in + if is_new + then 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 @@ -334,5 +364,7 @@ let open_cfg ?text_editor ~typ instance = | Some client, Some text_editor -> let extension_uri = ExtensionContext.extensionUri @@ Superbol_instance.context instance in + state := Some (ExtensionContext.workspaceState + @@ Superbol_instance.context instance); open_cfg_for ~typ ~extension_uri ~text_editor client | _ -> Promise.return () From 90794c286deac569aac911df2375dd852401ced7 Mon Sep 17 00:00:00 2001 From: Mateo <74507788+NeoKaios@users.noreply.github.com> Date: Tue, 1 Oct 2024 15:22:35 +0200 Subject: [PATCH 35/40] chore: apply suggestions from code review Co-authored-by: Nicolas Berthier --- assets/cfg-dot-renderer.html | 4 ++-- src/lsp/cobol_cfg/cfg_jumps.ml | 3 ++- src/lsp/cobol_lsp/lsp_lookup.ml | 7 ++++--- src/lsp/superbol_free_lib/vscode_extension.ml | 6 ++++-- 4 files changed, 12 insertions(+), 8 deletions(-) diff --git a/assets/cfg-dot-renderer.html b/assets/cfg-dot-renderer.html index 8f0de0c14..1ee5d357c 100644 --- a/assets/cfg-dot-renderer.html +++ b/assets/cfg-dot-renderer.html @@ -135,10 +135,10 @@

Title

- Rendering... Please wait
+ Rendering… Please wait
If this takes too long, you can try changing the Render Options :
    -
  • Reduce the incoming edge requirement for spliting hubs
    • +
  • Reduce the incoming edge requirement for splitting hubs
  • Collapse nodes that are only linked via a fallthrough edge
diff --git a/src/lsp/cobol_cfg/cfg_jumps.ml b/src/lsp/cobol_cfg/cfg_jumps.ml index 30b6d573e..80765b4be 100644 --- a/src/lsp/cobol_cfg/cfg_jumps.ml +++ b/src/lsp/cobol_cfg/cfg_jumps.ml @@ -31,7 +31,8 @@ module Jumps = Set.Make(struct | Perform _ -> 2 | Call _ -> 3 | Entry _ -> 4 - in match j1, j2 with + in + match j1, j2 with | Go qn1, Go qn2 | GoDepending qn1, GoDepending qn2 | Perform qn1, Perform qn2 -> Cobol_ptree.compare_qualname qn1 qn2 diff --git a/src/lsp/cobol_lsp/lsp_lookup.ml b/src/lsp/cobol_lsp/lsp_lookup.ml index af7d40f86..73b9e7d26 100644 --- a/src/lsp/cobol_lsp/lsp_lookup.ml +++ b/src/lsp/cobol_lsp/lsp_lookup.ml @@ -68,9 +68,10 @@ module TYPES = struct | ObjectRef | Pointer - type procedure_at_position = { - cu: Cobol_unit.Types.cobol_unit option; - proc_name: Cobol_ptree.qualname option; + type procedure_at_position = + { + cu: Cobol_unit.Types.cobol_unit option; + proc_name: Cobol_ptree.qualname option; } end open TYPES diff --git a/src/lsp/superbol_free_lib/vscode_extension.ml b/src/lsp/superbol_free_lib/vscode_extension.ml index 525f9d9ee..a1b1bd5fa 100644 --- a/src/lsp/superbol_free_lib/vscode_extension.ml +++ b/src/lsp/superbol_free_lib/vscode_extension.ml @@ -600,8 +600,10 @@ let contributes = ] ~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'" ()] + [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 = From 888cd5c0dd25aa1a2b8c5da28768bbb34637b31f Mon Sep 17 00:00:00 2001 From: Mateo Date: Tue, 1 Oct 2024 15:23:15 +0200 Subject: [PATCH 36/40] fix: interaction between shatter and collapse --- src/lsp/cobol_cfg/cfg_builder.ml | 39 ++++++++++++++++---------------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/src/lsp/cobol_cfg/cfg_builder.ml b/src/lsp/cobol_cfg/cfg_builder.ml index db945fc61..eee4698be 100644 --- a/src/lsp/cobol_cfg/cfg_builder.ml +++ b/src/lsp/cobol_cfg/cfg_builder.ml @@ -90,12 +90,9 @@ type edge = 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 + 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 @@ -300,7 +297,19 @@ let do_collapse_fallthru g = | 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 -> - Cfg.add_edge_e cfg (pred, e, next) + 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 @@ -328,12 +337,11 @@ let do_collapse_fallthru g = | Some names -> { node with typ = Collapsed (NEL.rev names) } end cfg -let do_hide_unreachable ~except g = +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) - && not (List.mem n.id except) then true, Cfg.remove_vertex cfg n else did_remove, cfg end cfg (false, cfg) @@ -435,25 +443,18 @@ let remove_nodes ids cfg = end cfg ids let handle_cfg_options ~(options: Cfg_options.t) cfg = - let unreachable_expections = - match options.transformation with - | Some Cfg_options.Neighborhood id - | Some Cfg_options.Descendents id -> [id] - | None -> [] in 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 - then do_hide_unreachable ~except:unreachable_expections else 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) - |> (if options.collapse_fallthru then do_collapse_fallthru else Fun.id) - (* IMPORTANT: shatter needs to be after collapse, or else it's possible - to find a collapsed node linked to duplicate shattered nodes *) |> do_shatter_nodes ~ids:options.split_nodes ~limit:options.shatter_hubs + |> (if options.collapse_fallthru then do_collapse_fallthru else Fun.id) (* CFG TO STRING FORMATTERS *) From a3d4346ff5df88ab81f89a183dc2ba8ecb4b2a0c Mon Sep 17 00:00:00 2001 From: Mateo Date: Wed, 2 Oct 2024 16:39:56 +0200 Subject: [PATCH 37/40] refactor: review changes and minor bugfixes --- .drom | 7 +- assets/cfg-arc-renderer.html | 36 +-- assets/cfg-arc.css | 29 ++ assets/cfg-arc.js | 34 +-- assets/cfg-d3-renderer.html | 231 --------------- assets/cfg-dot-renderer.html | 97 +----- assets/cfg-dot.css | 86 ++++++ assets/cfg-dot.js | 40 +-- dune-project | 11 - opam/cobol_cfg.opam | 11 - opam/osx/cobol_cfg-osx.opam | 11 - opam/windows/cobol_cfg-windows.opam | 11 - src/lsp/cobol_cfg/cfg_builder.ml | 104 +------ src/lsp/cobol_cfg/cfg_builder.mli | 135 ++++++++- src/lsp/cobol_cfg/cfg_options.ml | 20 -- src/lsp/cobol_cfg/cobol_cfg.ml | 23 +- src/lsp/cobol_cfg/dune | 2 +- src/lsp/cobol_cfg/package.toml | 11 - src/lsp/cobol_lsp/lsp_cfg.ml | 133 +++++++++ src/lsp/cobol_lsp/lsp_request.ml | 69 +---- .../superbol_cfg_explorer.ml | 278 ++++++++++-------- .../superbol_cfg_explorer.mli | 9 + 22 files changed, 615 insertions(+), 773 deletions(-) create mode 100644 assets/cfg-arc.css delete mode 100644 assets/cfg-d3-renderer.html create mode 100644 assets/cfg-dot.css create mode 100644 src/lsp/cobol_lsp/lsp_cfg.ml diff --git a/.drom b/.drom index 2249bba2c..436351bbd 100644 --- a/.drom +++ b/.drom @@ -5,7 +5,7 @@ version:0.9.0 # hash of toml configuration files # used for generation of all files -2e98390cc73b915e0bf317cb253bec56:. +d3322e46fe7329e9bbda1b7042625e6a:. # end context for . # begin context for .github/workflows/workflow.yml @@ -81,11 +81,12 @@ 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 -5b0d97854c33a01ceaa5eebf37fed47d:opam/cobol_cfg.opam +535909f451064f672cd8c6a798512ba1:opam/cobol_cfg.opam # end context for opam/cobol_cfg.opam # begin context for opam/cobol_common.opam @@ -295,7 +296,7 @@ c882aea48ff6d4b120283f41153810ee:sphinx/about.rst # begin context for src/lsp/cobol_cfg/dune # file src/lsp/cobol_cfg/dune -0719aadf966f84be3629fc49a10309d0: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 diff --git a/assets/cfg-arc-renderer.html b/assets/cfg-arc-renderer.html index ca8eae4e4..25f245546 100644 --- a/assets/cfg-arc-renderer.html +++ b/assets/cfg-arc-renderer.html @@ -1,38 +1,9 @@ + - + +

Title

@@ -41,4 +12,3 @@

Title

- diff --git a/assets/cfg-arc.css b/assets/cfg-arc.css new file mode 100644 index 000000000..989550595 --- /dev/null +++ b/assets/cfg-arc.css @@ -0,0 +1,29 @@ +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 index cf2d32ee4..4c0d78d66 100644 --- a/assets/cfg-arc.js +++ b/assets/cfg-arc.js @@ -1,3 +1,5 @@ +// JS file attached to cfg-arc-renderer.html + const vscode = acquireVsCodeApi() const elementLegend = document.getElementById('legend'); @@ -320,23 +322,21 @@ function removeEntryStmt() { } window.addEventListener("message", event => { - switch (event.data.type) { - case "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() - break; - case "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) - break; - } + 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-d3-renderer.html b/assets/cfg-d3-renderer.html deleted file mode 100644 index c1761c753..000000000 --- a/assets/cfg-d3-renderer.html +++ /dev/null @@ -1,231 +0,0 @@ - - - - - - - - - diff --git a/assets/cfg-dot-renderer.html b/assets/cfg-dot-renderer.html index 1ee5d357c..2bf7acbf3 100644 --- a/assets/cfg-dot-renderer.html +++ b/assets/cfg-dot-renderer.html @@ -1,98 +1,11 @@ + -
@@ -119,7 +32,7 @@

Title

-
@@ -136,12 +49,12 @@

Title

Rendering… Please wait
- If this takes too long, you can try changing the Render Options : + If this takes too long, you can try changing the + :
    -
  • Reduce the incoming edge requirement for splitting hubs
    • +
  • Reduce the incoming edge requirement for splitting nodes
  • Collapse nodes that are only linked via a fallthrough edge
-
diff --git a/assets/cfg-dot.css b/assets/cfg-dot.css new file mode 100644 index 000000000..dd83f4e7e --- /dev/null +++ b/assets/cfg-dot.css @@ -0,0 +1,86 @@ +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 index b1df9f9d0..f61ef22cb 100644 --- a/assets/cfg-dot.js +++ b/assets/cfg-dot.js @@ -1,3 +1,5 @@ +// 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"] @@ -272,31 +274,21 @@ function renderGraph(dot, _graph) { /// MAIN LISTENER window.addEventListener('message', event => { - switch (event.data.type) { - case "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 === "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 = true - break; - case "graph_content": - graph = JSON.parse(event.data.graph) - renderGraph(event.data.dot, graph) - updateTitle(graph, event.data.graph_name) - setRenderOptions(event.data.render_options || {}) - hideModals() - dataHistory.push(JSON.stringify([event.data.dot, graph, renderOptions, event.data.graph_name])) - if(dataHistory.length > 1) { - document.getElementById('history-btn').disabled = false - } - break; - case "focused_proc": - focus(event.data.procedure) - break; } + 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/dune-project b/dune-project index 71afc2fae..419cc40b2 100644 --- a/dune-project +++ b/dune-project @@ -500,19 +500,8 @@ (description "SuperBOL Studio OSS is a new platform for COBOL") (depends (ocaml (>= 4.14.0)) - (toml (and (>= 7.1.0) (< 8.0.0))) - (superbol_project (= version)) - (superbol_preprocs (= version)) - (pretty (= version)) (ocamlgraph (and (>= 2.1.0) (< 3.0.0))) - (lsp (and ( >= 1.18 )( < 1.19 ))) - (jsonrpc ( >= 1.15 )) (cobol_typeck (= version)) - (cobol_parser (= version)) - (cobol_indent (= version)) - (cobol_data (= version)) - (cobol_config (= version)) - (cobol_common (= version)) odoc ) ) diff --git a/opam/cobol_cfg.opam b/opam/cobol_cfg.opam index 911a68aef..accd08164 100644 --- a/opam/cobol_cfg.opam +++ b/opam/cobol_cfg.opam @@ -47,19 +47,8 @@ install: [ depends: [ "ocaml" {>= "4.14.0"} "dune" {>= "2.8.0"} - "toml" {>= "7.1.0" & < "8.0.0"} - "superbol_project" {= version} - "superbol_preprocs" {= version} - "pretty" {= version} "ocamlgraph" {>= "2.1.0" & < "3.0.0"} - "lsp" {>= "1.18" & < "1.19"} - "jsonrpc" {>= "1.15"} "cobol_typeck" {= version} - "cobol_parser" {= version} - "cobol_indent" {= version} - "cobol_data" {= version} - "cobol_config" {= version} - "cobol_common" {= 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 index db42881c3..5558101d5 100644 --- a/opam/osx/cobol_cfg-osx.opam +++ b/opam/osx/cobol_cfg-osx.opam @@ -49,19 +49,8 @@ install: [ depends: [ "ocaml" {>= "4.14.0"} "dune" {>= "2.8.0"} - "toml-osx" {>= "7.1.0" & < "8.0.0"} - "superbol_project-osx" {= version} - "superbol_preprocs-osx" {= version} - "pretty-osx" {= version} "ocamlgraph-osx" {>= "2.1.0" & < "3.0.0"} - "lsp-osx" {>= "1.18" & < "1.19"} - "jsonrpc-osx" {>= "1.15"} "cobol_typeck-osx" {= version} - "cobol_parser-osx" {= version} - "cobol_indent-osx" {= version} - "cobol_data-osx" {= version} - "cobol_config-osx" {= version} - "cobol_common-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 index 92ba763db..27370d92e 100644 --- a/opam/windows/cobol_cfg-windows.opam +++ b/opam/windows/cobol_cfg-windows.opam @@ -49,19 +49,8 @@ install: [ depends: [ "ocaml" {>= "4.14.0"} "dune" {>= "2.8.0"} - "toml-windows" {>= "7.1.0" & < "8.0.0"} - "superbol_project-windows" {= version} - "superbol_preprocs-windows" {= version} - "pretty-windows" {= version} "ocamlgraph-windows" {>= "2.1.0" & < "3.0.0"} - "lsp-windows" {>= "1.18" & < "1.19"} - "jsonrpc-windows" {>= "1.15"} "cobol_typeck-windows" {= version} - "cobol_parser-windows" {= version} - "cobol_indent-windows" {= version} - "cobol_data-windows" {= version} - "cobol_config-windows" {= version} - "cobol_common-windows" {= version} "odoc" {with-doc} ] # Content of `opam-trailer` field: \ No newline at end of file diff --git a/src/lsp/cobol_cfg/cfg_builder.ml b/src/lsp/cobol_cfg/cfg_builder.ml index eee4698be..67550e47d 100644 --- a/src/lsp/cobol_cfg/cfg_builder.ml +++ b/src/lsp/cobol_cfg/cfg_builder.ml @@ -17,8 +17,6 @@ module NEL = Cobol_common.Basics.NEL (* TYPES AND HELPERS *) -type qualname = Cobol_ptree.qualname - type display_name_type = | Full | Short @@ -36,10 +34,6 @@ let qn_to_fullname qn = then name else name ^ " IN " ^ qual -let incr ref = - ref := !ref + 1; - !ref - let prefix_to_string prefix = begin match prefix with | Cobol_ptree.CallGeneral i -> @@ -99,10 +93,6 @@ module Edge = struct type t = edge let compare = Stdlib.compare let default = FallThrough - let to_string = function - | FallThrough -> "f" - | Perform -> "p" - | Go -> "g" end module Cfg = Graph.Persistent.Digraph.ConcreteLabeled(Node)(Edge) @@ -110,6 +100,10 @@ module Cfg = Graph.Persistent.Digraph.ConcreteLabeled(Node)(Edge) (* 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 () = @@ -133,7 +127,7 @@ let build_node ?(is_section=false) ?(display_name_type=Full) ~cu paragraph = | Short -> short_name in Normal (full_name, display_name), ~@qn, section_name in { - id = incr node_idx; + id = next_node_idx (); section_name; loc = Some loc; jumps; @@ -156,7 +150,7 @@ let new_node ~typ = | `Call s -> External s, None, call_stmt_section_name in { - id = incr node_idx; + id = next_node_idx (); section_name; loc; jumps = Jumps.empty; @@ -350,7 +344,7 @@ let do_hide_unreachable g = in aux g let clone_node node = - { node with id = incr node_idx; } + { node with id = next_node_idx (); } let do_shatter_nodes ~ids ~limit g = let shatter_typ { typ; _ } = @@ -456,91 +450,9 @@ let handle_cfg_options ~(options: Cfg_options.t) cfg = |> do_shatter_nodes ~ids:options.split_nodes ~limit:options.shatter_hubs |> (if options.collapse_fallthru then do_collapse_fallthru else Fun.id) -(* CFG TO STRING FORMATTERS *) - -let vertex_name_record names = - Pretty.to_string "%a" - (NEL.pp ~fopen:"{" ~fclose:"}" ~fsep:"|" Fmt.string) - names - -module Dot = Graph.Graphviz.Dot(struct - include 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 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 - (* GRAPH OUTPUT FORMAT *) -let nodes_pos cfg = - Cfg.fold_vertex begin fun n acc -> - match n.loc with - | None -> acc - | Some loc -> (n.id, loc)::acc - end cfg [] - -type graph = { - name: string; - string_repr_dot: string; - string_repr_d3: string; - nodes_pos: (int * srcloc) list -} - 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 - { - name; - string_repr_dot = to_dot_string cfg_with_options; - string_repr_d3 = to_d3_string cfg; - nodes_pos = nodes_pos cfg; - } + (cfg, cfg_with_options) diff --git a/src/lsp/cobol_cfg/cfg_builder.mli b/src/lsp/cobol_cfg/cfg_builder.mli index 581a49a37..febbd0e3b 100644 --- a/src/lsp/cobol_cfg/cfg_builder.mli +++ b/src/lsp/cobol_cfg/cfg_builder.mli @@ -8,18 +8,141 @@ (* *) (******************************************************************************) -type graph = { - name: string; - string_repr_dot: string; - string_repr_d3: string; - nodes_pos: (int * Cobol_ptree.srcloc) list +open Cfg_jumps + +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 Cobol_common.Basics.NEL.t + | Split of string + +type node = { + id: int; + section_name: string; + loc: Cobol_common.srcloc option; + typ: node_type; + jumps: Jumps.t; + will_fallthru: bool; + terminal: bool; (* unused atm *) } +module Node: sig + type t = node + + val compare : node -> node -> int + val hash : node -> int + val equal : node -> node -> bool +end + +type edge = + | FallThrough + | Perform + | Go + +module Edge: sig + type t = edge + + val compare : 'a -> 'a -> int + val default : edge +end + +module Cfg : +sig + type t + + module V : sig + type t = node + + val compare : t -> t -> int + val hash : t -> int + val equal : t -> t -> bool + + type label = t + + val create : label -> t + val label : t -> label + end + + type vertex = node + + module E : sig + type t = vertex * edge * vertex + + val compare : t -> t -> int + + type vertex = node + + val src : t -> vertex + val dst : t -> vertex + + type label = edge + + val create : vertex -> label -> vertex -> t + val label : t -> label + end + + type edge = E.t + + val is_directed : bool + val is_empty : t -> bool + val nb_vertex : t -> int + val nb_edges : t -> int + val out_degree : t -> vertex -> int + val in_degree : t -> vertex -> int + val mem_vertex : t -> vertex -> bool + val mem_edge : t -> vertex -> vertex -> bool + val mem_edge_e : t -> edge -> bool + val find_edge : t -> vertex -> vertex -> edge + val find_all_edges : t -> vertex -> vertex -> edge list + val succ : t -> vertex -> vertex list + val pred : t -> vertex -> vertex list + val succ_e : t -> vertex -> edge list + val pred_e : t -> vertex -> edge list + val iter_vertex : (vertex -> unit) -> t -> unit + val fold_vertex : (vertex -> 'a -> 'a) -> t -> 'a -> 'a + val iter_edges : (vertex -> vertex -> unit) -> t -> unit + + val fold_edges : + (vertex -> vertex -> 'a -> 'a) -> t -> 'a -> 'a + + val iter_edges_e : (edge -> unit) -> t -> unit + val fold_edges_e : (edge -> 'a -> 'a) -> t -> 'a -> 'a + val map_vertex : (vertex -> vertex) -> t -> t + val iter_succ : (vertex -> unit) -> t -> vertex -> unit + val iter_pred : (vertex -> unit) -> t -> vertex -> unit + + val fold_succ : + (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + + val fold_pred : + (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + + val iter_succ_e : (edge -> unit) -> t -> vertex -> unit + + val fold_succ_e : + (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + + val iter_pred_e : (edge -> unit) -> t -> vertex -> unit + + val fold_pred_e : + (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + + val empty : t + val add_vertex : t -> vertex -> t + val remove_vertex : t -> vertex -> t + val add_edge : t -> vertex -> vertex -> t + val add_edge_e : t -> edge -> t + val remove_edge : t -> vertex -> vertex -> t + val remove_edge_e : t -> edge -> t +end + + val make : options:Cfg_options.t -> name:string -> Cobol_typeck.Outputs.t - -> graph + -> Cfg.t * Cfg.t val possible_cfgs_of_doc : Cobol_typeck.Outputs.t diff --git a/src/lsp/cobol_cfg/cfg_options.ml b/src/lsp/cobol_cfg/cfg_options.ml index 84761a1f3..ce03e0885 100644 --- a/src/lsp/cobol_cfg/cfg_options.ml +++ b/src/lsp/cobol_cfg/cfg_options.ml @@ -13,7 +13,6 @@ type transformation = | Neighborhood of int type t = { - graph_name: string option; hide_unreachable: bool; collapse_fallthru: bool; shatter_hubs: int option; @@ -22,22 +21,3 @@ type t = { split_nodes: int list; } -let create - ?(graph_name=None) - ?(hide_unreachable=false) - ?(collapse_fallthru=false) - ?(shatter_hubs=None) - ?(transformation=None) - ?(hidden_nodes=[]) - ?(split_nodes=[]) - () = - { - hide_unreachable; - collapse_fallthru; - graph_name; - shatter_hubs; - transformation; - hidden_nodes; - split_nodes; - } - diff --git a/src/lsp/cobol_cfg/cobol_cfg.ml b/src/lsp/cobol_cfg/cobol_cfg.ml index 3d5660696..4bd095ca2 100644 --- a/src/lsp/cobol_cfg/cobol_cfg.ml +++ b/src/lsp/cobol_cfg/cobol_cfg.ml @@ -1,15 +1,12 @@ -(**************************************************************************) -(* *) -(* SuperBOL OSS Studio *) -(* *) -(* Copyright (c) 2022-2023 OCamlPro SAS *) -(* *) -(* All rights reserved. *) -(* This source code is licensed under the GNU Affero General Public *) -(* License version 3 found in the LICENSE.md file in the root directory *) -(* of this source tree. *) -(* *) -(**************************************************************************) +(******************************************************************************) +(* *) +(* Copyright (c) 2021-2024 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This file is distributed under the terms of the *) +(* OCAMLPRO-NON-COMMERCIAL license. *) +(* *) +(******************************************************************************) -module Builder = Cfg_builder module Options = Cfg_options +module Builder = Cfg_builder diff --git a/src/lsp/cobol_cfg/dune b/src/lsp/cobol_cfg/dune index f36103ad4..1c748901d 100644 --- a/src/lsp/cobol_cfg/dune +++ b/src/lsp/cobol_cfg/dune @@ -5,7 +5,7 @@ (public_name cobol_cfg) (wrapped true) ; use field 'dune-libraries' to add libraries without opam deps - (libraries toml superbol_project superbol_preprocs pretty ocamlgraph lsp jsonrpc cobol_typeck cobol_parser cobol_indent cobol_data cobol_config cobol_common ) + (libraries ocamlgraph cobol_typeck ) ; 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_cfg/package.toml b/src/lsp/cobol_cfg/package.toml index 459bfbbdb..a5f2f8b8a 100644 --- a/src/lsp/cobol_cfg/package.toml +++ b/src/lsp/cobol_cfg/package.toml @@ -53,18 +53,7 @@ skip = ["index.mld"] # ez_file = ">=0.1 <1.3" # base-unix = { libname = "unix", version = ">=base" } [dependencies] -cobol_common = "version" -cobol_config = "version" -cobol_data = "version" -cobol_indent = "version" -cobol_parser = "version" cobol_typeck = "version" -superbol_preprocs = "version" -superbol_project = "version" -jsonrpc = ">=1.15" -lsp = ">=1.18 <1.19" -pretty = "version" -toml = "7.1.0" ocamlgraph = "2.1.0" # package tools dependencies diff --git a/src/lsp/cobol_lsp/lsp_cfg.ml b/src/lsp/cobol_lsp/lsp_cfg.ml new file mode 100644 index 000000000..c3e47410f --- /dev/null +++ b/src/lsp/cobol_lsp/lsp_cfg.ml @@ -0,0 +1,133 @@ +(* what licence here ? *) + +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 shatter_hubs = + List.assoc_opt "shatter_hubs" 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; + shatter_hubs; + 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.Builder.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_request.ml b/src/lsp/cobol_lsp/lsp_request.ml index c9eedd747..ee2ff8296 100644 --- a/src/lsp/cobol_lsp/lsp_request.ml +++ b/src/lsp/cobol_lsp/lsp_request.ml @@ -133,42 +133,6 @@ 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 create_cfg_options o = - let open Yojson.Safe.Util in - let graph_name = - List.assoc_opt "graph_name" o |> Option.map to_string in - let hide_unreachable = - List.assoc_opt "hide_unreachable" o |> Option.map to_bool in - let collapse_fallthru = - List.assoc_opt "collapse_fallthru" o |> Option.map to_bool in - let shatter_hubs = - List.assoc_opt "shatter_hubs" 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 = - List.assoc_opt "hidden_nodes" o |> Option.map to_list - |> Option.map (List.map to_int) in - let split_nodes = - List.assoc_opt "split_nodes" o |> Option.map to_list - |> Option.map (List.map to_int) in - Cobol_cfg.Options.create () - ~graph_name - ?hide_unreachable - ?collapse_fallthru - ~shatter_hubs - ~transformation - ?hidden_nodes - ?split_nodes - let handle_get_cfg registry params = let params = Jsonrpc.Structured.yojson_of_t params in let uri, name, options = Yojson.Safe.Util.( @@ -179,23 +143,11 @@ let handle_get_cfg registry params = 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 options = create_cfg_options options in - try - let { string_repr_dot; string_repr_d3; name; nodes_pos } : graph = - make ~options ~name checked_doc in - let nodes_pos = List.map begin fun (n,loc) -> - let range = Lsp_position.range_of_srcloc_in ~filename:uri loc in - (string_of_int n, Range.yojson_of_t range) - end nodes_pos in - Some (`Assoc [ - ("string_repr_d3", `String string_repr_d3); - ("string_repr_dot", `String string_repr_dot); - ("nodes_pos", `Assoc nodes_pos); - ("name", `String name);]) - with Invalid_argument _ -> None - end - |> Option.value ~default:(`Assoc []) + 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 @@ -207,8 +159,8 @@ let handle_get_possible_cfg registry params = 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.value ~default:(`List []) + end |> + Option.get let handle_find_procedure registry params = @@ -225,11 +177,10 @@ let handle_find_procedure registry params = let proc = match proc_name, cu with | Some qn, _ -> Pretty.to_string "%a" Cobol_ptree.pp_qualname qn |> Str.global_replace (Str.regexp "\n") " " - | None, Some cu -> ~&(cu.unit_name) - | _ -> "" in + | _ -> raise Not_found in Some (`String proc) - end - |> Option.value ~default:(`String "") + end |> + Option.get (** {3 Definitions} *) diff --git a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml index 673d87922..c81ca4011 100644 --- a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml +++ b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.ml @@ -12,63 +12,73 @@ (* *) (**************************************************************************) -open Vscode +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 + 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 + match typ, !graphviz_html, !d3_arc_html with | D3_arc_diagram, _, Some value | Graphviz, Some value, _ -> Ok(`CompleteHtml value) | _ -> - let html_uri = Uri.joinPath extension_uri + 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 + | D3_arc_diagram -> "cfg-arc-renderer.html"] + in try - let html = read_whole_file @@ Uri.fsPath html_uri in - let js = match typ with - | Graphviz -> "cfg-dot.js" - | D3_arc_diagram -> "cfg-arc.js" in + 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 = - Uri.joinPath extension_uri ~pathSegments:["assets"; js] in - Ok( `IncompleteHtml (html, 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) -> + | `IncompleteHtml (html, js_path, css_path) -> let html_content = - let path = Uri.toString - (WebView.asWebviewUri webview ~localResource:js_path) () in - Printf.sprintf "%s" - html path in + 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(Window.showInformationMessage () ~message) +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 - Window.createTextEditorDecorationType ~options + VS.Window.createTextEditorDecorationType ~options (* PERSISTENT OPTION MANAGEMENT *) @@ -78,10 +88,13 @@ let update_state ~key value = match !state with | None -> () | Some state -> - let _ : Promise.void = - Memento.update state ~key ~value in () + let _ : Promise.void = VS.Memento.update state ~key ~value + in () -let get_state_value ~key = Option.bind !state (Memento.get ~key) +let get_state_value ~key = + match !state with + | None -> None + | Some state -> VS.Memento.get ~key state (* GRAPH FROM LSP *) @@ -94,40 +107,47 @@ type graph = { let decode_graph res = let string_repr_dot = - Jsonoo.Decode.field "string_repr_dot" Jsonoo.Decode.string res in + 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 + 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 = Uri.path uri in + let path = VS.Uri.path uri in let data = let base = ["uri", Jsonoo.Encode.string path; - "name", Jsonoo.Encode.string name] in + "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 + in Jsonoo.Encode.object_ full + in Vscode_languageclient.LanguageClient.sendRequest client () - ~meth:"superbol/getCFG" ~data - |> Promise.then_ ~fulfilled:begin fun jsonoo -> - try Promise.return (Some (decode_graph jsonoo)) - with Jsonoo.Decode_error _ -> - Window.showErrorMessage + ~meth:"superbol/getCFG" ~data |> + Promise.then_ + ~rejected:begin fun _ -> + VS.Window.showErrorMessage ~message:"Impossible to render graph, \ try closing and reopening the webview" () - end + end + ~fulfilled:begin fun jsonoo -> + Promise.return (Some (decode_graph jsonoo)) + end (* WEBVIEW MANAGEMENT *) type stored_data = { - webview_panel: WebviewPanel.t; + webview_panel: VS.WebviewPanel.t; graph: graph; render_options: Jsonoo.t; } @@ -138,52 +158,57 @@ let window_listener = ref None let webviewpanel_disposal ~filename ~typ () = Hashtbl.remove webview_panels (filename, typ); if Hashtbl.length webview_panels == 0 - then ( - Option.iter Disposable.dispose !window_listener; - window_listener := None); - match Window.activeTextEditor () with + 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 = TextEditor.document text_editor - |> TextDocument.uri in - if String.equal filename @@ Uri.path uri - then TextEditor.setDecorations 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_ - ["graph_name", Jsonoo.Encode.string graph.name] in - let filename = Uri.path uri in + 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; _ } -> - WebviewPanel.reveal webview_panel (); + | Some { webview_panel; render_options; _ } -> + VS.WebviewPanel.reveal webview_panel (); Hashtbl.replace webview_panels (filename, typ) { webview_panel; graph; render_options }; - WebviewPanel.webview webview_panel, false + 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 = Window.createWebviewPanel ~viewType - ~title:"SuperBOL CFG Viewer" ~showOptions:(ViewColumn.Beside) in - let _ : Disposable.t = - WebviewPanel.onDidDispose webview_panel () + | 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 = WebviewPanel.webview webview_panel in - WebView.set_options webview (WebviewOptions.create ~enableScripts:true ()); + ~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 = - Hashtbl.find_opt webview_panels (Uri.path uri, typ) - |> Option.map begin fun { webview_panel; graph; render_options } -> - WebviewPanel.webview webview_panel, graph, render_options - end + 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 = Uri.path uri in + 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 @@ -195,58 +220,60 @@ let update_webview_data ~uri ~typ ?graph ?render_options () = (* CLICK ON NODE *) let on_click ~nodes_pos ~text_editor arg = - let open Vscode in - let uri = TextDocument.uri @@ TextEditor.document text_editor in - let column = TextEditor.viewColumn text_editor in + 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 - List.assoc_opt node nodes_pos - |> Option.iter begin fun range -> - let range = Range.t_of_js @@ Jsonoo.t_to_js range 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 = - Window.showTextDocument ~document:(`Uri uri) ?column () - |> Promise.then_ ~fulfilled:(fun text_editor -> - let selection = Selection.makePositions - ~anchor:(Range.start range) ~active:(Range.start range) in - TextEditor.revealRange text_editor ~range - ~revealType:TextEditorRevealType.InCenterIfOutsideViewport (); - TextEditor.set_selection text_editor selection; - TextEditor.setDecorations text_editor ~decorationType + 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 () - end + with Not_found -> () let setup_window_listener ~client = let listener event = - if TextEditorSelectionChangeEvent.kind event == - TextEditorSelectionChangeKind.Command + if VS.TextEditorSelectionChangeEvent.kind event == + VS.TextEditorSelectionChangeKind.Command then () else - match TextEditorSelectionChangeEvent.selections event with + match VS.TextEditorSelectionChangeEvent.selections event with | [] -> () | selection::_ -> - let text_editor = TextEditorSelectionChangeEvent.textEditor event in - TextEditor.setDecorations text_editor ~decorationType + let text_editor = VS.TextEditorSelectionChangeEvent.textEditor event in + VS.TextEditor.setDecorations text_editor ~decorationType ~rangesOrOptions:(`Ranges []); - let uri = TextEditor.document text_editor |> TextDocument.uri in + let uri = VS.TextEditor.document text_editor |> VS.TextDocument.uri in let process_selection_change webview = - let pos_start = Selection.start selection in + let pos_start = VS.Selection.start selection in let data = - let uri = Jsonoo.Encode.string @@ Uri.path uri in + let uri = Jsonoo.Encode.string @@ VS.Uri.path uri in Jsonoo.Encode.object_ ["uri", uri; - "line", Jsonoo.Encode.int @@ Position.line pos_start; - "character", Jsonoo.Encode.int @@ Position.character pos_start] + "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_ ~fulfilled:begin fun res -> + ~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; - WebView.postMessage webview ojs - end) + VS.WebView.postMessage webview ojs + end in () in let webview = webview_data_find_opt ~uri ~typ:Graphviz in @@ -260,19 +287,21 @@ let setup_window_listener ~client = in let disposable_listener = match !window_listener with - | Some listener -> listener - | None -> Window.onDidChangeTextEditorSelection () () - ~listener ~thisArgs:Ojs.null ~disposables:[] in - window_listener := Some disposable_listener + | 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 + else "graph_content" + in let ojs = Ojs.empty_obj () in - (match get_state_value ~key:(Uri.path uri ^ ":" ^ graph.name) with + (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); @@ -280,17 +309,18 @@ let send_graph ?(as_new_graph=false) ~uri ~typ webview graph = 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 = WebView.postMessage webview ojs + 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 = Uri.path uri 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 () + | None -> + Promise.return () | Some graph -> update_webview_data ~uri ~typ ~graph ~render_options (); update_state ~key:(path ^ ":" ^ name) render_options_ojs; @@ -300,10 +330,12 @@ let on_graph_update ~webview ~client ~uri ~typ name arg = in () let on_message ~client ~text_editor ~typ arg = - let uri = TextEditor.document text_editor |> TextDocument.uri in + 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 - webview_data_find_opt ~uri ~typ - |> Option.iter begin fun (webview, graph, _) -> + 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 @@ -312,29 +344,28 @@ let on_message ~client ~text_editor ~typ arg = | "ready" -> send_graph ~as_new_graph:true ~typ ~uri webview graph | _ -> () - end (* USER REQUEST LOGIC *) let open_cfg_for ~typ ~text_editor ~extension_uri client = let open Promise in - let uri = TextEditor.document text_editor |> TextDocument.uri in + let uri = VS.TextEditor.document text_editor |> VS.TextDocument.uri in let data = - let uri = Jsonoo.Encode.string @@ Uri.path uri in + 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 = Window.showErrorMessage - ~message:("Unable to display control-flow: " ^ e) () in - return () + 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 -> + ~meth:"superbol/getPossibleCFG" ~data |> + then_ ~fulfilled:begin fun jsonoo_graph_names -> let items = Jsonoo.Decode.(list string) jsonoo_graph_names in - Window.showQuickPick ~items () - |> then_ ~fulfilled:begin function + VS.Window.showQuickPick ~items () |> + then_ ~fulfilled:begin function | None -> return () | Some name -> then_ (callGetCFG ~uri ~name client) ~fulfilled:begin function @@ -342,13 +373,13 @@ let open_cfg_for ~typ ~text_editor ~extension_uri client = | 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 _ : Disposable.t = - WebView.onDidReceiveMessage webview () + let _ : VS.Disposable.t = + VS.WebView.onDidReceiveMessage webview () ~listener:(on_message ~client ~text_editor ~typ) ~thisArgs:Ojs.null ~disposables:[] in if is_new - then WebView.set_html webview html_content + then VS.WebView.set_html webview html_content else send_graph ~as_new_graph:true ~typ ~uri webview graph; setup_window_listener ~client; return () @@ -358,13 +389,14 @@ let open_cfg_for ~typ ~text_editor ~extension_uri client = let open_cfg ?text_editor ~typ instance = let text_editor = match text_editor with - | None -> Window.activeTextEditor () - | e -> e in + | None -> VS.Window.activeTextEditor () + | e -> e + in match Superbol_instance.client instance, text_editor with | Some client, Some text_editor -> - let extension_uri = ExtensionContext.extensionUri - @@ Superbol_instance.context instance in - state := Some (ExtensionContext.workspaceState - @@ Superbol_instance.context instance); + 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 index e243208b0..cbf0eef51 100644 --- a/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.mli +++ b/src/vscode/superbol-vscode-platform/superbol_cfg_explorer.mli @@ -14,6 +14,15 @@ 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 From 617734a17898953144b91aecc2dd671f7871b752 Mon Sep 17 00:00:00 2001 From: Mateo Date: Tue, 22 Oct 2024 11:54:29 +0200 Subject: [PATCH 38/40] fix: licence, isolate cfg_types, rename shatter --- assets/cfg-arc-renderer.html | 13 +++ assets/cfg-arc.css | 14 ++++ assets/cfg-arc.js | 13 +++ assets/cfg-dot-renderer.html | 17 +++- assets/cfg-dot.css | 14 ++++ assets/cfg-dot.js | 31 ++++--- src/lsp/cobol_cfg/cfg_builder.ml | 48 ++--------- src/lsp/cobol_cfg/cfg_builder.mli | 130 +----------------------------- src/lsp/cobol_cfg/cfg_options.ml | 6 +- src/lsp/cobol_cfg/cfg_types.ml | 50 ++++++++++++ src/lsp/cobol_cfg/cobol_cfg.ml | 1 + src/lsp/cobol_lsp/lsp_cfg.ml | 9 ++- 12 files changed, 158 insertions(+), 188 deletions(-) create mode 100644 src/lsp/cobol_cfg/cfg_types.ml diff --git a/assets/cfg-arc-renderer.html b/assets/cfg-arc-renderer.html index 25f245546..35696008a 100644 --- a/assets/cfg-arc-renderer.html +++ b/assets/cfg-arc-renderer.html @@ -1,3 +1,16 @@ + + + + + + + + + + + + + diff --git a/assets/cfg-arc.css b/assets/cfg-arc.css index 989550595..e272a31e2 100644 --- a/assets/cfg-arc.css +++ b/assets/cfg-arc.css @@ -1,3 +1,17 @@ +/* ----------------------------------------------------------------------- + * + * 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%; } diff --git a/assets/cfg-arc.js b/assets/cfg-arc.js index 4c0d78d66..51e2b8377 100644 --- a/assets/cfg-arc.js +++ b/assets/cfg-arc.js @@ -1,3 +1,16 @@ +// ----------------------------------------------------------------------- +// +// 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() diff --git a/assets/cfg-dot-renderer.html b/assets/cfg-dot-renderer.html index 2bf7acbf3..6f8da98c3 100644 --- a/assets/cfg-dot-renderer.html +++ b/assets/cfg-dot-renderer.html @@ -1,3 +1,16 @@ + + + + + + + + + + + + + @@ -31,8 +44,8 @@

Title

-
-