diff --git a/.drom b/.drom index f19bd048e..ca0d126ef 100644 --- a/.drom +++ b/.drom @@ -5,12 +5,12 @@ version:0.9.0 # hash of toml configuration files # used for generation of all files -6c1ce4b45a9a51f176134a026617d473:. +902350756f0d7d15400b20a907430e9e:. # end context for . # begin context for .github/workflows/workflow.yml # file .github/workflows/workflow.yml -b5d1e8c2eb697e9b85aff82f2b2ed8de:.github/workflows/workflow.yml +a123dfeb615e907fa895b378cd52ee3c:.github/workflows/workflow.yml # end context for .github/workflows/workflow.yml # begin context for .gitignore @@ -30,7 +30,7 @@ d00f73c835ae4a1589d55ebda4ab381b:CHANGES.md # begin context for Makefile # file Makefile -24041fb1bf88b61ac79928c5efab293b:Makefile +7fd4812f5873242aaa1d65a344f7e4c3:Makefile # end context for Makefile # begin context for README.md @@ -80,7 +80,7 @@ c8281f46ba9a11d0b61bc8ef67eaa357:docs/style.css # begin context for dune-project # file dune-project -31a668178aac1bc694fe232f601130b7:dune-project +22badd64255c88417b1d5ed3a0d03754:dune-project # end context for dune-project # begin context for opam/cobol_common.opam @@ -98,6 +98,16 @@ f35f27448b53dab19091f656ce3628cd:opam/cobol_config.opam 5c0ae643628488ea2a7be1262d4109cb:opam/cobol_data.opam # end context for opam/cobol_data.opam +# begin context for opam/cobol_data_old.opam +# file opam/cobol_data_old.opam +9016e14416fd7da536e24e8d4eced63f:opam/cobol_data_old.opam +# end context for opam/cobol_data_old.opam + +# begin context for opam/cobol_data_types.opam +# file opam/cobol_data_types.opam +761c1c937c7db9064ee9836ce70cfba7:opam/cobol_data_types.opam +# end context for opam/cobol_data_types.opam + # begin context for opam/cobol_indent.opam # file opam/cobol_indent.opam b8d28175ca0061bb86a8c097940bfe34:opam/cobol_indent.opam @@ -128,9 +138,14 @@ b8d28175ca0061bb86a8c097940bfe34:opam/cobol_indent.opam fc02e4984b73153fecd9d70c4ccab428:opam/cobol_typeck.opam # end context for opam/cobol_typeck.opam +# begin context for opam/cobol_typeck_old.opam +# file opam/cobol_typeck_old.opam +a69b0b9f93c6bac105da84b6072b3355:opam/cobol_typeck_old.opam +# end context for opam/cobol_typeck_old.opam + # begin context for opam/cobol_unit.opam # file opam/cobol_unit.opam -bfd8e1dd67b61b3f4e5f4b8f12180288:opam/cobol_unit.opam +76d88c1b0a68e0af28464a34049d254c:opam/cobol_unit.opam # end context for opam/cobol_unit.opam # begin context for opam/ebcdic_lib.opam @@ -298,6 +313,16 @@ c830729656f586961a44188b55cb4ac6:src/lsp/cobol_data/dune 940d29cde7f16cd0916ed1d5f9c41154:src/lsp/cobol_data/version.mlt # end context for src/lsp/cobol_data/version.mlt +# begin context for src/lsp/cobol_data_old/dune +# file src/lsp/cobol_data_old/dune +e74b6a4502967712b07002d1fb8b4292:src/lsp/cobol_data_old/dune +# end context for src/lsp/cobol_data_old/dune + +# begin context for src/lsp/cobol_data_old/version.mlt +# file src/lsp/cobol_data_old/version.mlt +940d29cde7f16cd0916ed1d5f9c41154:src/lsp/cobol_data_old/version.mlt +# end context for src/lsp/cobol_data_old/version.mlt + # begin context for src/lsp/cobol_indent/dune # file src/lsp/cobol_indent/dune 206291029ab9b39c62663475e37e57cd:src/lsp/cobol_indent/dune @@ -320,7 +345,7 @@ c830729656f586961a44188b55cb4ac6:src/lsp/cobol_data/dune # begin context for src/lsp/cobol_parser/dune # file src/lsp/cobol_parser/dune -09762dde0adad2bf9c7c37823db7919c:src/lsp/cobol_parser/dune +0b682680037cd6c542be12c29b35715d:src/lsp/cobol_parser/dune # end context for src/lsp/cobol_parser/dune # begin context for src/lsp/cobol_parser/version.mlt @@ -358,9 +383,19 @@ ef30db283bff57bd7bfea9b29e9178fd:src/lsp/cobol_typeck/dune 940d29cde7f16cd0916ed1d5f9c41154:src/lsp/cobol_typeck/version.mlt # end context for src/lsp/cobol_typeck/version.mlt +# begin context for src/lsp/cobol_typeck_old/dune +# file src/lsp/cobol_typeck_old/dune +f806267d9749a4f405ed7b6e4e0ebffe:src/lsp/cobol_typeck_old/dune +# end context for src/lsp/cobol_typeck_old/dune + +# begin context for src/lsp/cobol_typeck_old/version.mlt +# file src/lsp/cobol_typeck_old/version.mlt +940d29cde7f16cd0916ed1d5f9c41154:src/lsp/cobol_typeck_old/version.mlt +# end context for src/lsp/cobol_typeck_old/version.mlt + # begin context for src/lsp/cobol_unit/dune # file src/lsp/cobol_unit/dune -d2c167a61ac9aa89964577228ccb49fa:src/lsp/cobol_unit/dune +461e7b0db5a7aaf9cf342be193d92cd5:src/lsp/cobol_unit/dune # end context for src/lsp/cobol_unit/dune # begin context for src/lsp/cobol_unit/version.mlt diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index be2e106a0..d8eb7e514 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_project cobol_common cobol_parser cobol_ptree ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_indent cobol_preproc cobol_data cobol_typeck cobol_unit ez_toml ezr_toml + - 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_project cobol_common cobol_parser cobol_ptree ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_indent cobol_preproc cobol_data cobol_data_old cobol_typeck cobol_typeck_old cobol_unit ez_toml ezr_toml # 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 c49eb10ef..b0ae3097e 100644 --- a/Makefile +++ b/Makefile @@ -28,7 +28,7 @@ all: build build: ./scripts/before.sh build ${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_project cobol_common cobol_parser cobol_ptree ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_indent cobol_preproc cobol_data cobol_typeck cobol_unit ez_toml ezr_toml + ./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_project cobol_common cobol_parser cobol_ptree ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_indent cobol_preproc cobol_data cobol_data_old cobol_typeck cobol_typeck_old cobol_unit ez_toml ezr_toml ./scripts/after.sh build build-deps: diff --git a/drom.toml b/drom.toml index d4293d5ac..8d3dbaa05 100644 --- a/drom.toml +++ b/drom.toml @@ -200,10 +200,18 @@ dir = "src/lsp/cobol_preproc" dir = "src/lsp/cobol_data" # edit 'src/lsp/cobol_lsp/package.toml' for package-specific options +[[package]] +dir = "src/lsp/cobol_data_old" +# edit 'src/lsp/cobol_lsp/package.toml' for package-specific options + [[package]] dir = "src/lsp/cobol_typeck" # edit 'src/lsp/cobol_lsp/package.toml' for package-specific options +[[package]] +dir = "src/lsp/cobol_typeck_old" +# edit 'src/lsp/cobol_lsp/package.toml' for package-specific options + [[package]] dir = "src/lsp/cobol_unit" # edit 'src/lsp/cobol_unit/package.toml' for package-specific options diff --git a/dune-project b/dune-project index c1f802a96..2a77d9e0f 100644 --- a/dune-project +++ b/dune-project @@ -368,6 +368,21 @@ ) ) +(package + (name cobol_data_old) + (synopsis "SuperBOL Studio OSS Project") + (description "SuperBOL Studio OSS is a new platform for COBOL") + (depends + (ocaml (>= 4.14.0)) + (cobol_ptree (= version)) + (cobol_data (= version)) + (cobol_config (= version)) + (cobol_common (= version)) + (ppx_deriving ( >= 5.2.1 )) + odoc + ) + ) + (package (name cobol_typeck) (synopsis "SuperBOL Studio OSS Project") @@ -384,6 +399,23 @@ ) ) +(package + (name cobol_typeck_old) + (synopsis "SuperBOL Studio OSS Project") + (description "SuperBOL Studio OSS is a new platform for COBOL") + (depends + (ocaml (>= 4.14.0)) + (cobol_unit (= version)) + (cobol_typeck (= version)) + (cobol_ptree (= version)) + (cobol_parser (= version)) + (cobol_data (= version)) + (cobol_common (= version)) + (ppx_deriving ( >= 5.2.1 )) + odoc + ) + ) + (package (name cobol_unit) (synopsis "SuperBOL Studio OSS Project") @@ -391,6 +423,7 @@ (depends (ocaml (>= 4.14.0)) (cobol_ptree (= version)) + (cobol_data_old (= version)) (cobol_data (= version)) (cobol_config (= version)) (cobol_common (= version)) diff --git a/opam/cobol_data_old.opam b/opam/cobol_data_old.opam new file mode 100644 index 000000000..53f49fdbd --- /dev/null +++ b/opam/cobol_data_old.opam @@ -0,0 +1,55 @@ +# 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_data_old" +version: "0.1.0" +license: "MIT" +synopsis: "SuperBOL Studio OSS Project" +description: "SuperBOL Studio OSS is a new platform for COBOL" +authors: [ + "Nicolas Berthier " + "David Declerck " + "Fabrice Le Fessant " + "Emilien Lemaire " +] +maintainer: [ + "Nicolas Berthier " + "David Declerck " + "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"} + "cobol_ptree" {= version} + "cobol_data" {= version} + "cobol_config" {= version} + "cobol_common" {= version} + "ppx_deriving" {>= "5.2.1"} + "odoc" {with-doc} +] +# Content of `opam-trailer` field: \ No newline at end of file diff --git a/opam/cobol_data_types.opam b/opam/cobol_data_types.opam new file mode 100644 index 000000000..4a343f71d --- /dev/null +++ b/opam/cobol_data_types.opam @@ -0,0 +1,55 @@ +# 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_data_types" +version: "0.1.0" +license: "MIT" +synopsis: "SuperBOL Studio OSS Project" +description: "SuperBOL Studio OSS is a new platform for COBOL" +authors: [ + "Nicolas Berthier " + "David Declerck " + "Fabrice Le Fessant " + "Emilien Lemaire " +] +maintainer: [ + "Nicolas Berthier " + "David Declerck " + "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"} + "cobol_ptree" {= version} + "cobol_data" {= version} + "cobol_config" {= version} + "cobol_common" {= version} + "ppx_deriving" {>= "5.2.1"} + "odoc" {with-doc} +] +# Content of `opam-trailer` field: \ No newline at end of file diff --git a/opam/cobol_typeck_old.opam b/opam/cobol_typeck_old.opam new file mode 100644 index 000000000..76a5505d4 --- /dev/null +++ b/opam/cobol_typeck_old.opam @@ -0,0 +1,57 @@ +# 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_typeck_old" +version: "0.1.0" +license: "MIT" +synopsis: "SuperBOL Studio OSS Project" +description: "SuperBOL Studio OSS is a new platform for COBOL" +authors: [ + "Nicolas Berthier " + "David Declerck " + "Fabrice Le Fessant " + "Emilien Lemaire " +] +maintainer: [ + "Nicolas Berthier " + "David Declerck " + "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"} + "cobol_unit" {= version} + "cobol_typeck" {= version} + "cobol_ptree" {= version} + "cobol_parser" {= version} + "cobol_data" {= version} + "cobol_common" {= version} + "ppx_deriving" {>= "5.2.1"} + "odoc" {with-doc} +] +# Content of `opam-trailer` field: \ No newline at end of file diff --git a/opam/cobol_unit.opam b/opam/cobol_unit.opam index 2eba59bc7..d4642d32e 100644 --- a/opam/cobol_unit.opam +++ b/opam/cobol_unit.opam @@ -46,6 +46,7 @@ depends: [ "ocaml" {>= "4.14.0"} "dune" {>= "2.8.0"} "cobol_ptree" {= version} + "cobol_data_old" {= version} "cobol_data" {= version} "cobol_config" {= version} "cobol_common" {= version} diff --git a/src/lsp/cobol_common/cobol_common.ml b/src/lsp/cobol_common/errors.ml similarity index 68% rename from src/lsp/cobol_common/cobol_common.ml rename to src/lsp/cobol_common/errors.ml index d82635a41..84b767e8c 100644 --- a/src/lsp/cobol_common/cobol_common.ml +++ b/src/lsp/cobol_common/errors.ml @@ -11,15 +11,6 @@ (* *) (**************************************************************************) -module Basics = Basics -module Srcloc = Srcloc -module Copybook = Copybook -module Diagnostics = Diagnostics -module Visitor = Visitor -module Behaviors = Behaviors -module Tokenizing = Tokenizing -module Symbolic = Symbolic (* for now; may be moved elsewhere later *) - exception FatalError of string let fatal fmt = Pretty.string_to (fun s -> raise @@ FatalError s) fmt @@ -38,12 +29,6 @@ let init_default_exn_printers () = (* --- *) -module Types = struct - include Diagnostics.TYPES - include Srcloc.TYPES -end -include Types - (* TODO: move the ['a result] type related functions somewhere else *) let join_all l = List.fold_left @@ -54,18 +39,3 @@ let join_all l = (Ok []) l |> Result.map List.rev - -(* --- *) - -(* let tmp_files = ref [] *) -(* let remove_temporary_files = ref true *) - -(* let add_temporary_file file = tmp_files := file :: !tmp_files *) -(* let keep_temporary_files () = remove_temporary_files := false *) - -(* ;; *) - -(* at_exit begin fun () -> *) -(* if !remove_temporary_files then *) -(* List.iter (fun file -> Sys.remove file) !tmp_files *) -(* end *) diff --git a/src/lsp/cobol_common/cobol_common.mli b/src/lsp/cobol_common/errors.mli similarity index 73% rename from src/lsp/cobol_common/cobol_common.mli rename to src/lsp/cobol_common/errors.mli index 484538c99..23a16157b 100644 --- a/src/lsp/cobol_common/cobol_common.mli +++ b/src/lsp/cobol_common/errors.mli @@ -11,28 +11,9 @@ (* *) (**************************************************************************) -module Basics = Basics -module Srcloc = Srcloc -module Copybook = Copybook -module Diagnostics = Diagnostics -module Visitor = Visitor -module Behaviors = Behaviors -module Tokenizing = Tokenizing -module Symbolic = Symbolic (* for now; may be moved elsewhere later *) - exception FatalError of string val fatal: ('a, Format.formatter, unit, _) format4 -> 'a -module Types: sig - include module type of Diagnostics.TYPES - include module type of Srcloc.TYPES -end -include module type of Types - with type 'a with_diags = 'a Types.with_diags - and type 'a with_loc = 'a Types.with_loc - and type lexloc = Types.lexloc - and type srcloc = Types.srcloc - (* TODO: remove this (note: only one ref in `cobol_data`) *) (** [join_all diags res_l] takes every value of a list of [('a, 'e) result list] and return a [('a, 'e) result]. If all the elements in the parameter list are diff --git a/src/lsp/cobol_common/srcloc.ml b/src/lsp/cobol_common/srcloc.ml index a3c65d854..19a848bee 100644 --- a/src/lsp/cobol_common/srcloc.ml +++ b/src/lsp/cobol_common/srcloc.ml @@ -66,6 +66,7 @@ module TYPES = struct end include TYPES +type t = srcloc (* For debugging: *) diff --git a/src/lsp/cobol_common/srcloc.mli b/src/lsp/cobol_common/srcloc.mli index 74636b499..90f82033e 100644 --- a/src/lsp/cobol_common/srcloc.mli +++ b/src/lsp/cobol_common/srcloc.mli @@ -22,6 +22,7 @@ type srcloc = TYPES.srcloc type copylocs = TYPES.copylocs type 'a with_loc = 'a TYPES.with_loc = { payload: 'a; loc: srcloc; } [@@deriving ord] +type t= srcloc module INFIX: sig (* Meaning of letters: diff --git a/src/lsp/cobol_config/cobol_config.ml b/src/lsp/cobol_config/config.ml similarity index 96% rename from src/lsp/cobol_config/cobol_config.ml rename to src/lsp/cobol_config/config.ml index db28d3e9a..1ddc2a196 100644 --- a/src/lsp/cobol_config/cobol_config.ml +++ b/src/lsp/cobol_config/config.ml @@ -15,16 +15,10 @@ open EzCompat open Ez_file.V1 open EzFile.OP -include Types - -module Options = Options -module Default = Default -module Diagnostics = Config_diagnostics +open Types module DIAGS = Cobol_common.Diagnostics -exception ERROR of Config_diagnostics.error - let __init_default_exn_printers = Printexc.register_printer begin function | ERROR e -> @@ -237,7 +231,7 @@ let from_file ?search_path file = | Conf_ast.String s -> s | v -> raise @@ ERROR (Invalid_key_value_pair ("name", v)) } let dialect = - try DIALECT.of_gnucobol_config_name config.name + try Dialect.of_gnucobol_config_name config.name with Invalid_argument _ -> raise @@ ERROR (Unknown_dialect config.name) let options = options @@ -252,15 +246,15 @@ let from_file ?search_path file = let from_dialect ?search_path d = let search_path = retrieve_search_path ?search_path () in let config_filename = function - | DIALECT.GnuCOBOL -> "default.conf" - | dialect -> Pretty.to_string "%s.conf" (DIALECT.to_string dialect) + | Types.GnuCOBOL -> "default.conf" + | dialect -> Pretty.to_string "%s.conf" (Dialect.to_string dialect) in let load_gnucobol_conf conf = from_file ~search_path @@ find_file ~search_path (config_filename conf) in match d with - | DIALECT.Default -> DIAGS.result (module Default: T) + | Types.Default -> DIAGS.result (module Default: T) | d -> load_gnucobol_conf d let dialect (module C: T) = C.dialect diff --git a/src/lsp/cobol_config/cobol_config.mli b/src/lsp/cobol_config/config.mli similarity index 92% rename from src/lsp/cobol_config/cobol_config.mli rename to src/lsp/cobol_config/config.mli index c7b5d704e..d538ec071 100644 --- a/src/lsp/cobol_config/cobol_config.mli +++ b/src/lsp/cobol_config/config.mli @@ -16,13 +16,7 @@ or use the default value of any options that is badly typed in the configuration file or not set in the configuration file.*) -include module type of Types - -module Options = Options -module Default = Default -module Diagnostics = Config_diagnostics - -exception ERROR of Diagnostics.error +open Types val print_options: Format.formatter -> unit @@ -50,7 +44,7 @@ val from_file given for {!from_file} applies here as well. *) val from_dialect : ?search_path: string list - -> Types.DIALECT.t + -> Types.dialect -> (module T) Cobol_common.Diagnostics.with_diags val dialect: t -> dialect diff --git a/src/lsp/cobol_config/default.ml b/src/lsp/cobol_config/default.ml index eea6438f2..d71a86682 100644 --- a/src/lsp/cobol_config/default.ml +++ b/src/lsp/cobol_config/default.ml @@ -43,8 +43,8 @@ let default_aliases = module Default: Types.T = struct open Types - let dialect = DIALECT.Default - let config = { name = DIALECT.to_string dialect } + let dialect = Default + let config = { name = Dialect.to_string dialect } let words = let alias_for b = ReserveAlias { alias_for = b; diff --git a/src/lsp/cobol_config/dialect.ml b/src/lsp/cobol_config/dialect.ml new file mode 100644 index 000000000..58fc2a8d7 --- /dev/null +++ b/src/lsp/cobol_config/dialect.ml @@ -0,0 +1,129 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +open Types + +let default = Default +let gnucobol = GnuCOBOL +let cobol85 = COBOL85 +let cobol2002 = COBOL2002 +let cobol2014 = COBOL2014 +let acu = ACU { strict = false } +let acu_strict = ACU { strict = true } +let bs2000 = BS2000 { strict = false } +let bs2000_strict = BS2000 { strict = true } +let gcos = GCOS { strict = false } +let gcos_strict = GCOS { strict = true } +let ibm = IBM { strict = false } +let ibm_strict = IBM { strict = true } +let mf = MicroFocus { strict = false } +let mf_strict = MicroFocus { strict = true } +let mvs = MVS { strict = false } +let mvs_strict = MVS { strict = true } +let realia = Realia { strict = false } +let realia_strict = Realia { strict = true } +let rm = RM { strict = false } +let rm_strict = RM { strict = true } +let xopen = XOpen + +let to_string: dialect -> string = function + | Default -> "default" + | GnuCOBOL -> "gnucobol" + | COBOL85 -> "cobol85" + | COBOL2002 -> "cobol2002" + | COBOL2014 -> "cobol2014" + | ACU { strict = false } -> "acu" + | ACU { strict = true } -> "acu-strict" + | BS2000 { strict = false } -> "bs2000" + | BS2000 { strict = true } -> "bs2000-strict" + | GCOS { strict = false } -> "gcos" + | GCOS { strict = true } -> "gcos-strict" + | IBM { strict = false } -> "ibm" + | IBM { strict = true } -> "ibm-strict" + | MicroFocus { strict = false } -> "mf" + | MicroFocus { strict = true } -> "mf-strict" + | MVS { strict = false } -> "mvs" + | MVS { strict = true } -> "mvs-strict" + | Realia { strict = false } -> "realia" + | Realia { strict = true } -> "realia-strict" + | RM { strict = false } -> "rm" + | RM { strict = true } -> "rm-strict" + | XOpen -> "xopen" + +let of_string: string -> dialect = fun s -> + match String.lowercase_ascii s with + | "default" -> Default + | "gnucobol" -> GnuCOBOL + | "cobol85" -> COBOL85 + | "cobol2002" -> COBOL2002 + | "cobol2014" -> COBOL2014 + | "xopen" -> XOpen + | l -> + let prefix, strict = match EzString.chop_suffix l ~suffix:"-strict" with + | Some prefix -> prefix, true + | None -> l, false + in + match prefix with + | "acu" -> ACU { strict } + | "bs2000" -> BS2000 { strict } + | "gcos" -> GCOS { strict } + | "ibm" -> IBM { strict } + | "mf" | "microfocus" -> MicroFocus { strict } + | "mvs" -> MVS { strict } + | "realia" -> Realia { strict } + | "rm" -> RM { strict } + | _ -> invalid_arg s + +let all_canonical_names = + [ + "default"; + "gnucobol"; + "cobol85"; + "cobol2002"; + "cobol2014"; + ] @ List.concat_map (fun d -> [d; d ^ "-strict"]) [ + "acu"; + "bs2000"; + "gcos"; + "ibm"; + "mf"; + "mvs"; + "realia"; + "rm"; + ] @ [ + "xopen"; + ] + +let of_gnucobol_config_name: string -> dialect = function + | "COBOL 85" -> COBOL85 + | "COBOL 2002" -> COBOL2002 + | "COBOL 2014" -> COBOL2014 + | "GnuCOBOL" -> GnuCOBOL + | "ACUCOBOL-GT" -> ACU { strict = true } + | "ACUCOBOL-GT (lax)" -> ACU { strict = false } + | "BS2000 COBOL" -> BS2000 { strict = true } + | "BS2000 COBOL (lax)" -> BS2000 { strict = false } + | "GCOS" -> GCOS { strict = true } + | "GCOS (lax)" -> GCOS { strict = false } + | "IBM COBOL" -> IBM { strict = true } + | "IBM COBOL (lax)" -> IBM { strict = false } + | "Micro Focus COBOL" -> MicroFocus { strict = true } + | "Micro Focus COBOL (lax)" -> MicroFocus { strict = false } + | "IBM COBOL for MVS & VM" -> MVS { strict = true } + | "MVS/VM COBOL (lax)" -> MVS { strict = false } + | "CA Realia II" -> Realia { strict = true } + | "CA Realia II (lax)" -> Realia { strict = false } + | "RM-COBOL" -> RM { strict = true } + | "RM-COBOL (lax)" -> RM { strict = false } + | "X/Open COBOL" -> XOpen + | s -> of_string s diff --git a/src/lsp/cobol_config/types.ml b/src/lsp/cobol_config/types.ml index 5c75aad26..7257b6dd1 100644 --- a/src/lsp/cobol_config/types.ml +++ b/src/lsp/cobol_config/types.ml @@ -18,6 +18,8 @@ open Cobol_common.Diagnostics.TYPES module DIAGS = Cobol_common.Diagnostics +exception ERROR of Config_diagnostics.error + type doc = Pretty.simple (** Global configuration representative (default, gcos, gcos-strict, etc). Just @@ -294,142 +296,22 @@ and word_spec = } | NotReserved -module DIALECT = struct - - type t = - | Default - | GnuCOBOL - | COBOL85 - | COBOL2002 - | COBOL2014 - | ACU of dialect_strictness - | BS2000 of dialect_strictness - | GCOS of dialect_strictness - | IBM of dialect_strictness - | MicroFocus of dialect_strictness - | MVS of dialect_strictness - | Realia of dialect_strictness - | RM of dialect_strictness - | XOpen - and dialect_strictness = { strict: bool } - - let default = Default - let gnucobol = GnuCOBOL - let cobol85 = COBOL85 - let cobol2002 = COBOL2002 - let cobol2014 = COBOL2014 - let acu = ACU { strict = false } - let acu_strict = ACU { strict = true } - let bs2000 = BS2000 { strict = false } - let bs2000_strict = BS2000 { strict = true } - let gcos = GCOS { strict = false } - let gcos_strict = GCOS { strict = true } - let ibm = IBM { strict = false } - let ibm_strict = IBM { strict = true } - let mf = MicroFocus { strict = false } - let mf_strict = MicroFocus { strict = true } - let mvs = MVS { strict = false } - let mvs_strict = MVS { strict = true } - let realia = Realia { strict = false } - let realia_strict = Realia { strict = true } - let rm = RM { strict = false } - let rm_strict = RM { strict = true } - let xopen = XOpen - - let to_string: t -> string = function - | Default -> "default" - | GnuCOBOL -> "gnucobol" - | COBOL85 -> "cobol85" - | COBOL2002 -> "cobol2002" - | COBOL2014 -> "cobol2014" - | ACU { strict = false } -> "acu" - | ACU { strict = true } -> "acu-strict" - | BS2000 { strict = false } -> "bs2000" - | BS2000 { strict = true } -> "bs2000-strict" - | GCOS { strict = false } -> "gcos" - | GCOS { strict = true } -> "gcos-strict" - | IBM { strict = false } -> "ibm" - | IBM { strict = true } -> "ibm-strict" - | MicroFocus { strict = false } -> "mf" - | MicroFocus { strict = true } -> "mf-strict" - | MVS { strict = false } -> "mvs" - | MVS { strict = true } -> "mvs-strict" - | Realia { strict = false } -> "realia" - | Realia { strict = true } -> "realia-strict" - | RM { strict = false } -> "rm" - | RM { strict = true } -> "rm-strict" - | XOpen -> "xopen" - - let of_string: string -> t = fun s -> - match String.lowercase_ascii s with - | "default" -> Default - | "gnucobol" -> GnuCOBOL - | "cobol85" -> COBOL85 - | "cobol2002" -> COBOL2002 - | "cobol2014" -> COBOL2014 - | "xopen" -> XOpen - | l -> - let prefix, strict = match EzString.chop_suffix l ~suffix:"-strict" with - | Some prefix -> prefix, true - | None -> l, false - in - match prefix with - | "acu" -> ACU { strict } - | "bs2000" -> BS2000 { strict } - | "gcos" -> GCOS { strict } - | "ibm" -> IBM { strict } - | "mf" | "microfocus" -> MicroFocus { strict } - | "mvs" -> MVS { strict } - | "realia" -> Realia { strict } - | "rm" -> RM { strict } - | _ -> invalid_arg s - - let all_canonical_names = - [ - "default"; - "gnucobol"; - "cobol85"; - "cobol2002"; - "cobol2014"; - ] @ List.concat_map (fun d -> [d; d ^ "-strict"]) [ - "acu"; - "bs2000"; - "gcos"; - "ibm"; - "mf"; - "mvs"; - "realia"; - "rm"; - ] @ [ - "xopen"; - ] - - let of_gnucobol_config_name: string -> t = function - | "COBOL 85" -> COBOL85 - | "COBOL 2002" -> COBOL2002 - | "COBOL 2014" -> COBOL2014 - | "GnuCOBOL" -> GnuCOBOL - | "ACUCOBOL-GT" -> ACU { strict = true } - | "ACUCOBOL-GT (lax)" -> ACU { strict = false } - | "BS2000 COBOL" -> BS2000 { strict = true } - | "BS2000 COBOL (lax)" -> BS2000 { strict = false } - | "GCOS" -> GCOS { strict = true } - | "GCOS (lax)" -> GCOS { strict = false } - | "IBM COBOL" -> IBM { strict = true } - | "IBM COBOL (lax)" -> IBM { strict = false } - | "Micro Focus COBOL" -> MicroFocus { strict = true } - | "Micro Focus COBOL (lax)" -> MicroFocus { strict = false } - | "IBM COBOL for MVS & VM" -> MVS { strict = true } - | "MVS/VM COBOL (lax)" -> MVS { strict = false } - | "CA Realia II" -> Realia { strict = true } - | "CA Realia II (lax)" -> Realia { strict = false } - | "RM-COBOL" -> RM { strict = true } - | "RM-COBOL (lax)" -> RM { strict = false } - | "X/Open COBOL" -> XOpen - | s -> of_string s - -end -type dialect = DIALECT.t +type dialect = + | Default + | GnuCOBOL + | COBOL85 + | COBOL2002 + | COBOL2014 + | ACU of dialect_strictness + | BS2000 of dialect_strictness + | GCOS of dialect_strictness + | IBM of dialect_strictness + | MicroFocus of dialect_strictness + | MVS of dialect_strictness + | Realia of dialect_strictness + | RM of dialect_strictness + | XOpen +and dialect_strictness = { strict: bool } module type CONFIG = sig val dialect: dialect diff --git a/src/lsp/cobol_data/cobol_data.ml b/src/lsp/cobol_data/cobol_data.ml deleted file mode 100644 index 99641af48..000000000 --- a/src/lsp/cobol_data/cobol_data.ml +++ /dev/null @@ -1,40 +0,0 @@ -(**************************************************************************) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(** This module implements functions to type the COBOL data.*) - -module OLD = struct - - module Types = struct - include Types - type group = Group.t - - include Compilation_unit.TYPES - type compilation_units = Compilation_unit.SET.t - type +'a compilation_units_map = 'a Compilation_unit.MAP.t - end - - include Env - module Group = Group - module Mangling = Mangling - module Picture = Data_picture - module Qualmap = Qualmap - module Compilation_unit = Compilation_unit -end - -module Memory = Data_memory -module Types = Data_types -module Item = Data_item -module Picture = Data_picture -module Printer = Data_printer -module Visitor = Data_visitor diff --git a/src/lsp/cobol_data/data_types.ml b/src/lsp/cobol_data/data_types.ml deleted file mode 100644 index 1a3803021..000000000 --- a/src/lsp/cobol_data/data_types.ml +++ /dev/null @@ -1,216 +0,0 @@ -(**************************************************************************) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(** Representation of COBOL data items *) - -(* Note: location of qualnames often correspond to the *unqualified* name, with - implicit qualification based on item groups. *) - -open Cobol_common.Srcloc.TYPES - -module NEL = Cobol_common.Basics.NEL -type 'a nel = 'a NEL.t - -type picture_config = Data_picture.TYPES.config -type picture = Data_picture.t - -type usage = - | Binary of (* [`numeric] *) picture - | Binary_C_long of signedness (* GnuCOBOL *) - | Binary_char of signedness (* +COB2002 *) - | Binary_double of signedness (* +COB2002 *) - | Binary_long of signedness (* +COB2002 *) - | Binary_short of signedness (* +COB2002 *) - | Bit of (* [`boolean] *) picture - | Display of (* [any] *) picture - | Float_binary of { width: [`W32|`W64|`W128]; (* +COB2002 *) - endian: Cobol_ptree.endianness_mode } - | Float_decimal of { width: [`W16 | `W34]; (* +COB2002 *) - endian: Cobol_ptree.endianness_mode; - encoding: Cobol_ptree.encoding_mode } - | Float_extended (* +COB2002 *) - | Float_long (* +COB2002 *) - | Float_short (* +COB2002 *) - | Function_pointer of Cobol_ptree.name with_loc (* tmp *) - | Index - | National of (* [any] *) picture - | Object_reference of Cobol_ptree.object_reference_kind option (* tmp *) - | Packed_decimal of (* [`numeric] *) picture - | Pointer of Cobol_ptree.name with_loc option (* tmp *) - | Program_pointer of Cobol_ptree.name with_loc option (* tmp *) -and signedness = { signed: bool } - -type data_storage = - | File - | Local_storage - | Working_storage - | Linkage (* file? *) - -let pp_data_storage ppf s = - Fmt.string ppf @@ match s with - | File -> "FILE" - | Local_storage -> "LOCAL-STORAGE" - | Working_storage -> "WORKING-STORAGE" - | Linkage -> "LINKAGE" - -type length = - | Fixed_length - | Variable_length - (* Note: OCCURS DYNAMIC is considered fixed-length in ISO/IEC *) - -type record = - { - record_name: string; - record_storage: data_storage; - record_item: item_definition with_loc; - record_renamings: record_renamings; - } -and item_definitions = item_definition with_loc nel -and item_redefinitions = item_definition with_loc list - -and item_definition = - | Field of field_definition - | Table of table_definition - -and field_definition = - { - field_qualname: Cobol_ptree.qualname with_loc option; - field_redefines: Cobol_ptree.qualname with_loc option; (* redef only *) - field_leading_ranges: table_range list; - field_offset: Data_memory.offset; (** offset w.r.t record address *) - field_size: Data_memory.size; - field_layout: field_layout; - field_length: length; - field_conditions: condition_names; - field_redefinitions: item_redefinitions; - } - -and field_layout = - | Elementary_field of - { - usage: usage; - init_value: Cobol_ptree.literal with_loc option; - } - | Struct_field of - { - subfields: item_definitions; - } - -and table_definition = - { - table_field: field_definition with_loc; - table_offset: Data_memory.offset; - table_size: Data_memory.size; - table_range: table_range; - table_init_values: Cobol_ptree.literal with_loc list; (* list for now *) - table_redefines: Cobol_ptree.qualname with_loc option; (* redef only *) - table_redefinitions: item_redefinitions; - } -and table_range = - { - range_span: span; - range_indexes: Cobol_ptree.qualname with_loc list; - } -and span = - | Fixed_span of fixed_span (* OCCURS _ TIMES *) - | Depending_span of depending_span (* OCCURS _ TO _ TIMES DEPENDING ON _ *) - | Dynamic_span of dynamic_span (* OCCURS DYNAMIC CAPACITY _ FROM _ TO _ *) - -and fixed_span = - { - occurs_times: int with_loc; (* int for now *) - } -and depending_span = - { - occurs_depending_min: int with_loc; (* int for now *) - occurs_depending_max: int with_loc; (* ditto *) - occurs_depending: Cobol_ptree.qualname with_loc; - } -and dynamic_span = - { - occurs_dynamic_capacity: Cobol_ptree.qualname with_loc option; - occurs_dynamic_capacity_min: int with_loc option; - occurs_dynamic_capacity_max: int with_loc option; - occurs_dynamic_initialized: bool with_loc; - } - -and condition_names = condition_name with_loc list -and condition_name = - { - condition_name_qualname: Cobol_ptree.qualname with_loc; - condition_name_item: Cobol_ptree.condition_name_item; (* for now *) - } - -(** Note: RENAMES could be represented by simply adding an (optional, - non-constant) offset to redefinitions (and use group layouts with FILLERs - throughout to forbid using the new name as a qualifier). - - Such a representation would be much more general than what typical COBOL - data definitions allow; in particular, one could have "shifted" redefintions - of any non-01 group item. - - However, we keep the distinction between RENAMES and REDEFINES to better - match said typical COBOL, and possibly allow more detailed error - reporting. *) -and record_renamings = record_renaming with_loc list -and record_renaming = - { - renaming_name: Cobol_ptree.qualname with_loc; - renaming_layout: renamed_item_layout; - renaming_offset: Data_memory.offset; - renaming_size: Data_memory.size; - renaming_from: Cobol_ptree.qualname with_loc; - renaming_thru: Cobol_ptree.qualname with_loc option; - } -and renamed_item_layout = - | Renamed_elementary of - { - usage: usage; - } - | Renamed_struct of - { - subfields: item_definitions; (* CHECKME: items rather than fields? *) - } - -(* type data_const_record = *) -(* { *) -(* const_name: Cobol_ptree.name with_loc; *) -(* const_descr: Cobol_ptree.constant_item_descr; *) -(* const_layout: const_layout; *) -(* } *) - -type data_definition = - | Data_field of - { - record: record; - def: field_definition with_loc; - } - | Data_renaming of (* not sure *) - { - record: record; - def: record_renaming with_loc; - } - | Data_condition of - { - record: record; - field: field_definition with_loc; - def: condition_name with_loc; - } - | Table_index of - { - record: record; (* record where [table] is defined *) - table: table_definition with_loc; (* table whose index it is *) - qualname: Cobol_ptree.qualname with_loc; (* fully qualified name *) - } - -(* screen: "_ OCCURS n TIMES" only. Max 2 dimensions. *) diff --git a/src/lsp/cobol_data/data_item.ml b/src/lsp/cobol_data/item.ml similarity index 59% rename from src/lsp/cobol_data/data_item.ml rename to src/lsp/cobol_data/item.ml index d77717770..ecf9240b6 100644 --- a/src/lsp/cobol_data/data_item.ml +++ b/src/lsp/cobol_data/item.ml @@ -11,38 +11,36 @@ (* *) (**************************************************************************) -open Data_types - -module Visitor = Cobol_common.Visitor +open Types (* ignores redefs by default *) let fold_definitions ?(fold_redefinitions = false) ~field ~table def acc = - Data_visitor.fold_item_definition' object - inherit [_] Data_visitor.folder + Visitor.fold_item_definition' object + inherit [_] Visitor.folder method! fold_field_definition' def acc = - Visitor.do_children (field def acc) + Cobol_common.Visitor.do_children (field def acc) method! fold_table_definition' def acc = - Visitor.do_children (table def acc) - method! fold_usage _ = Visitor.skip + Cobol_common.Visitor.do_children (table def acc) + method! fold_usage _ = Cobol_common.Visitor.skip method! fold_item_redefinitions _ acc = if fold_redefinitions - then Visitor.do_children acc - else Visitor.skip_children acc - method! fold_table_range _ = Visitor.skip - method! fold_fixed_span _ = Visitor.skip - method! fold_depending_span _ = Visitor.skip - method! fold_dynamic_span _ = Visitor.skip - method! fold_condition_names _ = Visitor.skip - method! fold_memory_offset _ = Visitor.skip - method! fold_memory_size _ = Visitor.skip - method! fold_qualname' _ = Visitor.skip + then Cobol_common.Visitor.do_children acc + else Cobol_common.Visitor.skip_children acc + method! fold_table_range _ = Cobol_common.Visitor.skip + method! fold_fixed_span _ = Cobol_common.Visitor.skip + method! fold_depending_span _ = Cobol_common.Visitor.skip + method! fold_dynamic_span _ = Cobol_common.Visitor.skip + method! fold_condition_names _ = Cobol_common.Visitor.skip + method! fold_memory_offset _ = Cobol_common.Visitor.skip + method! fold_memory_size _ = Cobol_common.Visitor.skip + method! fold_qualname' _ = Cobol_common.Visitor.skip end def acc -let offset: item_definition -> Data_memory.offset = function +let offset: item_definition -> Memory.offset = function | Field f -> f.field_offset | Table t -> t.table_offset -let size: item_definition -> Data_memory.size = function +let size: item_definition -> Memory.size = function | Field f -> f.field_size | Table t -> t.table_size @@ -52,4 +50,4 @@ let qualname = function (** Note: may be a no-op *) let pp_item_qualname ?(leading = Fmt.nop) ppf item = - Fmt.(option (leading ++ Cobol_ptree.pp_qualname')) ppf (qualname item) + Fmt.(option (leading ++ Cobol_ptree.Types.pp_qualname')) ppf (qualname item) diff --git a/src/lsp/cobol_data/data_memory.ml b/src/lsp/cobol_data/memory.ml similarity index 96% rename from src/lsp/cobol_data/data_memory.ml rename to src/lsp/cobol_data/memory.ml index 74ac596e5..1c1430d25 100644 --- a/src/lsp/cobol_data/data_memory.ml +++ b/src/lsp/cobol_data/memory.ml @@ -38,12 +38,12 @@ let show_elementary_size = Pretty.to_string "%a" pp_elementary_size (* --- *) type symbolic_var = - | Valof of Cobol_ptree.qualname + | Valof of Cobol_ptree.Types.qualname [@@deriving ord] let pp_symbolic_var ppf = function | Valof qn -> - Pretty.print ppf "@[(valof@;<1 2>%a)@]" Cobol_ptree.pp_qualname qn + Pretty.print ppf "@[(valof@;<1 2>%a)@]" Cobol_ptree.Types.pp_qualname qn let show_symbolic_var = Pretty.to_string "%a" pp_symbolic_var module AE = diff --git a/src/lsp/cobol_data/data_memory.mli b/src/lsp/cobol_data/memory.mli similarity index 94% rename from src/lsp/cobol_data/data_memory.mli rename to src/lsp/cobol_data/memory.mli index 2988b1ac4..ed389ec46 100644 --- a/src/lsp/cobol_data/data_memory.mli +++ b/src/lsp/cobol_data/memory.mli @@ -22,7 +22,7 @@ type elementary_size = [@@deriving show, ord] type symbolic_var = private - | Valof of Cobol_ptree.qualname + | Valof of Cobol_ptree.Types.qualname [@@deriving show, ord] type factor @@ -41,11 +41,11 @@ exception NOT_SCALAR of [ `Vars of symbolic_var Cobol_common.Basics.NEL.t (* --- *) val int: int -> factor -val valof: Cobol_ptree.qualname -> factor +val valof: Cobol_ptree.Types.qualname -> factor val point_size: size (* null-size *) val const_size: int -> size -val valof_size: Cobol_ptree.qualname -> size +val valof_size: Cobol_ptree.Types.qualname -> size val elementary_size: elementary_size -> size val bit_size: size val byte_size: size diff --git a/src/lsp/cobol_data/data_picture.ml b/src/lsp/cobol_data/picture.ml similarity index 99% rename from src/lsp/cobol_data/data_picture.ml rename to src/lsp/cobol_data/picture.ml index 68ef72f1d..d542dc7d8 100644 --- a/src/lsp/cobol_data/data_picture.ml +++ b/src/lsp/cobol_data/picture.ml @@ -1138,7 +1138,7 @@ let error_diagnostics ~loc errors = add_diags acc ~loc:(Srcloc.sub loc ~pos ~len) error end DIAGS.Set.none (List.rev errors) -module Make (Config: Cobol_config.T) (Env: ENV) = struct +module Make (Config: Cobol_config.Types.T) (Env: ENV) = struct exception InvalidPicture of string with_loc * Cobol_common.Diagnostics.diagnostics * picture diff --git a/src/lsp/cobol_data/data_picture.mli b/src/lsp/cobol_data/picture.mli similarity index 99% rename from src/lsp/cobol_data/data_picture.mli rename to src/lsp/cobol_data/picture.mli index b679078f3..e1d32d493 100644 --- a/src/lsp/cobol_data/data_picture.mli +++ b/src/lsp/cobol_data/picture.mli @@ -217,7 +217,7 @@ val fixed_numeric -> (* decimal_digits: *)int -> picture -module Make (Config: Cobol_config.T) (Env: ENV) : sig +module Make (Config: Cobol_config.Types.T) (Env: ENV) : sig exception InvalidPicture of string with_loc * Cobol_common.Diagnostics.diagnostics * picture diff --git a/src/lsp/cobol_data/data_printer.ml b/src/lsp/cobol_data/printer.ml similarity index 90% rename from src/lsp/cobol_data/data_printer.ml rename to src/lsp/cobol_data/printer.ml index 22fcac566..6bed95bde 100644 --- a/src/lsp/cobol_data/data_printer.ml +++ b/src/lsp/cobol_data/printer.ml @@ -11,29 +11,29 @@ (* *) (**************************************************************************) -open Data_types +open Types open Cobol_common.Srcloc.TYPES open Cobol_common.Srcloc.INFIX -let pp_offset = Data_memory.pp_offset -let pp_size = Data_memory.pp_size +let pp_offset = Memory.pp_offset +let pp_size = Memory.pp_size -let pp_int' = Cobol_ptree.pp_with_loc Fmt.int +let pp_int' = Cobol_ptree.Types.pp_with_loc Fmt.int let pp_int'_opt = Fmt.option pp_int' -let pp_qualname'_opt = Fmt.option Cobol_ptree.pp_qualname' -let pp_qualname'_list = Fmt.(hbox (list ~sep:comma Cobol_ptree.pp_qualname')) - (* Pretty.list ~fopen:"@[" ~fsep:",@;" ~fclose:"@]" Cobol_ptree.pp_qualname' *) -let pp_literal'_opt = Fmt.option Cobol_ptree.pp_literal' -let pp_literal'_list = Fmt.list Cobol_ptree.pp_literal' +let pp_qualname'_opt = Fmt.option Cobol_ptree.Types.pp_qualname' +let pp_qualname'_list = Fmt.(hbox (list ~sep:comma Cobol_ptree.Types.pp_qualname')) + (* Pretty.list ~fopen:"@[" ~fsep:",@;" ~fclose:"@]" Cobol_ptree.Types.pp_qualname' *) +let pp_literal'_opt = Fmt.option Cobol_ptree.Types.pp_literal' +let pp_literal'_list = Fmt.list Cobol_ptree.Types.pp_literal' (* usage *) let pp_usage: usage Pretty.printer = - let pp_usage_with_picture ppf name (picture: Data_picture.t) = + let pp_usage_with_picture ppf name (picture: Picture.t) = Pretty.record [ Fmt.(styled `Yellow @@ any name); - Fmt.field "category" (fun () -> picture.category) Data_picture.pp_category; + Fmt.field "category" (fun () -> picture.category) Picture.pp_category; ] ppf () and pp_usage_with_sign ppf name signed = Fmt.(styled `Yellow @@ (if signed then any "signed-" else nop) ++ any name) @@ -100,7 +100,7 @@ and pp_depending_span: depending_span Pretty.printer = T Fmt.(styled `Yellow @@ any "depending-span"); T (Fmt.field "min_occurs" (fun x -> x.occurs_depending_min) pp_int'); T (Fmt.field "max_occurs" (fun x -> x.occurs_depending_max) pp_int'); - T (Fmt.field "depending" (fun x -> x.occurs_depending) Cobol_ptree.pp_qualname'); + T (Fmt.field "depending" (fun x -> x.occurs_depending) Cobol_ptree.Types.pp_qualname'); ] and pp_dynamic_span: dynamic_span Pretty.printer = @@ -137,7 +137,7 @@ let rec pp_item_definition: item_definition Pretty.printer = fun ppf -> function | Table def -> pp_table_definition ppf def and pp_item_definition': item_definition with_loc Pretty.printer = fun ppf -> - Cobol_ptree.pp_with_loc pp_item_definition ppf + Cobol_ptree.Types.pp_with_loc pp_item_definition ppf and pp_item_definitions: item_definitions Pretty.printer = fun ppf defs -> NEL.pp ~fopen:"" ~fsep:"" ~fclose:"" pp_item_definition' ppf defs @@ -169,7 +169,7 @@ and pp_field_definition: field_definition Pretty.printer = fun ppf x -> ] ppf x and pp_field_definition': field_definition with_loc Pretty.printer = fun ppf -> - Cobol_ptree.pp_with_loc pp_field_definition ppf + Cobol_ptree.Types.pp_with_loc pp_field_definition ppf (* and pp_field_definitions: field_definitions Pretty.printer = fun ppf defs -> *) (* NEL.pp ~fopen:"" ~fsep:"" ~fclose:"" pp_field_definition' ppf defs *) @@ -208,7 +208,7 @@ and pp_table_definition: table_definition Pretty.printer = fun ppf x -> ] ppf x and pp_table_definition': table_definition with_loc Pretty.printer = fun ppf -> - Cobol_ptree.pp_with_loc pp_table_definition ppf + Cobol_ptree.Types.pp_with_loc pp_table_definition ppf (* condition-names *) @@ -216,12 +216,12 @@ and pp_table_definition': table_definition with_loc Pretty.printer = fun ppf -> and pp_condition_name: condition_name Pretty.printer = Pretty.record_with_conditional_fields [ T (Fmt.field "qualname" (fun r -> r.condition_name_qualname) - Cobol_ptree.pp_qualname'); + Cobol_ptree.Types.pp_qualname'); T (Fmt.field "values" (fun _ -> "...") Fmt.string); ] and pp_condition_name': condition_name with_loc Pretty.printer = fun ppf -> - Cobol_ptree.pp_with_loc pp_condition_name ppf + Cobol_ptree.Types.pp_with_loc pp_condition_name ppf and pp_condition_names: condition_names Pretty.printer = fun ppf -> Fmt.(list ~sep:nop) pp_condition_name' ppf @@ -240,17 +240,17 @@ let pp_renamed_item_layout: renamed_item_layout Pretty.printer = fun ppf -> func let pp_record_renaming: record_renaming Pretty.printer = Pretty.record_with_conditional_fields [ - T (Fmt.field "qualname" (fun r -> r.renaming_name) Cobol_ptree.pp_qualname'); - T (Fmt.field "from" (fun r -> r.renaming_from) Cobol_ptree.pp_qualname'); + T (Fmt.field "qualname" (fun r -> r.renaming_name) Cobol_ptree.Types.pp_qualname'); + T (Fmt.field "from" (fun r -> r.renaming_from) Cobol_ptree.Types.pp_qualname'); C ((fun r -> r.renaming_thru <> None), Fmt.field "thru" (fun r -> r.renaming_thru) pp_qualname'_opt); - T (Fmt.field "offset" (fun r -> r.renaming_offset) Data_memory.pp_offset); - T (Fmt.field "size" (fun r -> r.renaming_size) Data_memory.pp_size); + T (Fmt.field "offset" (fun r -> r.renaming_offset) Memory.pp_offset); + T (Fmt.field "size" (fun r -> r.renaming_size) Memory.pp_size); T (Pretty.vfield "layout" (fun r -> r.renaming_layout) pp_renamed_item_layout); ] let pp_record_renaming': record_renaming with_loc Pretty.printer = fun ppf -> - Cobol_ptree.pp_with_loc pp_record_renaming ppf + Cobol_ptree.Types.pp_with_loc pp_record_renaming ppf let pp_record_renamings: record_renamings Pretty.printer = fun ppf -> Fmt.(list ~sep:nop) pp_record_renaming' ppf diff --git a/src/lsp/cobol_data/types.ml b/src/lsp/cobol_data/types.ml index 1ba8d6cc6..8d6e04587 100644 --- a/src/lsp/cobol_data/types.ml +++ b/src/lsp/cobol_data/types.ml @@ -11,94 +11,206 @@ (* *) (**************************************************************************) -(* open Cobol_common.Srcloc.TYPES *) -(* open Cobol_common.Srcloc.INFIX *) -(* open Cobol_ast *) - -(* TODO: those properties should be re-introduced later when relevant; they are - commented for now as they do not appear necessary to the classicfication of - data items. *) - -(* type bit_length = *) -(* | L16 *) -(* | L32 *) -(* | L62 [@@deriving show] *) - -(* type pointer_length = *) -(* | L4 *) -(* | L8 [@@deriving show] *) - -(* type numeric_format = { *) -(* signed: bool; *) -(* integer_length: int; *) -(* decimal_length: int; *) -(* } [@@deriving show] *) - -(* type numeric_encoding = *) -(* | Ascii *) -(* | Bcd *) -(* | Int of bit_length *) -(* | Float of bit_length [@@deriving show] *) - -(* (\* NOTE: The numeric does not support yet the floating point format of the 2014 standard *\) *) -(* type numeric = *) -(* (numeric_format * numeric_encoding) [@@deriving show] *) - -(* type alphanumeric_category = *) -(* | Alphanumeric of int *) -(* | AlphanumericEdited of int [@@deriving show] *) - -(* type national_category = (\* UTF-16 *\) *) -(* | National of int *) -(* | NationalEdited of int [@@deriving show] *) - -type elementary_data_class = - | Alphabetic - | Alphanumeric - | Boolean +(** Representation of COBOL data items *) + +(* Note: location of qualnames often correspond to the *unqualified* name, with + implicit qualification based on item groups. *) + +open Cobol_common.Srcloc.TYPES + +module NEL = Cobol_common.Basics.NEL +type 'a nel = 'a NEL.t + +type picture_config = Picture.TYPES.config +type picture = Picture.t + +type usage = + | Binary of (* [`numeric] *) picture + | Binary_C_long of signedness (* GnuCOBOL *) + | Binary_char of signedness (* +COB2002 *) + | Binary_double of signedness (* +COB2002 *) + | Binary_long of signedness (* +COB2002 *) + | Binary_short of signedness (* +COB2002 *) + | Bit of (* [`boolean] *) picture + | Display of (* [any] *) picture + | Float_binary of { width: [`W32|`W64|`W128]; (* +COB2002 *) + endian: Cobol_ptree.Types.endianness_mode } + | Float_decimal of { width: [`W16 | `W34]; (* +COB2002 *) + endian: Cobol_ptree.Types.endianness_mode; + encoding: Cobol_ptree.Types.encoding_mode } + | Float_extended (* +COB2002 *) + | Float_long (* +COB2002 *) + | Float_short (* +COB2002 *) + | Function_pointer of Cobol_ptree.Types.name with_loc (* tmp *) | Index - | National - | Numeric - | Object - | Pointer -[@@deriving show] - -type data_type = - | Elementary of elementary_data_class leveled pictured - | Table of table_type leveled - | Group of data_type Cobol_ptree.with_loc list leveled -[@@deriving show] - -and 'a leveled = { (* TODO: no need to keep levels *) - typ: 'a; - level: int; -} [@@deriving show] - -and 'a pictured = 'a * Data_picture.t option [@@deriving show] - -and table_type = { (* TODO: inline in `Table/OCcurs` *) - elements_type: data_type Cobol_ptree.with_loc; - length: table_length; -} - -and table_length = - | Fixed of Cobol_ptree.integer - | OccursDepending of (* TODO: get rid of that (duplicate of AST nodes) *) - { (* TODO: resolve depending before building the final type repr. *) - min_size: Cobol_ptree.integer; - max_size: Cobol_ptree.integer; - depending: Cobol_ptree.qualname Cobol_ptree.with_loc; - } [@@deriving show] - -(* let loc_of = function *) -(* | Elementary typ_loc -> ~@typ_loc *) -(* | Group fields_loc -> ~@fields_loc *) -(* | Table elements_loc -> ~@elements_loc *) - -(* let level_of = function *) -(* | Elementary { payload = {level; _}, _; _ } *) -(* | Group { payload = {level; _}; _ } *) -(* | Table { payload = {level; _}; _ } -> level *) - -(* let pp_cob_data_type_loc fmt data_type = *) -(* pp_cob_data_type fmt data_type *) + | National of (* [any] *) picture + | Object_reference of Cobol_ptree.Types.object_reference_kind option (* tmp *) + | Packed_decimal of (* [`numeric] *) picture + | Pointer of Cobol_ptree.Types.name with_loc option (* tmp *) + | Program_pointer of Cobol_ptree.Types.name with_loc option (* tmp *) +and signedness = { signed: bool } + +type data_storage = + | File + | Local_storage + | Working_storage + | Linkage (* file? *) + +let pp_data_storage ppf s = + Fmt.string ppf @@ match s with + | File -> "FILE" + | Local_storage -> "LOCAL-STORAGE" + | Working_storage -> "WORKING-STORAGE" + | Linkage -> "LINKAGE" + +type length = + | Fixed_length + | Variable_length + (* Note: OCCURS DYNAMIC is considered fixed-length in ISO/IEC *) + +type record = + { + record_name: string; + record_storage: data_storage; + record_item: item_definition with_loc; + record_renamings: record_renamings; + } +and item_definitions = item_definition with_loc nel +and item_redefinitions = item_definition with_loc list + +and item_definition = + | Field of field_definition + | Table of table_definition + +and field_definition = + { + field_qualname: Cobol_ptree.Types.qualname with_loc option; + field_redefines: Cobol_ptree.Types.qualname with_loc option; (* redef only *) + field_leading_ranges: table_range list; + field_offset: Memory.offset; (** offset w.r.t record address *) + field_size: Memory.size; + field_layout: field_layout; + field_length: length; + field_conditions: condition_names; + field_redefinitions: item_redefinitions; + } + +and field_layout = + | Elementary_field of + { + usage: usage; + init_value: Cobol_ptree.Types.literal with_loc option; + } + | Struct_field of + { + subfields: item_definitions; + } + +and table_definition = + { + table_field: field_definition with_loc; + table_offset: Memory.offset; + table_size: Memory.size; + table_range: table_range; + table_init_values: Cobol_ptree.Types.literal with_loc list; (* list for now *) + table_redefines: Cobol_ptree.Types.qualname with_loc option; (* redef only *) + table_redefinitions: item_redefinitions; + } +and table_range = + { + range_span: span; + range_indexes: Cobol_ptree.Types.qualname with_loc list; + } +and span = + | Fixed_span of fixed_span (* OCCURS _ TIMES *) + | Depending_span of depending_span (* OCCURS _ TO _ TIMES DEPENDING ON _ *) + | Dynamic_span of dynamic_span (* OCCURS DYNAMIC CAPACITY _ FROM _ TO _ *) + +and fixed_span = + { + occurs_times: int with_loc; (* int for now *) + } +and depending_span = + { + occurs_depending_min: int with_loc; (* int for now *) + occurs_depending_max: int with_loc; (* ditto *) + occurs_depending: Cobol_ptree.Types.qualname with_loc; + } +and dynamic_span = + { + occurs_dynamic_capacity: Cobol_ptree.Types.qualname with_loc option; + occurs_dynamic_capacity_min: int with_loc option; + occurs_dynamic_capacity_max: int with_loc option; + occurs_dynamic_initialized: bool with_loc; + } + +and condition_names = condition_name with_loc list +and condition_name = + { + condition_name_qualname: Cobol_ptree.Types.qualname with_loc; + condition_name_item: Cobol_ptree.Types.condition_name_item; (* for now *) + } + +(** Note: RENAMES could be represented by simply adding an (optional, + non-constant) offset to redefinitions (and use group layouts with FILLERs + throughout to forbid using the new name as a qualifier). + + Such a representation would be much more general than what typical COBOL + data definitions allow; in particular, one could have "shifted" redefintions + of any non-01 group item. + + However, we keep the distinction between RENAMES and REDEFINES to better + match said typical COBOL, and possibly allow more detailed error + reporting. *) +and record_renamings = record_renaming with_loc list +and record_renaming = + { + renaming_name: Cobol_ptree.Types.qualname with_loc; + renaming_layout: renamed_item_layout; + renaming_offset: Memory.offset; + renaming_size: Memory.size; + renaming_from: Cobol_ptree.Types.qualname with_loc; + renaming_thru: Cobol_ptree.Types.qualname with_loc option; + } +and renamed_item_layout = + | Renamed_elementary of + { + usage: usage; + } + | Renamed_struct of + { + subfields: item_definitions; (* CHECKME: items rather than fields? *) + } + +(* type data_const_record = *) +(* { *) +(* const_name: Cobol_ptree.Types.name with_loc; *) +(* const_descr: Cobol_ptree.Types.constant_item_descr; *) +(* const_layout: const_layout; *) +(* } *) + +type data_definition = + | Data_field of + { + record: record; + def: field_definition with_loc; + } + | Data_renaming of (* not sure *) + { + record: record; + def: record_renaming with_loc; + } + | Data_condition of + { + record: record; + field: field_definition with_loc; + def: condition_name with_loc; + } + | Table_index of + { + record: record; (* record where [table] is defined *) + table: table_definition with_loc; (* table whose index it is *) + qualname: Cobol_ptree.Types.qualname with_loc; (* fully qualified name *) + } + +(* screen: "_ OCCURS n TIMES" only. Max 2 dimensions. *) diff --git a/src/lsp/cobol_data/data_visitor.ml b/src/lsp/cobol_data/visitor.ml similarity index 98% rename from src/lsp/cobol_data/data_visitor.ml rename to src/lsp/cobol_data/visitor.ml index 27454394e..7ad0267ff 100644 --- a/src/lsp/cobol_data/data_visitor.ml +++ b/src/lsp/cobol_data/visitor.ml @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open Data_types +open Types open Cobol_common.Visitor open Cobol_common.Visitor.INFIX (* for `>>` (== `|>`) *) @@ -50,8 +50,8 @@ class ['a] folder = object method fold_record_renamings: (record_renamings, 'a) fold = default method fold_record_renaming': (record_renaming with_loc, 'a) fold = default method fold_record_renaming: (record_renaming, 'a) fold = default - method fold_memory_offset: (Data_memory.offset, 'a) fold = default - method fold_memory_size: (Data_memory.size, 'a) fold = default + method fold_memory_offset: (Memory.offset, 'a) fold = default + method fold_memory_size: (Memory.size, 'a) fold = default end (* --- *) diff --git a/src/lsp/cobol_data/compilation_unit.ml b/src/lsp/cobol_data_old/compilation_unit.ml similarity index 100% rename from src/lsp/cobol_data/compilation_unit.ml rename to src/lsp/cobol_data_old/compilation_unit.ml diff --git a/src/lsp/cobol_data_old/dune b/src/lsp/cobol_data_old/dune new file mode 100644 index 000000000..9b9d047ba --- /dev/null +++ b/src/lsp/cobol_data_old/dune @@ -0,0 +1,26 @@ +; generated by drom from package skeleton 'library' + +(library + (name cobol_data_old) + (public_name cobol_data_old) + (wrapped true) + ; use field 'dune-libraries' to add libraries without opam deps + (libraries cobol_ptree 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 ppx_deriving.ord)) + + ) + + +(rule + (targets version.ml) + (deps (:script version.mlt) package.toml) + (action (with-stdout-to %{targets} (run %{ocaml} unix.cma %{script})))) + +(documentation + (package cobol_data_old)) + +; use field 'dune-trailer' to add more stuff here + diff --git a/src/lsp/cobol_data/env.ml b/src/lsp/cobol_data_old/env.ml similarity index 87% rename from src/lsp/cobol_data/env.ml rename to src/lsp/cobol_data_old/env.ml index 37c464592..7a525a1b8 100644 --- a/src/lsp/cobol_data/env.ml +++ b/src/lsp/cobol_data_old/env.ml @@ -35,26 +35,26 @@ open Types * entry arguments *) module Names = Set.Make (struct - type t = Cobol_ptree.name + type t = Cobol_ptree.Types.name let compare = String.compare end) module DATA_ITEM = struct type condition = { - target: Cobol_ptree.qualname; - values: Cobol_ptree.condition_name_value list; + target: Cobol_ptree.Types.qualname; + values: Cobol_ptree.Types.condition_name_value list; } [@@deriving show] type t = - { name: Cobol_ptree.name; + { name: Cobol_ptree.Types.name; typ: data_type option; size: int; global: bool; - value: Cobol_ptree.data_value_clause option; - renames: Cobol_ptree.qualname list; + value: Cobol_ptree.Types.data_value_clause option; + renames: Cobol_ptree.Types.qualname list; condition: condition option; - redefines: Cobol_ptree.qualname option; - constant: Cobol_ptree.constant_value option; } + redefines: Cobol_ptree.Types.qualname option; + constant: Cobol_ptree.Types.constant_value option; } [@@deriving show] let make name = @@ -71,7 +71,7 @@ end module PROG_ENV = struct type t = - { name: Cobol_ptree.name; + { name: Cobol_ptree.Types.name; parent_prog: t option; data_items: DATA_ITEM.t Qualmap.t; currency_signs: Cobol_common.Basics.CharSet.t; diff --git a/src/lsp/cobol_data/group.ml b/src/lsp/cobol_data_old/group.ml similarity index 98% rename from src/lsp/cobol_data/group.ml rename to src/lsp/cobol_data_old/group.ml index cdd351bba..7e11e3a06 100644 --- a/src/lsp/cobol_data/group.ml +++ b/src/lsp/cobol_data_old/group.ml @@ -14,7 +14,7 @@ (* NB: needs quite a bit of rework and cleanup; validation should also be moved to `Cobol_typeck`. *) -open Cobol_ptree +open Cobol_ptree.Types open Cobol_common.Srcloc.TYPES open Cobol_common.Srcloc.INFIX (* open Pictured_ast.Data_sections *) @@ -303,8 +303,8 @@ let group_range (module Diags: Cobol_common.Diagnostics.STATEFUL) first last gro (note that the major qualifier is first and the minor is last). *) let list_of_qualname qualname = let rec aux acc = function - | Cobol_ptree.Qual(n, qn) -> aux (n::acc) qn - | Cobol_ptree.Name n -> n::acc + | Cobol_ptree.Types.Qual(n, qn) -> aux (n::acc) qn + | Cobol_ptree.Types.Name n -> n::acc in aux [] qualname @@ -390,7 +390,7 @@ let of_working_item_descrs (wss: working_item_descr with_loc list) = in let res = Result.bind groups (fun groups -> - Cobol_common.join_all @@ + Cobol_common.Errors.join_all @@ List.map (fun (group, rename) -> let group = make_data_group (module Diags) group in Result.bind group (fun group -> @@ -398,7 +398,7 @@ let of_working_item_descrs (wss: working_item_descr with_loc list) = ~none:[] ~some:(fun renames -> make_renames (module Diags) group renames) rename - |> Cobol_common.join_all + |> Cobol_common.Errors.join_all |> Result.map (fun renames -> List.map (function | { payload = Group {name; elements; data_item}; loc } -> diff --git a/src/lsp/cobol_data/group.mli b/src/lsp/cobol_data_old/group.mli similarity index 96% rename from src/lsp/cobol_data/group.mli rename to src/lsp/cobol_data_old/group.mli index a5d2e8893..88dff820a 100644 --- a/src/lsp/cobol_data/group.mli +++ b/src/lsp/cobol_data_old/group.mli @@ -12,7 +12,7 @@ (**************************************************************************) (** This module implements a hierarchical version of cobol data items.*) -open Cobol_ptree +open Cobol_ptree.Types (* open Pictured_ast.Data_sections *) open Cobol_common.Srcloc.TYPES @@ -35,5 +35,5 @@ val pp_data_group_list: Format.formatter -> t list -> unit (** Convert a list of located {!t working_item_descr_entry} to a list of {!t t}*) val of_working_item_descrs - : Cobol_ptree.working_item_descr with_loc list + : Cobol_ptree.Types.working_item_descr with_loc list -> t list Cobol_common.Diagnostics.with_diags diff --git a/src/lsp/cobol_data/mangling.ml b/src/lsp/cobol_data_old/mangling.ml similarity index 98% rename from src/lsp/cobol_data/mangling.ml rename to src/lsp/cobol_data_old/mangling.ml index 33323c151..0c0328bba 100644 --- a/src/lsp/cobol_data/mangling.ml +++ b/src/lsp/cobol_data_old/mangling.ml @@ -12,7 +12,7 @@ (**************************************************************************) open Cobol_common.Srcloc.INFIX -open Cobol_ptree +open Cobol_ptree.Types (* TODO: Don't require naming of fillers to avoid this kind of exceptions. *) exception Not_mangled diff --git a/src/lsp/cobol_data/mangling.mli b/src/lsp/cobol_data_old/mangling.mli similarity index 98% rename from src/lsp/cobol_data/mangling.mli rename to src/lsp/cobol_data_old/mangling.mli index ba3b7e373..2b439b491 100644 --- a/src/lsp/cobol_data/mangling.mli +++ b/src/lsp/cobol_data_old/mangling.mli @@ -14,7 +14,7 @@ (** This module aims to implement mangling functions for the COBOL AST.*) -open Cobol_ptree +open Cobol_ptree.Types (** This exception is raised when a not mangled name is given in a context where it is expected for the name to be mangled *) diff --git a/src/lsp/cobol_data_old/package.toml b/src/lsp/cobol_data_old/package.toml new file mode 100644 index 000000000..5b6dfe4ea --- /dev/null +++ b/src/lsp/cobol_data_old/package.toml @@ -0,0 +1,77 @@ + +# name of package +name = "cobol_data_old" +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 ppx_deriving.ord" + +# 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_ptree = "version" +cobol_data = "version" + +# package tools dependencies +[tools] +ppx_deriving = ">=5.2.1" + +# 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_ptree/cobol_ptree.ml b/src/lsp/cobol_data_old/picture.ml similarity index 81% rename from src/lsp/cobol_ptree/cobol_ptree.ml rename to src/lsp/cobol_data_old/picture.ml index 4793159e4..f3dd52d3e 100644 --- a/src/lsp/cobol_ptree/cobol_ptree.ml +++ b/src/lsp/cobol_data_old/picture.ml @@ -11,12 +11,4 @@ (* *) (**************************************************************************) -include PTree_types - -module Visitor = Visitor -module Terms_visitor = Terms_visitor -module Proc_division_visitor = Proc_division_visitor - -module Terms_helpers = Terms_helpers - -module Dummies = PTree_dummies +include Cobol_data.Picture diff --git a/src/lsp/cobol_data/qualmap.ml b/src/lsp/cobol_data_old/qualmap.ml similarity index 99% rename from src/lsp/cobol_data/qualmap.ml rename to src/lsp/cobol_data_old/qualmap.ml index 5828622aa..452e18c08 100644 --- a/src/lsp/cobol_data/qualmap.ml +++ b/src/lsp/cobol_data_old/qualmap.ml @@ -11,13 +11,13 @@ (* *) (**************************************************************************) -open Cobol_ptree +open Cobol_ptree.Types open Cobol_common.Srcloc.INFIX module QUAL_NAME = struct type t = qualname [@@deriving show] - let compare = Cobol_ptree.compare_qualname + let compare = Cobol_ptree.Types.compare_qualname end diff --git a/src/lsp/cobol_data/qualmap.mli b/src/lsp/cobol_data_old/qualmap.mli similarity index 99% rename from src/lsp/cobol_data/qualmap.mli rename to src/lsp/cobol_data_old/qualmap.mli index 55fac073d..ab6e92531 100644 --- a/src/lsp/cobol_data/qualmap.mli +++ b/src/lsp/cobol_data_old/qualmap.mli @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open Cobol_ptree +open Cobol_ptree.Types type 'a t [@@deriving show] diff --git a/src/lsp/cobol_data_old/types.ml b/src/lsp/cobol_data_old/types.ml new file mode 100644 index 000000000..cfa6b4bdc --- /dev/null +++ b/src/lsp/cobol_data_old/types.ml @@ -0,0 +1,104 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* open Cobol_common.Srcloc.TYPES *) +(* open Cobol_common.Srcloc.INFIX *) +(* open Cobol_ast *) + +(* TODO: those properties should be re-introduced later when relevant; they are + commented for now as they do not appear necessary to the classicfication of + data items. *) + +(* type bit_length = *) +(* | L16 *) +(* | L32 *) +(* | L62 [@@deriving show] *) + +(* type pointer_length = *) +(* | L4 *) +(* | L8 [@@deriving show] *) + +(* type numeric_format = { *) +(* signed: bool; *) +(* integer_length: int; *) +(* decimal_length: int; *) +(* } [@@deriving show] *) + +(* type numeric_encoding = *) +(* | Ascii *) +(* | Bcd *) +(* | Int of bit_length *) +(* | Float of bit_length [@@deriving show] *) + +(* (\* NOTE: The numeric does not support yet the floating point format of the 2014 standard *\) *) +(* type numeric = *) +(* (numeric_format * numeric_encoding) [@@deriving show] *) + +(* type alphanumeric_category = *) +(* | Alphanumeric of int *) +(* | AlphanumericEdited of int [@@deriving show] *) + +(* type national_category = (\* UTF-16 *\) *) +(* | National of int *) +(* | NationalEdited of int [@@deriving show] *) + +type elementary_data_class = + | Alphabetic + | Alphanumeric + | Boolean + | Index + | National + | Numeric + | Object + | Pointer +[@@deriving show] + +type data_type = + | Elementary of elementary_data_class leveled pictured + | Table of table_type leveled + | Group of data_type Cobol_ptree.Types.with_loc list leveled +[@@deriving show] + +and 'a leveled = { (* TODO: no need to keep levels *) + typ: 'a; + level: int; +} [@@deriving show] + +and 'a pictured = 'a * Cobol_data.Picture.t option [@@deriving show] + +and table_type = { (* TODO: inline in `Table/OCcurs` *) + elements_type: data_type Cobol_ptree.Types.with_loc; + length: table_length; +} + +and table_length = + | Fixed of Cobol_ptree.Types.integer + | OccursDepending of (* TODO: get rid of that (duplicate of AST nodes) *) + { (* TODO: resolve depending before building the final type repr. *) + min_size: Cobol_ptree.Types.integer; + max_size: Cobol_ptree.Types.integer; + depending: Cobol_ptree.Types.qualname Cobol_ptree.Types.with_loc; + } [@@deriving show] + +(* let loc_of = function *) +(* | Elementary typ_loc -> ~@typ_loc *) +(* | Group fields_loc -> ~@fields_loc *) +(* | Table elements_loc -> ~@elements_loc *) + +(* let level_of = function *) +(* | Elementary { payload = {level; _}, _; _ } *) +(* | Group { payload = {level; _}; _ } *) +(* | Table { payload = {level; _}; _ } -> level *) + +(* let pp_cob_data_type_loc fmt data_type = *) +(* pp_cob_data_type fmt data_type *) diff --git a/src/lsp/cobol_data_old/version.mlt b/src/lsp/cobol_data_old/version.mlt new file mode 100644 index 000000000..1bcf00592 --- /dev/null +++ b/src/lsp/cobol_data_old/version.mlt @@ -0,0 +1,30 @@ +#!/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 commit_hash = query "git show -s --pretty=format:%H" +let commit_date = query "git show -s --pretty=format:%ci" +let version = "0.1.0" + +let string_option = function + | None -> "None" + | Some s -> Printf.sprintf "Some %S" s + +let () = + Format.printf "@["; + Format.printf "let version = %S@," version; + Format.printf + "let commit_hash = %s@," (string_option commit_hash); + Format.printf + "let commit_date = %s@," (string_option commit_date); + Format.printf "@]@."; + () diff --git a/src/lsp/cobol_indent/cobol_indent.ml b/src/lsp/cobol_indent/cobol_indent.ml deleted file mode 100644 index ac10c228b..000000000 --- a/src/lsp/cobol_indent/cobol_indent.ml +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 Type = Indent_type - -(*return the result of indentation. use user-defined indent_config*) -let indent_range = Indenter.indent_range - -let indent_range_str - ~dialect ~source_format ~indent_config ~range ~filename ~contents -= - indent_range - ~dialect ~source_format ~indent_config ~range ~filename ~contents - |> Indent_util.apply contents - -let config l = Indent_config.(merge default (of_list l)) diff --git a/src/lsp/cobol_indent/indent_check.ml b/src/lsp/cobol_indent/indent_check.ml index dfb2e6369..fde7dc73d 100644 --- a/src/lsp/cobol_indent/indent_check.ml +++ b/src/lsp/cobol_indent/indent_check.ml @@ -15,7 +15,7 @@ open EzCompat open Cobol_common.Srcloc -open Indent_type +open Types open Indent_keywords open Indent_util diff --git a/src/lsp/cobol_indent/indent_check.mli b/src/lsp/cobol_indent/indent_check.mli index e5f3b9508..5040f6d2c 100644 --- a/src/lsp/cobol_indent/indent_check.mli +++ b/src/lsp/cobol_indent/indent_check.mli @@ -13,5 +13,5 @@ val check_indentation :Cobol_preproc.Text.t - -> Indent_type.indent_state - -> Indent_type.indent_state + -> Types.indent_state + -> Types.indent_state diff --git a/src/lsp/cobol_indent/indent_config.ml b/src/lsp/cobol_indent/indent_config.ml index 6dee117ab..3124f5f63 100644 --- a/src/lsp/cobol_indent/indent_config.ml +++ b/src/lsp/cobol_indent/indent_config.ml @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open Indent_type +open Types open Indent_keywords type t = indent_config diff --git a/src/lsp/cobol_indent/indent_config.mli b/src/lsp/cobol_indent/indent_config.mli index cbb20b7e3..02890c775 100644 --- a/src/lsp/cobol_indent/indent_config.mli +++ b/src/lsp/cobol_indent/indent_config.mli @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -type t = Indent_type.indent_config +type t = Types.indent_config val default : t @@ -20,4 +20,4 @@ val merge : t -> t -> t val of_list : (string * int) list -> t -val offset_of_keyword: t -> Indent_type.context_kind -> int +val offset_of_keyword: t -> Types.context_kind -> int diff --git a/src/lsp/cobol_indent/indent_keywords.ml b/src/lsp/cobol_indent/indent_keywords.ml index b8ff03ea7..f078a0a9e 100644 --- a/src/lsp/cobol_indent/indent_keywords.ml +++ b/src/lsp/cobol_indent/indent_keywords.ml @@ -18,7 +18,7 @@ TODO: use the aforementioned associations instead of redefining them below. *) -open Indent_type +open Types (*data division *) let data_context_of_str : string -> data_context = function diff --git a/src/lsp/cobol_indent/indent_keywords.mli b/src/lsp/cobol_indent/indent_keywords.mli index 17bdfb8fd..54c0d17c5 100644 --- a/src/lsp/cobol_indent/indent_keywords.mli +++ b/src/lsp/cobol_indent/indent_keywords.mli @@ -11,17 +11,17 @@ (* *) (**************************************************************************) -val string_of_keyword: Indent_type.context_kind -> string +val string_of_keyword: Types.context_kind -> string -val data_context_of_str: string -> Indent_type.data_context +val data_context_of_str: string -> Types.data_context -val proc_context_of_str: string -> Indent_type.proc_context +val proc_context_of_str: string -> Types.proc_context (* To check whether the string is a keyword of statement *) val is_statement: string -> bool (* To check whether the keyword is implicitly terminable *) -val is_not_imp_terminable: Indent_type.context_kind -> bool +val is_not_imp_terminable: Types.context_kind -> bool (* To check whether the keyword is a keyword of phrase *) -val is_phrase: Indent_type.context_kind -> bool +val is_phrase: Types.context_kind -> bool diff --git a/src/lsp/cobol_indent/indenter.ml b/src/lsp/cobol_indent/indent_main.ml similarity index 85% rename from src/lsp/cobol_indent/indenter.ml rename to src/lsp/cobol_indent/indent_main.ml index 8ff9ac072..507bab36b 100644 --- a/src/lsp/cobol_indent/indenter.ml +++ b/src/lsp/cobol_indent/indent_main.ml @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open Indent_type +open Types (*indent a range of file, with the default indent_config*) let indent_range ~dialect ~source_format ~indent_config ~range ~filename ~contents = @@ -23,7 +23,7 @@ let indent_range ~dialect ~source_format ~indent_config ~range ~filename ~conten Cobol_preproc.Src_format.from_config SFFixed in let state = - Cobol_preproc.fold_source_lines ~dialect ~source_format + Cobol_preproc.Main.fold_source_lines ~dialect ~source_format ~on_initial_source_format:(fun src_format st -> { st with src_format }) ~on_compiler_directive:(fun _ { payload = cd; _} st -> match cd with @@ -42,3 +42,12 @@ let indent_range ~dialect ~source_format ~indent_config ~range ~filename ~conten in (* NB: note here we ignore diagnostics *) state.result.acc + +let indent_range_str + ~dialect ~source_format ~indent_config ~range ~filename ~contents += + indent_range + ~dialect ~source_format ~indent_config ~range ~filename ~contents + |> Indent_util.apply contents + +let config l = Indent_config.(merge default (of_list l)) diff --git a/src/lsp/cobol_indent/indenter.mli b/src/lsp/cobol_indent/indent_main.mli similarity index 70% rename from src/lsp/cobol_indent/indenter.mli rename to src/lsp/cobol_indent/indent_main.mli index 99d0751ec..29068b070 100644 --- a/src/lsp/cobol_indent/indenter.mli +++ b/src/lsp/cobol_indent/indent_main.mli @@ -13,10 +13,20 @@ (*indent a range of file, with the user-defined or default indent_config*) val indent_range - : dialect: Cobol_config.dialect - -> source_format:Cobol_config.source_format_spec + : dialect: Cobol_config.Types.dialect + -> source_format:Cobol_config.Types.source_format_spec -> indent_config:Indent_config.t option - -> range:Indent_type.range option + -> range:Types.range option -> filename:string -> contents:string - -> Indent_type.indent_record list + -> Types.indent_record list + + +val indent_range_str : + dialect:Cobol_config.Types.dialect -> + source_format:Cobol_config.Types.source_format_spec -> + indent_config:Types.indent_config option -> + range:Types.range option -> + filename:string -> contents:string -> string + +val config : (string * int) list -> Types.indent_config diff --git a/src/lsp/cobol_indent/indent_util.ml b/src/lsp/cobol_indent/indent_util.ml index a458b4cf7..44620be05 100644 --- a/src/lsp/cobol_indent/indent_util.ml +++ b/src/lsp/cobol_indent/indent_util.ml @@ -13,7 +13,7 @@ open Cobol_common.Srcloc -open Indent_type +open Types open Indent_keywords let check_pos diff --git a/src/lsp/cobol_indent/indent_util.mli b/src/lsp/cobol_indent/indent_util.mli index bc5552092..27f780a18 100644 --- a/src/lsp/cobol_indent/indent_util.mli +++ b/src/lsp/cobol_indent/indent_util.mli @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open Indent_type +open Types val check_pos: Cobol_preproc.Src_format.any -> diff --git a/src/lsp/cobol_indent/indent_type.ml b/src/lsp/cobol_indent/types.ml similarity index 100% rename from src/lsp/cobol_indent/indent_type.ml rename to src/lsp/cobol_indent/types.ml diff --git a/src/lsp/cobol_lsp/alltypes.ml b/src/lsp/cobol_lsp/alltypes.ml new file mode 100644 index 000000000..119389ed3 --- /dev/null +++ b/src/lsp/cobol_lsp/alltypes.ml @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +include Lsp_imports +include Diagnostics.TYPES +include Lookup.TYPES +include Document.TYPES +include Project.TYPES +include Project_cache.TYPES +include Server.TYPES diff --git a/src/lsp/cobol_lsp/cobol_lsp.ml b/src/lsp/cobol_lsp/cobol_lsp.ml deleted file mode 100644 index d94955588..000000000 --- a/src/lsp/cobol_lsp/cobol_lsp.ml +++ /dev/null @@ -1,42 +0,0 @@ -(**************************************************************************) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -include Lsp_server_loop - -(* --- *) - -(** {1 Modules and functions exported for testing purposes} - - Signatures of modules below may change unexpectedly. *) - -module INTERNAL = struct - module Types = struct - include Lsp_imports - include Lsp_diagnostics.TYPES - include Lsp_lookup.TYPES - include Lsp_document.TYPES - include Lsp_project.TYPES - include Lsp_project_cache.TYPES - include Lsp_server.TYPES - end - module Diagnostics = Lsp_diagnostics - module Lookup = Lsp_lookup - module Project = Lsp_project - module Project_cache = Lsp_project_cache - module Document = Lsp_document - module Server = Lsp_server - module Loop = Lsp_server_loop - module Request = Lsp_request.INTERNAL - module Utils = Lsp_utils - module Debug = Lsp_debug -end diff --git a/src/lsp/cobol_lsp/lsp_diagnostics.ml b/src/lsp/cobol_lsp/diagnostics.ml similarity index 96% rename from src/lsp/cobol_lsp/lsp_diagnostics.ml rename to src/lsp/cobol_lsp/diagnostics.ml index 0908a54af..32a2db246 100644 --- a/src/lsp/cobol_lsp/lsp_diagnostics.ml +++ b/src/lsp/cobol_lsp/diagnostics.ml @@ -44,9 +44,9 @@ let translate_one ~rootdir ~uri (diag: DIAG.t) = let uri, range = match Option.map project_srcloc (DIAG.location diag) with | Some (Lexing.{ pos_fname = f; _ }, _ as lexloc) -> - pseudo_normalized_uri ~rootdir f, Lsp_position.range_of_lexloc lexloc + pseudo_normalized_uri ~rootdir f, Position.range_of_lexloc lexloc | None -> - uri, Lsp_position.pointwise_range_at_start + uri, Position.pointwise_range_at_start in let diag = Lsp.Types.Diagnostic.create () diff --git a/src/lsp/cobol_lsp/lsp_diagnostics.mli b/src/lsp/cobol_lsp/diagnostics.mli similarity index 100% rename from src/lsp/cobol_lsp/lsp_diagnostics.mli rename to src/lsp/cobol_lsp/diagnostics.mli diff --git a/src/lsp/cobol_lsp/lsp_document.ml b/src/lsp/cobol_lsp/document.ml similarity index 91% rename from src/lsp/cobol_lsp/lsp_document.ml rename to src/lsp/cobol_lsp/document.ml index 760ddde48..3f91a5dc1 100644 --- a/src/lsp/cobol_lsp/lsp_document.ml +++ b/src/lsp/cobol_lsp/document.ml @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open Lsp_project.TYPES +open Project.TYPES open Ez_file.V1 module DIAGS = Cobol_common.Diagnostics @@ -20,7 +20,7 @@ module TYPES = struct type document = { - project: Lsp_project.t; + project: Project.t; textdoc: Lsp.Text_document.t; copybook: bool; artifacts: Cobol_parser.Outputs.artifacts; @@ -32,9 +32,9 @@ module TYPES = struct } and checked_doc = Cobol_typeck.Outputs.t and rewinder = - (Cobol_ptree.compilation_group option, + (Cobol_ptree.Types.compilation_group option, Cobol_common.Behaviors.eidetic) Cobol_parser.Outputs.output - Cobol_parser.rewinder + Cobol_parser.Main.rewinder (** Raised by {!val:Document.checked}. *) exception Unparseable of Lsp.Types.DocumentUri.t @@ -66,16 +66,16 @@ type t = document let uri { textdoc; _ } = Lsp.Text_document.documentUri textdoc let rewindable_parse ({ project; textdoc; _ } as doc) = - Cobol_parser.rewindable_parse_with_artifacts + Cobol_parser.Main.rewindable_parse_with_artifacts ~options:Cobol_parser.Options.{ default with recovery = EnableRecovery { silence_benign_recoveries = true }; config = project.config.cobol_config; } @@ - Cobol_preproc.preprocessor + Cobol_preproc.Main.preprocessor ~options:Cobol_preproc.Options.{ default with - libpath = Lsp_project.libpath_for ~uri:(uri doc) project; + libpath = Project.libpath_for ~uri:(uri doc) project; config = project.config.cobol_config; source_format = project.config.source_format } @@ @@ -92,10 +92,10 @@ let check doc ptree = let DIAGS.{ result = artifacts, rewinder, checked; diags} = DIAGS.more_result ~f:begin fun (ptree, rewinder) -> let config = doc.project.config.cobol_config in - Cobol_typeck.compilation_group ~config ptree |> - Cobol_typeck.translate_diagnostics ~config |> + Cobol_typeck.Engine.compilation_group ~config ptree |> + Cobol_typeck.Engine.translate_diagnostics ~config |> DIAGS.map_result ~f:begin fun checked -> - Cobol_parser.artifacts ptree, Some rewinder, Some checked + Cobol_parser.Main.artifacts ptree, Some rewinder, Some checked end end ptree in @@ -115,15 +115,15 @@ let reparse_and_analyze ?position ({ copybook; rewinder; textdoc; _ } as doc) = { doc with artifacts = no_artifacts; rewinder = None; checked = None } | Some position, Some rewinder -> check doc @@ - Cobol_parser.rewind_and_parse rewinder ~position @@ - Cobol_preproc.reset_preprocessor_for_string @@ + Cobol_parser.Main.rewind_and_parse rewinder ~position @@ + Cobol_preproc.Main.reset_preprocessor_for_string @@ Lsp.Text_document.text textdoc (** Creates a record for a document that is not yet parsed or analyzed. *) let blank ~project ?copybook textdoc = let copybook = match copybook with | Some p -> p - | None -> Lsp_project.detect_copybook project + | None -> Project.detect_copybook project ~uri:(Lsp.Text_document.documentUri textdoc) in { @@ -156,7 +156,7 @@ let first_change_pos changes = acc end Int.(max_int, max_int) changes (* can |changes|=0 really happen? *) in - Cobol_parser.Indexed { line; char } + Cobol_parser.Main.Indexed { line; char } let update ({ textdoc; _ } as doc) changes = let position = first_change_pos changes in @@ -180,7 +180,7 @@ let to_cache ({ project; textdoc; checked; diags; artifacts = { pplog; tokens; rev_comments; rev_ignored; _ }; _ } as doc) = { - doc_cache_filename = Lsp_project.relative_path_for ~uri:(uri doc) project; + doc_cache_filename = Project.relative_path_for ~uri:(uri doc) project; doc_cache_checksum = Digest.string (Lsp.Text_document.text textdoc); doc_cache_langid = Lsp.Text_document.languageId textdoc; doc_cache_version = Lsp.Text_document.version textdoc; @@ -206,7 +206,7 @@ let of_cache ~project doc_cache_ignored = rev_ignored; doc_cache_checked = checked; doc_cache_diags = diags } = - let absolute_filename = Lsp_project.absolute_path_for ~filename project in + let absolute_filename = Project.absolute_path_for ~filename project in if checksum <> Digest.file absolute_filename then failwith "Bad checksum" else diff --git a/src/lsp/cobol_lsp/lsp_lookup.ml b/src/lsp/cobol_lsp/lookup.ml similarity index 90% rename from src/lsp/cobol_lsp/lsp_lookup.ml rename to src/lsp/cobol_lsp/lookup.ml index 0792d9939..cc5d5fbc8 100644 --- a/src/lsp/cobol_lsp/lsp_lookup.ml +++ b/src/lsp/cobol_lsp/lookup.ml @@ -30,17 +30,17 @@ module TYPES = struct } and element_in_context = | Data_name of - Cobol_ptree.qualname + Cobol_ptree.Types.qualname | Data_full_name of - Cobol_ptree.qualname + Cobol_ptree.Types.qualname | Data_item of { - full_qn: Cobol_ptree.qualname option; + full_qn: Cobol_ptree.Types.qualname option; def_loc: srcloc; } | Proc_name of { - qn: Cobol_ptree.qualname; + qn: Cobol_ptree.Types.qualname; in_section: Cobol_unit.Types.procedure_section option; } @@ -50,7 +50,7 @@ module TYPES = struct as_item: item_definition option; } and paragraph_definition = - Cobol_ptree.paragraph with_loc + Cobol_ptree.Types.paragraph with_loc and item_definition = Cobol_data.Types.item_definition with_loc @@ -61,7 +61,7 @@ open TYPES (* --- *) -let baseloc_of_qualname: Cobol_ptree.qualname -> srcloc = function +let baseloc_of_qualname: Cobol_ptree.Types.qualname -> srcloc = function | Name name | Qual (name, _) -> ~@name @@ -72,8 +72,8 @@ let baseloc_of_qualname: Cobol_ptree.qualname -> srcloc = function [qualname], from the first qualifier to the last. This function is temporary and is expected to be replaced once a better way of getting this location is found. *) -let lexloc_of_qualname_in ~filename (qn: Cobol_ptree.qualname) = - let rec end_pos: Cobol_ptree.qualname -> Lexing.position = function +let lexloc_of_qualname_in ~filename (qn: Cobol_ptree.Types.qualname) = + let rec end_pos: Cobol_ptree.Types.qualname -> Lexing.position = function | Name n -> Cobol_common.Srcloc.end_pos_in ~filename ~@n | Qual (_, qn) -> end_pos qn in @@ -85,15 +85,15 @@ let lexloc_of_qualname_in ~filename (qn: Cobol_ptree.qualname) = the qualifiers of [qualname] that are after or at position [pos] ion [filename]. This function is temporary and is expected to be replaced once a better way of finding the qualname is implemented. *) -let rec qualname_at_pos ~filename (qn: Cobol_ptree.qualname) pos = +let rec qualname_at_pos ~filename (qn: Cobol_ptree.Types.qualname) pos = match qn with | Name _ -> qn | Qual (name, qn') -> try let lexloc = lexloc_of_qualname_in ~filename qn in - if not (Lsp_position.is_after_lexloc pos lexloc) && - not (Lsp_position.is_in_srcloc ~filename pos ~@name) + if not (Position.is_after_lexloc pos lexloc) && + not (Position.is_in_srcloc ~filename pos ~@name) then qualname_at_pos ~filename qn' pos else qn with Invalid_argument _ -> qn (* dummy loc *) @@ -151,7 +151,7 @@ let element_at_position ~uri pos group : element_at_position = Cobol_unit.Visitor.fold_unit_group object inherit [acc] Cobol_unit.Visitor.folder - inherit! [acc] Lsp_position.sieve ~filename ~pos + inherit! [acc] Position.sieve ~filename ~pos method! fold_cobol_unit' cu ({ elt; _ } as acc) = let name = ~&(~&cu.unit_name) in @@ -197,7 +197,7 @@ let copy_at_pos ~filename pos ptree = | None -> match Cobol_common.Srcloc.as_copy loc with | Some { loc; _ } as copy - when Lsp_position.is_in_srcloc ~filename pos loc -> + when Position.is_in_srcloc ~filename pos loc -> Visitor.skip_children copy | _ -> Visitor.do_children None diff --git a/src/lsp/cobol_lsp/lsp_server_loop.ml b/src/lsp/cobol_lsp/loop.ml similarity index 92% rename from src/lsp/cobol_lsp/lsp_server_loop.ml rename to src/lsp/cobol_lsp/loop.ml index 5611893fc..bb004f4ab 100644 --- a/src/lsp/cobol_lsp/lsp_server_loop.ml +++ b/src/lsp/cobol_lsp/loop.ml @@ -31,11 +31,11 @@ open Ez_file.V1.EzFile.OP [project_layout] does not provide a per-project storage directory ({i i.e,} [project_layout.relative_work_dirname = None]). *) let config - ~(project_layout: Lsp_project.layout) + ~(project_layout: Project.layout) ?(enable_caching = true) ?(fallback_storage_directory: string option) () = - let cache_storage: Lsp_project_cache.storage = + let cache_storage: Project_cache.storage = match project_layout.relative_work_dirname, fallback_storage_directory with | _ when not enable_caching -> No_storage @@ -57,7 +57,7 @@ let config relative_filename = relative_work_dirname // "lsp-cache"; } in - Lsp_server.{ + Server.{ cache_config = { cache_storage; cache_verbose = true; @@ -76,14 +76,14 @@ let run ~config = | Jsonrpc.Packet.Notification n -> continue @@ Lsp_notif.handle n state | Jsonrpc.Packet.Request r -> - continue @@ reply @@ Lsp_request.handle r state + continue @@ reply @@ Request.handle r state | Jsonrpc.Packet.Batch_call calls -> batch calls state | Jsonrpc.Packet.Response _ | Batch_response _ -> Pretty.error "Response@ recieved@ unexpectedly@."; continue state | exception End_of_file -> - Lsp_request.shutdown state; + Request.shutdown state; Error "Premature end of input stream" (* exit loop *) | exception Lsp_io.Parse_error msg -> Lsp_io.pretty_notification ~type_:Error "%s" msg; @@ -95,12 +95,12 @@ let run ~config = | `Notification n :: calls' -> batch calls' @@ Lsp_notif.handle n state | `Request n :: calls' -> - batch calls' @@ reply @@ Lsp_request.handle n state + batch calls' @@ reply @@ Request.handle n state and reply (state, response) = Lsp_io.send_response response; state and continue = function - | Lsp_server.Exit code -> code (* exit loop *) + | Server.Exit code -> code (* exit loop *) | state -> loop state in loop (NotInitialized config) diff --git a/src/lsp/cobol_lsp/lsp_server_loop.mli b/src/lsp/cobol_lsp/loop.mli similarity index 92% rename from src/lsp/cobol_lsp/lsp_server_loop.mli rename to src/lsp/cobol_lsp/loop.mli index 7bbfeb5d7..c618b8cb9 100644 --- a/src/lsp/cobol_lsp/lsp_server_loop.mli +++ b/src/lsp/cobol_lsp/loop.mli @@ -16,8 +16,8 @@ val config -> ?enable_caching: bool -> ?fallback_storage_directory: string -> unit - -> Lsp_server.config + -> Server.config val run - : config: Lsp_server.config - -> Lsp_server.exit_status + : config: Server.config + -> Server.exit_status diff --git a/src/lsp/cobol_lsp/lsp_completion.ml b/src/lsp/cobol_lsp/lsp_completion.ml index d1e01d418..e6a7d1d21 100644 --- a/src/lsp/cobol_lsp/lsp_completion.ml +++ b/src/lsp/cobol_lsp/lsp_completion.ml @@ -17,14 +17,15 @@ open Cobol_common (* Visitor *) open Cobol_common.Srcloc.INFIX open Lsp_completion_keywords -open Lsp.Types + +module POSITION = Lsp.Types.Position let name_proposals ast ~filename pos = let visitor = object inherit [StringSet.t] Cobol_ptree.Visitor.folder method! fold_compilation_unit' cu = - if Lsp_position.is_in_srcloc ~filename pos ~@cu + if Position.is_in_srcloc ~filename pos ~@cu then Visitor.do_children else Visitor.skip_children @@ -56,13 +57,13 @@ let keyword_proposals ast pos = method! fold_data_division' {loc; _} _ = Visitor.skip_children @@ - if Lsp_position.is_in_srcloc pos loc + if Position.is_in_srcloc pos loc then Some Data_div else None method! fold_procedure_division' {loc; _} _ = Visitor.skip_children @@ - if Lsp_position.is_in_srcloc pos loc + if Position.is_in_srcloc pos loc then Some Proc_div else None @@ -75,7 +76,7 @@ let keyword_proposals ast pos = let keyword_proposals _ast _pos = keywords_all -let completion_items text (pos:Position.t) ast = +let completion_items text (pos:POSITION.t) ast = let filename = Lsp.Uri.to_path (Lsp.Text_document.documentUri text) in let range = let line = pos.line in @@ -83,8 +84,8 @@ let completion_items text (pos:Position.t) ast = let texts = String.split_on_char '\n' @@ Lsp.Text_document.text text in let text_line = List.nth texts line in let index = 1 + String.rindex_from text_line (character - 1) ' ' in - let position_start = Position.create ~character:index ~line in - Range.create ~start:position_start ~end_:pos + let position_start = POSITION.create ~character:index ~line in + Lsp.Types.Range.create ~start:position_start ~end_:pos in let names = name_proposals ast ~filename pos in @@ -92,9 +93,9 @@ let completion_items text (pos:Position.t) ast = let words = names @ keywords in List.map (fun x -> - let textedit = TextEdit.create ~newText:x ~range in + let textedit = Lsp.Types.TextEdit.create ~newText:x ~range in (*we may change the ~sortText/preselect for reason of priority *) - CompletionItem.create + Lsp.Types.CompletionItem.create ~label:x ~sortText:x ~preselect:false diff --git a/src/lsp/cobol_lsp/lsp_folding.ml b/src/lsp/cobol_lsp/lsp_folding.ml index 7ec77e027..0c00bcb1b 100644 --- a/src/lsp/cobol_lsp/lsp_folding.ml +++ b/src/lsp/cobol_lsp/lsp_folding.ml @@ -11,6 +11,7 @@ open Lsp.Types open Cobol_common (* Visitor *) +open Cobol_common.Srcloc.TYPES type range = FoldingRange.t diff --git a/src/lsp/cobol_lsp/lsp_notif.ml b/src/lsp/cobol_lsp/lsp_notif.ml index 07bec7eda..c4bd6b579 100644 --- a/src/lsp/cobol_lsp/lsp_notif.ml +++ b/src/lsp/cobol_lsp/lsp_notif.ml @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open Lsp_server.TYPES +open Server.TYPES let on_notification state notif = match state, notif with @@ -22,15 +22,15 @@ let on_notification state notif = | NotInitialized _ | Exit _ as state, _ -> state (* spec indicate notif should just be discarded *) | Initialized config, Initialized -> - Running (Lsp_server.init ~config) + Running (Server.init ~config) | Running registry, TextDocumentDidOpen params -> - Running (Lsp_server.did_open params registry) + Running (Server.did_open params registry) | Running registry, TextDocumentDidChange params -> - Running (Lsp_server.did_change params registry) + Running (Server.did_change params registry) | Running registry, TextDocumentDidClose params -> - Running (Lsp_server.did_close params registry) + Running (Server.did_close params registry) | Running _, Exit -> - Lsp_request.shutdown state; + Request.shutdown state; Exit (Error "Received premature 'exit' notification") | _ -> state @@ -42,7 +42,7 @@ let handle notif state = state | Ok notif -> try on_notification state notif with - | Lsp_server.Document_not_found { uri } -> + | Server.Document_not_found { uri } -> Lsp_io.pretty_notification ~type_:Error "Document@ %s@ is@ not@ opened@ yet" (Lsp.Types.DocumentUri.to_string uri); diff --git a/src/lsp/cobol_lsp/lsp_notif.mli b/src/lsp/cobol_lsp/lsp_notif.mli index 3a3b4c299..7f944c36a 100644 --- a/src/lsp/cobol_lsp/lsp_notif.mli +++ b/src/lsp/cobol_lsp/lsp_notif.mli @@ -11,4 +11,4 @@ (* *) (**************************************************************************) -val handle: Jsonrpc.Notification.t -> (Lsp_server.state as 's) -> 's +val handle: Jsonrpc.Notification.t -> (Server.state as 's) -> 's diff --git a/src/lsp/cobol_lsp/lsp_notify.mli b/src/lsp/cobol_lsp/lsp_notify.mli index 66439ccf6..ba5707b33 100644 --- a/src/lsp/cobol_lsp/lsp_notify.mli +++ b/src/lsp/cobol_lsp/lsp_notify.mli @@ -14,12 +14,12 @@ (** [unknown kind given_qualname] ... *) val unknown : string - -> Cobol_ptree.qualname + -> Cobol_ptree.Types.qualname -> unit (** [ambiguous kind given_qualname ~matching_qualnames] ... *) val ambiguous : string - -> Cobol_ptree.qualname - -> matching_qualnames: Cobol_ptree.qualname Cobol_common.Basics.NEL.t + -> Cobol_ptree.Types.qualname + -> matching_qualnames: Cobol_ptree.Types.qualname Cobol_common.Basics.NEL.t -> unit diff --git a/src/lsp/cobol_lsp/lsp_semtoks.ml b/src/lsp/cobol_lsp/lsp_semtoks.ml index 937d85a14..68a8f4254 100644 --- a/src/lsp/cobol_lsp/lsp_semtoks.ml +++ b/src/lsp/cobol_lsp/lsp_semtoks.ml @@ -11,9 +11,10 @@ (* *) (**************************************************************************) +open Cobol_common.Srcloc.TYPES open Cobol_common (* Srcloc, Visitor *) open Cobol_common.Srcloc.INFIX -open Cobol_parser.Tokens +open Cobol_parser.Grammar_tokens module TOKTYP = struct type t = { index: int; name: string } @@ -97,7 +98,7 @@ type semtok = { } let semtok ?(tokmods = TOKMOD.none) toktyp lexloc = - let range = Lsp_position.range_of_lexloc lexloc in + let range = Position.range_of_lexloc lexloc in let line = range.start.line in let start = range.start.character in let length = range.end_.character - start in @@ -108,7 +109,7 @@ let single_line_lexlocs_in ~filename = let acc_semtoks ~filename ?range ?tokmods toktyp loc acc = List.fold_left begin fun acc lexloc -> match range with - | Some r when not (Lsp_position.intersects_lexloc r lexloc) -> acc + | Some r when not (Position.intersects_lexloc r lexloc) -> acc | _ -> semtok toktyp ?tokmods lexloc :: acc end acc @@ single_line_lexlocs_in ~filename loc @@ -158,7 +159,7 @@ let semtoks_from_ptree ~filename ?range ptree = let add_name' name category acc = acc_semtoks category ~@name acc in - let rec add_qualname (qn: Cobol_ptree.qualname) toktyp acc = + let rec add_qualname (qn: Cobol_ptree.Types.qualname) toktyp acc = match qn with | Name name -> add_name' name toktyp acc @@ -166,7 +167,7 @@ let semtoks_from_ptree ~filename ?range ptree = add_name' name toktyp acc |> add_qualname qn toktyp in - let add_ident (id: Cobol_ptree.ident) toktyp acc = + let add_ident (id: Cobol_ptree.Types.ident) toktyp acc = match id with | QualIdent {ident_name; _} -> add_qualname ~&ident_name toktyp acc | _ -> acc (* TODO *) @@ -547,7 +548,7 @@ let semtoks_of_comments ~filename ?range rev_comments = | Cobol_preproc.Text.{ comment_loc = s, _ as lexloc; _ } when s.Lexing.pos_fname = filename && Option.fold range - ~some:(fun r -> Lsp_position.intersects_lexloc r lexloc) + ~some:(fun r -> Position.intersects_lexloc r lexloc) ~none:true -> semtok TOKTYP.comment lexloc :: acc | _ -> @@ -562,7 +563,7 @@ let semtoks_of_ignored ~filename ?range rev_ignored = List.fold_left begin fun acc ((s, _ ) as lexloc) -> if s.Lexing.pos_fname = filename && Option.fold range - ~some:(fun r -> Lsp_position.intersects_lexloc r lexloc) + ~some:(fun r -> Position.intersects_lexloc r lexloc) ~none:true then semtok TOKTYP.comment lexloc :: acc else acc diff --git a/src/lsp/cobol_lsp/lsp_semtoks.mli b/src/lsp/cobol_lsp/lsp_semtoks.mli index 6754cf631..b4088712d 100644 --- a/src/lsp/cobol_lsp/lsp_semtoks.mli +++ b/src/lsp/cobol_lsp/lsp_semtoks.mli @@ -23,5 +23,5 @@ val data -> pplog: Cobol_preproc.Trace.log -> rev_comments: Cobol_preproc.Text.comments -> rev_ignored: Cobol_common.Srcloc.lexloc list - -> ptree: Cobol_ptree.compilation_group + -> ptree: Cobol_ptree.Types.compilation_group -> int array diff --git a/src/lsp/cobol_lsp/lsp_position.ml b/src/lsp/cobol_lsp/position.ml similarity index 100% rename from src/lsp/cobol_lsp/lsp_position.ml rename to src/lsp/cobol_lsp/position.ml diff --git a/src/lsp/cobol_lsp/lsp_position.mli b/src/lsp/cobol_lsp/position.mli similarity index 100% rename from src/lsp/cobol_lsp/lsp_position.mli rename to src/lsp/cobol_lsp/position.mli diff --git a/src/lsp/cobol_lsp/lsp_project.ml b/src/lsp/cobol_lsp/project.ml similarity index 97% rename from src/lsp/cobol_lsp/lsp_project.ml rename to src/lsp/cobol_lsp/project.ml index d5094ad09..7195e5546 100644 --- a/src/lsp/cobol_lsp/lsp_project.ml +++ b/src/lsp/cobol_lsp/project.ml @@ -36,8 +36,8 @@ let rootdir_for ~uri ~layout = let show_n_forget_diagnostics ?(force = false) { result = project; diags } = if force || diags <> DIAGS.Set.none then - Lsp_diagnostics.publish @@ - Lsp_diagnostics.translate diags + Diagnostics.publish @@ + Diagnostics.translate diags ~rootdir:(Superbol_project.string_of_rootdir project.rootdir) ~uri:(`Main (Lsp.Uri.of_path project.config_filename)); project diff --git a/src/lsp/cobol_lsp/lsp_project.mli b/src/lsp/cobol_lsp/project.mli similarity index 100% rename from src/lsp/cobol_lsp/lsp_project.mli rename to src/lsp/cobol_lsp/project.mli diff --git a/src/lsp/cobol_lsp/lsp_project_cache.ml b/src/lsp/cobol_lsp/project_cache.ml similarity index 81% rename from src/lsp/cobol_lsp/lsp_project_cache.ml rename to src/lsp/cobol_lsp/project_cache.ml index 4c45b8028..388294cd9 100644 --- a/src/lsp/cobol_lsp/lsp_project_cache.ml +++ b/src/lsp/cobol_lsp/project_cache.ml @@ -37,7 +37,7 @@ include TYPES opened document pertaining to a given project. *) module CACHED_DOCS = Set.Make (struct - open Lsp_document.TYPES + open Document.TYPES type t = cached let compare { doc_cache_filename = f1; _ } { doc_cache_filename = f2; _ } = String.compare f1 f2 @@ -45,7 +45,7 @@ module CACHED_DOCS = type cached_project_record = { - cached_project: Lsp_project.cached; + cached_project: Project.cached; cached_docs: CACHED_DOCS.t; } @@ -56,10 +56,10 @@ let cache_filename ~config ~rootdir = | No_storage -> None | Store_in_file { relative_filename } -> - Some (Lsp_project.string_of_rootdir rootdir // relative_filename) + Some (Project.string_of_rootdir rootdir // relative_filename) | Store_in_shared_dir { dirname } -> Some (dirname // Digest.(to_hex @@ - string @@ Lsp_project.string_of_rootdir rootdir)) + string @@ Project.string_of_rootdir rootdir)) let version_tag_length = 40 (* use full commit hash when available *) let version_tag = @@ -84,10 +84,10 @@ let read_project_cache ic = (** (Internal) May raise {!Failure} or {!Sys_error}. *) let save_project_cache ~config - (Lsp_project.{ rootdir; _ } as project) cached_docs = + (Project.{ rootdir; _ } as project) cached_docs = let cached_project_record = { - cached_project = Lsp_project.to_cache project; + cached_project = Project.to_cache project; cached_docs; } in @@ -98,7 +98,7 @@ let save_project_cache ~config (* if Lsp_utils.is_file cache_file *) (* then (* read, write if commit hash or document changed *) *) (* else *) - Lsp_utils.write_to cache_file (write_project_cache cached_project_record); + Utils.write_to cache_file (write_project_cache cached_project_record); Lsp_io.pretty_notification "Wrote cache at: %s" cache_file ~log:true ~type_:Info | None -> @@ -107,24 +107,24 @@ let save_project_cache ~config let save ~config docs = (* Pivot all active projects: associate projects with all their documents, and ignore any project that has none. *) - URIMap.fold begin fun _ (Lsp_document.{ project; _ } as doc) -> - Lsp_project.MAP.update project begin function - | None -> Some (CACHED_DOCS.singleton (Lsp_document.to_cache doc)) - | Some s -> Some (CACHED_DOCS.add (Lsp_document.to_cache doc) s) + URIMap.fold begin fun _ (Document.{ project; _ } as doc) -> + Project.MAP.update project begin function + | None -> Some (CACHED_DOCS.singleton (Document.to_cache doc)) + | Some s -> Some (CACHED_DOCS.add (Document.to_cache doc) s) end - end docs Lsp_project.MAP.empty |> - Lsp_project.MAP.iter (save_project_cache ~config) + end docs Project.MAP.empty |> + Project.MAP.iter (save_project_cache ~config) (** (Internal) *) let load_project ~rootdir ~layout ~config { cached_project; cached_docs; _ } = - let project = Lsp_project.of_cache ~rootdir ~layout cached_project in - let add_doc doc docs = URIMap.add (Lsp_document.uri doc) doc docs in + let project = Project.of_cache ~rootdir ~layout cached_project in + let add_doc doc docs = URIMap.add (Document.uri doc) doc docs in CACHED_DOCS.fold begin fun cached_doc docs -> try - let doc = Lsp_document.of_cache ~project cached_doc in + let doc = Document.of_cache ~project cached_doc in if config.cache_verbose then Lsp_io.pretty_notification "Successfully read cache for %s" - (Lsp.Uri.to_string @@ Lsp_document.uri doc) ~log:true ~type_:Info; + (Lsp.Uri.to_string @@ Document.uri doc) ~log:true ~type_:Info; add_doc doc docs with | Failure msg | Sys_error msg -> @@ -141,10 +141,10 @@ let load_project ~rootdir ~layout ~config { cached_project; cached_docs; _ } = let load ~rootdir ~layout ~config = let fallback = URIMap.empty in let load_cache cache_file = - let cached_project = Lsp_utils.read_from cache_file read_project_cache in + let cached_project = Utils.read_from cache_file read_project_cache in let project = load_project ~rootdir ~layout ~config cached_project in Lsp_io.pretty_notification "Successfully read cache for %s" - (Lsp_project.string_of_rootdir rootdir) ~log:true ~type_:Info; + (Project.string_of_rootdir rootdir) ~log:true ~type_:Info; project in match cache_filename ~config ~rootdir with diff --git a/src/lsp/cobol_lsp/lsp_project_cache.mli b/src/lsp/cobol_lsp/project_cache.mli similarity index 95% rename from src/lsp/cobol_lsp/lsp_project_cache.mli rename to src/lsp/cobol_lsp/project_cache.mli index b080ef83d..7d7fff607 100644 --- a/src/lsp/cobol_lsp/lsp_project_cache.mli +++ b/src/lsp/cobol_lsp/project_cache.mli @@ -48,7 +48,7 @@ include module type of TYPES ([Sys_error], [Failure]). *) val save : config: TYPES.config - -> Lsp_document.t URIMap.t + -> Document.t URIMap.t -> unit (** [load ~rootdir ~config ~layout] pre-loads cached documents pertaining to a @@ -62,7 +62,7 @@ val save {!Lsp_io.send_notification}. May raise some IO-related exceptions ([Sys_error], [Failure]). *) val load - : rootdir:Lsp_project.rootdir - -> layout: Lsp_project.layout + : rootdir:Project.rootdir + -> layout: Project.layout -> config: TYPES.config - -> Lsp_document.t URIMap.t + -> Document.t URIMap.t diff --git a/src/lsp/cobol_lsp/lsp_request.ml b/src/lsp/cobol_lsp/request.ml similarity index 83% rename from src/lsp/cobol_lsp/lsp_request.ml rename to src/lsp/cobol_lsp/request.ml index bcb075bd1..77f2e20de 100644 --- a/src/lsp/cobol_lsp/lsp_request.ml +++ b/src/lsp/cobol_lsp/request.ml @@ -14,10 +14,9 @@ open Cobol_common.Srcloc.TYPES open Cobol_common.Srcloc.INFIX open Lsp_imports -open Lsp_project.TYPES -open Lsp_server.TYPES -open Lsp_lookup.TYPES -open Lsp.Types +open Project.TYPES +open Server.TYPES +open Lookup.TYPES open Ez_file.V1 (** {2 Handling requests} *) @@ -25,13 +24,14 @@ open Ez_file.V1 (** Catch generic exception cases, and report errors using {!error} above *) let try_doc ~f registry doc_id = let doc = - try Lsp_server.find_document doc_id registry + try Server.find_document doc_id registry with Not_found -> Lsp_error.request_failed "Received a request about a document that has not been opened yet (uri = \ %s) --- possible cause is the client did not manage to send the didOpen \ notification; this may happen due to unhandled character encodings.\ - " (DocumentUri.to_string doc_id.TextDocumentIdentifier.uri) + " (Lsp.Types.DocumentUri.to_string + doc_id.Lsp.Types.TextDocumentIdentifier.uri) in try f ~doc with e -> @@ -39,26 +39,26 @@ let try_doc ~f registry doc_id = (** Same as [try_doc], with some additional document data *) let try_with_document_data ~f = - try_doc ~f:(fun ~doc -> f ~doc @@ Lsp_document.checked doc) + try_doc ~f:(fun ~doc -> f ~doc @@ Document.checked doc) (** {3 Initialization} *) -let handle_initialize (params: InitializeParams.t) = - InitializeResult.create () +let handle_initialize (params: Lsp.Types.InitializeParams.t) = + Lsp.Types.InitializeResult.create () ~capabilities:(Lsp_capabilities.reply params.capabilities) (** {3 Shutdown} *) let handle_shutdown registry = - Lsp_server.save_project_caches registry + Server.save_project_caches registry (** {3 Definitions} *) let focus_on_name_in_defintions = true -let find_data_definition Lsp_position.{ location_of; location_of_srcloc } +let find_data_definition Position.{ location_of; location_of_srcloc } ?(allow_notifications = true) - (qn: Cobol_ptree.qualname) (cu: Cobol_unit.Types.cobol_unit) = + (qn: Cobol_ptree.Types.qualname) (cu: Cobol_unit.Types.cobol_unit) = match Cobol_unit.Qualmap.find qn cu.unit_data.data_items.named with | Data_field { def = { loc; _ }; _ } | Data_renaming { def = { loc; _ }; _ } @@ -88,10 +88,10 @@ let find_data_definition Lsp_position.{ location_of; location_of_srcloc } [] let find_proc_definition - Lsp_position.{ location_of; _ } + Position.{ location_of; _ } ?(allow_notifications = true) ?(in_section: Cobol_unit.Types.procedure_section option) - (qn: Cobol_ptree.qualname) (cu: Cobol_unit.Types.cobol_unit) = + (qn: Cobol_ptree.Types.qualname) (cu: Cobol_unit.Types.cobol_unit) = match Cobol_unit.Procedure.find ?in_section qn cu.unit_procedure with | Paragraph { payload = { paragraph_name = Some qn; _ }; _ } when focus_on_name_in_defintions -> @@ -129,19 +129,19 @@ let find_definitions ?allow_notifications loc_translator with Not_found -> [] let lookup_definition_in_doc - DefinitionParams.{ textDocument = doc; position; _ } + Lsp.Types.DefinitionParams.{ textDocument = doc; position; _ } Cobol_typeck.Outputs.{ group; _ } = - match Lsp_lookup.element_at_position ~uri:doc.uri position group with + match Lookup.element_at_position ~uri:doc.uri position group with | { element_at_position = None; _ } | { enclosing_compilation_unit_name = None; _ } -> None | { element_at_position = Some qn; enclosing_compilation_unit_name = Some cu_name } -> - let loc_translator = Lsp_position.loc_translator doc in + let loc_translator = Position.loc_translator doc in Some (`Location (find_definitions loc_translator cu_name qn group)) -let handle_definition registry (params: DefinitionParams.t) = +let handle_definition registry (params: Lsp.Types.DefinitionParams.t) = try_with_document_data registry params.textDocument ~f:(fun ~doc:_ -> lookup_definition_in_doc params) @@ -168,10 +168,10 @@ let find_proc_qn ~kind qn ?in_section cu = end let lookup_references_in_doc - ReferenceParams.{ textDocument = doc; position; context; _ } + Lsp.Types.ReferenceParams.{ textDocument = doc; position; context; _ } Cobol_typeck.Outputs.{ group; artifacts = { references }; _ } = - match Lsp_lookup.element_at_position ~uri:doc.uri position group with + match Lookup.element_at_position ~uri:doc.uri position group with | { element_at_position = None; _ } -> Lsp_debug.message "Lsp_request.lookup_references_in_doc: element_at_position = None"; None @@ -180,8 +180,8 @@ let lookup_references_in_doc None | { element_at_position = Some qn; enclosing_compilation_unit_name = Some cu_name } -> - let Lsp_position.{ location_of_srcloc; _ } as loc_translator - = Lsp_position.loc_translator doc in + let Position.{ location_of_srcloc; _ } as loc_translator + = Position.loc_translator doc in let def_locs = if context.includeDeclaration then find_definitions ~allow_notifications:false loc_translator @@ -218,24 +218,24 @@ let lookup_references_in_doc in Some (def_locs @ ref_locs) -let handle_references state (params: ReferenceParams.t) = +let handle_references state (params: Lsp.Types.ReferenceParams.t) = try_with_document_data state params.textDocument ~f:(fun ~doc:_ -> lookup_references_in_doc params) (** {3 Formatting} *) -let lsp_text_edit Cobol_indent.Type.{ lnum; offset_orig; offset_modif } = +let lsp_text_edit Cobol_indent.Types.{ lnum; offset_orig; offset_modif } = let delta = offset_modif - offset_orig in - let position = Position.create ~line:(lnum - 1) ~character:offset_orig in - let range = Range.create ~start:position ~end_:position in + let position = Lsp.Types.Position.create ~line:(lnum - 1) ~character:offset_orig in + let range = Lsp.Types.Range.create ~start:position ~end_:position in if delta > 0 then - TextEdit.create ~newText:(String.make delta ' ') ~range + Lsp.Types.TextEdit.create ~newText:(String.make delta ' ') ~range else let start = - Position.create ~line:(lnum - 1) ~character:(offset_orig + delta) + Lsp.Types.Position.create ~line:(lnum - 1) ~character:(offset_orig + delta) in - let range = Range.create ~start ~end_:position in - TextEdit.create ~newText:"" ~range + let range = Lsp.Types.Range.create ~start ~end_:position in + Lsp.Types.TextEdit.create ~newText:"" ~range (*Remark: The first line of the text selected to RangeFormatting must be @@ -244,22 +244,22 @@ let lsp_text_edit Cobol_indent.Type.{ lnum; offset_orig; offset_modif } = Otherwise, unexpected result. *) let handle_range_formatting registry params = - let open DocumentRangeFormattingParams in + let open Lsp.Types.DocumentRangeFormattingParams in let { textDocument = doc; range = {start; end_}; _ } = params in - let Lsp_document.{ project; textdoc; _ } = - Lsp_server.find_document doc registry + let Document.{ project; textdoc; _ } = + Server.find_document doc registry in let range_to_indent = - Cobol_indent.Type.{ + Cobol_indent.Types.{ start_line = start.line + 1; end_line = end_.line + 1 } in let edit_list = - Cobol_indent.indent_range - ~dialect:(Cobol_config.dialect project.config.cobol_config) + Cobol_indent.Indent_main.indent_range + ~dialect:(Cobol_config.Config.dialect project.config.cobol_config) ~source_format:project.config.source_format - ~indent_config:(Some (Cobol_indent.config project.config.indent_config)) + ~indent_config:(Some (Cobol_indent.Indent_main.config project.config.indent_config)) ~filename:(Lsp.Uri.to_path doc.uri) ~contents:(Lsp.Text_document.text textdoc) ~range:(Some range_to_indent) @@ -267,15 +267,15 @@ let handle_range_formatting registry params = Some (List.map lsp_text_edit edit_list) let handle_formatting registry params = - let DocumentFormattingParams.{ textDocument = doc; _ } = params in - let Lsp_document.{ project; textdoc; _ } = - Lsp_server.find_document doc registry in + let Lsp.Types.DocumentFormattingParams.{ textDocument = doc; _ } = params in + let Document.{ project; textdoc; _ } = + Server.find_document doc registry in try let editList = - Cobol_indent.indent_range - ~dialect:(Cobol_config.dialect project.config.cobol_config) + Cobol_indent.Indent_main.indent_range + ~dialect:(Cobol_config.Config.dialect project.config.cobol_config) ~source_format:project.config.source_format - ~indent_config:(Some (Cobol_indent.config project.config.indent_config)) + ~indent_config:(Some (Cobol_indent.Indent_main.config project.config.indent_config)) ~filename:(Lsp.Uri.to_path doc.uri) ~contents:(Lsp.Text_document.text textdoc) ~range:None @@ -288,7 +288,7 @@ let handle_formatting registry params = let handle_semtoks_full, handle_semtoks_range = - let handle registry ?range (doc: TextDocumentIdentifier.t) = + let handle registry ?range (doc: Lsp.Types.TextDocumentIdentifier.t) = try_with_document_data registry doc ~f:begin fun ~doc:{ artifacts = { pplog; tokens; rev_comments; rev_ignored; _ }; @@ -298,17 +298,17 @@ let handle_semtoks_full, ~pplog ~rev_comments ~rev_ignored ~tokens:(Lazy.force tokens) ~ptree in - Some (SemanticTokens.create ~data ()) + Some (Lsp.Types.SemanticTokens.create ~data ()) end in - (fun registry (SemanticTokensParams.{ textDocument; _ }) -> + (fun registry (Lsp.Types.SemanticTokensParams.{ textDocument; _ }) -> handle registry textDocument), - (fun registry (SemanticTokensRangeParams.{ textDocument; range; _ }) -> + (fun registry (Lsp.Types.SemanticTokensRangeParams.{ textDocument; range; _ }) -> handle registry ~range textDocument) (** {3 Hover} *) -let handle_hover registry (params: HoverParams.t) = +let handle_hover registry (params: Lsp.Types.HoverParams.t) = let filename = Lsp.Uri.to_path params.textDocument.uri in let find_hovered_pplog_event pplog = List.find_opt begin function @@ -317,14 +317,14 @@ let handle_hover registry (params: HoverParams.t) = false | Replacement { matched_loc = loc; _ } | FileCopy { copyloc = loc; _ } -> - Lsp_position.is_in_lexloc params.position + Position.is_in_lexloc params.position (Cobol_common.Srcloc.lexloc_in ~filename loc) end (Cobol_preproc.Trace.events pplog) in let hover_markdown ~loc value = - let content = MarkupContent.create ~kind:MarkupKind.Markdown ~value in - let range = Lsp_position.range_of_srcloc_in ~filename loc in - Some (Hover.create () ~contents:(`MarkupContent content) ~range) + let content = Lsp.Types.MarkupContent.create ~kind:Lsp.Types.MarkupKind.Markdown ~value in + let range = Position.range_of_srcloc_in ~filename loc in + Some (Lsp.Types.Hover.create () ~contents:(`MarkupContent content) ~range) in try_doc registry params.textDocument ~f:begin fun ~doc:{ project; artifacts = { pplog; _ }; _ } -> @@ -352,12 +352,12 @@ let handle_hover registry (params: HoverParams.t) = (** {3 Completion} *) -let handle_completion registry (params: CompletionParams.t) = +let handle_completion registry (params: Lsp.Types.CompletionParams.t) = try_with_document_data registry params.textDocument ~f:begin fun ~doc:{ textdoc; _ } { ptree; _ } -> let items = Lsp_completion.completion_items textdoc params.position ptree in - Some (`CompletionList (CompletionList.create () + Some (`CompletionList (Lsp.Types.CompletionList.create () ~isIncomplete:false ~items)) end @@ -368,7 +368,7 @@ let handle_completion registry (params: CompletionParams.t) = It only supports folding complete lines, and does not support FoldingRangeKind or CollapsedText (To support these features, need to change the client capability) *) -let handle_folding_range registry (params: FoldingRangeParams.t) = +let handle_folding_range registry (params: Lsp.Types.FoldingRangeParams.t) = try_with_document_data registry params.textDocument ~f:begin fun ~doc:_ { ptree; group; _ } -> let filename = Lsp.Uri.to_path params.textDocument.uri in @@ -474,7 +474,7 @@ let handle (Jsonrpc.Request.{ id; _ } as req) state = | Error server_error -> state, Jsonrpc.Response.error id @@ - Lsp_server.jsonrpc_of_error server_error req.method_ + Server.jsonrpc_of_error server_error req.method_ | exception Jsonrpc.Response.Error.E e -> state, Jsonrpc.Response.error id e | exception e -> diff --git a/src/lsp/cobol_lsp/lsp_request.mli b/src/lsp/cobol_lsp/request.mli similarity index 85% rename from src/lsp/cobol_lsp/lsp_request.mli rename to src/lsp/cobol_lsp/request.mli index 64e42b9eb..a89fc01d0 100644 --- a/src/lsp/cobol_lsp/lsp_request.mli +++ b/src/lsp/cobol_lsp/request.mli @@ -11,32 +11,32 @@ (* *) (**************************************************************************) -val handle: Jsonrpc.Request.t -> (Lsp_server.state as 's) -> 's * Jsonrpc.Response.t -val shutdown: Lsp_server.state -> unit +val handle: Jsonrpc.Request.t -> (Server.state as 's) -> 's * Jsonrpc.Response.t +val shutdown: Server.state -> unit module INTERNAL: sig val lookup_definition - : Lsp_server.t + : Server.t -> Lsp.Types.DefinitionParams.t -> [> `Location of Lsp.Types.Location.t list ] option val lookup_definition_in_doc : Lsp.Types.DefinitionParams.t - -> Lsp_document.checked_doc + -> Document.checked_doc -> [> `Location of Lsp.Types.Location.t list ] option val lookup_references - : Lsp_server.t + : Server.t -> Lsp.Types.ReferenceParams.t -> Lsp.Types.Location.t list option val lookup_references_in_doc : Lsp.Types.ReferenceParams.t - -> Lsp_document.checked_doc + -> Document.checked_doc -> Lsp.Types.Location.t list option val hover - : Lsp_server.t + : Server.t -> Lsp.Types.HoverParams.t -> Lsp.Types.Hover.t option val formatting - : Lsp_server.t + : Server.t -> Lsp.Types.DocumentFormattingParams.t -> Lsp.Types.TextEdit.t list option end diff --git a/src/lsp/cobol_lsp/lsp_server.ml b/src/lsp/cobol_lsp/server.ml similarity index 83% rename from src/lsp/cobol_lsp/lsp_server.ml rename to src/lsp/cobol_lsp/server.ml index 5b2c01372..e3e85af2b 100644 --- a/src/lsp/cobol_lsp/lsp_server.ml +++ b/src/lsp/cobol_lsp/server.ml @@ -19,14 +19,14 @@ module DIAGS = Cobol_common.Diagnostics module TYPES = struct type config = { - project_layout: Lsp_project.layout; - cache_config: Lsp_project_cache.config; + project_layout: Project.layout; + cache_config: Project_cache.config; } type registry = { (* private *) - projects: Lsp_project.SET.t; - docs: Lsp_document.t URIMap.t; - indirect_diags: Lsp_diagnostics.t URIMap.t; (* diagnostics for other URIs + projects: Project.SET.t; + docs: Document.t URIMap.t; + indirect_diags: Diagnostics.t URIMap.t; (* diagnostics for other URIs mentioned by docs in `docs` *) config: config; @@ -56,18 +56,18 @@ type t = registry (* Code: *) let add_project proj r = - let projects = Lsp_project.SET.add proj r.projects in + let projects = Project.SET.add proj r.projects in if projects == r.projects then r else { r with projects } let add_or_replace_doc doc r = - let docs = URIMap.add (Lsp_document.uri doc) doc r.docs in + let docs = URIMap.add (Document.uri doc) doc r.docs in if docs == r.docs then r else { r with docs } (** {2 Handling of diagnostics for non-opened documents} *) -let dispatch_diagnostics (Lsp_document.{ project; diags; _ } as doc) registry = - let uri = Lsp_document.uri doc in - let rootdir = Lsp_project.rootdir project in +let dispatch_diagnostics (Document.{ project; diags; _ } as doc) registry = + let uri = Document.uri doc in + let rootdir = Project.rootdir project in let indirect4uri = if diags <> DIAGS.Set.none then URIMap.empty (* stick to the new diagnostics *) @@ -75,13 +75,13 @@ let dispatch_diagnostics (Lsp_document.{ project; diags; _ } as doc) registry = in if URIMap.is_empty indirect4uri then begin let all_diags = - Lsp_diagnostics.translate diags ~uri:(`Main uri) - ~rootdir:(Lsp_project.string_of_rootdir rootdir) + Diagnostics.translate diags ~uri:(`Main uri) + ~rootdir:(Project.string_of_rootdir rootdir) in (* Note here we may publish diagnostics for non-opened documents. LSP protocol does not seem to forbid that (but some editors just ignore those). *) - Lsp_diagnostics.publish all_diags; + Diagnostics.publish all_diags; { registry with indirect_diags = (* Register published diagnostics for the other documents in case they @@ -94,14 +94,14 @@ let dispatch_diagnostics (Lsp_document.{ project; diags; _ } as doc) registry = URIMap.union (fun _ a b -> Some (List.rev_append a b)) end indirect4uri URIMap.empty in - Lsp_diagnostics.publish all_diags; + Diagnostics.publish all_diags; registry end (** {2 Management of per-project caches} *) let save_project_caches { config = { cache_config = config; _ }; docs; _ } = - try Lsp_project_cache.save ~config docs + try Project_cache.save ~config docs with e -> Lsp_error.internal "Exception@ caught@ while@ saving@ project@ caches:@ %a@." Fmt.exn e @@ -109,9 +109,9 @@ let save_project_caches { config = { cache_config = config; _ }; docs; _ } = let load_project_cache ~rootdir ({ config = { project_layout = layout; cache_config = config; _ }; projects; docs = old_docs; _ } as registry) = - let new_docs = Lsp_project_cache.load ~config ~layout ~rootdir in + let new_docs = Project_cache.load ~config ~layout ~rootdir in let projects = match URIMap.choose_opt new_docs with - | Some (_, Lsp_document.{ project = p; _ }) -> Lsp_project.SET.add p projects + | Some (_, Document.{ project = p; _ }) -> Project.SET.add p projects | None -> projects and docs = URIMap.union (fun _ _old new_ -> Some new_) old_docs new_docs in { registry with projects; docs } @@ -122,17 +122,17 @@ let load_project_cache ~rootdir ({ config = { project_layout = layout; let init ~config : registry = { config; - projects = Lsp_project.SET.empty; + projects = Project.SET.empty; docs = URIMap.empty; indirect_diags = URIMap.empty; } let create_or_retrieve_project ~uri registry = let layout = registry.config.project_layout in - let rootdir = Lsp_project.rootdir_for ~uri ~layout in - try Lsp_project.SET.for_rootdir ~rootdir registry.projects, registry + let rootdir = Project.rootdir_for ~uri ~layout in + try Project.SET.for_rootdir ~rootdir registry.projects, registry with Not_found -> - let project = Lsp_project.for_ ~rootdir ~layout in + let project = Project.for_ ~rootdir ~layout in project, add_project project registry let document_error_while_ operation doc e backtrace registry = @@ -146,10 +146,10 @@ let add (DidOpenTextDocumentParams.{ textDocument = { uri; _ }; _ } as doc) ?copybook registry = let project, registry = create_or_retrieve_project ~uri registry in try - let doc = Lsp_document.load ~project ?copybook doc in + let doc = Document.load ~project ?copybook doc in let registry = dispatch_diagnostics doc registry in add_or_replace_doc doc registry - with Lsp_document.Internal_error (doc, e, backtrace) -> + with Document.Internal_error (doc, e, backtrace) -> document_error_while_"opening" doc e backtrace registry let did_open (DidOpenTextDocumentParams.{ textDocument = { uri; text; _ }; @@ -165,8 +165,8 @@ let did_open (DidOpenTextDocumentParams.{ textDocument = { uri; text; _ }; | None | Some _ when try_cache -> let registry = let layout = registry.config.project_layout in - let rootdir = Lsp_project.rootdir_for ~uri ~layout in - if Lsp_project.SET.mem_rootdir ~rootdir registry.projects + let rootdir = Project.rootdir_for ~uri ~layout in + if Project.SET.mem_rootdir ~rootdir registry.projects then registry else load_project_cache ~rootdir registry in @@ -185,10 +185,10 @@ let did_change DidChangeTextDocumentParams.{ textDocument = { uri; _ }; contentChanges; _ } registry = try let doc = find_document TextDocumentIdentifier.{ uri } registry in - let doc = Lsp_document.update doc contentChanges in + let doc = Document.update doc contentChanges in let registry = dispatch_diagnostics doc registry in add_or_replace_doc doc registry - with Lsp_document.Internal_error (doc, e, backtrace) -> + with Document.Internal_error (doc, e, backtrace) -> document_error_while_"updating" doc e backtrace registry let did_close DidCloseTextDocumentParams.{ textDocument = { uri } } registry = diff --git a/src/lsp/cobol_lsp/lsp_server.mli b/src/lsp/cobol_lsp/server.mli similarity index 90% rename from src/lsp/cobol_lsp/lsp_server.mli rename to src/lsp/cobol_lsp/server.mli index e47e4b0a2..76d54111b 100644 --- a/src/lsp/cobol_lsp/lsp_server.mli +++ b/src/lsp/cobol_lsp/server.mli @@ -16,14 +16,14 @@ open Lsp_imports module TYPES: sig type config = { - project_layout: Lsp_project.layout; - cache_config: Lsp_project_cache.config; + project_layout: Project.layout; + cache_config: Project_cache.config; } type registry = private { - projects: Lsp_project.SET.t; - docs: Lsp_document.t URIMap.t; - indirect_diags: Lsp_diagnostics.t URIMap.t; (* diagnostics for other URIs + projects: Project.SET.t; + docs: Document.t URIMap.t; + indirect_diags: Diagnostics.t URIMap.t; (* diagnostics for other URIs mentioned by docs in `docs` *) config: config; @@ -73,7 +73,7 @@ val did_close : Lsp.Types.DidCloseTextDocumentParams.t -> t -> t val find_document - : Lsp.Types.TextDocumentIdentifier.t -> t -> Lsp_document.t + : Lsp.Types.TextDocumentIdentifier.t -> t -> Document.t val jsonrpc_of_error : 'a error -> string -> Jsonrpc.Response.Error.t diff --git a/src/lsp/cobol_lsp/lsp_utils.ml b/src/lsp/cobol_lsp/utils.ml similarity index 100% rename from src/lsp/cobol_lsp/lsp_utils.ml rename to src/lsp/cobol_lsp/utils.ml diff --git a/src/lsp/cobol_lsp/lsp_utils.mli b/src/lsp/cobol_lsp/utils.mli similarity index 100% rename from src/lsp/cobol_lsp/lsp_utils.mli rename to src/lsp/cobol_lsp/utils.mli diff --git a/src/lsp/cobol_parser/cobol_parser.ml b/src/lsp/cobol_parser/cobol_parser.ml deleted file mode 100644 index fea3b33da..000000000 --- a/src/lsp/cobol_parser/cobol_parser.ml +++ /dev/null @@ -1,66 +0,0 @@ -(**************************************************************************) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(** {1 Exported modules} *) - -(** Options to tune the parser engine *) -module Options = Parser_options - -(** Output types for the engine *) -module Outputs = Parser_outputs - -module Tokens = Grammar_tokens -module Keywords = Text_keywords - -(** {1 Exported functions} *) - -include Parser_engine - -(** {1 Modules and functions exported for testing purposes} - - Signatures of modules below may change unexpectedly. *) - -module INTERNAL = struct - - (** {2 COBOL tokens} *) - - module Tokens = Grammar_tokens - - let pp_token = Text_tokenizer.pp_token - let pp_tokens = Text_tokenizer.pp_tokens - let pp_tokens' = Text_tokenizer.pp_tokens' - - (** {2 COBOL grammar} *) - - module Grammar (* : Grammar_sig.S *) = Grammar - - (** {2 Dummy parser} *) - - (** Parser with dummy source locations, that can be fed directly with a - list of tokens *) - module Dummy = struct - module Tags = struct - let loc = Cobol_common.Srcloc.dummy - end - - let parse_as item toks = - let toks = ref toks - and dummy_lexer = Lexing.from_string ~with_positions:false "" in - item begin fun _ -> match !toks () with - | Seq.Nil -> Grammar_tokens.EOF - | Cons (x, tl) -> toks := tl; x - end dummy_lexer - - let parse_list_as parse lx = parse_as parse (List.to_seq lx) - end -end diff --git a/src/lsp/cobol_parser/dune b/src/lsp/cobol_parser/dune index 4164f945c..74e86dd7a 100644 --- a/src/lsp/cobol_parser/dune +++ b/src/lsp/cobol_parser/dune @@ -36,7 +36,7 @@ (flags --inspection --table --only-tokens)) (rule - (targets text_keywords.ml) + (targets keywords.ml) (enabled_if (<> %{profile} "release")) (deps grammar.cmly) (mode promote) diff --git a/src/lsp/cobol_parser/grammar.mly b/src/lsp/cobol_parser/grammar.mly index 4dea5b9f8..8993effa7 100644 --- a/src/lsp/cobol_parser/grammar.mly +++ b/src/lsp/cobol_parser/grammar.mly @@ -13,7 +13,7 @@ (**************************************************************************) open Grammar_utils -open Cobol_ptree +open Cobol_ptree.Types open Cobol_ptree.Terms_helpers open Cobol_common.Srcloc.INFIX @@ -62,7 +62,7 @@ let dual_handler_none = (* %[@post.tag diagnostic loc:Cobol_common.Srcloc.srcloc option -> *) (* unit Cobol_common.Diagnostics.in_result] *) -%[@post.tag special_names Cobol_ptree.special_names_clause] +%[@post.tag special_names Cobol_ptree.Types.special_names_clause] %[@post.tag pending string] @@ -184,7 +184,7 @@ let dual_handler_none = (* Entry points *) -%start compilation_group +%start compilation_group %start standalone_condition %% @@ -2177,7 +2177,7 @@ let idents [@symbol ""] [@recovery []] := let ident_or_literal [@symbol ""] [@cost 0] - [@recovery Cobol_ptree.UPCAST.ident_with_literal dummy_ident] := + [@recovery Cobol_ptree.Types.UPCAST.ident_with_literal dummy_ident] := | i = ident; %prec lowest { UPCAST.ident_with_literal i } | l = literal; { UPCAST.literal_with_ident l } @@ -2204,11 +2204,11 @@ let integer [@recovery "0"] let fixedlit [@recovery fixed_zero] [@cost 10] [@symbol ""] := - | (i, _, d) = FIXEDLIT; { Cobol_ptree.fixed_of_strings i d } + | (i, _, d) = FIXEDLIT; { Cobol_ptree.Types.fixed_of_strings i d } let floatlit [@recovery floating_zero] [@cost 10] [@symbol ""] := - | (i, _, d, e) = FLOATLIT; { Cobol_ptree.floating_of_strings i d e } + | (i, _, d, e) = FLOATLIT; { Cobol_ptree.Types.floating_of_strings i d e } let alphanum [@recovery dummy_alphanum_string] [@symbol ""] := | ~ = ALPHANUM; < > @@ -3396,7 +3396,7 @@ let perform_statement [@context perform_stmt] := perform_statements = isl } } let perform_phrase := - | FOREVER; { PerformForever } (* GC/COBOL-IT extension *) + | FOREVER; { PerformForever } (* GC/COBOL-IT extension *) | ~ = ident_or_integer; TIMES; | wt = ro(with_test); UNTIL; until = condition; { PerformUntil { with_test = wt; until } } diff --git a/src/lsp/cobol_parser/grammar_post_actions.ml b/src/lsp/cobol_parser/grammar_post_actions.ml index b38c2efe8..502df0d8b 100644 --- a/src/lsp/cobol_parser/grammar_post_actions.ml +++ b/src/lsp/cobol_parser/grammar_post_actions.ml @@ -7,7 +7,7 @@ open MenhirInterpreter type post_action = | Post_pending: (string) -> post_action - | Post_special_names: (Cobol_ptree.special_names_clause) -> post_action + | Post_special_names: (Cobol_ptree.Types.special_names_clause) -> post_action | NoPost: post_action let post_production_num diff --git a/src/lsp/cobol_parser/grammar_recover.ml b/src/lsp/cobol_parser/grammar_recover.ml index 6fc3bc57b..d1d4aa9c7 100644 --- a/src/lsp/cobol_parser/grammar_recover.ml +++ b/src/lsp/cobol_parser/grammar_recover.ml @@ -2,13 +2,13 @@ open Grammar module Default = struct - let fixed_zero = Cobol_ptree.{ fixed_integer = "0"; + let fixed_zero = Cobol_ptree.Types.{ fixed_integer = "0"; fixed_fractional = "0" } - let floating_zero = Cobol_ptree.{ float_significand = fixed_zero; + let floating_zero = Cobol_ptree.Types.{ float_significand = fixed_zero; float_exponent = "1" } - let boolean_zero = Cobol_ptree.{ bool_base = `Bool; + let boolean_zero = Cobol_ptree.Types.{ bool_base = `Bool; bool_value = "0" } @@ -2118,7 +2118,7 @@ module Default = struct | MenhirInterpreter.N MenhirInterpreter.N_ident_or_nonnumeric_no_all -> raise Not_found | MenhirInterpreter.N MenhirInterpreter.N_ident_or_nonnumeric -> raise Not_found | MenhirInterpreter.N MenhirInterpreter.N_ident_or_nested -> raise Not_found - | MenhirInterpreter.N MenhirInterpreter.N_ident_or_literal -> Cobol_ptree.UPCAST.ident_with_literal dummy_ident + | MenhirInterpreter.N MenhirInterpreter.N_ident_or_literal -> Cobol_ptree.Types.UPCAST.ident_with_literal dummy_ident | MenhirInterpreter.N MenhirInterpreter.N_ident_or_integer -> raise Not_found | MenhirInterpreter.N MenhirInterpreter.N_ident_or_alphanum -> raise Not_found | MenhirInterpreter.N MenhirInterpreter.N_ident_by_after_before -> raise Not_found diff --git a/src/lsp/cobol_parser/grammar_tokens.mly b/src/lsp/cobol_parser/grammar_tokens.mly index c9d843d28..016bc11ad 100644 --- a/src/lsp/cobol_parser/grammar_tokens.mly +++ b/src/lsp/cobol_parser/grammar_tokens.mly @@ -11,13 +11,13 @@ %} %[@recovery.header - let fixed_zero = Cobol_ptree.{ fixed_integer = "0"; + let fixed_zero = Cobol_ptree.Types.{ fixed_integer = "0"; fixed_fractional = "0" } - let floating_zero = Cobol_ptree.{ float_significand = fixed_zero; + let floating_zero = Cobol_ptree.Types.{ float_significand = fixed_zero; float_exponent = "1" } - let boolean_zero = Cobol_ptree.{ bool_base = `Bool; + let boolean_zero = Cobol_ptree.Types.{ bool_base = `Bool; bool_value = "0" } ] @@ -27,10 +27,10 @@ %token WORD [@recovery "_"] (* [@symbol ""] *) %token WORD_IN_AREA_A [@recovery "_"] (* [@symbol ""] *) %token INFO_WORD [@recovery "_"] -%token COMMENT_ENTRY [@recovery ["_"]] -%token ALPHANUM -%token ALPHANUM_PREFIX -%token BOOLIT [@recovery boolean_zero] +%token COMMENT_ENTRY [@recovery ["_"]] +%token ALPHANUM +%token ALPHANUM_PREFIX +%token BOOLIT [@recovery boolean_zero] %token NULLIT [@recovery "_"] %token NATLIT [@recovery "_"] %token SINTLIT [@recovery "0"] diff --git a/src/lsp/cobol_parser/grammar_utils.ml b/src/lsp/cobol_parser/grammar_utils.ml index 317e774e2..2d5f8daa3 100644 --- a/src/lsp/cobol_parser/grammar_utils.ml +++ b/src/lsp/cobol_parser/grammar_utils.ml @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open Cobol_ptree +open Cobol_ptree.Types (* Note: we can share the same source overlay manager across several parsers as long as we don't parse localized tokens using multiple instances of the diff --git a/src/lsp/cobol_parser/grammar_utils.mli b/src/lsp/cobol_parser/grammar_utils.mli index c291060c0..46350bd6f 100644 --- a/src/lsp/cobol_parser/grammar_utils.mli +++ b/src/lsp/cobol_parser/grammar_utils.mli @@ -15,6 +15,6 @@ module Overlay_manager: Cobol_preproc.Src_overlay.MANAGER val relation_condition : neg: bool - -> Cobol_ptree.binary_relation - -> (Cobol_ptree.logop * Cobol_ptree.flat_combined_relation) option - -> Cobol_ptree.condition + -> Cobol_ptree.Types.binary_relation + -> (Cobol_ptree.Types.logop * Cobol_ptree.Types.flat_combined_relation) option + -> Cobol_ptree.Types.condition diff --git a/src/lsp/cobol_parser/text_keywords.ml b/src/lsp/cobol_parser/keywords.ml similarity index 100% rename from src/lsp/cobol_parser/text_keywords.ml rename to src/lsp/cobol_parser/keywords.ml diff --git a/src/lsp/cobol_parser/text_keywords.mli b/src/lsp/cobol_parser/keywords.mli similarity index 100% rename from src/lsp/cobol_parser/text_keywords.mli rename to src/lsp/cobol_parser/keywords.mli diff --git a/src/lsp/cobol_parser/parser_engine.ml b/src/lsp/cobol_parser/main.ml similarity index 89% rename from src/lsp/cobol_parser/parser_engine.ml rename to src/lsp/cobol_parser/main.ml index 87fbcac08..5be32258c 100644 --- a/src/lsp/cobol_parser/parser_engine.ml +++ b/src/lsp/cobol_parser/main.ml @@ -13,10 +13,10 @@ module DIAGS = Cobol_common.Diagnostics -open Cobol_common.Types +open Cobol_common.Diagnostics.TYPES open Cobol_common.Srcloc.INFIX -open Parser_options (* import types for options *) -open Parser_outputs (* import types for outputs *) +open Options (* import types for options *) +open Outputs (* import types for outputs *) module Tokzr = Text_tokenizer module Overlay_manager = Grammar_utils.Overlay_manager @@ -38,20 +38,20 @@ type 'x rewinder = ('x * ('x rewinder)) with_diags; } and preprocessor_rewind = - ?new_position: Lexing.position -> (Cobol_preproc.preprocessor as 'r) -> 'r + ?new_position: Lexing.position -> (Cobol_preproc.Main.preprocessor as 'r) -> 'r and position = | Lexing of Lexing.position | Indexed of { line: int; char: int } (* all starting at 0 *) type 'm simple_parsing = ?options:parser_options - -> Cobol_preproc.preprocessor - -> (Cobol_ptree.compilation_group option, 'm) output DIAGS.with_diags + -> Cobol_preproc.Main.preprocessor + -> (Cobol_ptree.Types.compilation_group option, 'm) output DIAGS.with_diags type 'm rewindable_parsing = ?options:parser_options - -> Cobol_preproc.preprocessor - -> (((Cobol_ptree.compilation_group option, 'm) output as 'x) * + -> Cobol_preproc.Main.preprocessor + -> (((Cobol_ptree.Types.compilation_group option, 'm) output as 'x) * 'x rewinder) DIAGS.with_diags (* --- *) @@ -78,7 +78,7 @@ type 'm state = basis (mostly the pre-processor and tokenizer's states). *) and 'm preproc = { - pp: Cobol_preproc.preprocessor; (* also holds diagnostics *) + pp: Cobol_preproc.Main.preprocessor; (* also holds diagnostics *) tokzr: 'm Tokzr.state; persist: 'm persist; } @@ -94,12 +94,12 @@ and 'm persist = (** Initializes a parser state, given a preprocessor. *) let make_parser - (type m) Parser_options.{ verbose; show; recovery; config } + (type m) Options.{ verbose; show; recovery; config } ?show_if_verbose ~(tokenizer_memory: m memory) pp = let tokzr: m Tokzr.state = let memory: m Tokzr.memory = match tokenizer_memory with - | Parser_options.Amnesic -> Tokzr.amnesic - | Parser_options.Eidetic -> Tokzr.eidetic + | Options.Amnesic -> Tokzr.amnesic + | Options.Eidetic -> Tokzr.eidetic in let module Config = (val config) in Tokzr.init ~verbose ?show_if_verbose ~memory Config.words @@ -130,21 +130,21 @@ and update_tokzr ps tokzr = else { ps with preproc = { ps.preproc with tokzr } } let add_diag diag ({ preproc = { pp; _ }; _ } as ps) = - update_pp ps (Cobol_preproc.add_diag pp diag) + update_pp ps (Cobol_preproc.Main.add_diag pp diag) let add_diags diags ({ preproc = { pp; _ }; _ } as ps) = - update_pp ps (Cobol_preproc.add_diags pp diags) + update_pp ps (Cobol_preproc.Main.add_diags pp diags) let all_diags { preproc = { pp; tokzr; _ }; _ } = - DIAGS.Set.union (Cobol_preproc.diags pp) @@ Tokzr.diagnostics tokzr + DIAGS.Set.union (Cobol_preproc.Main.diags pp) @@ Tokzr.diagnostics tokzr (* --- *) let rec produce_tokens (ps: _ state as 's) : 's * Text_tokenizer.tokens = - let text, pp = Cobol_preproc.next_chunk ps.preproc.pp in + let text, pp = Cobol_preproc.Main.next_chunk ps.preproc.pp in let { preproc = { pp; tokzr; _ }; _ } as ps = update_pp ps pp in assert (text <> []); (* Note: this is the source format in use at the end of the sentence. *) - let source_format = Cobol_preproc.source_format pp in + let source_format = Cobol_preproc.Main.source_format pp in match Tokzr.tokenize_text ~source_format tokzr text with | Error `MissingInputs, tokzr -> produce_tokens (update_tokzr ps tokzr) @@ -396,7 +396,7 @@ let on_exn ps e = let first_stage (ps: 'm state) ~make_checkpoint : ('a, 'm) stage = let ps, tokens = produce_tokens ps in let first_pos = match tokens with - | [] -> Cobol_preproc.position ps.preproc.pp + | [] -> Cobol_preproc.Main.position ps.preproc.pp | t :: _ -> Cobol_common.Srcloc.start_pos ~@t in normal ps tokens (make_checkpoint first_pos) @@ -419,9 +419,9 @@ let aggregate_output (type m) (ps: m state) res | Eidetic -> let artifacts = { tokens = Tokzr.parsed_tokens ps.preproc.tokzr; - pplog = Cobol_preproc.rev_log ps.preproc.pp; - rev_comments = Cobol_preproc.rev_comments ps.preproc.pp; - rev_ignored = Cobol_preproc.rev_ignored ps.preproc.pp } in + pplog = Cobol_preproc.Main.rev_log ps.preproc.pp; + rev_comments = Cobol_preproc.Main.rev_comments ps.preproc.pp; + rev_ignored = Cobol_preproc.Main.rev_ignored ps.preproc.pp } in WithArtifacts (res, artifacts) (** Simple parsing *) @@ -469,7 +469,7 @@ let init_rewindable_parse ps ~make_checkpoint = (** Stores a stage as part of the memorized rewindable history events. *) let save_interim_stage (ps, _, env) (store: _ rewindable_history) = - let preproc_position = Cobol_preproc.position ps.preproc.pp in + let preproc_position = Cobol_preproc.Main.position ps.preproc.pp in match store with | store' when preproc_position.pos_cnum <> preproc_position.pos_bol -> @@ -516,7 +516,7 @@ let find_history_event_preceding ~position ({ store; _ } as rwps) = pos | Indexed { line; char } -> let ps = rewindable_parser_state rwps in - Cobol_preproc.position_at ~line ~char ps.preproc.pp + Cobol_preproc.Main.position_at ~line ~char ps.preproc.pp in let rec aux = function | [] -> @@ -560,7 +560,7 @@ let rec rewind_n_parse let rewindable_parse : options:_ -> memory:'m memory -> make_checkpoint:_ - -> Cobol_preproc.preprocessor + -> Cobol_preproc.Main.preprocessor -> ((('a option, 'm) output as 'x) * 'x rewinder) with_diags = fun ~options ~memory ~make_checkpoint pp -> let res, rwps = @@ -580,9 +580,9 @@ let rewindable_parse let parse (type m) ~(memory: m memory) - ?(options = Parser_options.default) - : Cobol_preproc.preprocessor -> - (Cobol_ptree.compilation_group option, m) output with_diags = + ?(options = Options.default) + : Cobol_preproc.Main.t -> + (Cobol_ptree.Types.compilation_group option, m) output with_diags = parse_once ~options ~memory ~make_checkpoint:Grammar.Incremental.compilation_group @@ -592,9 +592,9 @@ let parse_with_artifacts = parse ~memory:Eidetic let rewindable_parse (type m) ~(memory: m memory) - ?(options = Parser_options.default) - : Cobol_preproc.preprocessor -> - (((Cobol_ptree.compilation_group option, m) output as 'x) * 'x rewinder) + ?(options = Options.default) + : Cobol_preproc.Main.t -> + (((Cobol_ptree.Types.compilation_group option, m) output as 'x) * 'x rewinder) with_diags = rewindable_parse ~options ~memory ~make_checkpoint:Grammar.Incremental.compilation_group @@ -608,3 +608,38 @@ let rewind_and_parse { rewind_n_parse } rewind_preproc ~position = let artifacts : (_, Cobol_common.Behaviors.eidetic) output -> _ = function | WithArtifacts (_, artifacts) -> artifacts + +module INTERNAL = struct + + (** {2 COBOL tokens} *) + + module Tokens = Grammar_tokens + + let pp_token = Text_tokenizer.pp_token + let pp_tokens = Text_tokenizer.pp_tokens + let pp_tokens' = Text_tokenizer.pp_tokens' + + (** {2 COBOL grammar} *) + + module Grammar (* : Grammar_sig.S *) = Grammar + + (** {2 Dummy parser} *) + + (** Parser with dummy source locations, that can be fed directly with a + list of tokens *) + module Dummy = struct + module Tags = struct + let loc = Cobol_common.Srcloc.dummy + end + + let parse_as item toks = + let toks = ref toks + and dummy_lexer = Lexing.from_string ~with_positions:false "" in + item begin fun _ -> match !toks () with + | Seq.Nil -> Grammar_tokens.EOF + | Cons (x, tl) -> toks := tl; x + end dummy_lexer + + let parse_list_as parse lx = parse_as parse (List.to_seq lx) + end +end diff --git a/src/lsp/cobol_parser/parser_engine.mli b/src/lsp/cobol_parser/main.mli similarity index 84% rename from src/lsp/cobol_parser/parser_engine.mli rename to src/lsp/cobol_parser/main.mli index db0525f37..7fa5e18d0 100644 --- a/src/lsp/cobol_parser/parser_engine.mli +++ b/src/lsp/cobol_parser/main.mli @@ -11,8 +11,8 @@ (* *) (**************************************************************************) -open Parser_options -open Parser_outputs +open Options +open Outputs (** Parsing functions essentially parse a stream of tokens that is produced by a given preprocessor (typically returned by @@ -36,9 +36,9 @@ open Parser_outputs (** Simple parsing functions traverse the inputs once to produce a result. *) type 'm simple_parsing - = ?options:Parser_options.parser_options - -> Cobol_preproc.preprocessor - -> (Cobol_ptree.compilation_group option, 'm) output + = ?options:Options.parser_options + -> Cobol_preproc.Main.preprocessor + -> (Cobol_ptree.Types.compilation_group option, 'm) output Cobol_common.Diagnostics.with_diags (* val parse *) @@ -60,8 +60,8 @@ val parse_with_artifacts {!rewinder} that may then be given to {!rewind_and_parse}. *) type 'm rewindable_parsing = ?options:parser_options - -> Cobol_preproc.preprocessor - -> (((Cobol_ptree.compilation_group option, 'm) output as 'x) * 'x rewinder) + -> Cobol_preproc.Main.preprocessor + -> (((Cobol_ptree.Types.compilation_group option, 'm) output as 'x) * 'x rewinder) Cobol_common.Diagnostics.with_diags (** Rewinder for parsing functions that produce results of type ['x] *) @@ -73,7 +73,8 @@ and 'x rewinder [new_position] is not given, the text should be read from the very begining of the input. *) and preprocessor_rewind = - ?new_position:Lexing.position -> (Cobol_preproc.preprocessor as 'r) -> 'r + ?new_position:Lexing.position -> + (Cobol_preproc.Main.t as 'r) -> 'r (* val rewindable_parse *) (* : memory:'m memory -> 'm rewindable_parsing *) @@ -105,10 +106,27 @@ val rewind_and_parse : 'x rewinder -> preprocessor_rewind -> position: position - -> (((Cobol_ptree.compilation_group option, 'm) output as 'x) * 'x rewinder) + -> (((Cobol_ptree.Types.compilation_group option, 'm) output as 'x) * 'x rewinder) Cobol_common.Diagnostics.with_diags (** {1 Accessing artifacts} *) val artifacts : (_, Cobol_common.Behaviors.eidetic) output -> artifacts + +module INTERNAL : sig + + val pp_token : Text_tokenizer.token Pretty.printer + val pp_tokens : Text_tokenizer.tokens Pretty.printer + val pp_tokens' : ?fsep:Pretty.simple -> Text_tokenizer.tokens Pretty.printer + + module Dummy : sig + module Tags : sig + val loc : Cobol_common.Srcloc.t + end + val parse_list_as : (('a -> Grammar.token) -> Lexing.lexbuf -> 'b) -> + Grammar.token list -> 'b +end + + +end diff --git a/src/lsp/cobol_parser/parser_options.ml b/src/lsp/cobol_parser/options.ml similarity index 95% rename from src/lsp/cobol_parser/parser_options.ml rename to src/lsp/cobol_parser/options.ml index a218d9165..8bf991162 100644 --- a/src/lsp/cobol_parser/parser_options.ml +++ b/src/lsp/cobol_parser/options.ml @@ -33,7 +33,7 @@ type parser_options = verbose: bool; show: [`Pending] list; recovery: recovery; - config: Cobol_config.t; + config: Cobol_config.Types.t; } let default_recovery = @@ -44,5 +44,5 @@ let default = verbose = false; show = [`Pending]; recovery = default_recovery; - config = Cobol_config.default; + config = Cobol_config.Config.default; } diff --git a/src/lsp/cobol_parser/parser_outputs.ml b/src/lsp/cobol_parser/outputs.ml similarity index 97% rename from src/lsp/cobol_parser/parser_outputs.ml rename to src/lsp/cobol_parser/outputs.ml index 0d88ed5ad..74bb32cb0 100644 --- a/src/lsp/cobol_parser/parser_outputs.ml +++ b/src/lsp/cobol_parser/outputs.ml @@ -40,4 +40,4 @@ type ('result, 'memo) output = 'result * artifacts -> ('result, Cobol_common.Behaviors.eidetic) output type 'm parsed_compilation_group = - (Cobol_ptree.compilation_group option, 'm) output + (Cobol_ptree.Types.compilation_group option, 'm) output diff --git a/src/lsp/cobol_parser/package.toml b/src/lsp/cobol_parser/package.toml index 57e2bbdb3..382e0fd1e 100644 --- a/src/lsp/cobol_parser/package.toml +++ b/src/lsp/cobol_parser/package.toml @@ -95,7 +95,7 @@ dune-trailer = """ (flags --inspection --table --only-tokens)) (rule - (targets text_keywords.ml) + (targets keywords.ml) (enabled_if (<> %{profile} "release")) (deps grammar.cmly) (mode promote) diff --git a/src/lsp/cobol_parser/text_lexer.ml b/src/lsp/cobol_parser/text_lexer.ml index 233dcbf34..a5949ce37 100644 --- a/src/lsp/cobol_parser/text_lexer.ml +++ b/src/lsp/cobol_parser/text_lexer.ml @@ -86,7 +86,7 @@ let __init_puncts = List.iter begin fun (punct, token) -> Hashtbl.add punct_of_token token punct; Hashtbl.add token_of_punct punct token - end Text_keywords.puncts + end Keywords.puncts let __init_default_keywords = List.iter begin fun (kwd, token) -> @@ -94,10 +94,10 @@ let __init_default_keywords = (* Every default token needs to be reserved explicitly *) Hashtbl.add __token_of_keyword kwd { token; enabled = true; reserved = false } - end Text_keywords.keywords + end Keywords.keywords let silenced_keywords = - StringSet.of_list Text_keywords.silenced_keywords + StringSet.of_list Keywords.silenced_keywords (* --- *) @@ -125,7 +125,7 @@ let reserve_insensitive_token { token_of_keyword; _ } kwd token_handle = let reserve_sensitive_alias { token_of_keyword; _ } kwd token_handle = Hashtbl.add token_of_keyword kwd token_handle -let reserve_words lexer : Cobol_config.words_spec -> unit = +let reserve_words lexer : Cobol_config.Types.words_spec -> unit = let on_token_handle_of kwd descr ~f = try f @@ handle_of_keyword lexer kwd with | Not_found when StringSet.mem kwd silenced_keywords -> @@ -135,7 +135,7 @@ let reserve_words lexer : Cobol_config.words_spec -> unit = in List.iter begin fun (w, word_spec) -> match word_spec with - | Cobol_config.ReserveWord { preserve_context_sensitivity } -> + | Cobol_config.Types.ReserveWord { preserve_context_sensitivity } -> on_token_handle_of w "reserve" ~f:begin fun h -> if preserve_context_sensitivity then reserve_token h diff --git a/src/lsp/cobol_parser/text_lexer.mli b/src/lsp/cobol_parser/text_lexer.mli index 00bd223bc..f714f8ac4 100644 --- a/src/lsp/cobol_parser/text_lexer.mli +++ b/src/lsp/cobol_parser/text_lexer.mli @@ -36,7 +36,7 @@ val punct_of_token : (Grammar_tokens.token, string) Hashtbl.t val create: ?decimal_point_is_comma:bool -> unit -> lexer val handle_of_token: lexer -> Grammar_tokens.token -> token_handle -val reserve_words: lexer -> Cobol_config.words_spec -> unit +val reserve_words: lexer -> Cobol_config.Types.words_spec -> unit val enable_tokens: TokenHandles.t -> unit val disable_tokens: TokenHandles.t -> unit val decimal_point_is_comma: lexer -> lexer @@ -67,7 +67,7 @@ val tokens_of_string' errors, the alphanumeric token returned may represent part of the encoded input. *) val decode_symbolic_ebcdics' - : quotation: Cobol_ptree.alphanum_quote + : quotation: Cobol_ptree.Types.alphanum_quote -> string Cobol_common.Srcloc.with_loc -> Grammar_tokens.token Cobol_common.Srcloc.with_loc * Cobol_common.Diagnostics.Set.t diff --git a/src/lsp/cobol_parser/text_tokenizer.ml b/src/lsp/cobol_parser/text_tokenizer.ml index 847ea807d..b4ed876e6 100644 --- a/src/lsp/cobol_parser/text_tokenizer.ml +++ b/src/lsp/cobol_parser/text_tokenizer.ml @@ -54,7 +54,7 @@ let combined_tokens = NEXT_PAGE, "NEXT_PAGE"; ] -let pp_alphanum_string_prefix ppf Cobol_ptree.{ hexadecimal; quotation; str } = +let pp_alphanum_string_prefix ppf Cobol_ptree.Types.{ hexadecimal; quotation; str } = if hexadecimal then Fmt.char ppf 'X'; match quotation with | Simple_quote -> Fmt.pf ppf "'%s" str @@ -73,10 +73,10 @@ let pp_token_string: Grammar_tokens.token Pretty.printer = fun ppf -> | EIGHTY_EIGHT -> string "88" | FIXEDLIT (i, sep, d) -> print "%s%c%s" i sep d | FLOATLIT (i, sep, d, e) -> print "%s%c%sE%s" i sep d e - | ALPHANUM a -> Cobol_ptree.pp_alphanum_string ppf a + | ALPHANUM a -> Cobol_ptree.Types.pp_alphanum_string ppf a | ALPHANUM_PREFIX a -> pp_alphanum_string_prefix ppf a | NATLIT s -> print "N\"%s\"" s - | BOOLIT b -> print "B\"%a\"" Cobol_ptree.pp_boolean b + | BOOLIT b -> print "B\"%a\"" Cobol_ptree.Types.pp_boolean b | NULLIT s -> print "Z\"%s\"" s | COMMENT_ENTRY e -> print "%a" Fmt.(list ~sep:sp string) e | INTERVENING_ c -> print "%c" c @@ -370,7 +370,7 @@ let tokens_of_word { persist = { lexer; _ }; _ } fun { payload = c; loc } -> let tok t = [t &@ loc], DIAGS.Set.none in let alphanum ~hexadecimal str qte = - Cobol_ptree.{ + Cobol_ptree.Types.{ str; hexadecimal; quotation = match qte with @@ -392,9 +392,9 @@ let tokens_of_word { persist = { lexer; _ }; _ } | Alphanum { knd = Basic; str; qte; _ } -> tok @@ ALPHANUM (alphanum ~hexadecimal:false str qte) | Alphanum { knd = Bool; str; _ } - -> tok @@ BOOLIT (Cobol_ptree.boolean_of_string ~base:`Bool str) + -> tok @@ BOOLIT (Cobol_ptree.Types.boolean_of_string ~base:`Bool str) | Alphanum { knd = BoolX; str; _ } - -> tok @@ BOOLIT (Cobol_ptree.boolean_of_string ~base:`Hex str) + -> tok @@ BOOLIT (Cobol_ptree.Types.boolean_of_string ~base:`Hex str) | Alphanum { knd = Hex; str; qte } -> tok @@ ALPHANUM (alphanum ~hexadecimal:true str qte) | Alphanum { knd = NullTerm; str; _ } diff --git a/src/lsp/cobol_parser/text_tokenizer.mli b/src/lsp/cobol_parser/text_tokenizer.mli index 0acc6b21a..ce011c498 100644 --- a/src/lsp/cobol_parser/text_tokenizer.mli +++ b/src/lsp/cobol_parser/text_tokenizer.mli @@ -16,7 +16,7 @@ (** {2 Compilation group tokens} *) (** Tokens passed to {!Parser}; can be obtained via {!tokenize_text}. *) -type token = Grammar_tokens.token Cobol_ptree.with_loc +type token = Grammar_tokens.token Cobol_ptree.Types.with_loc type tokens = token list val pp_token: token Pretty.printer val pp_tokens: tokens Pretty.printer @@ -48,7 +48,7 @@ val init : ?verbose:bool -> ?show_if_verbose:[> `Tks | `Ctx] list -> memory:'a memory - -> Cobol_config.words_spec + -> Cobol_config.Types.words_spec -> 'a state val diagnostics diff --git a/src/lsp/cobol_preproc/cobol_preproc.ml b/src/lsp/cobol_preproc/cobol_preproc.ml deleted file mode 100644 index ebfd0ea37..000000000 --- a/src/lsp/cobol_preproc/cobol_preproc.ml +++ /dev/null @@ -1,37 +0,0 @@ -(**************************************************************************) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(** {1 Source format} *) - -module Src_format = Src_format - -(** {1 Text} - - "Text" refers to the source after manipulations by preprocessor statements. *) - -module Text = Text -module Text_printer = Text_printer - -(** {1 Miscellaneous support modules} *) - -module Src_overlay = Src_overlay -module Trace = Preproc_trace -module Directives = Preproc_directives - -(** {1 Main entry points for the processor itself} *) - -type input = [%import: Src_input.t] - -module Input = Src_input -module Options = Preproc_options -include Preproc_engine diff --git a/src/lsp/cobol_preproc/preproc_directives.ml b/src/lsp/cobol_preproc/directives.ml similarity index 100% rename from src/lsp/cobol_preproc/preproc_directives.ml rename to src/lsp/cobol_preproc/directives.ml diff --git a/src/lsp/cobol_preproc/preproc_engine.ml b/src/lsp/cobol_preproc/main.ml similarity index 96% rename from src/lsp/cobol_preproc/preproc_engine.ml rename to src/lsp/cobol_preproc/main.ml index fdfffa666..ffe9d56a4 100644 --- a/src/lsp/cobol_preproc/preproc_engine.ml +++ b/src/lsp/cobol_preproc/main.ml @@ -14,7 +14,7 @@ open Cobol_common.Srcloc.TYPES open Cobol_common.Srcloc.INFIX open Cobol_common.Diagnostics.TYPES -open Preproc_options +open Options module DIAGS = Cobol_common.Diagnostics @@ -25,7 +25,7 @@ type preprocessor = buff: Text.t; reader: Src_reader.t; ppstate: Preproc_state.t; - pplog: Preproc_trace.log; + pplog: Trace.log; diags: DIAGS.diagnostics; persist: preprocessor_persist; } @@ -35,15 +35,17 @@ and preprocessor_persist = { pparser: (module Text_processor.PPPARSER); overlay_manager: (module Src_overlay.MANAGER); - replacing: Preproc_directives.replacing with_loc list list; + replacing: Directives.replacing with_loc list list; copybooks: Cobol_common.Srcloc.copylocs; (* opened copybooks *) - dialect: Cobol_config.dialect; + dialect: Cobol_config.Types.dialect; source_format: Src_format.any option; (* to keep auto-detecting on reset *) libpath: string list; verbose: bool; show_if_verbose: [`Txt | `Src] list; } +type t = preprocessor + let diags { diags; reader; _ } = DIAGS.Set.union diags @@ Src_reader.diags reader let add_diag lp d = { lp with diags = DIAGS.Set.cons d lp.diags } let add_diags lp d = { lp with diags = DIAGS.Set.union d lp.diags } @@ -96,7 +98,7 @@ let show tag { persist = { verbose; show_if_verbose; _ }; _ } = verbose && List.mem tag show_if_verbose let source_format_config = function - | Cobol_config.SF sf -> Some (Src_format.from_config sf) + | Cobol_config.Types.SF sf -> Some (Src_format.from_config sf) | Auto -> None let preprocessor input = function @@ -110,7 +112,7 @@ let preprocessor input = function buff = []; reader = Src_reader.from input ?source_format; ppstate = Preproc_state.initial; - pplog = Preproc_trace.empty; + pplog = Trace.empty; diags = DIAGS.Set.none; persist = { @@ -182,8 +184,8 @@ let rec next_chunk ({ reader; buff; persist = { dialect; _ }; _ } as lp) = and apply_compiler_directive ({ reader; pplog; _ } as lp) { payload = compdir; loc } = - let lp = with_pplog lp @@ Preproc_trace.new_compdir ~loc ~compdir pplog in - match (compdir : Preproc_directives.compiler_directive) with + let lp = with_pplog lp @@ Trace.new_compdir ~loc ~compdir pplog in + match (compdir : Directives.compiler_directive) with | CDirSource sf -> (match Src_reader.with_source_format sf reader with | Ok reader -> with_reader lp reader @@ -285,7 +287,7 @@ and do_replace lp rev_prefix repl suffix = replacing phrase. *) apply_active_replacing_full lp @@ List.rev rev_prefix in - let lp = with_pplog lp @@ Preproc_trace.new_replace ~loc pplog in + let lp = with_pplog lp @@ Trace.new_replace ~loc pplog in let lp = match repl, lp.persist.replacing with | CDirReplace { replacing = repl; _ }, ([] as replacing) | CDirReplace { replacing = repl; also = false }, replacing -> @@ -310,7 +312,7 @@ and read_lib ({ persist = { libpath; copybooks; verbose; _ }; _ } as lp) (* TODO: `note addendum *) [], DIAGS.Acc.error lp.diags ~loc "@[Cyclic@ COPY@ of@ `%s'@]" filename, - Preproc_trace.cyclic_copy ~loc ~filename lp.pplog + Trace.cyclic_copy ~loc ~filename lp.pplog | Ok filename -> if verbose then Pretty.error "Reading library `%s'@." filename; @@ -321,12 +323,12 @@ and read_lib ({ persist = { libpath; copybooks; verbose; _ }; _ } as lp) ~postproc:(Cobol_common.Srcloc.copy_from ~filename ~copyloc:loc) end in - text, lp.diags, Preproc_trace.copy_done ~loc ~filename lp.pplog + text, lp.diags, Trace.copy_done ~loc ~filename lp.pplog | Error lnf -> [], DIAGS.Acc.error lp.diags ~loc "%a" Cobol_common.Copybook.pp_lookup_error lnf, - Preproc_trace.missing_copy ~loc ~info:lnf lp.pplog + Trace.missing_copy ~loc ~info:lnf lp.pplog in text, with_diags_n_pplog lp diags pplog @@ -401,7 +403,7 @@ let reset_preprocessor_for_string string ?new_position pp = (* --- *) -let preprocessor ?(options = Preproc_options.default) input = +let preprocessor ?(options = Options.default) input = preprocessor input (`WithOptions options) (** Default pretty-printing formatter for {!lex_file}, {!lex_lib}, and diff --git a/src/lsp/cobol_preproc/preproc_engine.mli b/src/lsp/cobol_preproc/main.mli similarity index 84% rename from src/lsp/cobol_preproc/preproc_engine.mli rename to src/lsp/cobol_preproc/main.mli index 96acbc782..4058dc5a8 100644 --- a/src/lsp/cobol_preproc/preproc_engine.mli +++ b/src/lsp/cobol_preproc/main.mli @@ -14,9 +14,10 @@ open Cobol_common.Srcloc.TYPES type preprocessor +type t = preprocessor val preprocessor - : ?options: Preproc_options.preproc_options + : ?options: Options.preproc_options -> Src_input.t -> preprocessor val reset_preprocessor_for_string @@ -33,7 +34,7 @@ val add_diags: preprocessor -> Cobol_common.Diagnostics.Set.t -> preprocessor val position: preprocessor -> Lexing.position val position_at: line:int -> char: int -> preprocessor -> Lexing.position val source_format: preprocessor -> Src_format.any -val rev_log: preprocessor -> Preproc_trace.log +val rev_log: preprocessor -> Trace.log val rev_comments: preprocessor -> Text.comments val rev_ignored: preprocessor -> lexloc list @@ -42,22 +43,22 @@ val next_chunk: preprocessor -> Text.text * preprocessor (** {2 High-level commands} *) val lex_input - : dialect: Cobol_config.dialect - -> source_format: Cobol_config.source_format_spec + : dialect: Cobol_config.Types.dialect + -> source_format: Cobol_config.Types.source_format_spec -> ?ppf:Format.formatter -> Src_input.t -> unit Cobol_common.Diagnostics.with_diags val lex_file - : dialect: Cobol_config.dialect - -> source_format: Cobol_config.source_format_spec + : dialect: Cobol_config.Types.dialect + -> source_format: Cobol_config.Types.source_format_spec -> ?ppf:Format.formatter -> string -> unit Cobol_common.Diagnostics.with_diags val lex_lib - : dialect: Cobol_config.dialect - -> source_format: Cobol_config.source_format_spec + : dialect: Cobol_config.Types.dialect + -> source_format: Cobol_config.Types.source_format_spec -> libpath:string list -> ?ppf:Format.formatter -> [< `Alphanum | `Word ] * string @@ -83,35 +84,35 @@ val lex_lib Diagnostics resulting from lexing and parsing the input are attached to the returned accumulated value. *) val fold_source_lines - : dialect: Cobol_config.dialect - -> source_format: Cobol_config.source_format_spec + : dialect: Cobol_config.Types.dialect + -> source_format: Cobol_config.Types.source_format_spec -> ?on_initial_source_format: (Src_format.any -> 'a -> 'a) -> ?skip_compiler_directives_text: bool -> ?on_compiler_directive - : (int -> Preproc_directives.compiler_directive with_loc -> 'a -> 'a) + : (int -> Directives.compiler_directive with_loc -> 'a -> 'a) -> f:(int -> Text.text -> 'a -> 'a) -> Src_input.t -> 'a -> 'a Cobol_common.Diagnostics.with_diags val preprocess_input - : ?options: Preproc_options.preproc_options + : ?options: Options.preproc_options -> ?ppf:Format.formatter -> Src_input.t -> unit Cobol_common.Diagnostics.with_diags val preprocess_file - : ?options: Preproc_options.preproc_options + : ?options: Options.preproc_options -> ?ppf:Format.formatter -> string -> unit Cobol_common.Diagnostics.with_diags val text_of_file - : ?options: Preproc_options.preproc_options + : ?options: Options.preproc_options -> string -> Text.t Cobol_common.Diagnostics.with_diags val text_of_input - : ?options: Preproc_options.preproc_options + : ?options: Options.preproc_options -> Src_input.t -> Text.t Cobol_common.Diagnostics.with_diags diff --git a/src/lsp/cobol_preproc/preproc_options.ml b/src/lsp/cobol_preproc/options.ml similarity index 85% rename from src/lsp/cobol_preproc/preproc_options.ml rename to src/lsp/cobol_preproc/options.ml index 2c8e9acc6..ca1884e7c 100644 --- a/src/lsp/cobol_preproc/preproc_options.ml +++ b/src/lsp/cobol_preproc/options.ml @@ -15,14 +15,14 @@ type preproc_options = { verbose: bool; libpath: string list; - config: Cobol_config.t; - source_format: Cobol_config.source_format_spec; + config: Cobol_config.Types.t; + source_format: Cobol_config.Types.source_format_spec; } let default = { verbose = false; libpath = []; - config = Cobol_config.default; - source_format = Cobol_config.Auto; + config = Cobol_config.Config.default; + source_format = Cobol_config.Types.Auto; } diff --git a/src/lsp/cobol_preproc/preproc_grammar.mly b/src/lsp/cobol_preproc/preproc_grammar.mly index 98bbe9bbe..5e21684d8 100644 --- a/src/lsp/cobol_preproc/preproc_grammar.mly +++ b/src/lsp/cobol_preproc/preproc_grammar.mly @@ -10,7 +10,7 @@ (* *) (**************************************************************************) -%parameter +%parameter %parameter %{ open Cobol_common.Srcloc.INFIX @@ -22,10 +22,10 @@ (* Entry points *) -%start copy_statement -%start replace_statement @@ -104,8 +104,8 @@ let copy_replacing_text_identifier := c @ [lpar] @ cl @ [rpar] } let leading_or_trailing == - | LEADING; { Preproc_directives.Leading } - | TRAILING; { Preproc_directives.Trailing } + | LEADING; { Directives.Leading } + | TRAILING; { Directives.Trailing } (* --- REPLACE -------------------------------------------------------------- *) @@ -117,7 +117,7 @@ let replace_statement_ := { result = CDirReplace { also; replacing }; diags } } | REPLACE; last = ibo(LAST); OFF; "."; { Cobol_common.Diagnostics.simple_result @@ - Preproc_directives.CDirReplaceOff { last } } + Directives.CDirReplaceOff { last } } (* ISO/IEC 1989:2014 only allows the following clauses in "REPLACE"; however we allow the same clauses as GnuCOBOL. *) diff --git a/src/lsp/cobol_preproc/preproc_grammar_sig.ml b/src/lsp/cobol_preproc/preproc_grammar_sig.ml index 98b509b78..01ce85e6e 100644 --- a/src/lsp/cobol_preproc/preproc_grammar_sig.ml +++ b/src/lsp/cobol_preproc/preproc_grammar_sig.ml @@ -17,7 +17,7 @@ module type S = sig (* From _build/default/src/cobol_preproc/preproc_grammar.mli *) module Make - (CONFIG: Cobol_config.T) + (CONFIG: Cobol_config.Types.T) (Overlay_manager: Src_overlay.MANAGER) : sig @@ -31,9 +31,9 @@ module type S = sig (* The monolithic API. *) - val replace_statement: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Preproc_directives.replace_statement Cobol_common.Srcloc.with_loc) + val replace_statement: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Directives.replace_statement Cobol_common.Srcloc.with_loc) - val copy_statement: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Preproc_directives.copy_statement Cobol_common.Srcloc.with_loc) + val copy_statement: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (Directives.copy_statement Cobol_common.Srcloc.with_loc) val _unused_symbols: (Lexing.lexbuf -> token) -> Lexing.lexbuf -> (unit) @@ -50,9 +50,9 @@ module type S = sig module Incremental : sig - val replace_statement: Lexing.position -> (Preproc_directives.replace_statement Cobol_common.Srcloc.with_loc) MenhirInterpreter.checkpoint + val replace_statement: Lexing.position -> (Directives.replace_statement Cobol_common.Srcloc.with_loc) MenhirInterpreter.checkpoint - val copy_statement: Lexing.position -> (Preproc_directives.copy_statement Cobol_common.Srcloc.with_loc) MenhirInterpreter.checkpoint + val copy_statement: Lexing.position -> (Directives.copy_statement Cobol_common.Srcloc.with_loc) MenhirInterpreter.checkpoint val _unused_symbols: Lexing.position -> (unit) MenhirInterpreter.checkpoint diff --git a/src/lsp/cobol_preproc/preproc_utils.ml b/src/lsp/cobol_preproc/preproc_utils.ml index 36e156b98..8d41729e0 100644 --- a/src/lsp/cobol_preproc/preproc_utils.ml +++ b/src/lsp/cobol_preproc/preproc_utils.ml @@ -16,7 +16,7 @@ open Cobol_common.Srcloc.INFIX open Cobol_common.Diagnostics.TYPES module DIAGS = Cobol_common.Diagnostics -module Make (Config: Cobol_config.T) = struct +module Make (Config: Cobol_config.Types.T) = struct let safe_partial_replacing_when_src_literal ~loc = Config.safe_partial_replacing_when_src_literal#verify' ~loc:(Some loc) |> diff --git a/src/lsp/cobol_preproc/preproc_utils.mli b/src/lsp/cobol_preproc/preproc_utils.mli index 2ad9f7c30..0b646c0f9 100644 --- a/src/lsp/cobol_preproc/preproc_utils.mli +++ b/src/lsp/cobol_preproc/preproc_utils.mli @@ -14,14 +14,14 @@ open Cobol_common.Srcloc.TYPES open Cobol_common.Diagnostics.TYPES -module Make (Config: Cobol_config.T) : sig +module Make (Config: Cobol_config.Types.T) : sig val replacing' - : ?repl_dir:Preproc_directives.replacing_direction + : ?repl_dir:Directives.replacing_direction -> [< `Alphanum of Text.pseudotext | `PseudoText of Text.pseudotext ] Cobol_common.Srcloc.with_loc -> Text.pseudotext Cobol_common.Srcloc.with_loc - -> Preproc_directives.replacing option Cobol_common.Diagnostics.with_diags + -> Directives.replacing option Cobol_common.Diagnostics.with_diags val filter_map_4_list_with_diags' : 'a option with_diags with_loc list -> 'a with_loc list with_diags diff --git a/src/lsp/cobol_preproc/src_format.ml b/src/lsp/cobol_preproc/src_format.ml index 0a7819bae..e3e2d9b70 100644 --- a/src/lsp/cobol_preproc/src_format.ml +++ b/src/lsp/cobol_preproc/src_format.ml @@ -68,7 +68,7 @@ let equal (* | CBLXIndic, FixedWidth _ (\* when p == cobolx_paging *\) -> SFCOBOLX *) let from_config - : Cobol_config.source_format -> any = function + : Cobol_config.Types.source_format -> any = function | SFFree -> SF ( NoIndic, FreePaging) | SFFixed -> SF (FixedIndic, FixedWidth fixed_paging) | SFVariable -> SF (FixedIndic, FixedWidth variable_paging) @@ -84,7 +84,7 @@ let decypher ~dialect format = (* SOURCEFORMAT"FREE" on MF means: X/Open free format *) (* cf https://www.microfocus.com/documentation/visual-\ cobol/vc50pu7/VS2019/HRLHLHINTR01U008.html *) - | "FREE", Cobol_config.DIALECT.MicroFocus _ -> Ok Cobol_config.SFXOpen + | "FREE", Cobol_config.Types.MicroFocus _ -> Ok Cobol_config.Types.SFXOpen | "FREE", _ -> Ok SFFree | "FIXED", _ -> Ok SFFixed | "VARIABLE", _ -> Ok SFVariable diff --git a/src/lsp/cobol_preproc/src_format.mli b/src/lsp/cobol_preproc/src_format.mli index b4c8e8520..441d7c96e 100644 --- a/src/lsp/cobol_preproc/src_format.mli +++ b/src/lsp/cobol_preproc/src_format.mli @@ -46,10 +46,10 @@ type comment_entry_termination = (* skip until... *) val equal: 'k source_format -> 'r source_format -> bool -val from_config: Cobol_config.source_format -> any +val from_config: Cobol_config.Types.source_format -> any (* val to_config: 'k source_format -> Cobol_config.source_format *) val decypher - : dialect: Cobol_config.dialect + : dialect: Cobol_config.Types.dialect -> string -> (any, [> `SFUnknown of string ]) result val guess_from: contents_prefix: string -> any diff --git a/src/lsp/cobol_unit/cobol_unit.ml b/src/lsp/cobol_preproc/src_input.mli similarity index 76% rename from src/lsp/cobol_unit/cobol_unit.ml rename to src/lsp/cobol_preproc/src_input.mli index 506ba18e0..a42ac71c7 100644 --- a/src/lsp/cobol_unit/cobol_unit.ml +++ b/src/lsp/cobol_preproc/src_input.mli @@ -11,16 +11,13 @@ (* *) (**************************************************************************) -module Qual = Unit_qual -module Qualmap = Unit_qualmap +type t = + | String of { contents: string; filename: string } + | Channel of { ic: in_channel; filename: string } -module Types = struct - include Unit_types - include Unit_group.TYPES -end +(* [string ~filename content] *) +val string : filename:string -> string -> t -module Group = Unit_group -module Procedure = Unit_procedure -module Collections = Unit_collections -module Printer = Unit_printer -module Visitor = Unit_visitor +val channel : filename:string -> in_channel -> t + +val from : filename:string -> f:(t -> 'a) -> 'a diff --git a/src/lsp/cobol_preproc/src_reader.ml b/src/lsp/cobol_preproc/src_reader.ml index 3c9103466..1e6bdd511 100644 --- a/src/lsp/cobol_preproc/src_reader.ml +++ b/src/lsp/cobol_preproc/src_reader.ml @@ -83,20 +83,20 @@ let decode_compiler_directive ~dialect compdir_text = let start_pos = Cobol_common.Srcloc.start_pos loc in let parser = Compdir_grammar.Incremental.compiler_directive start_pos in let raw_loc = Cobol_common.Srcloc.raw in - let open Preproc_directives in + let open Directives in match Compdir_grammar.MenhirInterpreter.loop supplier parser with | Source_format_is_free lexloc -> - let sf = Src_format.from_config Cobol_config.SFFree in + let sf = Src_format.from_config Cobol_config.Types.SFFree in Ok (CDirSource (sf &@ raw_loc lexloc) &@ loc) | Source_format_is (format, lexloc) | Set_sourceformat (format, lexloc) -> (match Src_format.decypher ~dialect format with | Ok sf -> - Ok (Preproc_directives.CDirSource (sf &@ raw_loc lexloc) &@ loc) + Ok (Directives.CDirSource (sf &@ raw_loc lexloc) &@ loc) | Error (`SFUnknown f) -> Error (Unknown_source_format (f, raw_loc lexloc))) | Set (string, lexloc) -> - Ok (Preproc_directives.CDirSet (string &@ raw_loc lexloc) &@ loc) + Ok (Directives.CDirSet (string &@ raw_loc lexloc) &@ loc) | exception Compdir_grammar.Error -> Error (Malformed_or_unknown_compiler_directive loc) diff --git a/src/lsp/cobol_preproc/src_reader.mli b/src/lsp/cobol_preproc/src_reader.mli index e19f12533..3ae86a2a5 100644 --- a/src/lsp/cobol_preproc/src_reader.mli +++ b/src/lsp/cobol_preproc/src_reader.mli @@ -33,21 +33,21 @@ val rev_newline_cnums: t -> int list val next_chunk: t -> t * Text.t val fold_lines - : dialect: Cobol_config.dialect + : dialect: Cobol_config.Types.dialect -> ?skip_compiler_directives_text: bool -> ?on_compiler_directive - : (int -> Preproc_directives.compiler_directive with_loc -> 'a -> 'a) + : (int -> Directives.compiler_directive with_loc -> 'a -> 'a) -> f:(int -> Text.t -> 'a -> 'a) -> t -> 'a -> 'a val print_lines - : dialect: Cobol_config.dialect + : dialect: Cobol_config.Types.dialect -> ?skip_compiler_directives_text: bool -> Format.formatter -> t -> unit val try_compiler_directive - : dialect: Cobol_config.dialect -> Text.t - -> ((Text.t * Preproc_directives.compiler_directive with_loc * Text.t) option, + : dialect: Cobol_config.Types.dialect -> Text.t + -> ((Text.t * Directives.compiler_directive with_loc * Text.t) option, Text.t * Preproc_diagnostics.error * Text.t) result (** {1 Change of source format} *) diff --git a/src/lsp/cobol_preproc/text_processor.ml b/src/lsp/cobol_preproc/text_processor.ml index a8735a103..e6e9774f5 100644 --- a/src/lsp/cobol_preproc/text_processor.ml +++ b/src/lsp/cobol_preproc/text_processor.ml @@ -15,8 +15,8 @@ open Cobol_common.Srcloc.TYPES open Cobol_common.Srcloc.INFIX open Cobol_common.Diagnostics.TYPES open Text.TYPES -open Preproc_directives (* import types of directives *) -open Preproc_trace (* import types of log events *) +open Directives (* import types of directives *) +open Trace (* import types of log events *) module DIAGS = Cobol_common.Diagnostics @@ -378,11 +378,11 @@ let apply_replacing k repl log = fun k done_text log text -> match k, try_replacing_phrase k repl text, text with | OnPartText, Ok (done_text', le, []), _ -> - Ok (done_text @ done_text', Preproc_trace.append le log) + Ok (done_text @ done_text', Trace.append le log) | OnFullText, Ok (done_text', le, []), _ -> - done_text @ done_text', Preproc_trace.append le log + done_text @ done_text', Trace.append le log | _, Ok (done_text', le, text), _ -> - aux k (done_text @ done_text') (Preproc_trace.append le log) text + aux k (done_text @ done_text') (Trace.append le log) text | OnPartText, Error `MissingText, _ -> Error (`MissingText (done_text, log, text)) | OnPartText, Error `NoReplacement, [] -> diff --git a/src/lsp/cobol_preproc/text_processor.mli b/src/lsp/cobol_preproc/text_processor.mli index 6b76befb7..e113a523e 100644 --- a/src/lsp/cobol_preproc/text_processor.mli +++ b/src/lsp/cobol_preproc/text_processor.mli @@ -20,23 +20,23 @@ open Text.TYPES (** {1 Compiler directives} *) val replacing - : ?partial: Preproc_directives.partial_replacing + : ?partial: Directives.partial_replacing -> pseudotext with_loc -> pseudotext with_loc - -> Preproc_directives.replacing option with_diags + -> Directives.replacing option with_diags type (_, _) repl_attempt = | OnPartText: ([`NoReplacement | `MissingText], partial_text_repl_result) repl_attempt | OnFullText: ([`NoReplacement], - text * Preproc_trace.log) repl_attempt + text * Trace.log) repl_attempt and partial_text_repl_result = - (text * Preproc_trace.log, - [`MissingText of text * Preproc_trace.log * text]) result + (text * Trace.log, + [`MissingText of text * Trace.log * text]) result val apply_replacing : (_, 'a) repl_attempt - -> Preproc_directives.replacing with_loc list - -> Preproc_trace.log + -> Directives.replacing with_loc list + -> Trace.log -> text -> 'a @@ -45,9 +45,9 @@ val apply_replacing module type ENTRY_POINTS = sig type 'x entry val replace_statement - : Preproc_directives.replace_statement with_diags with_loc entry + : Directives.replace_statement with_diags with_loc entry val copy_statement - : Preproc_directives.copy_statement with_diags with_loc entry + : Directives.copy_statement with_diags with_loc entry end module type PPPARSER = sig diff --git a/src/lsp/cobol_preproc/preproc_trace.ml b/src/lsp/cobol_preproc/trace.ml similarity index 97% rename from src/lsp/cobol_preproc/preproc_trace.ml rename to src/lsp/cobol_preproc/trace.ml index c4722d8cf..2bf51207e 100644 --- a/src/lsp/cobol_preproc/preproc_trace.ml +++ b/src/lsp/cobol_preproc/trace.ml @@ -31,7 +31,7 @@ module TYPES = struct } | CompilerDirective of { - compdir: Preproc_directives.compiler_directive; + compdir: Directives.compiler_directive; loc: srcloc; } diff --git a/src/lsp/cobol_preproc/preproc_trace.mli b/src/lsp/cobol_preproc/trace.mli similarity index 79% rename from src/lsp/cobol_preproc/preproc_trace.mli rename to src/lsp/cobol_preproc/trace.mli index 92816c69f..e48cf9b1a 100644 --- a/src/lsp/cobol_preproc/preproc_trace.mli +++ b/src/lsp/cobol_preproc/trace.mli @@ -12,22 +12,22 @@ module TYPES: sig type log_entry = | FileCopy of { - copyloc: Cobol_common.srcloc; + copyloc: Cobol_common.Srcloc.t; status: copy_event_status; } | Replace of { - replloc: Cobol_common.srcloc; + replloc: Cobol_common.Srcloc.t; } | Replacement of { - matched_loc: Cobol_common.srcloc; + matched_loc: Cobol_common.Srcloc.t; replacement_text: Text.text; } | CompilerDirective of { - compdir: Preproc_directives.compiler_directive; - loc: Cobol_common.srcloc; + compdir: Directives.compiler_directive; + loc: Cobol_common.Srcloc.t; } and copy_event_status = @@ -48,23 +48,23 @@ val append : log_entry -> log -> log val new_compdir - : loc: Cobol_common.srcloc - -> compdir:Preproc_directives.compiler_directive + : loc: Cobol_common.Srcloc.t + -> compdir:Directives.compiler_directive -> log -> log val copy_done - : loc: Cobol_common.srcloc + : loc: Cobol_common.Srcloc.t -> filename: string -> log -> log val cyclic_copy - : loc: Cobol_common.srcloc + : loc: Cobol_common.Srcloc.t -> filename: string -> log -> log val missing_copy - : loc: Cobol_common.srcloc + : loc: Cobol_common.Srcloc.t -> info: Cobol_common.Copybook.lookup_info -> log -> log val new_replace - : loc: Cobol_common.srcloc + : loc: Cobol_common.Srcloc.t -> log -> log (* --- *) diff --git a/src/lsp/cobol_ptree/compilation_group_visitor.ml b/src/lsp/cobol_ptree/compilation_group_visitor.ml index aaba91f07..1bc171d6f 100644 --- a/src/lsp/cobol_ptree/compilation_group_visitor.ml +++ b/src/lsp/cobol_ptree/compilation_group_visitor.ml @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open PTree_types +open Types open Cobol_common.Srcloc.TYPES open Cobol_common.Srcloc.INFIX diff --git a/src/lsp/cobol_ptree/data_division_visitor.ml b/src/lsp/cobol_ptree/data_division_visitor.ml index 3420d0095..af9e425bb 100644 --- a/src/lsp/cobol_ptree/data_division_visitor.ml +++ b/src/lsp/cobol_ptree/data_division_visitor.ml @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open PTree_types +open Types open Cobol_common.Visitor open Cobol_common.Visitor.INFIX (* for `>>` (== `|>`) *) diff --git a/src/lsp/cobol_ptree/data_sections_visitor.ml b/src/lsp/cobol_ptree/data_sections_visitor.ml index cea11e39e..b7ea608c4 100644 --- a/src/lsp/cobol_ptree/data_sections_visitor.ml +++ b/src/lsp/cobol_ptree/data_sections_visitor.ml @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open PTree_types +open Types open Cobol_common.Srcloc.INFIX open Cobol_common.Visitor diff --git a/src/lsp/cobol_ptree/pTree_dummies.ml b/src/lsp/cobol_ptree/dummies.ml similarity index 99% rename from src/lsp/cobol_ptree/pTree_dummies.ml rename to src/lsp/cobol_ptree/dummies.ml index c87ae467f..22a48686c 100644 --- a/src/lsp/cobol_ptree/pTree_dummies.ml +++ b/src/lsp/cobol_ptree/dummies.ml @@ -14,7 +14,7 @@ (** Defines some dummy nodes that can be used to fill in missing parts of the parse tree. *) -open PTree_types +open Types open Cobol_common.Srcloc.INFIX let dummy_loc = diff --git a/src/lsp/cobol_ptree/misc_sections_visitor.ml b/src/lsp/cobol_ptree/misc_sections_visitor.ml index 0aad5b8d2..24e40c320 100644 --- a/src/lsp/cobol_ptree/misc_sections_visitor.ml +++ b/src/lsp/cobol_ptree/misc_sections_visitor.ml @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open PTree_types +open Types open Cobol_common.Srcloc.TYPES open Cobol_common.Visitor diff --git a/src/lsp/cobol_ptree/proc_division_visitor.ml b/src/lsp/cobol_ptree/proc_division_visitor.ml index 55b22b53a..0bdd96f3f 100644 --- a/src/lsp/cobol_ptree/proc_division_visitor.ml +++ b/src/lsp/cobol_ptree/proc_division_visitor.ml @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open PTree_types +open Types open Cobol_common.Srcloc.TYPES open Cobol_common.Visitor diff --git a/src/lsp/cobol_ptree/statements_visitor.ml b/src/lsp/cobol_ptree/statements_visitor.ml index 5b11ff47e..f78af68c8 100644 --- a/src/lsp/cobol_ptree/statements_visitor.ml +++ b/src/lsp/cobol_ptree/statements_visitor.ml @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open PTree_types +open Types open Cobol_common.Srcloc.INFIX open Cobol_common.Visitor diff --git a/src/lsp/cobol_ptree/pTree_types.ml b/src/lsp/cobol_ptree/types.ml similarity index 100% rename from src/lsp/cobol_ptree/pTree_types.ml rename to src/lsp/cobol_ptree/types.ml diff --git a/src/lsp/cobol_typeck/cobol_typeck.ml b/src/lsp/cobol_typeck/cobol_typeck.ml deleted file mode 100644 index 5c55e878f..000000000 --- a/src/lsp/cobol_typeck/cobol_typeck.ml +++ /dev/null @@ -1,24 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 OLD = struct - include Old_typeck_engine - - module Env_builder = Old_env_builder - module Group_builder = Old_group_builder - module Prog_builder = Old_prog_builder -end - -module Outputs = Typeck_outputs -module Diagnostics = Typeck_diagnostics -include Typeck_engine diff --git a/src/lsp/cobol_typeck/cobol_typeck.mli b/src/lsp/cobol_typeck/cobol_typeck.mli deleted file mode 100644 index d8f007477..000000000 --- a/src/lsp/cobol_typeck/cobol_typeck.mli +++ /dev/null @@ -1,28 +0,0 @@ -(**************************************************************************) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(** Type-checking and validation of COBOL compilation groups *) - -module OLD: sig - include module type of Old_typeck_engine - - (** {1 Access to independent builder modules} *) - - module Env_builder = Old_env_builder - module Group_builder = Old_group_builder - module Prog_builder = Old_prog_builder -end - -module Outputs = Typeck_outputs -module Diagnostics = Typeck_diagnostics -include module type of Typeck_engine diff --git a/src/lsp/cobol_typeck/cobol_validation.ml b/src/lsp/cobol_typeck/cobol_validation.ml index fcc031d05..b66a6913e 100644 --- a/src/lsp/cobol_typeck/cobol_validation.ml +++ b/src/lsp/cobol_typeck/cobol_validation.ml @@ -14,14 +14,14 @@ (* open Cobol_common.Srcloc.TYPES *) (* open Cobol_data.Pictured_ast.Data_sections *) module DIAGS = Cobol_common.Diagnostics -open Cobol_ptree +open Cobol_ptree.Types (* exception SemanticError of string * srcloc *) (* This follows the 85 standard and IBM dialect specification. *) let validate_data_clauses ?(is_elementary = false) - Cobol_ptree.{ payload = Cobol_ptree.{ data_clauses; _ }; loc } + Cobol_ptree.Types.{ payload = Cobol_ptree.Types.{ data_clauses; _ }; loc } = (* This does not generalize well to other mutual exclusion constraints. diff --git a/src/lsp/cobol_typeck/cobol_validation.mli b/src/lsp/cobol_typeck/cobol_validation.mli index c59b3b909..c92e54f7f 100644 --- a/src/lsp/cobol_typeck/cobol_validation.mli +++ b/src/lsp/cobol_typeck/cobol_validation.mli @@ -15,5 +15,5 @@ val validate_data_clauses : ?is_elementary: bool - -> Cobol_ptree.data_item Cobol_ptree.with_loc + -> Cobol_ptree.Types.data_item Cobol_ptree.Types.with_loc -> Cobol_common.Diagnostics.Set.t diff --git a/src/lsp/cobol_typeck/typeck_diagnostics.ml b/src/lsp/cobol_typeck/diagnostics.ml similarity index 98% rename from src/lsp/cobol_typeck/typeck_diagnostics.ml rename to src/lsp/cobol_typeck/diagnostics.ml index 25eb1e41b..e28de566a 100644 --- a/src/lsp/cobol_typeck/typeck_diagnostics.ml +++ b/src/lsp/cobol_typeck/diagnostics.ml @@ -23,7 +23,7 @@ type diagnostic = | Proc_error of Typeck_procedure_diagnostics.error | Dialect_feature_used of { - feature: unit Cobol_config.feature; + feature: unit Cobol_config.Types.feature; usage_loc: srcloc; } diff --git a/src/lsp/cobol_typeck/typeck_engine.ml b/src/lsp/cobol_typeck/engine.ml similarity index 84% rename from src/lsp/cobol_typeck/typeck_engine.ml rename to src/lsp/cobol_typeck/engine.ml index 7548c40db..b5da1546d 100644 --- a/src/lsp/cobol_typeck/typeck_engine.ml +++ b/src/lsp/cobol_typeck/engine.ml @@ -17,12 +17,12 @@ module DIAGS = Cobol_common.Diagnostics let compilation_group (type m) : ?config: _ -> m Cobol_parser.Outputs.parsed_compilation_group -> _ = - fun ?(config = Cobol_config.default) -> + fun ?(config = Cobol_config.Config.default) -> function | Only None | WithArtifacts (None, _) -> - Typeck_outputs.none, Typeck_diagnostics.none + Outputs.none, Diagnostics.none | Only Some cg | WithArtifacts (Some cg, _) -> Typeck_units.of_compilation_group config cg -let translate_diagnostics ?(config = Cobol_config.default) (output, diags) = - DIAGS.result output ~diags:(Typeck_diagnostics.translate ~config diags) +let translate_diagnostics ?(config = Cobol_config.Config.default) (output, diags) = + DIAGS.result output ~diags:(Diagnostics.translate ~config diags) diff --git a/src/lsp/cobol_typeck/typeck_engine.mli b/src/lsp/cobol_typeck/engine.mli similarity index 83% rename from src/lsp/cobol_typeck/typeck_engine.mli rename to src/lsp/cobol_typeck/engine.mli index ca43fe17b..2341c58a9 100644 --- a/src/lsp/cobol_typeck/typeck_engine.mli +++ b/src/lsp/cobol_typeck/engine.mli @@ -12,11 +12,11 @@ (**************************************************************************) val compilation_group - : ?config: Cobol_config.t + : ?config: Cobol_config.Types.t -> _ Cobol_parser.Outputs.parsed_compilation_group - -> Typeck_outputs.t * Typeck_diagnostics.t + -> Outputs.t * Diagnostics.t val translate_diagnostics - : ?config: Cobol_config.t - -> Typeck_outputs.t * Typeck_diagnostics.t - -> Typeck_outputs.t Cobol_common.Diagnostics.with_diags + : ?config: Cobol_config.Types.t + -> Outputs.t * Diagnostics.t + -> Outputs.t Cobol_common.Diagnostics.with_diags diff --git a/src/lsp/cobol_typeck/typeck_outputs.ml b/src/lsp/cobol_typeck/outputs.ml similarity index 95% rename from src/lsp/cobol_typeck/typeck_outputs.ml rename to src/lsp/cobol_typeck/outputs.ml index ef55f7b85..b14c47b7c 100644 --- a/src/lsp/cobol_typeck/typeck_outputs.ml +++ b/src/lsp/cobol_typeck/outputs.ml @@ -30,8 +30,8 @@ type artifacts = type outputs = { - ptree: Cobol_ptree.compilation_group; - group: Cobol_unit.Types.group; + ptree: Cobol_ptree.Types.compilation_group; + group: Cobol_unit.Group.TYPES.group; artifacts: artifacts; } type t = outputs @@ -51,7 +51,7 @@ let no_artifacts: artifacts = let none: t = { - ptree = Cobol_ptree.{ control_division = None; + ptree = Cobol_ptree.Types.{ control_division = None; compilation_units = [] }; group = Cobol_unit.Group.empty; artifacts = no_artifacts; diff --git a/src/lsp/cobol_typeck/typeck_clauses.ml b/src/lsp/cobol_typeck/typeck_clauses.ml index db1c4da99..0beaa8e9f 100644 --- a/src/lsp/cobol_typeck/typeck_clauses.ml +++ b/src/lsp/cobol_typeck/typeck_clauses.ml @@ -14,17 +14,17 @@ open Cobol_data.Types open Cobol_common.Srcloc.TYPES open Cobol_common.Srcloc.INFIX -open Typeck_diagnostics +open Diagnostics module PIC = Cobol_data.Picture type data_clauses = { - occurs: Cobol_ptree.data_occurs_clause with_loc option; - usage: Cobol_ptree.usage_clause with_loc option; - picture: Cobol_ptree.picture_clause with_loc option; - value: Cobol_ptree.data_value_clause with_loc option; - redefines: Cobol_ptree.name with_loc option; + occurs: Cobol_ptree.Types.data_occurs_clause with_loc option; + usage: Cobol_ptree.Types.usage_clause with_loc option; + picture: Cobol_ptree.Types.picture_clause with_loc option; + value: Cobol_ptree.Types.data_value_clause with_loc option; + redefines: Cobol_ptree.Types.name with_loc option; clause_diags: diagnostics; } @@ -97,9 +97,9 @@ let on_redefines_clause acc = end -let of_data_item (data_clauses: Cobol_ptree.data_clause with_loc list) = +let of_data_item (data_clauses: Cobol_ptree.Types.data_clause with_loc list) = List.fold_left begin fun acc { payload = clause; loc } -> - match (clause: Cobol_ptree.data_clause) with + match (clause: Cobol_ptree.Types.data_clause) with | DataOccurs o -> on_occurs_clause acc (o &@ loc) | DataRedefines r -> on_redefines_clause acc (r &@ loc) | DataUsage u -> on_usage_clause acc (u &@ loc) @@ -113,7 +113,7 @@ let of_data_item (data_clauses: Cobol_ptree.data_clause with_loc list) = let translate_picture_clause ~picture_config - { payload = Cobol_ptree.{ picture; + { payload = Cobol_ptree.Types.{ picture; picture_locale = _; picture_depending = _ }; loc = _ } = match PIC.(of_string picture_config ~&picture) with @@ -128,7 +128,7 @@ let translate_picture_clause Result.error -let display_usage_from_literal: Cobol_ptree.literal -> usage = +let display_usage_from_literal: Cobol_ptree.Types.literal -> usage = (* TODO: `Display|`National *) let detect_sign i = if EzString.starts_with ~prefix:"-" i @@ -163,12 +163,12 @@ let ensure_picture diags `Boolean_class | `Nonalpha_class | `Any_class] = `Any_class) - ~(usage_clause: Cobol_ptree.usage_clause) picture = + ~(usage_clause: Cobol_ptree.Types.usage_clause) picture = let pic = match picture with | Some Ok pic -> Ok pic | Some Error pic -> (* grab the raw length for now *) - Error (`Length (String.length ~&(~&pic.Cobol_ptree.picture))) + Error (`Length (String.length ~&(~&pic.Cobol_ptree.Types.picture))) | None -> Error `None in @@ -213,7 +213,7 @@ let ensure_picture diags let auto_usage diags ~usage_clause picture = - match (usage_clause: Cobol_ptree.usage_clause) with + match (usage_clause: Cobol_ptree.Types.usage_clause) with | Binary -> let diags, picture = ensure_picture diags ~only:`Numeric_category ~usage_clause picture in @@ -269,11 +269,11 @@ let to_usage_n_value ~item_name ~item_loc ~picture_config item_clauses = Display (* TODO: NATIONAL in case value is a natlit *) in let signedness s = - Cobol_data.Types.{ signed = s <> Some Cobol_ptree.Unsigned } + Cobol_data.Types.{ signed = s <> Some Cobol_ptree.Types.Unsigned } and endian = (* TODO: set default via FLOAT-BINARY in OPTIONS paragraph *) - Option.value ~default:Cobol_ptree.HighOrderLeft + Option.value ~default:Cobol_ptree.Types.HighOrderLeft and encoding = (* TODO: set default via FLOAT-DECIMAL in OPTIONS paragraph *) - Option.value ~default:Cobol_ptree.DecimalEncoding + Option.value ~default:Cobol_ptree.Types.DecimalEncoding in let diags, usage = match usage_clause with diff --git a/src/lsp/cobol_typeck/typeck_config.ml b/src/lsp/cobol_typeck/typeck_config.ml index 198b79c18..55d2d1c66 100644 --- a/src/lsp/cobol_typeck/typeck_config.ml +++ b/src/lsp/cobol_typeck/typeck_config.ml @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open Cobol_ptree +open Cobol_ptree.Types open Cobol_common.Srcloc.INFIX module Visitor = Cobol_common.Visitor @@ -23,7 +23,7 @@ type output = Cobol_unit.Types.unit_config type acc = { config: output; - diags: Typeck_diagnostics.t; + diags: Diagnostics.t; } let default_config = @@ -35,7 +35,7 @@ let default_config = let init config = { config; - diags = Typeck_diagnostics.none; + diags = Diagnostics.none; } let error acc e = { acc with diags = Config_error e :: acc.diags } diff --git a/src/lsp/cobol_typeck/typeck_config.mli b/src/lsp/cobol_typeck/typeck_config.mli index b7821991a..f30f9d200 100644 --- a/src/lsp/cobol_typeck/typeck_config.mli +++ b/src/lsp/cobol_typeck/typeck_config.mli @@ -17,5 +17,5 @@ type output = Cobol_unit.Types.unit_config val of_compilation_unit : ?parent_config:Cobol_unit.Types.unit_config - -> Cobol_ptree.compilation_unit with_loc - -> output * Typeck_diagnostics.t + -> Cobol_ptree.Types.compilation_unit with_loc + -> output * Diagnostics.t diff --git a/src/lsp/cobol_typeck/typeck_data_diagnostics.ml b/src/lsp/cobol_typeck/typeck_data_diagnostics.ml index bf85ee7ba..29fe69d98 100644 --- a/src/lsp/cobol_typeck/typeck_data_diagnostics.ml +++ b/src/lsp/cobol_typeck/typeck_data_diagnostics.ml @@ -46,7 +46,7 @@ type error = | Unexpected_redefinition_level of { redef_loc: srcloc; - redef_name: Cobol_ptree.data_name with_loc option; + redef_name: Cobol_ptree.Types.data_name with_loc option; redef_level: int with_loc; expected_level: int; expected_redefined_loc: srcloc; @@ -54,39 +54,39 @@ type error = | Unexpected_redefinition_name of { redef_loc: srcloc; - redef_name: Cobol_ptree.data_name with_loc option; - redef_redefines: Cobol_ptree.name with_loc; + redef_name: Cobol_ptree.Types.data_name with_loc option; + redef_redefines: Cobol_ptree.Types.name with_loc; expected_name: string; } | Redefinition_of_ODO_item of { redef_loc: srcloc; - redef_name: Cobol_ptree.data_name with_loc option; - redef_redefines: Cobol_ptree.name with_loc; + redef_name: Cobol_ptree.Types.data_name with_loc option; + redef_redefines: Cobol_ptree.Types.name with_loc; odo_item: (* (_, [>`variable_length]) *)Cobol_data.Types.item_definition with_loc; - (* odo_item_name: Cobol_ptree.qualname with_loc option; *) + (* odo_item_name: Cobol_ptree.Types.qualname with_loc option; *) } | Missing_picture_clause_for_elementary_item of { - item_name: Cobol_ptree.data_name with_loc option; + item_name: Cobol_ptree.Types.data_name with_loc option; item_loc: srcloc; } | Unexpected_picture_clause of { - picture: Cobol_ptree.picture_clause with_loc; + picture: Cobol_ptree.Types.picture_clause with_loc; reason: [`Group_item | - `Item_with_usage of Cobol_ptree.usage_clause ]; - item_name: Cobol_ptree.data_name with_loc option; + `Item_with_usage of Cobol_ptree.Types.usage_clause ]; + item_name: Cobol_ptree.Types.data_name with_loc option; item_loc: srcloc; } | Unexpected_table_value_clause of { - item_name: Cobol_ptree.data_name with_loc option; + item_name: Cobol_ptree.Types.data_name with_loc option; value_loc: srcloc; } | Occurs_in_rename_operand of { - operand: Cobol_ptree.qualname with_loc; + operand: Cobol_ptree.Types.qualname with_loc; field: Cobol_data.Types.field_definition with_loc; } | Invalid_renaming_range of @@ -98,7 +98,7 @@ type error = | Invalid_renaming_of_variable_length_range of { loc: srcloc; - depending_vars: Cobol_ptree.qualname NEL.t; + depending_vars: Cobol_ptree.Types.qualname NEL.t; } | Picture_error of { @@ -108,12 +108,12 @@ type error = | Incompatible_picture of { picture: Cobol_data.Picture.t with_loc; - usage_clause: Cobol_ptree.usage_clause; + usage_clause: Cobol_ptree.Types.usage_clause; expected: [`Numeric_category | `Boolean_class | `Nonalpha_class]; } | Item_not_found of { - qualname: Cobol_ptree.qualname with_loc; + qualname: Cobol_ptree.Types.qualname with_loc; } | Misplaced of { @@ -131,16 +131,16 @@ and warning = | Redefinition_of_table_item of (* in GnuCOBOL that's a warning as well *) { redef_loc: srcloc; - redef_name: Cobol_ptree.data_name with_loc option; - redef_redefines: Cobol_ptree.name with_loc; - table_item_name: Cobol_ptree.qualname with_loc option; + redef_name: Cobol_ptree.Types.data_name with_loc option; + redef_redefines: Cobol_ptree.Types.name with_loc; + table_item_name: Cobol_ptree.Types.qualname with_loc option; (* table_item: (\* ([>`table], _) *\)Cobol_data.Types.item_definition with_loc; *) } | Mismatching_usage_in_group of (* not enforced by GnuCOBOL *) { - item_name: Cobol_ptree.data_name with_loc option; - item_usage: Cobol_ptree.usage_clause with_loc; - group_usage: Cobol_ptree.usage_clause with_loc; + item_name: Cobol_ptree.Types.data_name with_loc option; + item_usage: Cobol_ptree.Types.usage_clause with_loc; + group_usage: Cobol_ptree.Types.usage_clause with_loc; } | Duplicate_clause of { @@ -191,7 +191,7 @@ let warning_loc = function Some loc let pp_data_name'_opt - : Cobol_ptree.data_name with_loc option Pretty.printer + : Cobol_ptree.Types.data_name with_loc option Pretty.printer = fun ppf -> function | Some { payload = DataName n; _ } -> Pretty.print ppf "item '%s'" ~&n @@ -207,7 +207,7 @@ let pp_error ppf = function Pretty.print ppf "PICTURE@ of@ category@ %a@ is@ incompatible@ with@ \ USAGE@ %a; expected@ a@ PICTURE@ for@ %(%)@ data@ item" Cobol_data.Picture.pp_category_name ~&picture.category - Cobol_ptree.pp_usage_clause usage_clause + Cobol_ptree.Types.pp_usage_clause usage_clause (match expected with | `Numeric_category -> "numeric" | `Boolean_class -> "boolean" @@ -243,27 +243,27 @@ let pp_error ppf = function pp_data_name'_opt item_name | Unexpected_picture_clause { item_name; reason = `Item_with_usage u; _ } -> Pretty.print ppf "Unexpected@ PICTURE@ clause@ for@ %a@ with@ USAGE@ %a" - pp_data_name'_opt item_name Cobol_ptree.pp_usage_clause u + pp_data_name'_opt item_name Cobol_ptree.Types.pp_usage_clause u | Unexpected_table_value_clause { item_name; _ } -> Pretty.print ppf "Unexpected@ table@ VALUE@ clause@ for@ %a" pp_data_name'_opt item_name | Occurs_in_rename_operand { operand; _ } -> Pretty.print ppf "RENAMES@ operand@ '%a'@ has@ or@ is@ subordinate@ to@ \ an@ OCCURS@ clause" - Cobol_ptree.pp_qualname' operand + Cobol_ptree.Types.pp_qualname' operand | Invalid_renaming_range { from_field; thru_field; _ } -> Pretty.print ppf "Invalid@ pair@ of@ RENAMES@ operands: first@ field@ %a@ \ should@ precede@ second@ field@ %a" - (Fmt.option Cobol_ptree.pp_qualname') ~&from_field.field_qualname - (Fmt.option Cobol_ptree.pp_qualname') ~&thru_field.field_qualname + (Fmt.option Cobol_ptree.Types.pp_qualname') ~&from_field.field_qualname + (Fmt.option Cobol_ptree.Types.pp_qualname') ~&thru_field.field_qualname | Invalid_renaming_of_variable_length_range { depending_vars = vars; _ } -> Pretty.print ppf "Renaming@ of@ variable-length@ range@ (length@ depends@ \ on:@ %a)" - Fmt.(list ~sep:comma Cobol_ptree.pp_qualname) (NEL.to_list vars) + Fmt.(list ~sep:comma Cobol_ptree.Types.pp_qualname) (NEL.to_list vars) | Picture_error { error; _ } -> Cobol_data.Picture.pp_error ppf ~&error | Item_not_found { qualname; _ } -> - Pretty.print ppf "Item@ '%a'@ not@ found" Cobol_ptree.pp_qualname' qualname + Pretty.print ppf "Item@ '%a'@ not@ found" Cobol_ptree.Types.pp_qualname' qualname | Misplaced { entry; expl; _ } -> Pretty.print ppf "Misplaced@ %a@ %a\ " pp_entry entry pp_misplacement_explanation expl @@ -273,13 +273,13 @@ let pp_error ppf = function let pp_warning ppf = function | Redefinition_of_table_item { table_item_name; _ } -> Pretty.print ppf "Redefinition@ of@ item@ with@ OCCURS@ clause%a" - Fmt.(option (sp ++ Cobol_ptree.pp_qualname')) table_item_name + Fmt.(option (sp ++ Cobol_ptree.Types.pp_qualname')) table_item_name | Mismatching_usage_in_group { item_usage; item_name; group_usage } -> Pretty.print ppf "Mismatching@ USAGE@ %a@ for@ %a,@ subordinate@ to@ a@ \ group@ with@ USAGE@ %a" - Cobol_ptree.pp_usage_clause ~&item_usage + Cobol_ptree.Types.pp_usage_clause ~&item_usage pp_data_name'_opt item_name - Cobol_ptree.pp_usage_clause ~&group_usage + Cobol_ptree.Types.pp_usage_clause ~&group_usage | Duplicate_clause { clause_name; _ } -> (* TODO: addendum with second loc *) Pretty.print ppf "Duplicate %s clause" clause_name (* | Extraneous_clause { clause_name; _ } -> *) diff --git a/src/lsp/cobol_typeck/typeck_data_items.ml b/src/lsp/cobol_typeck/typeck_data_items.ml index 0c3dcfdfb..9e6367fdd 100644 --- a/src/lsp/cobol_typeck/typeck_data_items.ml +++ b/src/lsp/cobol_typeck/typeck_data_items.ml @@ -28,7 +28,7 @@ module PIC = Cobol_data.Picture type output = { definitions: Cobol_unit.Types.data_definitions; - references: Typeck_outputs.qualrefmap; + references: Outputs.qualrefmap; } (* --- *) @@ -36,7 +36,7 @@ type output = type acc = { current_storage: Cobol_data.Types.data_storage; - current_qualification: Cobol_ptree.qualname option; + current_qualification: Cobol_ptree.Types.qualname option; item_stack: item_stack; current_qualmap: Cobol_data.Types.field_definition with_loc Qualmap.t; pending_conditions: condition_name_under_construction list; @@ -44,17 +44,17 @@ type acc = definitions: Cobol_unit.Types.data_definitions; references: srcloc list Cobol_unit.Qual.MAP.t; picture_config: Cobol_data.Types.picture_config; - diags: Typeck_diagnostics.t; + diags: Diagnostics.t; } and item_stack = item_under_construction list and item_under_construction = (* item currently being assembled *) { item_level: int; (* 01 <= _ <= 49 *) - item_name: Cobol_ptree.data_name with_loc option; (* given item name *) + item_name: Cobol_ptree.Types.data_name with_loc option; (* given item name *) item_loc: srcloc; - item_qualname: Cobol_ptree.qualname with_loc option; (* full qualname *) - item_qualifier: Cobol_ptree.qualname option; (* qualifier for sub. items *) - item_redefines: Cobol_ptree.qualname with_loc option; (* if REDEFINES *) + item_qualname: Cobol_ptree.Types.qualname with_loc option; (* full qualname *) + item_qualifier: Cobol_ptree.Types.qualname option; (* qualifier for sub. items *) + item_redefines: Cobol_ptree.Types.qualname with_loc option; (* if REDEFINES *) item_offset: Cobol_data.Memory.offset; item_size: Cobol_data.Memory.size; item_clauses: Typeck_clauses.data_clauses; @@ -104,7 +104,7 @@ let error acc error = { acc with diags = Data_error error :: acc.diags } let warn acc d = { acc with diags = Data_warning d :: acc.diags } let result { definitions = { data_items; data_records }; - references; diags; _ } : output * Typeck_diagnostics.t = + references; diags; _ } : output * Diagnostics.t = { definitions = { data_items = { data_items with list = List.rev data_items.list }; data_records = List.rev data_records }; @@ -131,7 +131,7 @@ let def_n_redef_items (item_stack: item_stack) = (** [qualify name item_stack] returns the qualified name of a new item with name [name] that would be pushed onto [item_stack]. *) -let qualify: string with_loc -> item_stack -> Cobol_ptree.qualname with_loc = +let qualify: string with_loc -> item_stack -> Cobol_ptree.Types.qualname with_loc = fun n -> function | { item_qualifier = qn; _ } :: _ -> qual n qn &@<- n | [] -> name n &@<- n @@ -140,7 +140,7 @@ let qualify: string with_loc -> item_stack -> Cobol_ptree.qualname with_loc = (** [qualname data_name item_stack] returns the qualified name of a new item with base name [data_name] that would be pushed onto [item_stack]. *) let qualname - (data_name: Cobol_ptree.data_name with_loc option) + (data_name: Cobol_ptree.Types.data_name with_loc option) (item_stack: item_stack) = match data_name, item_stack with | Some { payload = DataName n; loc }, { item_qualifier = qn; _ } :: _ -> @@ -154,7 +154,7 @@ let qualname (** [qualifier data_name item_stack] returns the qualification of a new item with base name [data_name] that would be pushed onto [item_stack]. *) let qualifier - (data_name: Cobol_ptree.data_name with_loc option) + (data_name: Cobol_ptree.Types.data_name with_loc option) (item_stack: item_stack) = match data_name, item_stack with | Some { payload = DataName n; _ }, { item_qualifier = qn; _ } :: _ -> @@ -176,7 +176,7 @@ let current_item_offset: item_stack -> Cobol_data.Memory.offset = function (* --- *) -let record_name: acc -> Cobol_ptree.qualname with_loc option -> acc * string = +let record_name: acc -> Cobol_ptree.Types.qualname with_loc option -> acc * string = fun acc -> function | None -> { acc with filler_count = succ acc.filler_count }, @@ -264,7 +264,7 @@ let check_inherited_usage acc ~item_name item_clauses item_stack = acc, { item_clauses with usage } | Some u, Some p -> let acc = (* check matching usage (according to the standard) *) - if Cobol_ptree.compare_usage_clause ~&u ~&p <> 0 then + if Cobol_ptree.Types.compare_usage_clause ~&u ~&p <> 0 then warn acc @@ Mismatching_usage_in_group { item_name; item_usage = u; group_usage = p } @@ -330,7 +330,7 @@ let field_usage_n_value acc { item_name; item_loc; item_clauses; _ } = Typeck_clauses.to_usage_n_value item_clauses ~item_name ~item_loc ~picture_config:acc.picture_config in - let acc = { acc with diags = Typeck_diagnostics.union acc.diags diags } in + let acc = { acc with diags = Diagnostics.union acc.diags diags } in acc, usage, value @@ -488,7 +488,7 @@ let register_ref ~from:{ loc; _ } ~to_:qualname_opt acc = acc | Some qn -> { acc with - references = Typeck_outputs.register_qualref ~&qn ~loc acc.references } + references = Outputs.register_qualref ~&qn ~loc acc.references } let find_in_current_record qualname acc = @@ -524,7 +524,7 @@ let on_redefinition_item acc item_clauses in let acc = match redefined_qualname with | Some qn - when Cobol_ptree.compare_name ~&redefined_name (name_of ~&qn) <> 0 -> + when Cobol_ptree.Types.compare_name ~&redefined_name (name_of ~&qn) <> 0 -> error acc @@ Unexpected_redefinition_name { redef_loc = loc; redef_name = item_name; @@ -590,14 +590,14 @@ let on_redefinition_item acc item_clauses let on_item acc ~at_level - { payload = Cobol_ptree.{ data_level; + { payload = Cobol_ptree.Types.{ data_level; data_name = item_name; data_clauses }; loc } = let item_clauses = Typeck_clauses.of_data_item data_clauses in let acc = { acc with - diags = Typeck_diagnostics.union acc.diags item_clauses.clause_diags } in + diags = Diagnostics.union acc.diags item_clauses.clause_diags } in match item_clauses.redefines with | Some redefined_name -> on_redefinition_item acc item_clauses @@ -650,8 +650,8 @@ let report_occurs acc operand field = let renaming acc - ?(renaming_qualifier: Cobol_ptree.qualname option) - { payload = Cobol_ptree.{ rename_to = name; + ?(renaming_qualifier: Cobol_ptree.Types.qualname option) + { payload = Cobol_ptree.Types.{ rename_to = name; rename_from = from; rename_thru = thru; _ }; loc } = @@ -741,7 +741,7 @@ let on_rename ({ loc; _ } as rename_item) acc = acc -let on_condition_name (cond_name: Cobol_ptree.condition_name_item with_loc) acc = +let on_condition_name (cond_name: Cobol_ptree.Types.condition_name_item with_loc) acc = match acc.item_stack with | [] -> error acc @@ Misplaced { entry = Condition_name_entry; diff --git a/src/lsp/cobol_typeck/typeck_data_items.mli b/src/lsp/cobol_typeck/typeck_data_items.mli index d26afb0aa..e396b87e3 100644 --- a/src/lsp/cobol_typeck/typeck_data_items.mli +++ b/src/lsp/cobol_typeck/typeck_data_items.mli @@ -16,10 +16,10 @@ open Cobol_common.Srcloc.TYPES type output = { definitions: Cobol_unit.Types.data_definitions; - references: Typeck_outputs.qualrefmap; + references: Outputs.qualrefmap; } val of_compilation_unit : Cobol_unit.Types.unit_config - -> Cobol_ptree.compilation_unit with_loc - -> output * Typeck_diagnostics.t + -> Cobol_ptree.Types.compilation_unit with_loc + -> output * Diagnostics.t diff --git a/src/lsp/cobol_typeck/typeck_procedure.ml b/src/lsp/cobol_typeck/typeck_procedure.ml index 3893e5712..2c43b34c2 100644 --- a/src/lsp/cobol_typeck/typeck_procedure.ml +++ b/src/lsp/cobol_typeck/typeck_procedure.ml @@ -21,7 +21,7 @@ module Visitor = Cobol_common.Visitor type output = { procedure: Cobol_unit.Types.procedure; - references: Typeck_outputs.references_in_unit; + references: Outputs.references_in_unit; } let procedure_of_compilation_unit cu' = @@ -35,7 +35,7 @@ let procedure_of_compilation_unit cu' = } and section_under_construction = { - sec_name: Cobol_ptree.procedure_name with_loc; + sec_name: Cobol_ptree.Types.procedure_name with_loc; sec_paragraphs: procedure_paragraph with_loc list; } @@ -52,8 +52,8 @@ let procedure_of_compilation_unit cu' = list = List.rev acc.block_list; } - let name n : Cobol_ptree.qualname = Name n - let qual n q : Cobol_ptree.qualname = Qual (n, q) + let name n : Cobol_ptree.Types.qualname = Name n + let qual n q : Cobol_ptree.Types.qualname = Qual (n, q) let section_block ({ payload = suc; loc }: section_under_construction with_loc) = @@ -69,7 +69,7 @@ let procedure_of_compilation_unit cu' = in Section ({ section_name = suc.sec_name; section_paragraphs } &@ loc) - let simple_paragraph (p: Cobol_ptree.paragraph with_loc) acc = + let simple_paragraph (p: Cobol_ptree.Types.paragraph with_loc) acc = match acc.current_section, ~&p.paragraph_name with | None, Some n -> { paragraph_name = Some (name n &@<- n); @@ -161,19 +161,19 @@ let references ~(data_definitions: Cobol_unit.Types.data_definitions) procedure type acc = { current_section: Cobol_unit.Types.procedure_section option; - refs: Typeck_outputs.references_in_unit; - diags: Typeck_diagnostics.t; + refs: Outputs.references_in_unit; + diags: Diagnostics.t; } let init = { current_section = None; - refs = Typeck_outputs.no_refs; - diags = Typeck_diagnostics.none; + refs = Outputs.no_refs; + diags = Diagnostics.none; } let references { refs; diags; _ } = refs, diags end in - let baseloc_of_qualname: Cobol_ptree.qualname -> srcloc = function + let baseloc_of_qualname: Cobol_ptree.Types.qualname -> srcloc = function | Name name | Qual (name, _) -> ~@name in @@ -191,20 +191,20 @@ let references ~(data_definitions: Cobol_unit.Types.data_definitions) procedure (* match Qualmap.find qn data_definitions.data_items.named with *) (* | Data_field { def; _ } -> *) (* { acc with *) - (* refs = Typeck_outputs.register_data_field_ref ~loc def acc.refs } *) + (* refs = Outputs.register_data_field_ref ~loc def acc.refs } *) (* | Data_renaming { def; _ } -> *) (* { acc with *) - (* refs = Typeck_outputs.register_data_renaming_ref ~loc def acc.refs } *) + (* refs = Outputs.register_data_renaming_ref ~loc def acc.refs } *) (* | Data_condition { def; _ } -> *) (* { acc with *) - (* refs = Typeck_outputs.register_condition_name_ref ~loc def acc.refs } *) + (* refs = Outputs.register_condition_name_ref ~loc def acc.refs } *) (* | Table_index { qualname = qn; _ } -> *) (* { acc with *) - (* refs = Typeck_outputs.register_data_qualref ~loc ~&qn acc.refs } *) + (* refs = Outputs.register_data_qualref ~loc ~&qn acc.refs } *) try let bnd = Qualmap.find_binding qn data_definitions.data_items.named in { acc with - refs = Typeck_outputs.register_data_qualref ~loc bnd.full_qn acc.refs } + refs = Outputs.register_data_qualref ~loc bnd.full_qn acc.refs } with | Not_found -> acc (* ignored for now, as we don't process all the DATA DIV. yet. *) @@ -223,7 +223,7 @@ let references ~(data_definitions: Cobol_unit.Types.data_definitions) procedure match Cobol_unit.Procedure.find ~&qn ?in_section procedure with | block -> { acc with - refs = Typeck_outputs.register_procedure_ref ~loc block acc.refs } + refs = Outputs.register_procedure_ref ~loc block acc.refs } | exception Not_found -> error acc @@ Unknown_proc_name qn | exception Qualmap.Ambiguous (lazy matching_qualnames) -> diff --git a/src/lsp/cobol_typeck/typeck_procedure.mli b/src/lsp/cobol_typeck/typeck_procedure.mli index cef1c1249..64965c14a 100644 --- a/src/lsp/cobol_typeck/typeck_procedure.mli +++ b/src/lsp/cobol_typeck/typeck_procedure.mli @@ -16,10 +16,10 @@ open Cobol_common.Srcloc.TYPES type output = { procedure: Cobol_unit.Types.procedure; - references: Typeck_outputs.references_in_unit; + references: Outputs.references_in_unit; } val of_compilation_unit : data_definitions: Cobol_unit.Types.data_definitions - -> Cobol_ptree.compilation_unit with_loc - -> output * Typeck_diagnostics.t + -> Cobol_ptree.Types.compilation_unit with_loc + -> output * Diagnostics.t diff --git a/src/lsp/cobol_typeck/typeck_procedure_diagnostics.ml b/src/lsp/cobol_typeck/typeck_procedure_diagnostics.ml index 0716215e5..45addb31f 100644 --- a/src/lsp/cobol_typeck/typeck_procedure_diagnostics.ml +++ b/src/lsp/cobol_typeck/typeck_procedure_diagnostics.ml @@ -20,12 +20,12 @@ module NEL = Cobol_common.Basics.NEL type qualname_ambiguity = { - given_qualname: Cobol_ptree.qualname with_loc; - matching_qualnames: Cobol_ptree.qualname NEL.t; + given_qualname: Cobol_ptree.Types.qualname with_loc; + matching_qualnames: Cobol_ptree.Types.qualname NEL.t; } type error = - | Unknown_proc_name of Cobol_ptree.qualname with_loc + | Unknown_proc_name of Cobol_ptree.Types.qualname with_loc | Ambiguous_data_name of qualname_ambiguity | Ambiguous_proc_name of qualname_ambiguity diff --git a/src/lsp/cobol_typeck/typeck_units.ml b/src/lsp/cobol_typeck/typeck_units.ml index 1d8fd5364..6727718f8 100644 --- a/src/lsp/cobol_typeck/typeck_units.ml +++ b/src/lsp/cobol_typeck/typeck_units.ml @@ -20,7 +20,7 @@ module DIAGS = Cobol_common.Diagnostics module CUs = Cobol_unit.Collections.SET module CUMap = Cobol_unit.Collections.MAP -let name_of_compilation_unit: Cobol_ptree.compilation_unit -> _ = function +let name_of_compilation_unit: Cobol_ptree.Types.compilation_unit -> _ = function | Program { program_name = name; _ } | Function { function_name = name; _ } | ClassDefinition { class_name = name; _ } @@ -31,8 +31,8 @@ type acc = parent_name: string with_loc option; parent_config: unit_config option; cus: CUs.t; (* = group *) - artifacts: Typeck_outputs.artifacts; - diags: Typeck_diagnostics.diagnostics; + artifacts: Outputs.artifacts; + diags: Diagnostics.diagnostics; } let init = @@ -40,8 +40,8 @@ let init = parent_name = None; parent_config = None; cus = CUs.empty; - artifacts = Typeck_outputs.no_artifacts; - diags = Typeck_diagnostics.none; + artifacts = Outputs.no_artifacts; + diags = Diagnostics.none; (* unit_config = *) (* { *) (* unit_currency_signs = Cobol_common.Basics.CharSet.singleton '$'; *) @@ -50,7 +50,7 @@ let init = } let result ptree acc = - Typeck_outputs.{ + Outputs.{ ptree; group = acc.cus; artifacts = acc.artifacts; @@ -84,7 +84,7 @@ let build_units _config = object let references = CUMap.add unit { unit_procedure.references with - data_refs = Typeck_outputs.merge_qualrefmaps + data_refs = Outputs.merge_qualrefmaps unit_data.references unit_procedure.references.data_refs } acc.artifacts.references @@ -97,7 +97,7 @@ let build_units _config = object cus = CUs.add unit acc.cus; artifacts = { references }; diags = - Typeck_diagnostics.(union unit_config_diags @@ + Diagnostics.(union unit_config_diags @@ union unit_data_diags @@ unit_procedure_diags); } in @@ -119,8 +119,8 @@ end (** This function builds the internal representation of full compilation groups. *) let of_compilation_group - : Cobol_config.t -> Cobol_ptree.compilation_group -> - Typeck_outputs.t * Typeck_diagnostics.t = + : Cobol_config.Types.t -> Cobol_ptree.Types.compilation_group -> + Outputs.t * Diagnostics.t = fun config compilation_group_ptree -> Cobol_ptree.Visitor.fold_compilation_group (build_units config) compilation_group_ptree init |> diff --git a/src/lsp/cobol_typeck/typeck_units.mli b/src/lsp/cobol_typeck/typeck_units.mli index 6d8300da1..afdd31eaf 100644 --- a/src/lsp/cobol_typeck/typeck_units.mli +++ b/src/lsp/cobol_typeck/typeck_units.mli @@ -12,6 +12,6 @@ (**************************************************************************) val of_compilation_group - : Cobol_config.t - -> Cobol_ptree.compilation_group - -> Typeck_outputs.t * Typeck_diagnostics.t + : Cobol_config.Types.t + -> Cobol_ptree.Types.compilation_group + -> Outputs.t * Diagnostics.t diff --git a/src/lsp/cobol_typeck_old/dune b/src/lsp/cobol_typeck_old/dune new file mode 100644 index 000000000..5ec35ec86 --- /dev/null +++ b/src/lsp/cobol_typeck_old/dune @@ -0,0 +1,26 @@ +; generated by drom from package skeleton 'library' + +(library + (name cobol_typeck_old) + (public_name cobol_typeck_old) + (wrapped true) + ; use field 'dune-libraries' to add libraries without opam deps + (libraries cobol_unit cobol_typeck cobol_ptree cobol_parser cobol_data 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 ppx_deriving.ord)) + + ) + + +(rule + (targets version.ml) + (deps (:script version.mlt) package.toml) + (action (with-stdout-to %{targets} (run %{ocaml} unix.cma %{script})))) + +(documentation + (package cobol_typeck_old)) + +; use field 'dune-trailer' to add more stuff here + diff --git a/src/lsp/cobol_typeck/old_env_builder.ml b/src/lsp/cobol_typeck_old/env_builder.ml similarity index 92% rename from src/lsp/cobol_typeck/old_env_builder.ml rename to src/lsp/cobol_typeck_old/env_builder.ml index ec4acb977..036552605 100644 --- a/src/lsp/cobol_typeck/old_env_builder.ml +++ b/src/lsp/cobol_typeck_old/env_builder.ml @@ -11,12 +11,10 @@ (* *) (**************************************************************************) -open Cobol_ptree +open Cobol_ptree.Types open Cobol_common.Srcloc.INFIX open Cobol_common.Diagnostics.TYPES -module Cobol_data = Cobol_data.OLD - module Visitor = Cobol_common.Visitor module CharSet = Cobol_common.Basics.CharSet module DIAGS = Cobol_common.Diagnostics @@ -40,13 +38,13 @@ let initialize_prog_env = | _ -> true in let special_names_clause_folder = object - inherit [Cobol_data.PROG_ENV.t with_diags] Cobol_ptree.Visitor.folder + inherit [Cobol_data_old.Env.PROG_ENV.t with_diags] Cobol_ptree.Visitor.folder method! fold_special_names_clause' { loc; payload = clause } = acc_result @@ fun env -> match clause with | DecimalPointIsComma -> Visitor.skip @@ - DIAGS.result Cobol_data.PROG_ENV.{ env with decimal_point = ',' } + DIAGS.result Cobol_data_old.Env.PROG_ENV.{ env with decimal_point = ',' } | CurrencySign { sign = (Alphanum { str; _ } | National str); picture_symbol = None } | CurrencySign { picture_symbol = Some (Alphanum { str; _ } | @@ -75,8 +73,8 @@ let initialize_prog_env = end in let ensure_currency_sign_is_defined env = (* Currency sign defaults to '$' *) - if CharSet.is_empty env.Cobol_data.PROG_ENV.currency_signs - then Cobol_data.PROG_ENV.{ env with currency_signs = CharSet.singleton '$' } + if CharSet.is_empty env.Cobol_data_old.Env.PROG_ENV.currency_signs + then Cobol_data_old.Env.PROG_ENV.{ env with currency_signs = CharSet.singleton '$' } else env in fun env_div base_env -> @@ -88,7 +86,7 @@ let initialize_prog_env = (* TODO: avoid returning `options with_diags` *) let for_compilation_unit = let build_env ?parent_env name env = - let prog_env = Cobol_data.PROG_ENV.make ?parent:parent_env ~&name in + let prog_env = Cobol_data_old.Env.PROG_ENV.make ?parent:parent_env ~&name in Visitor.skip @@ DIAGS.map_result ~f:Option.some (initialize_prog_env env prog_env) in diff --git a/src/lsp/cobol_typeck/old_env_builder.mli b/src/lsp/cobol_typeck_old/env_builder.mli similarity index 89% rename from src/lsp/cobol_typeck/old_env_builder.mli rename to src/lsp/cobol_typeck_old/env_builder.mli index 5f7e0beff..a16cf6eb8 100644 --- a/src/lsp/cobol_typeck/old_env_builder.mli +++ b/src/lsp/cobol_typeck_old/env_builder.mli @@ -11,10 +11,10 @@ (* *) (**************************************************************************) -open Cobol_ptree +open Cobol_ptree.Types open Cobol_common.Diagnostics.TYPES val for_compilation_unit - : parents: Cobol_data.OLD.PROG_ENV.t list + : parents: Cobol_data_old.Env.PROG_ENV.t list -> compilation_unit with_loc - -> Cobol_data.OLD.PROG_ENV.t option with_diags + -> Cobol_data_old.Env.PROG_ENV.t option with_diags diff --git a/src/lsp/cobol_typeck/old_group_builder.ml b/src/lsp/cobol_typeck_old/group_builder.ml similarity index 89% rename from src/lsp/cobol_typeck/old_group_builder.ml rename to src/lsp/cobol_typeck_old/group_builder.ml index c16aa5947..5e64bf597 100644 --- a/src/lsp/cobol_typeck/old_group_builder.ml +++ b/src/lsp/cobol_typeck_old/group_builder.ml @@ -11,12 +11,10 @@ (* *) (**************************************************************************) -open Cobol_ptree +open Cobol_ptree.Types open Cobol_common.Srcloc.INFIX open Cobol_common.Diagnostics.TYPES -module Cobol_data = Cobol_data.OLD - module DIAGS = Cobol_common.Diagnostics module Visitor = Cobol_common.Visitor @@ -59,7 +57,7 @@ let rev_and_validate_data_item_descrs descr | Data item -> DIAGS.Set.union diags @@ - Cobol_validation.validate_data_clauses ~is_elementary + Cobol_typeck.Cobol_validation.validate_data_clauses ~is_elementary (item &@<- descr), descr | _ -> (* TODO *) @@ -70,7 +68,7 @@ let rev_and_validate_data_item_descrs DIAGS.result res ~diags let cobol_class_of_picture - : Cobol_data.Picture.t with_loc -> Cobol_data.Types.elementary_data_class = + : Cobol_data_old.Picture.t with_loc -> Cobol_data_old.Types.elementary_data_class = fun { payload = pic; _ } -> match pic.category with | Alphabetic _ -> Alphabetic @@ -81,15 +79,15 @@ let cobol_class_of_picture let rec from_item_descrs config prog_env data_group : _ with_diags = - let module Config = (val config: Cobol_config.T) in + let module Config = (val config: Cobol_config.Types.T) in - let picture_of_string Cobol_data.PROG_ENV.{ decimal_point; + let picture_of_string Cobol_data_old.Env.PROG_ENV.{ decimal_point; currency_signs; _ } s = let module E = struct let decimal_char = decimal_point let currency_signs = currency_signs end in - let module PIC = Cobol_data.Picture.Make (val config) (E) in + let module PIC = Cobol_data_old.Picture.Make (val config) (E) in try DIAGS.result @@ PIC.of_string s with PIC.InvalidPicture (str, diags, dummy) -> DIAGS.result ~diags (dummy &@<- str) @@ -104,12 +102,12 @@ let rec from_item_descrs config prog_env data_group : _ with_diags = DIAGS.some_result element | Some element, Some OccursFixed occurs_fixed -> DIAGS.some_result @@ - (Cobol_data.Types.Table { typ = { elements_type = element; + (Cobol_data_old.Types.Table { typ = { elements_type = element; length = Fixed ~&(occurs_fixed.times) }; level } &@ loc) | Some element, Some OccursDepending { from; to_; depending; _ } -> DIAGS.some_result @@ - (Cobol_data.Types.Table { typ = { elements_type = element; + (Cobol_data_old.Types.Table { typ = { elements_type = element; length = OccursDepending { min_size = ~&from; max_size = ~&to_; depending } }; @@ -121,7 +119,7 @@ let rec from_item_descrs config prog_env data_group : _ with_diags = in match ~&data_group with - | Cobol_data.Group.Elementary {data_item = Data dde; name = _} -> + | Cobol_data_old.Group.Elementary {data_item = Data dde; name = _} -> let level = ~&(dde.data_level) and loc = ~@data_group in let picture, usage, occurs = List.fold_left begin fun (pic, usage, occurs) { payload = clause; loc } -> @@ -141,24 +139,24 @@ let rec from_item_descrs config prog_env data_group : _ with_diags = | Some pic, None -> let pic = picture_of_string prog_env pic in DIAGS.map_result ~f:begin fun pic -> - Some (Cobol_data.Types.Elementary ({ typ = cobol_class_of_picture pic; level }, + Some (Cobol_data_old.Types.Elementary ({ typ = cobol_class_of_picture pic; level }, Some ~&pic) &@ loc) end pic | None, Some usage -> begin match usage with | Index -> DIAGS.some_result - (Cobol_data.Types.Elementary ({typ = Index; level}, None) &@ loc) + (Cobol_data_old.Types.Elementary ({typ = Index; level}, None) &@ loc) | Pointer _ | FunctionPointer _ | ProgramPointer _ -> DIAGS.some_result - (Cobol_data.Types.Elementary ({typ = Pointer; level}, None) &@ loc) + (Cobol_data_old.Types.Elementary ({typ = Pointer; level}, None) &@ loc) (* | ProgramPointer _ -> *) (* Result.ok @@ Elementary (({typ = Types.Pointer (\* L8 *\); level}, None) &@ loc) *) | ObjectReference _ -> DIAGS.some_result - (Cobol_data.Types.Elementary ({typ = Object; level}, None) &@ loc) + (Cobol_data_old.Types.Elementary ({typ = Object; level}, None) &@ loc) | BinaryChar _ | BinaryShort _ | BinaryLong _ @@ -173,23 +171,23 @@ let rec from_item_descrs config prog_env data_group : _ with_diags = | FloatExtended -> (* As per ISO/IEC 1989:2014, 8.5.2.10 Numeric category *) DIAGS.some_result - (Cobol_data.Types.Elementary ({typ = Numeric; level}, None) &@ loc) + (Cobol_data_old.Types.Elementary ({typ = Numeric; level}, None) &@ loc) | UsagePending (`Comp1 | `Comp2 | `BinaryCLong _) -> DIAGS.some_result - (Cobol_data.Types.Elementary ({typ = Numeric; level}, None) &@ loc) + (Cobol_data_old.Types.Elementary ({typ = Numeric; level}, None) &@ loc) | _ -> DIAGS.error_result None ~loc "Missing@ PICTURE@ clause" end | Some picture, Some usage -> let pic = picture_of_string prog_env picture in let cls = DIAGS.map_result ~f:cobol_class_of_picture pic in - DIAGS.map2_results ~f:begin fun pic (cls: Cobol_data.Types.elementary_data_class) -> + DIAGS.map2_results ~f:begin fun pic (cls: Cobol_data_old.Types.elementary_data_class) -> match usage, cls with | (Binary | PackedDecimal | UsagePending (`Comp3 | `Comp5 | `Comp6 | `CompX)), (Numeric as cls) -> DIAGS.some_result - (Cobol_data.Types.Elementary ({ typ = cls; level }, + (Cobol_data_old.Types.Elementary ({ typ = cls; level }, Some ~&pic) &@ loc) | (Binary | PackedDecimal | UsagePending (`Comp3 | `Comp5 | `Comp6 | `CompX)), _ -> @@ -198,7 +196,7 @@ let rec from_item_descrs config prog_env data_group : _ with_diags = (COMP) or PACKED-DECIMAL must be a numeric picture" | _ -> DIAGS.some_result - (Cobol_data.Types.Elementary ({ typ = cls; level }, + (Cobol_data_old.Types.Elementary ({ typ = cls; level }, Some ~&pic) &@ loc) end pic cls | None, None -> @@ -219,15 +217,15 @@ let rec from_item_descrs config prog_env data_group : _ with_diags = in let rec prepend_usage usage ({ payload; loc } as dg) = match payload with - | Cobol_data.Group.Elementary ({data_item = Data ({ data_clauses; + | Cobol_data_old.Group.Elementary ({data_item = Data ({ data_clauses; _} as data_item); _ } as element) -> let data_item = Data { data_item with data_clauses = usage :: data_clauses } in - Cobol_data.Group.Elementary { element with data_item } &@ loc + Cobol_data_old.Group.Elementary { element with data_item } &@ loc | Group ({ elements; _ } as group) -> let elements = List.map (prepend_usage usage) elements in - Cobol_data.Group.Group { group with elements } &@ loc + Cobol_data_old.Group.Group { group with elements } &@ loc | _ -> dg in @@ -243,7 +241,7 @@ let rec from_item_descrs config prog_env data_group : _ with_diags = in acc_occurs ~occurs_clause:occurs ~level ~loc @@ DIAGS.map_some_result ~f:begin fun elements -> - Cobol_data.Types.Group { typ = elements; level } &@ loc + Cobol_data_old.Types.Group { typ = elements; level } &@ loc end elements | Renames { targets; _ } -> @@ -259,7 +257,7 @@ let rec from_item_descrs config prog_env data_group : _ with_diags = OccursDynamic _); _ } -> true | _ -> false in - let rec check_data_group ~is_first_or_last (data_group: Cobol_data.Group.t) = + let rec check_data_group ~is_first_or_last (data_group: Cobol_data_old.Group.t) = match ~&data_group with | Renames _ | Constant _ -> DIAGS.Set.none @@ -321,7 +319,7 @@ let rec from_item_descrs config prog_env data_group : _ with_diags = let elements = of_data_elements config prog_env targets in DIAGS.with_more_diags ~diags @@ DIAGS.map_some_result ~f:begin fun elements -> - Cobol_data.Types.Group { typ = elements; level = 66 } &@ loc + Cobol_data_old.Types.Group { typ = elements; level = 66 } &@ loc end elements | [] -> DIAGS.error_result None ~loc @@ -368,7 +366,7 @@ let lookup_working_data_item_descrs = object method! fold_data_item' { loc; payload = { data_level; data_name; data_clauses } } { diags; result = acc } = - let mangle = Cobol_data.Mangling.mangle_data_name ~default_loc:loc in + let mangle = Cobol_data_old.Mangling.mangle_data_name ~default_loc:loc in let data_item = (* TODO: no need to mangle at this point *) { data_level; data_name = mangle data_name; data_clauses (* = convert_data_clauses data_clauses *) } in @@ -394,5 +392,5 @@ let check_data_groups config env working_groups = let working_data_of_compilation_unit' config env root = Cobol_ptree.Visitor.fold_compilation_unit' lookup_working_data_item_descrs root @@ DIAGS.result [] |> - DIAGS.more_result ~f:Cobol_data.Group.of_working_item_descrs |> + DIAGS.more_result ~f:Cobol_data_old.Group.of_working_item_descrs |> DIAGS.more_result ~f:(check_data_groups config env) diff --git a/src/lsp/cobol_typeck/old_group_builder.mli b/src/lsp/cobol_typeck_old/group_builder.mli similarity index 83% rename from src/lsp/cobol_typeck/old_group_builder.mli rename to src/lsp/cobol_typeck_old/group_builder.mli index 0f684123a..1537ce2f1 100644 --- a/src/lsp/cobol_typeck/old_group_builder.mli +++ b/src/lsp/cobol_typeck_old/group_builder.mli @@ -14,7 +14,7 @@ open Cobol_common.Diagnostics.TYPES val working_data_of_compilation_unit' - : Cobol_config.t - -> Cobol_data.OLD.PROG_ENV.t - -> Cobol_ptree.compilation_unit Cobol_ptree.with_loc - -> Cobol_data.OLD.Group.t' Cobol_ptree.with_loc list with_diags + : Cobol_config.Types.t + -> Cobol_data_old.Env.PROG_ENV.t + -> Cobol_ptree.Types.compilation_unit Cobol_ptree.Types.with_loc + -> Cobol_data_old.Group.t' Cobol_ptree.Types.with_loc list with_diags diff --git a/src/lsp/cobol_typeck_old/package.toml b/src/lsp/cobol_typeck_old/package.toml new file mode 100644 index 000000000..92d641643 --- /dev/null +++ b/src/lsp/cobol_typeck_old/package.toml @@ -0,0 +1,79 @@ + +# name of package +name = "cobol_typeck_old" +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 ppx_deriving.ord" + +# 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_ptree = "version" +cobol_common = "version" +cobol_data = "version" +cobol_parser = "version" +cobol_unit = "version" +cobol_typeck = "version" + +# package tools dependencies +[tools] +ppx_deriving = ">=5.2.1" + +# 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_typeck/old_prog_builder.ml b/src/lsp/cobol_typeck_old/prog_builder.ml similarity index 93% rename from src/lsp/cobol_typeck/old_prog_builder.ml rename to src/lsp/cobol_typeck_old/prog_builder.ml index 3d09c7484..7bd77fa64 100644 --- a/src/lsp/cobol_typeck/old_prog_builder.ml +++ b/src/lsp/cobol_typeck_old/prog_builder.ml @@ -11,17 +11,13 @@ (* *) (**************************************************************************) -module Cobol_data = Cobol_data.OLD -module Env_builder = Old_env_builder -module Group_builder = Old_group_builder - -open Cobol_ptree +open Cobol_ptree.Types open Cobol_common.Srcloc.INFIX open Cobol_common.Diagnostics.TYPES module Visitor = Cobol_common.Visitor module DIAGS = Cobol_common.Diagnostics -module CU = Cobol_data.Compilation_unit +module CU = Cobol_data_old.Compilation_unit module CUs = CU.SET let name_of_compilation_unit = function @@ -35,7 +31,7 @@ let register_cu ~cu_name ~cu_loc ~cu_env ~cu_wss (parents, progs) = DIAGS.result (cu_env :: parents, CUs.add prog progs) let lookup_cus config = object - inherit [(Cobol_data.PROG_ENV.t list * CUs.t) + inherit [(Cobol_data_old.Env.PROG_ENV.t list * CUs.t) with_diags] Cobol_ptree.Visitor.folder method! fold_compilation_unit' cu acc = diff --git a/src/lsp/cobol_typeck/old_typeck_engine.ml b/src/lsp/cobol_typeck_old/typeck_engine.ml similarity index 87% rename from src/lsp/cobol_typeck/old_typeck_engine.ml rename to src/lsp/cobol_typeck_old/typeck_engine.ml index e5fc7ead9..192bba020 100644 --- a/src/lsp/cobol_typeck/old_typeck_engine.ml +++ b/src/lsp/cobol_typeck_old/typeck_engine.ml @@ -13,19 +13,16 @@ (** Type-checking and validation of COBOL compilation groups *) -module Cobol_data = Cobol_data.OLD -module Prog_builder = Old_prog_builder - module DIAGS = Cobol_common.Diagnostics -module CU = Cobol_data.Compilation_unit +module CU = Cobol_data_old.Compilation_unit module CUs = CU.SET let analyze_compilation_group (type m) : ?config: _ -> m Cobol_parser.Outputs.parsed_compilation_group -> _ = - fun ?(config = Cobol_config.default) -> + fun ?(config = Cobol_config.Config.default) -> function | Only None | WithArtifacts (None, _) -> - DIAGS.result (Cobol_data.Compilation_unit.SET.empty, None) + DIAGS.result (Cobol_data_old.Compilation_unit.SET.empty, None) | Only Some cg | WithArtifacts (Some cg, _) -> match Prog_builder.compilation_group config cg with | { diags; _ } when DIAGS.Set.has_errors diags -> diff --git a/src/lsp/cobol_typeck_old/version.mlt b/src/lsp/cobol_typeck_old/version.mlt new file mode 100644 index 000000000..1bcf00592 --- /dev/null +++ b/src/lsp/cobol_typeck_old/version.mlt @@ -0,0 +1,30 @@ +#!/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 commit_hash = query "git show -s --pretty=format:%H" +let commit_date = query "git show -s --pretty=format:%ci" +let version = "0.1.0" + +let string_option = function + | None -> "None" + | Some s -> Printf.sprintf "Some %S" s + +let () = + Format.printf "@["; + Format.printf "let version = %S@," version; + Format.printf + "let commit_hash = %s@," (string_option commit_hash); + Format.printf + "let commit_date = %s@," (string_option commit_date); + Format.printf "@]@."; + () diff --git a/src/lsp/cobol_unit/unit_collections.ml b/src/lsp/cobol_unit/collections.ml similarity index 99% rename from src/lsp/cobol_unit/unit_collections.ml rename to src/lsp/cobol_unit/collections.ml index df8fb2e9a..b42429149 100644 --- a/src/lsp/cobol_unit/unit_collections.ml +++ b/src/lsp/cobol_unit/collections.ml @@ -13,7 +13,7 @@ open EzCompat -open Unit_types +open Types open Cobol_common.Srcloc.TYPES open Cobol_common.Srcloc.INFIX diff --git a/src/lsp/cobol_unit/dune b/src/lsp/cobol_unit/dune index f8d494d05..2fa6a2746 100644 --- a/src/lsp/cobol_unit/dune +++ b/src/lsp/cobol_unit/dune @@ -5,7 +5,7 @@ (public_name cobol_unit) (wrapped true) ; use field 'dune-libraries' to add libraries without opam deps - (libraries cobol_ptree cobol_data cobol_config cobol_common ) + (libraries cobol_ptree cobol_data_old 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_unit/unit_group.ml b/src/lsp/cobol_unit/group.ml similarity index 91% rename from src/lsp/cobol_unit/unit_group.ml rename to src/lsp/cobol_unit/group.ml index cd5269d2d..2cacb589a 100644 --- a/src/lsp/cobol_unit/unit_group.ml +++ b/src/lsp/cobol_unit/group.ml @@ -12,8 +12,8 @@ (**************************************************************************) module TYPES = struct - type group = Unit_collections.SET.t - type +'a group_map = 'a Unit_collections.MAP.t + type group = Collections.SET.t + type +'a group_map = 'a Collections.MAP.t end (* (\** Alias for {!Collections.SET.empty} *\) *) @@ -25,4 +25,4 @@ end (* (\** Alias for {!Collections.SET.iter} *\) *) (* let iter = Unit_collections.SET.iter *) -include Unit_collections.SET +include Collections.SET diff --git a/src/lsp/cobol_unit/package.toml b/src/lsp/cobol_unit/package.toml index 7efc7ea56..e4e0b13ad 100644 --- a/src/lsp/cobol_unit/package.toml +++ b/src/lsp/cobol_unit/package.toml @@ -57,6 +57,7 @@ cobol_common = "version" cobol_config = "version" cobol_ptree = "version" cobol_data = "version" +cobol_data_old = "version" # package tools dependencies [tools] diff --git a/src/lsp/cobol_unit/unit_printer.ml b/src/lsp/cobol_unit/printer.ml similarity index 91% rename from src/lsp/cobol_unit/unit_printer.ml rename to src/lsp/cobol_unit/printer.ml index 7f862a6f2..d28ae0b5d 100644 --- a/src/lsp/cobol_unit/unit_printer.ml +++ b/src/lsp/cobol_unit/printer.ml @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open Unit_types +open Types open Cobol_common.Srcloc.INFIX @@ -22,13 +22,13 @@ let pp_cobol_unit ?(show_items = false) = (Fmt.(list ~sep:nop) Cobol_data.Printer.pp_record)); C'(show_items, Pretty.vfield "items" (fun x -> x.unit_data.data_items.named) - (Unit_qualmap.pp_qualmap Cobol_data.Printer.pp_data_definition)); + (Qualmap.pp_qualmap Cobol_data.Printer.pp_data_definition)); ] let pp_cobol_unit' ppf u = pp_cobol_unit ppf ~&u let pp_group ppf group = - Unit_collections.SET.iter begin fun u -> + Collections.SET.iter begin fun u -> Fmt.(vbox @@ (styled `Yellow @@ any "unit") ++ any ": " ++ pp_cobol_unit' ++ any "@\n") ppf u end group diff --git a/src/lsp/cobol_unit/unit_procedure.ml b/src/lsp/cobol_unit/procedure.ml similarity index 78% rename from src/lsp/cobol_unit/unit_procedure.ml rename to src/lsp/cobol_unit/procedure.ml index 9290bf639..7897582eb 100644 --- a/src/lsp/cobol_unit/unit_procedure.ml +++ b/src/lsp/cobol_unit/procedure.ml @@ -13,30 +13,30 @@ (** Utilities to deal with sections/paragraphs of PROCEDURE DIVISIONs *) -open Unit_types +open Types let rec find ?(in_section: procedure_section option) - (procedure_name: Cobol_ptree.procedure_name) + (procedure_name: Cobol_ptree.Types.procedure_name) (procedure: procedure) : procedure_block = match in_section with | None -> - Unit_qualmap.find procedure_name procedure.named + Qualmap.find procedure_name procedure.named | Some { section_paragraphs; _ } -> try - Paragraph (Unit_qualmap.find procedure_name section_paragraphs.named) + Paragraph (Qualmap.find procedure_name section_paragraphs.named) with Not_found -> find procedure_name procedure let rec full_qn ?(in_section: procedure_section option) - (procedure_name: Cobol_ptree.procedure_name) + (procedure_name: Cobol_ptree.Types.procedure_name) (procedure: procedure) = match in_section with | None -> - (Unit_qualmap.find_binding procedure_name procedure.named).full_qn + (Qualmap.find_binding procedure_name procedure.named).full_qn | Some { section_paragraphs; _ } -> try - (Unit_qualmap.find_binding procedure_name section_paragraphs.named).full_qn + (Qualmap.find_binding procedure_name section_paragraphs.named).full_qn with Not_found -> full_qn procedure_name procedure diff --git a/src/lsp/cobol_unit/unit_procedure.mli b/src/lsp/cobol_unit/procedure.mli similarity index 80% rename from src/lsp/cobol_unit/unit_procedure.mli rename to src/lsp/cobol_unit/procedure.mli index 14446cd17..7d2fe347c 100644 --- a/src/lsp/cobol_unit/unit_procedure.mli +++ b/src/lsp/cobol_unit/procedure.mli @@ -14,13 +14,13 @@ (** Utilities to deal with sections/paragraphs of PROCEDURE DIVISIONs *) val find - : ?in_section: Unit_types.procedure_section - -> Cobol_ptree.qualname - -> Unit_types.procedure - -> Unit_types.procedure_block + : ?in_section: Types.procedure_section + -> Cobol_ptree.Types.qualname + -> Types.procedure + -> Types.procedure_block val full_qn - : ?in_section: Unit_types.procedure_section - -> Cobol_ptree.qualname - -> Unit_types.procedure - -> Cobol_ptree.qualname + : ?in_section: Types.procedure_section + -> Cobol_ptree.Types.qualname + -> Types.procedure + -> Cobol_ptree.Types.qualname diff --git a/src/lsp/cobol_unit/unit_qual.ml b/src/lsp/cobol_unit/qual.ml similarity index 70% rename from src/lsp/cobol_unit/unit_qual.ml rename to src/lsp/cobol_unit/qual.ml index efbf20fe5..0edb0faa4 100644 --- a/src/lsp/cobol_unit/unit_qual.ml +++ b/src/lsp/cobol_unit/qual.ml @@ -18,25 +18,25 @@ open Cobol_common.Srcloc.INFIX (* --- *) -let pp = Cobol_ptree.pp_qualname -let compare = Cobol_ptree.compare_qualname +let pp = Cobol_ptree.Types.pp_qualname +let compare = Cobol_ptree.Types.compare_qualname -let name n : Cobol_ptree.qualname = Name n +let name n : Cobol_ptree.Types.qualname = Name n -let name_of : Cobol_ptree.qualname -> string = function +let name_of : Cobol_ptree.Types.qualname -> string = function | Qual (n, _) | Name n -> String.uppercase_ascii ~&n -let qual_of : Cobol_ptree.qualname -> _ option = function +let qual_of : Cobol_ptree.Types.qualname -> _ option = function | Qual (_, qn) -> Some qn | Name _ -> None -let qual name : Cobol_ptree.qualname option -> Cobol_ptree.qualname = function +let qual name : Cobol_ptree.Types.qualname option -> Cobol_ptree.Types.qualname = function | None -> Name name | Some qn -> Qual (name, qn) (** [requal qn qn'] qualifies [qn] with [qn'] iff [qn] is not already qualified. *) -let requal: (Cobol_ptree.qualname as 'a) -> 'a option -> 'a = fun qn qn' -> - let rec aux (qn: Cobol_ptree.qualname) = match qn with +let requal: (Cobol_ptree.Types.qualname as 'a) -> 'a option -> 'a = fun qn qn' -> + let rec aux (qn: Cobol_ptree.Types.qualname) = match qn with | Name name -> qual name qn' | Qual (name, qn) -> Qual (name, aux qn) in @@ -44,18 +44,18 @@ let requal: (Cobol_ptree.qualname as 'a) -> 'a option -> 'a = fun qn qn' -> | Name _ -> aux qn | Qual _ -> qn -let names_of : Cobol_ptree.qualname -> StrSet.t = - let rec aux acc : Cobol_ptree.qualname -> StrSet.t = function +let names_of : Cobol_ptree.Types.qualname -> StrSet.t = + let rec aux acc : Cobol_ptree.Types.qualname -> StrSet.t = function | Name _ as n -> StrSet.add (name_of n) acc | Qual (_, qn) as n -> aux (StrSet.add (name_of n) acc) qn in aux StrSet.empty -let indirect_quals_of : Cobol_ptree.qualname -> StrSet.t = function +let indirect_quals_of : Cobol_ptree.Types.qualname -> StrSet.t = function | Name _ -> StrSet.empty | Qual (_, qn) -> names_of qn -let rec matches (qn: Cobol_ptree.qualname) ~(full: Cobol_ptree.qualname) = +let rec matches (qn: Cobol_ptree.Types.qualname) ~(full: Cobol_ptree.Types.qualname) = match qn, full with | Name _, Name _ -> name_of qn = name_of full @@ -72,8 +72,8 @@ let rec matches (qn: Cobol_ptree.qualname) ~(full: Cobol_ptree.qualname) = (** Collections to be used over fully qualified names. *) module M = struct - type t = Cobol_ptree.qualname - let compare = Cobol_ptree.compare_qualname + type t = Cobol_ptree.Types.qualname + let compare = Cobol_ptree.Types.compare_qualname end module SET = Stdlib.Set.Make (M) diff --git a/src/lsp/cobol_unit/unit_qualmap.ml b/src/lsp/cobol_unit/qualmap.ml similarity index 94% rename from src/lsp/cobol_unit/unit_qualmap.ml rename to src/lsp/cobol_unit/qualmap.ml index 0bb81c071..a03fc0c3d 100644 --- a/src/lsp/cobol_unit/unit_qualmap.ml +++ b/src/lsp/cobol_unit/qualmap.ml @@ -15,7 +15,7 @@ open EzCompat (* String{Map,Set} *) module StrMap = StringMap module StrSet = StringSet -open Unit_qual +open Qual module NEL = Cobol_common.Basics.NEL (* --- *) @@ -35,16 +35,16 @@ module TYPES = struct } | Cut of { binding: 'a binding; - qn_suffix: Cobol_ptree.qualname; + qn_suffix: Cobol_ptree.Types.qualname; } and 'a binding = { value: 'a; - full_qn: Cobol_ptree.qualname; (* kept so we have distinct locations *) + full_qn: Cobol_ptree.Types.qualname; (* kept so we have distinct locations *) } - exception Ambiguous of Cobol_ptree.qualname NEL.t Lazy.t + exception Ambiguous of Cobol_ptree.Types.qualname NEL.t Lazy.t end include TYPES @@ -77,7 +77,7 @@ let binding_qualifiers bindings = List.map (fun b -> b.full_qn) bindings let pp_qualname ppf qn = - Pretty.print ppf "@[%a@]" Cobol_ptree.pp_qualname qn + Pretty.print ppf "@[%a@]" Cobol_ptree.Types.pp_qualname qn let pp_binding pp_value ppf { value; full_qn; _ } = Pretty.print ppf "@[%a@ =>@ %a@]" @@ -113,7 +113,7 @@ let rec find_binding qn { map; _ } = | Exact { binding = None; refined; _ }, None -> find_unique_binding qn refined | Cut { binding; qn_suffix }, Some qn' - when Unit_qual.matches qn' ~full:qn_suffix -> + when Qual.matches qn' ~full:qn_suffix -> binding | Cut _, Some _ -> raise Not_found @@ -157,7 +157,7 @@ and find_all_bindings qn qmap : _ binding list = (* Skip keys at toplevel of map: *) StrMap.fold begin fun _key node acc -> match node with | Cut { binding; qn_suffix } - when Unit_qual.matches qn ~full:qn_suffix -> + when Qual.matches qn ~full:qn_suffix -> binding :: acc | Cut _ -> acc diff --git a/src/lsp/cobol_unit/unit_qualmap.mli b/src/lsp/cobol_unit/qualmap.mli similarity index 80% rename from src/lsp/cobol_unit/unit_qualmap.mli rename to src/lsp/cobol_unit/qualmap.mli index 0c6f6dd4b..0f605e127 100644 --- a/src/lsp/cobol_unit/unit_qualmap.mli +++ b/src/lsp/cobol_unit/qualmap.mli @@ -18,10 +18,10 @@ module TYPES: sig type 'a binding = { value: 'a; - full_qn: Cobol_ptree.qualname; + full_qn: Cobol_ptree.Types.qualname; } - exception Ambiguous of Cobol_ptree.qualname Cobol_common.Basics.NEL.t Lazy.t + exception Ambiguous of Cobol_ptree.Types.qualname Cobol_common.Basics.NEL.t Lazy.t end include module type of TYPES @@ -33,10 +33,10 @@ val pp_qualmap: 'a Pretty.printer -> 'a qualmap Pretty.printer val pp_qualmap_struct: 'a Pretty.printer -> 'a qualmap Pretty.printer val empty: 'a qualmap -val add: Cobol_ptree.qualname -> 'a -> 'a qualmap -> 'a qualmap +val add: Cobol_ptree.Types.qualname -> 'a -> 'a qualmap -> 'a qualmap val fold: f:('a binding -> 'b -> 'b) -> 'a qualmap -> 'b -> 'b -val find: Cobol_ptree.qualname -> 'a qualmap -> 'a +val find: Cobol_ptree.Types.qualname -> 'a qualmap -> 'a val bindings: 'a qualmap -> 'a binding list -val find_binding: Cobol_ptree.qualname -> 'a qualmap -> 'a binding +val find_binding: Cobol_ptree.Types.qualname -> 'a qualmap -> 'a binding diff --git a/src/lsp/cobol_unit/unit_types.ml b/src/lsp/cobol_unit/types.ml similarity index 89% rename from src/lsp/cobol_unit/unit_types.ml rename to src/lsp/cobol_unit/types.ml index 8d992106f..700ba574a 100644 --- a/src/lsp/cobol_unit/unit_types.ml +++ b/src/lsp/cobol_unit/types.ml @@ -21,7 +21,7 @@ open Cobol_common.Srcloc.TYPES many cases anonymous elements of [list] many not belong to [named]. *) type 'a named_n_ordered = { - named: 'a Unit_qualmap.t; + named: 'a Qualmap.t; list: 'a list; } @@ -46,13 +46,13 @@ type data_definitions = type procedure_paragraph = { - paragraph_name: Cobol_ptree.procedure_name with_loc option; - paragraph: Cobol_ptree.paragraph with_loc; + paragraph_name: Cobol_ptree.Types.procedure_name with_loc option; + paragraph: Cobol_ptree.Types.paragraph with_loc; } type procedure_section = { - section_name: Cobol_ptree.procedure_name with_loc; + section_name: Cobol_ptree.Types.procedure_name with_loc; section_paragraphs: procedure_paragraph with_loc named_n_ordered; } @@ -78,6 +78,6 @@ type t = cobol_unit with_loc (* --- *) -let block_name: _ -> Cobol_ptree.qualname with_loc option = function +let block_name: _ -> Cobol_ptree.Types.qualname with_loc option = function | Paragraph { payload = p; _ } -> p.paragraph_name | Section { payload = s; _ } -> Some s.section_name diff --git a/src/lsp/cobol_unit/unit_visitor.ml b/src/lsp/cobol_unit/visitor.ml similarity index 96% rename from src/lsp/cobol_unit/unit_visitor.ml rename to src/lsp/cobol_unit/visitor.ml index 18de8a490..10f1390d6 100644 --- a/src/lsp/cobol_unit/unit_visitor.ml +++ b/src/lsp/cobol_unit/visitor.ml @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open Unit_types +open Types open Cobol_common.Visitor open Cobol_common.Visitor.INFIX (* for `>>` (== `|>`) *) @@ -22,7 +22,7 @@ open Cobol_common.Srcloc.TYPES class ['a] folder = object inherit ['a] Cobol_data.Visitor.folder inherit!['a] Cobol_ptree.Proc_division_visitor.folder - method fold_unit_group: (Unit_group.t, 'a) fold = default + method fold_unit_group: (Group.t, 'a) fold = default method fold_cobol_unit: (cobol_unit, 'a) fold = default method fold_cobol_unit': (cobol_unit with_loc, 'a) fold = default method fold_unit_config: (unit_config, 'a) fold = default @@ -93,4 +93,4 @@ let fold_cobol_unit' (v: _ #folder) = let fold_unit_group (v: _ #folder) = handle v#fold_unit_group - ~continue:(Unit_group.fold (fold_cobol_unit' v)) + ~continue:(Group.fold (fold_cobol_unit' v)) diff --git a/src/lsp/superbol_free_lib/command_indent_file.ml b/src/lsp/superbol_free_lib/command_indent_file.ml index c6785027e..20ccdb176 100644 --- a/src/lsp/superbol_free_lib/command_indent_file.ml +++ b/src/lsp/superbol_free_lib/command_indent_file.ml @@ -13,7 +13,6 @@ open Ezcmd.V2 open EZCMD.TYPES -open Cobol_indent open Common_args @@ -23,9 +22,9 @@ let action { preproc_options = { source_format; config; _ } ; _ } files = |> Seq.map (fun filename -> let project = Project.for_ ~filename in let contents = Ez_file.V1.EzFile.read_file filename in - indent_range_str + Cobol_indent.Indent_main.indent_range_str ~source_format ~filename ~contents ~range:None - ~indent_config:(Some (Cobol_indent.config project.config.indent_config)) + ~indent_config:(Some (Cobol_indent.Indent_main.config project.config.indent_config)) ~dialect:Config.dialect |> Fmt.pr "%s") let cmd = diff --git a/src/lsp/superbol_free_lib/command_indent_range.ml b/src/lsp/superbol_free_lib/command_indent_range.ml index caeb2b076..78e2bea5f 100644 --- a/src/lsp/superbol_free_lib/command_indent_range.ml +++ b/src/lsp/superbol_free_lib/command_indent_range.ml @@ -13,7 +13,6 @@ open Ezcmd.V2 open EZCMD.TYPES -open Cobol_indent open Common_args @@ -22,9 +21,9 @@ let action = let module Config = (val config) in let project = Project.for_ ~filename in - let indent_config = Some (Cobol_indent.config project.config.indent_config) in + let indent_config = Some (Cobol_indent.Indent_main.config project.config.indent_config) in let contents = Ez_file.V1.EzFile.read_file filename in - indent_range_str ~source_format ~filename ~contents ~range ~indent_config + Cobol_indent.Indent_main.indent_range_str ~source_format ~filename ~contents ~range ~indent_config ~dialect:Config.dialect |> Fmt.pr "%s" let cmd = @@ -39,7 +38,7 @@ let cmd = let common, common_args = Common_args.get () in let args = direct_args @ common_args in let range start_line end_line = - let open Cobol_indent.Type in + let open Cobol_indent.Types in let start_line = !start_line |> Int32.of_string |> Int32.to_int in let end_line = !end_line |> Int32.of_string |> Int32.to_int in Some {start_line; end_line} diff --git a/src/lsp/superbol_free_lib/command_lsp.ml b/src/lsp/superbol_free_lib/command_lsp.ml index 3db5126f6..81c27dcc1 100644 --- a/src/lsp/superbol_free_lib/command_lsp.ml +++ b/src/lsp/superbol_free_lib/command_lsp.ml @@ -16,9 +16,9 @@ open EZCMD.TYPES let run_lsp ~enable_caching ~storage = - Cobol_lsp.INTERNAL.Debug.message "LSP Started with pid %d\n%!" + Cobol_lsp.Lsp_debug.message "LSP Started with pid %d\n%!" (Unix.getpid ()); - Cobol_preproc.Src_overlay.debug_oc := !Cobol_lsp.INTERNAL.Debug.debug_oc; + Cobol_preproc.Src_overlay.debug_oc := !Cobol_lsp.Lsp_debug.debug_oc; let project_layout, fallback_storage_directory = match storage with @@ -28,10 +28,10 @@ let run_lsp ~enable_caching ~storage = Project.{ layout with relative_work_dirname = None }, Some dir in let lsp_config = - Cobol_lsp.config () + Cobol_lsp.Loop.config () ~enable_caching ~project_layout ?fallback_storage_directory in - match Cobol_lsp.run ~config:lsp_config with + match Cobol_lsp.Loop.run ~config:lsp_config with | Ok () -> () | Error exit_msg -> Pretty.error "%s@." exit_msg; exit 1 diff --git a/src/lsp/superbol_free_lib/command_pp.ml b/src/lsp/superbol_free_lib/command_pp.ml index 0880e1081..2651b0322 100644 --- a/src/lsp/superbol_free_lib/command_pp.ml +++ b/src/lsp/superbol_free_lib/command_pp.ml @@ -63,15 +63,15 @@ let cmd = ~default: common.preproc_options.source_format } in input |> - Cobol_preproc.preprocessor ~options:preproc_options |> - Cobol_parser.parse_simple ~options:common.parser_options + Cobol_preproc.Main.preprocessor ~options:preproc_options |> + Cobol_parser.Main.parse_simple ~options:common.parser_options in - let my_text = Cobol_preproc.Input.from ~filename:file ~f:parse in + let my_text = Cobol_preproc.Src_input.from ~filename:file ~f:parse in Format.eprintf "%a@." Cobol_common.Diagnostics.Set.pp my_text.diags; match my_text.result with | Only (Some cg) -> ( let print = - Format.asprintf "@[%a@]@." Cobol_ptree.pp_compilation_group + Format.asprintf "@[%a@]@." Cobol_ptree.Types.pp_compilation_group in let contents = print cg in output_file filename contents; @@ -80,7 +80,7 @@ let cmd = parse ~source_format:(SF SFFree) (String { filename; contents }) with | { result = Only (Some cg'); _ } -> - if Cobol_ptree.compare_compilation_group cg' cg <> 0 then ( + if Cobol_ptree.Types.compare_compilation_group cg' cg <> 0 then ( Format.eprintf "Reparse: different@."; exit 1 ) @@ -96,7 +96,7 @@ let cmd = let text = let common = common_get () in Cobol_common.Diagnostics.show_n_forget @@ - Cobol_preproc.text_of_file file + Cobol_preproc.Main.text_of_file file ~options:common.preproc_options in let s = diff --git a/src/lsp/superbol_free_lib/common_args.ml b/src/lsp/superbol_free_lib/common_args.ml index d35814e76..0882b8d98 100644 --- a/src/lsp/superbol_free_lib/common_args.ml +++ b/src/lsp/superbol_free_lib/common_args.ml @@ -53,7 +53,7 @@ let iter_comma_separated_spec ~showable ~option_name ~f spec = let get () = let conf = ref "" in let dialect = ref None in - let format = ref Cobol_config.Auto in + let format = ref Cobol_config.Types.Auto in let formats = ["free"; "Free"; "FREE"; "fixed"; "Fixed"; "FIXED"; "cobol85"; "COBOL85"; @@ -78,8 +78,8 @@ let get () = EZCMD.info ~docv:"CONF_FILE" "Set the configuration file to be used"; ["dialect"; "std"], Arg.Symbol - (Cobol_config.DIALECT.all_canonical_names, - fun d -> dialect := Some (Cobol_config.DIALECT.of_string d)), + (Cobol_config.Dialect.all_canonical_names, + fun d -> dialect := Some (Cobol_config.Dialect.of_string d)), EZCMD.info ~docv:"DIALECT" "Set the dialect to bu used (overriden by `--conf` if used)"; @@ -115,11 +115,11 @@ let get () = DIAGS.show_n_forget @@ match !conf, !dialect with | "", None -> - DIAGS.result Cobol_config.default + DIAGS.result Cobol_config.Config.default | "", Some d -> - Cobol_config.from_dialect d + Cobol_config.Config.from_dialect d | s, None -> - Cobol_config.from_file s + Cobol_config.Config.from_file s | _ -> Pretty.failwith "Flags `--conf` and `--dialect` or `--std` cannot be \ used together" @@ -127,7 +127,7 @@ let get () = let source_format = match !format with | Auto -> - let module Config = (val config: Cobol_config.T) in + let module Config = (val config: Cobol_config.Types.T) in Config.format#value | SF _ -> !format in diff --git a/src/lsp/superbol_free_lib/globals.ml b/src/lsp/superbol_free_lib/globals.ml index 57ecc0187..55dfd79a9 100644 --- a/src/lsp/superbol_free_lib/globals.ml +++ b/src/lsp/superbol_free_lib/globals.ml @@ -29,6 +29,6 @@ swiss-knife for the COBOL language by OCamlPro" |} let version = Version.version - exception Error = Cobol_common.FatalError + exception Error = Cobol_common.Errors.FatalError end) diff --git a/src/lsp/superbol_free_lib/main.ml b/src/lsp/superbol_free_lib/main.ml index f4b996719..fa31346e8 100644 --- a/src/lsp/superbol_free_lib/main.ml +++ b/src/lsp/superbol_free_lib/main.ml @@ -48,7 +48,7 @@ let public_subcommands = [ ] let () = - Cobol_common.init_default_exn_printers () + Cobol_common.Errors.init_default_exn_printers () let main ?style_renderer ?utf_8 () = @@ -59,7 +59,7 @@ let main ?style_renderer ?utf_8 () = Pretty.init_formatters ?style_renderer ?utf_8 (); Globals.MAIN.main (* ~on_error:Cobol_common.keep_temporary_files *) - ~on_exit:Cobol_common.exit + ~on_exit:Cobol_common.Errors.exit ~print_config:Config.print ~common_args:[] public_subcommands diff --git a/src/lsp/superbol_free_lib/vscode_extension.ml b/src/lsp/superbol_free_lib/vscode_extension.ml index 122b01920..ba18f2473 100644 --- a/src/lsp/superbol_free_lib/vscode_extension.ml +++ b/src/lsp/superbol_free_lib/vscode_extension.ml @@ -270,10 +270,10 @@ let contributes = ~description:"List of copybooks paths"; Manifest.PROPERTY.enum "superbol.cobol.dialect" - ~cases:Cobol_config.DIALECT.all_canonical_names + ~cases:Cobol_config.Dialect.all_canonical_names ~description: "Default COBOL dialect; \"default\" is equivalent to \ \"gnucobol\"" - ~default:(`String Cobol_config.(DIALECT.to_string Default)); + ~default:(`String Cobol_config.(Dialect.to_string Default)); Manifest.PROPERTY.enum "superbol.cobol.source-format" ~description: "Default source reference-format" diff --git a/src/lsp/superbol_project/project_config.ml b/src/lsp/superbol_project/project_config.ml index b9259bc80..1ac0011f2 100644 --- a/src/lsp/superbol_project/project_config.ml +++ b/src/lsp/superbol_project/project_config.ml @@ -24,8 +24,8 @@ module TYPES = struct | RelativeToFileDir of string type config = { - mutable cobol_config: Cobol_config.t; - mutable source_format: Cobol_config.source_format_spec; + mutable cobol_config: Cobol_config.Types.t; + mutable source_format: Cobol_config.Types.source_format_spec; mutable libpath: path list; mutable copybook_extensions: string list; mutable copybook_if_no_extension: bool; @@ -55,8 +55,8 @@ let default_copybook_if_no_extension = true let default_indent_config = [] let default = { - cobol_config = Cobol_config.default; - source_format = Cobol_config.Auto; + cobol_config = Cobol_config.Config.default; + source_format = Cobol_config.Types.Auto; libpath = default_libpath; copybook_extensions = default_copybook_extensions; indent_config = default_indent_config; @@ -70,7 +70,7 @@ let new_default () = (* Translation to TOML *) let dialect_repr dialect = - TOML.value_of_string @@ Cobol_config.DIALECT.to_string dialect + TOML.value_of_string @@ Cobol_config.Dialect.to_string dialect let format_repr format = TOML.value_of_string @@ Cobol_config.Options.string_of_format format @@ -104,7 +104,7 @@ let config_repr config ~name = option ~name: "dialect" ~after_comments: ["Default dialect for COBOL source files"] - (dialect_repr @@ Cobol_config.dialect config.cobol_config); + (dialect_repr @@ Cobol_config.Config.dialect config.cobol_config); option ~name: "source-format" @@ -126,10 +126,11 @@ let config_repr config ~name = let config_section_name = "cobol" let config_from_dialect_name dialect_name = - try Cobol_config.(from_dialect @@ DIALECT.of_string dialect_name) with + try Cobol_config.Config.(from_dialect @@ + Cobol_config.Dialect.of_string dialect_name) with | Invalid_argument e -> raise @@ ERROR (Unknown_dialect e) - | Cobol_config.ERROR e -> + | Cobol_config.Types.ERROR e -> raise @@ ERROR (Cobol_config_error e) let get_source_format toml = diff --git a/src/lsp/superbol_project/project_config.mli b/src/lsp/superbol_project/project_config.mli index b0520f155..ba86d803a 100644 --- a/src/lsp/superbol_project/project_config.mli +++ b/src/lsp/superbol_project/project_config.mli @@ -18,8 +18,8 @@ module TYPES: sig | RelativeToFileDir of string type config = (* private *) { - mutable cobol_config: Cobol_config.t; - mutable source_format: Cobol_config.source_format_spec; + mutable cobol_config: Cobol_config.Types.t; + mutable source_format: Cobol_config.Types.source_format_spec; mutable libpath: path list; mutable copybook_extensions: string list; mutable copybook_if_no_extension: bool; diff --git a/src/lsp/superbol_project/project_diagnostics.ml b/src/lsp/superbol_project/project_diagnostics.ml index 4fc07286e..ea883218e 100644 --- a/src/lsp/superbol_project/project_diagnostics.ml +++ b/src/lsp/superbol_project/project_diagnostics.ml @@ -16,7 +16,7 @@ open Ez_toml.V1 type error = | Invalid_toml of { loc: TOML.Types.location; error: TOML.Types.error } | Unknown_dialect of string - | Cobol_config_error of Cobol_config.Diagnostics.error + | Cobol_config_error of Cobol_config.Config_diagnostics.error let pp_error ppf = function | Invalid_toml { loc; error } -> @@ -25,4 +25,4 @@ let pp_error ppf = function | Unknown_dialect name -> Pretty.print ppf "Unknown@ dialect: `%s'" name | Cobol_config_error e -> - Cobol_config.Diagnostics.pp_error ppf e + Cobol_config.Config_diagnostics.pp_error ppf e diff --git a/test/cobol_data/dune b/test/cobol_data/dune index 596bda45a..1760a2600 100644 --- a/test/cobol_data/dune +++ b/test/cobol_data/dune @@ -1,7 +1,7 @@ (tests (names test_qualified_map) (modules test_qualified_map) - (libraries alcotest cobol_data)) + (libraries alcotest cobol_data_old)) (library (name test_cobol_data) diff --git a/test/cobol_data/test_memory.ml b/test/cobol_data/test_memory.ml index 5fd40e083..8cc0498c0 100644 --- a/test/cobol_data/test_memory.ml +++ b/test/cobol_data/test_memory.ml @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open Testing_helpers.Make (Cobol_parser.INTERNAL.Dummy.Tags) +open Testing_helpers.Make (Cobol_parser.Main.INTERNAL.Dummy.Tags) module NEL = Cobol_common.Basics.NEL module Memory = Cobol_data.Memory diff --git a/test/cobol_data/test_qualified_map.ml b/test/cobol_data/test_qualified_map.ml index e959e5ab1..9b478db5e 100644 --- a/test/cobol_data/test_qualified_map.ml +++ b/test/cobol_data/test_qualified_map.ml @@ -11,9 +11,7 @@ (* *) (**************************************************************************) -module Cobol_data = Cobol_data.OLD - -open Cobol_ptree +open Cobol_ptree.Types open Cobol_common.Srcloc.INFIX type t = @@ -50,21 +48,21 @@ let transform wss map = | Group (name, elt, elts) -> let str_list = name::str_list in List.fold_left (aux str_list) - (Cobol_data.Qualmap.add (qualname_of_str_list str_list) elt map) + (Cobol_data_old.Qualmap.add (qualname_of_str_list str_list) elt map) elts | Elementary (name, elt) -> - Cobol_data.Qualmap.add (qualname_of_str_list (name::str_list)) elt map + Cobol_data_old.Qualmap.add (qualname_of_str_list (name::str_list)) elt map in aux [] map wss let wss = List.fold_left (fun map grp -> transform grp map) - Cobol_data.Qualmap.empty + Cobol_data_old.Qualmap.empty wss let wss = - Cobol_data.Qualmap.add + Cobol_data_old.Qualmap.add (Qual ("Level 5" &@ dummy_loc, Qual ("Level 3" &@ dummy_loc, Name ("Level 1" &@ dummy_loc)))) @@ -84,56 +82,56 @@ let name n: qualname = let access_elt_1 () = Alcotest.(check elt) "can access simple elt" - (Cobol_data.Qualmap.find (name "Level 1") wss) 0 + (Cobol_data_old.Qualmap.find (name "Level 1") wss) 0 let access_elt_3 () = Alcotest.(check elt) "can access simple sub element" - (Cobol_data.Qualmap.find (name "Level 3") wss) 1 + (Cobol_data_old.Qualmap.find (name "Level 3") wss) 1 let access_elt_3_2 () = Alcotest.(check elt) "can access qualified elt" - (Cobol_data.Qualmap.find (qual "Level 2" (name "Level 3")) wss) 2 + (Cobol_data_old.Qualmap.find (qual "Level 2" (name "Level 3")) wss) 2 let access_elt_4_2 () = Alcotest.(check elt) "can access qualified elt" - (Cobol_data.Qualmap.find (qual "Level 2" (name "Level 4")) wss) 4 + (Cobol_data_old.Qualmap.find (qual "Level 2" (name "Level 4")) wss) 4 let duplicate_2 () = let qualname: qualname = name "Level 2" in Alcotest.check_raises "Not_found on ambiguous" - Not_found (fun () -> ignore @@ Cobol_data.Qualmap.find qualname wss) + Not_found (fun () -> ignore @@ Cobol_data_old.Qualmap.find qualname wss) let bad_name () = let qualname: qualname = qual "Y" (name "Z") in Alcotest.check_raises "Not_found on bad name" - Not_found (fun () -> ignore @@ Cobol_data.Qualmap.find qualname wss) + Not_found (fun () -> ignore @@ Cobol_data_old.Qualmap.find qualname wss) let access_elt_x_y_z () = let qualname: qualname = qual "Z" (qual "Y" (name "X")) in Alcotest.(check elt) "can access qualified elt" - (Cobol_data.Qualmap.find qualname wss) 10 + (Cobol_data_old.Qualmap.find qualname wss) 10 let access_elt_x_z () = (* /!\ this should be considered ambiguous! /!\ *) let qualname: qualname = qual "Z" (name "X") in Alcotest.(check elt) "can access partial qualified elt" - (Cobol_data.Qualmap.find qualname wss) 11 + (Cobol_data_old.Qualmap.find qualname wss) 11 let bad_order () = let qualname: qualname = qual "Z" (qual "X" (name "Y")) in Alcotest.check_raises "Not_found on invalid name order" - Not_found (fun () -> ignore @@ Cobol_data.Qualmap.find qualname wss) + Not_found (fun () -> ignore @@ Cobol_data_old.Qualmap.find qualname wss) (* let pp_print_str_list = Format.(pp_print_list ~pp_sep:pp_print_space pp_print_string) let pp_print_set fmt = - Cobol_data.Qualmap.(fun elt -> + Cobol_data_old.Qualmap.(fun elt -> pp_qualname fmt elt; Format.pp_print_break fmt 2 0) let pp_print_map f fmt = - Cobol_data.Qualmap.iter (fun l elt -> + Cobol_data_old.Qualmap.iter (fun l elt -> Format.fprintf fmt "Key: %a; Value: %a;\n" pp_qualname l diff --git a/test/cobol_parsing/parser_testing.ml b/test/cobol_parsing/parser_testing.ml index 2f9ac8ed7..9ad7b88d8 100644 --- a/test/cobol_parsing/parser_testing.ml +++ b/test/cobol_parsing/parser_testing.ml @@ -16,12 +16,12 @@ module StrMap = EzCompat.StringMap let preproc ?(filename = "prog.cob") - ?(source_format = Cobol_config.(SF SFFixed)) + ?(source_format = Cobol_config.Types.(SF SFFixed)) contents = Cobol_common.Srcloc.TESTING.register_file_contents ~filename contents; String { filename; contents } |> - Cobol_preproc.preprocessor + Cobol_preproc.Main.preprocessor ~options:Cobol_preproc.Options.{ default with libpath = []; @@ -32,7 +32,7 @@ let show_parsed_tokens ?(verbose = false) ?(with_locations = false) ?source_format ?filename contents = let DIAGS.{ result = WithArtifacts (_, { tokens; _ }); _ } = preproc ?source_format ?filename contents |> - Cobol_parser.parse_with_artifacts + Cobol_parser.Main.parse_with_artifacts ~options:Cobol_parser.Options.{ default with verbose; @@ -40,12 +40,12 @@ let show_parsed_tokens ?(verbose = false) ?(with_locations = false) } in (if with_locations - then Cobol_parser.INTERNAL.pp_tokens' ~fsep:"@\n" - else Cobol_parser.INTERNAL.pp_tokens) Fmt.stdout (Lazy.force tokens) + then Cobol_parser.Main.INTERNAL.pp_tokens' ~fsep:"@\n" + else Cobol_parser.Main.INTERNAL.pp_tokens) Fmt.stdout (Lazy.force tokens) let show_diagnostics ?(verbose = false) ?source_format ?filename contents = preproc ?source_format ?filename contents |> - Cobol_parser.parse_simple + Cobol_parser.Main.parse_simple ~options:Cobol_parser.Options.{ default with verbose; @@ -143,18 +143,18 @@ let triplewise positions = actually on disk nor registered via {!Srcloc.register_file_contents}. *) let rewindable_parse ?(verbose = false) - ?(source_format = Cobol_config.(SF SFFixed)) + ?(source_format = Cobol_config.Types.(SF SFFixed)) ?config prog = let DIAGS.{ result = Only ptree, rewinder; diags } = String { filename = "prog.cob"; contents = prog } |> - Cobol_preproc.preprocessor + Cobol_preproc.Main.preprocessor ~options:Cobol_preproc.Options.{ verbose; libpath = []; source_format; config = Option.value config ~default:default.config; } |> - Cobol_parser.rewindable_parse_simple + Cobol_parser.Main.rewindable_parse_simple ~options:Cobol_parser.Options.{ default with verbose; recovery = DisableRecovery; @@ -166,8 +166,8 @@ let rewindable_parse (** Note: won't show detailed source locations as the openned file is neither actually on disk nor registered via {!Srcloc.register_file_contents}. *) let rewind_n_parse ~f rewinder { line; char; _ } preproc_rewind = - let DIAGS.{ result = Only ptree, rewinder; diags } = - Cobol_parser.rewind_and_parse rewinder preproc_rewind + let DIAGS.{ result = Cobol_parser.Outputs.Only ptree, rewinder; diags } = + Cobol_parser.Main.rewind_and_parse rewinder preproc_rewind ~position:(Indexed { line; char }) in f ptree diags; @@ -198,7 +198,7 @@ let iteratively_append_chunks ?config ~f (prog, positions) = Pretty.(to_string "%S" @@ EzString.after prog (pos.cnum - 1)); succ i, rewind_n_parse ~f:(f i num_chunks) rewinder pos - (Cobol_preproc.reset_preprocessor_for_string prog) + (Cobol_preproc.Main.reset_preprocessor_for_string prog) end (1, rewinder) (pairwise positions.pos_anonymous) @@ -230,7 +230,7 @@ let iteratively_append_chunks_stuttering ?config ~f Pretty.(to_string "%S" @@ EzString.after prog (pos.cnum - 1)); let rewinder = rewind_n_parse ~f:(f i num_chunks) rewinder pos - (Cobol_preproc.reset_preprocessor_for_string prog) + (Cobol_preproc.Main.reset_preprocessor_for_string prog) in let rewinder = if i < num_chunks then begin @@ -241,7 +241,7 @@ let iteratively_append_chunks_stuttering ?config ~f Fmt.(truncated ~max:30) Pretty.(to_string "%S" @@ EzString.after prog' (pos.cnum - 1)); rewind_n_parse ~f:(f i num_chunks) rewinder next_pos_1 - (Cobol_preproc.reset_preprocessor_for_string prog') + (Cobol_preproc.Main.reset_preprocessor_for_string prog') end else rewinder in succ i, rewinder @@ -280,13 +280,13 @@ let simulate_cut_n_paste ?config ~f0 ~f ?verbose ?(repeat = 1) and prog_suffix = EzString.after prog (next_pos.cnum - 1) in let rewinder = rewind_n_parse ~f:(fun _ _ -> ()) rewinder pos @@ - Cobol_preproc.reset_preprocessor_for_string @@ + Cobol_preproc.Main.reset_preprocessor_for_string @@ prog_prefix ^ prog_suffix in Pretty.out "Putting it back@."; let rewinder = rewind_n_parse ~f:(f chunk_num num_chunks ~ptree0) rewinder pos @@ - Cobol_preproc.reset_preprocessor_for_string prog + Cobol_preproc.Main.reset_preprocessor_for_string prog in loop (succ i) rewinder end diff --git a/test/cobol_parsing/test_appending.ml b/test/cobol_parsing/test_appending.ml index 7ff7232cf..46ec9d2a0 100644 --- a/test/cobol_parsing/test_appending.ml +++ b/test/cobol_parsing/test_appending.ml @@ -12,7 +12,7 @@ (**************************************************************************) let pp_ptree = - Fmt.option Cobol_ptree.pp_compilation_group + Fmt.option Cobol_ptree.Types.pp_compilation_group ~none:(Fmt.any "None") let show_ptree _i _n ptree (* _art *) _diags = diff --git a/test/cobol_parsing/test_appending_large.ml b/test/cobol_parsing/test_appending_large.ml index d8051526e..69b093aa8 100644 --- a/test/cobol_parsing/test_appending_large.ml +++ b/test/cobol_parsing/test_appending_large.ml @@ -30,7 +30,7 @@ let%expect_test "line-by-line-incremental-mf" = (* 3142 ./ReportWriter/RepWriteA.cbl *) (* 3087 ./Strings/UnstringFileEg.cbl *) (* 2413 ./SubProg/DateValid/ValiDate.cbl *) - let config = Testsuite_utils.from_dialect Cobol_config.DIALECT.mf_strict in + let config = Testsuite_utils.from_dialect Cobol_config.Dialect.mf_strict in deep_iter mf_root ~glob:"RepWriteSumm.[cC][bB][lL]" (* <- pick largest file *) ~f:begin fun path -> let file = srcdir // mf_testsuite // path in diff --git a/test/cobol_parsing/test_combined_relations_parsing.ml b/test/cobol_parsing/test_combined_relations_parsing.ml index abb4ec70a..af1c39625 100644 --- a/test/cobol_parsing/test_combined_relations_parsing.ml +++ b/test/cobol_parsing/test_combined_relations_parsing.ml @@ -13,11 +13,11 @@ open Alcotest -open Cobol_ptree -open Testing_helpers.Make (Cobol_parser.INTERNAL.Dummy.Tags) -open Cobol_parser.INTERNAL.Tokens -open Cobol_parser.INTERNAL.Grammar -open Cobol_parser.INTERNAL.Dummy +open Cobol_ptree.Types +open Testing_helpers.Make (Cobol_parser.Main.INTERNAL.Dummy.Tags) +open Cobol_parser.Grammar_tokens +open Cobol_parser.Grammar +open Cobol_parser.Main.INTERNAL.Dummy let condition: condition testable = testable pp_condition (=) let parse_condition = parse_list_as standalone_condition diff --git a/test/cobol_parsing/test_cutnpaste_large.ml b/test/cobol_parsing/test_cutnpaste_large.ml index 7202b3db4..303a7e395 100644 --- a/test/cobol_parsing/test_cutnpaste_large.ml +++ b/test/cobol_parsing/test_cutnpaste_large.ml @@ -23,12 +23,12 @@ let check_initial_ptree ~ptree0 diags = let check_new_ptree i n ~ptree0 ptree' diags = if Option.compare - Cobol_ptree.compare_compilation_group ptree0 ptree' = 0 + Cobol_ptree.Types.compare_compilation_group ptree0 ptree' = 0 then Pretty.out "Ok@." else Test_appending.show_ptree i n ptree' diags let%expect_test "cut-n-paste-mf" = - let config = Testsuite_utils.from_dialect Cobol_config.DIALECT.mf_strict in + let config = Testsuite_utils.from_dialect Cobol_config.Dialect.mf_strict in deep_iter mf_root ~glob:"DayDiffDriver.[cC][bB][lL]" (* <- pick large-ish file *) ~f:begin fun path -> let file = srcdir // mf_testsuite // path in diff --git a/test/cobol_parsing/testing_helpers.ml b/test/cobol_parsing/testing_helpers.ml index 652e34bf2..3311ca623 100644 --- a/test/cobol_parsing/testing_helpers.ml +++ b/test/cobol_parsing/testing_helpers.ml @@ -18,7 +18,7 @@ module type TAGS = sig end module Make (Tags: TAGS) = struct - open Cobol_ptree + open Cobol_ptree.Types module Term = struct let name n : qualname = Name (n &@ Tags.loc) diff --git a/test/cobol_preprocessing/preproc_testing.ml b/test/cobol_preprocessing/preproc_testing.ml index ad584b658..0e0b892f4 100644 --- a/test/cobol_preprocessing/preproc_testing.ml +++ b/test/cobol_preprocessing/preproc_testing.ml @@ -21,25 +21,25 @@ module DIAGS = Cobol_common.Diagnostics let preprocess ?(verbose = false) ?(filename = "prog.cob") - ?(source_format = Cobol_config.(SF SFFixed)) + ?(source_format = Cobol_config.Types.(SF SFFixed)) contents = DIAGS.show_n_forget ~ppf:Fmt.stdout @@ - Cobol_preproc.preprocess_input + Cobol_preproc.Main.preprocess_input ~options:Cobol_preproc.Options.{ default with verbose; libpath = []; source_format } @@ - Cobol_preproc.String { filename; contents } + Cobol_preproc.Src_input.String { filename; contents } let show_text ?(verbose = false) ?(filename = "prog.cob") - ?(source_format = Cobol_config.(SF SFFixed)) + ?(source_format = Cobol_config.Types.(SF SFFixed)) contents = let text = DIAGS.show_n_forget ~ppf:Fmt.stdout @@ - Cobol_preproc.text_of_input + Cobol_preproc.Main.text_of_input ~options:Cobol_preproc.Options.{ default with verbose; libpath = []; source_format } @@ - Cobol_preproc.String { filename; contents } + Cobol_preproc.Src_input.String { filename; contents } in Pretty.out "%a@\n" (Cobol_preproc.Text.pp_text' ~fsep:"@\n") text @@ -48,12 +48,12 @@ let show_source_lines ?(with_source_cdir_markers = false) ?(with_compiler_directives_text = true) ?(filename = "prog.cob") - ?(dialect = Cobol_config.DIALECT.Default) - ?(source_format = Cobol_config.(SF SFFixed)) + ?(dialect = Cobol_config.Types.Default) + ?(source_format = Cobol_config.Types.(SF SFFixed)) contents = DIAGS.show_n_forget ~ppf:Fmt.stdout @@ - Cobol_preproc.fold_source_lines ~dialect ~source_format + Cobol_preproc.Main.fold_source_lines ~dialect ~source_format ~f:begin fun lnum line () -> if with_line_numbers then Pretty.out "@\n%u: " lnum else Pretty.out "@\n"; Pretty.out "%a" Cobol_preproc.Text.pp_text line; @@ -71,13 +71,14 @@ let show_source_lines end let rec show_all_text pp = - match Cobol_preproc.next_chunk pp with + match Cobol_preproc.Main.next_chunk pp with | { payload = Cobol_preproc.Text.Eof; _ } :: _, _ -> - Cobol_common.Diagnostics.Set.pp Fmt.stdout (Cobol_preproc.diags pp); - pp + Cobol_common.Diagnostics.Set.pp Fmt.stdout + (Cobol_preproc.Main.diags pp); + pp | text, pp -> - Pretty.out "%a@\n" Cobol_preproc.Text.pp_text text; - show_all_text pp + Pretty.out "%a@\n" Cobol_preproc.Text.pp_text text; + show_all_text pp let show_lines ppf lines = Pretty.list ~fopen:"@[" ~fsep:"@\n" ~fclose:"@]" (Fmt.fmt "%S") @@ -86,7 +87,7 @@ let show_lines ppf lines = let preprocess_n_then_cut_n_paste_right_of_indicator ?(verbose = false) ?(filename = "prog.cob") - ?(source_format = Cobol_config.Auto) + ?(source_format = Cobol_config.Types.Auto) fixed_format_contents = let fixed_lines = EzString.split fixed_format_contents '\n' in let free_lines = @@ -96,13 +97,13 @@ let preprocess_n_then_cut_n_paste_right_of_indicator let free_format_contents = String.concat "\n" free_lines in Pretty.out "fixed: %a@." show_lines fixed_lines; Pretty.out " free: %a@." show_lines free_lines; - Cobol_preproc.Input.string ~filename fixed_format_contents |> - Cobol_preproc.preprocessor + Cobol_preproc.Src_input.string ~filename fixed_format_contents |> + Cobol_preproc.Main.preprocessor ~options:Cobol_preproc.Options.{ default with verbose; libpath = []; source_format } |> show_all_text |> - Cobol_preproc.reset_preprocessor_for_string free_format_contents |> + Cobol_preproc.Main.reset_preprocessor_for_string free_format_contents |> show_all_text |> - Cobol_preproc.reset_preprocessor_for_string fixed_format_contents |> + Cobol_preproc.Main.reset_preprocessor_for_string fixed_format_contents |> show_all_text |> ignore diff --git a/test/cobol_typeck/dune b/test/cobol_typeck/dune index cf566af6a..b63e6e6e8 100644 --- a/test/cobol_typeck/dune +++ b/test/cobol_typeck/dune @@ -16,7 +16,7 @@ (pps ppx_expect)) (inline_tests (modes best)) ; add js for testing with nodejs - (libraries cobol_typeck typeck_testing) + (libraries cobol_typeck cobol_typeck_old typeck_testing) ) (library diff --git a/test/cobol_typeck/typeck_testing.ml b/test/cobol_typeck/typeck_testing.ml index 9f7b6378c..cc68413db 100644 --- a/test/cobol_typeck/typeck_testing.ml +++ b/test/cobol_typeck/typeck_testing.ml @@ -18,14 +18,14 @@ module DIAGS = Cobol_common.Diagnostics let show_diagnostics ?(show_data = false) ?(verbose = false) ?source_format ?filename contents = preproc ?source_format ?filename contents |> - Cobol_parser.parse_simple + Cobol_parser.Main.parse_simple ~options:Cobol_parser.Options.{ default with verbose; recovery = EnableRecovery { silence_benign_recoveries = true }; } |> - DIAGS.map_result ~f:Cobol_typeck.compilation_group |> - DIAGS.more_result ~f:Cobol_typeck.translate_diagnostics |> + DIAGS.map_result ~f:Cobol_typeck.Engine.compilation_group |> + DIAGS.more_result ~f:Cobol_typeck.Engine.translate_diagnostics |> DIAGS.show_n_forget ~set_status:false ~ppf:Fmt.stdout |> begin fun Cobol_typeck.Outputs.{ group; _ } -> if show_data then diff --git a/test/cobol_unit/test_qualmap.ml b/test/cobol_unit/test_qualmap.ml index 8479d96f7..c7733bde4 100644 --- a/test/cobol_unit/test_qualmap.ml +++ b/test/cobol_unit/test_qualmap.ml @@ -12,7 +12,7 @@ (**************************************************************************) open Cobol_unit.Qualmap -open Testing_helpers.Make (Cobol_parser.INTERNAL.Dummy.Tags) +open Testing_helpers.Make (Cobol_parser.Main.INTERNAL.Dummy.Tags) module NEL = Cobol_common.Basics.NEL @@ -24,7 +24,7 @@ let show_map map = Pretty.out "@[Rep: %a@]@." (pp_qualmap_struct Fmt.text) map let pp_qualname ppf qn = - Pretty.print ppf "@[%a@]" Cobol_ptree.pp_qualname qn + Pretty.print ppf "@[%a@]" Cobol_ptree.Types.pp_qualname qn let show_item qn map = try diff --git a/test/config_parsing/test_gnucobol_config.ml b/test/config_parsing/test_gnucobol_config.ml index 082ed6452..fa0424d32 100644 --- a/test/config_parsing/test_gnucobol_config.ml +++ b/test/config_parsing/test_gnucobol_config.ml @@ -15,19 +15,19 @@ open EzCompat let srcdir = Testsuite_utils.srcdir (* ../output-tests/testsuite_utils.ml *) let confdir = Testsuite_utils.confdir -let search_path = Lazy.force Cobol_config.default_search_path +let search_path = Lazy.force Cobol_config.Config.default_search_path module Default_conf = - (val Cobol_config.default) + (val Cobol_config.Config.default) module Parsed_conf = (val (Cobol_common.Diagnostics.show_n_forget @@ - Cobol_config.from_file ~search_path @@ + Cobol_config.Config.from_file ~search_path @@ Filename.concat confdir "default.conf")) module MF_conf = (val (Cobol_common.Diagnostics.show_n_forget @@ - Cobol_config.(from_dialect ~search_path DIALECT.mf_strict))) + Cobol_config.(Config.from_dialect ~search_path Dialect.mf_strict))) let both_diff s1 s2 = StringSet.union diff --git a/test/lsp/lsp_definition.ml b/test/lsp/lsp_definition.ml index 63b045fcb..bcfdeab6d 100644 --- a/test/lsp/lsp_definition.ml +++ b/test/lsp/lsp_definition.ml @@ -23,7 +23,7 @@ let print_definitions ~projdir server (doc, positions) : unit = let params = DefinitionParams.create ~position ~textDocument:prog () in Pretty.out "%s (line %d, character %d):@." position_name position.line position.character; - match LSP.Request.lookup_definition server params with + match Cobol_lsp.Request.INTERNAL.lookup_definition server params with | None | Some (`Location []) -> Pretty.out "No definition found@." | Some (`Location locs) -> @@ -31,7 +31,7 @@ let print_definitions ~projdir server (doc, positions) : unit = (* Yojson.Safe.to_channel Stdlib.stdout @@ *) (* Lsp.Client_request.yojson_of_result *) (* (Lsp.Client_request.TextDocumentDefinition params) *) - (* (LSP.Request.lookup_definition server params); *) + (* (Cobol_lsp.Request.lookup_definition server params); *) end positions.pos_map ;; diff --git a/test/lsp/lsp_formatting.ml b/test/lsp/lsp_formatting.ml index 16f6daf68..fc62b6994 100644 --- a/test/lsp/lsp_formatting.ml +++ b/test/lsp/lsp_formatting.ml @@ -27,8 +27,8 @@ let format_doc doc = let options = FormattingOptions.create ~insertSpaces:true ~tabSize:2 () in DocumentFormattingParams.create ~options ~textDocument:prog () in - let doc = (LSP.Types.URIMap.find prog.uri server.docs).textdoc in - let formatted = LSP.Request.formatting server params in + let doc = (Cobol_lsp.Alltypes.URIMap.find prog.uri server.docs).textdoc in + let formatted = Cobol_lsp.Request.INTERNAL.formatting server params in Option.map (fun edits -> Lsp.Text_document.apply_text_document_edits doc edits |> Lsp.Text_document.text ) formatted, end_with_postproc diff --git a/test/lsp/lsp_hover.ml b/test/lsp/lsp_hover.ml index a4b84621b..5bfe13d9c 100644 --- a/test/lsp/lsp_hover.ml +++ b/test/lsp/lsp_hover.ml @@ -22,7 +22,7 @@ let print_hovered server ~projdir (prog, prog_positions) = Pretty.out "%a(line %d, character %d):@." Fmt.(option ~none:nop @@ fmt "%s ") key position.line position.character; - match LSP.Request.hover server params with + match Cobol_lsp.Request.INTERNAL.hover server params with | None -> Pretty.out "Hovering nothing worthy@." | Some { contents = `List strings; range } -> diff --git a/test/lsp/lsp_references.ml b/test/lsp/lsp_references.ml index e04c59a1f..fad40244a 100644 --- a/test/lsp/lsp_references.ml +++ b/test/lsp/lsp_references.ml @@ -27,7 +27,7 @@ let print_references ~projdir server (doc, positions) : unit = in Pretty.out "%s (line %d, character %d):@." position_name position.line position.character; - match LSP.Request.lookup_references server params with + match Cobol_lsp.Request.INTERNAL.lookup_references server params with | None | Some [] -> Pretty.out "No reference found@." | Some locs -> diff --git a/test/lsp/lsp_testing.ml b/test/lsp/lsp_testing.ml index 940dd873f..fddeaca02 100644 --- a/test/lsp/lsp_testing.ml +++ b/test/lsp/lsp_testing.ml @@ -23,7 +23,6 @@ open Ez_file.V1 open Ez_file.FileString.OP module StrMap = EzCompat.StringMap -module LSP = Cobol_lsp.INTERNAL (* Used to remove full-path and lines in the test files *) let () = @@ -34,7 +33,7 @@ let () = let layout = Superbol_free_lib.Project.layout; and cache_config = - LSP.Project_cache.{ + Cobol_lsp.Project_cache.{ cache_storage = No_storage; cache_verbose = false; } @@ -46,14 +45,14 @@ let init_temp_project ?(toml = "") () = projdir let make_server () = - LSP.Server.init ~config:{ project_layout = layout; cache_config } + Cobol_lsp.Server.init ~config:{ project_layout = layout; cache_config } let add_cobol_doc server ?copybook ~projdir filename text = let path = projdir // filename in let uri = Lsp.Uri.of_path path in EzFile.write_file path text; let server = - LSP.Server.did_open ?copybook + Cobol_lsp.Server.did_open ?copybook DidOpenTextDocumentParams.{ textDocument = TextDocumentItem.{ languageId = "cobol"; version = 0; text; uri; @@ -106,7 +105,7 @@ let make_lsp_project ?toml () = print_endline in (* Force project initialization (so we can flush before the next RPC) *) - ignore @@ LSP.Project.in_existing_dir projdir ~layout; + ignore @@ Cobol_lsp.Project.in_existing_dir projdir ~layout; print_newline (); { projdir; end_with_postproc }, make_server () @@ -228,7 +227,7 @@ end (* --- *) (* let%expect_test "initialize-server" = *) -(* ignore @@ LSP.Project.in_existing_dir projdir ~layout; *) +(* ignore @@ Cobol_lsp.Project.in_existing_dir projdir ~layout; *) (* print_postproc [%expect.output]; *) (* [%expect {| *) (* {"params":{"diagnostics":[],"uri":"file://__rootdir__/superbol.toml"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} *) diff --git a/test/lsp/lsp_testing.mli b/test/lsp/lsp_testing.mli index a6f338f2c..f161e825b 100644 --- a/test/lsp/lsp_testing.mli +++ b/test/lsp/lsp_testing.mli @@ -12,7 +12,6 @@ (**************************************************************************) module StrMap = EzCompat.StringMap -module LSP = Cobol_lsp.INTERNAL type test_project = { @@ -23,10 +22,10 @@ type test_project = val make_lsp_project : ?toml:string -> unit - -> test_project * LSP.Types.registry + -> test_project * Cobol_lsp.Alltypes.registry val add_cobol_doc - : LSP.Types.registry -> ?copybook:bool -> projdir:string -> string -> string - -> LSP.Types.registry * Lsp.Types.TextDocumentIdentifier.t + : Cobol_lsp.Alltypes.registry -> ?copybook:bool -> projdir:string -> string -> string + -> Cobol_lsp.Alltypes.registry * Lsp.Types.TextDocumentIdentifier.t type positions = { diff --git a/test/output-tests/gnucobol.ml b/test/output-tests/gnucobol.ml index 3933d03e0..d2ba6d1a4 100644 --- a/test/output-tests/gnucobol.ml +++ b/test/output-tests/gnucobol.ml @@ -19,7 +19,7 @@ open Autofonce_core.Types module DIAGS = Cobol_common.Diagnostics let () = - Cobol_common.init_default_exn_printers (); + Cobol_common.Errors.init_default_exn_printers (); (* Disable backtrace recording so `OCAMLRUNPARAM=b` has no effect on the output of tests that fail expectedly. *) Stdlib.Printexc.record_backtrace false @@ -133,7 +133,7 @@ let setup_input ~filename contents = let oc = open_out filename in output_string oc contents; close_out oc; - Cobol_preproc.String { contents; filename } + Cobol_preproc.Src_input.String { contents; filename } let delete_file ~filename = Ez_file.FileString.remove filename @@ -159,20 +159,21 @@ let guess_source_format ~filename ~command = (* hackish detection of format *) try ignore (Str.search_forward regexp command 0); true with Not_found -> false in - Option.value ~default:Cobol_config.(SF SFFixed) @@ - List.find_map (fun (p, f) -> if Lazy.force p then Some f else None) [ - lazy (filename_suffixp "free.cob"), Cobol_config.(SF SFFree); - lazy (command_matchp free_flag_regexp), Cobol_config.(SF SFFree); - lazy (command_matchp fixd_format_regexp), Cobol_config.(SF SFFixed); - lazy (command_matchp free_format_regexp), Cobol_config.(SF SFFree); - lazy (command_matchp cb85_format_regexp), Cobol_config.(SF SFFixed); - lazy (command_matchp vrbl_format_regexp), Cobol_config.(SF SFVariable); - lazy (command_matchp xopn_format_regexp), Cobol_config.(SF SFXOpen); - lazy (command_matchp xcrd_format_regexp), Cobol_config.(SF SFxCard); - lazy (command_matchp term_format_regexp), Cobol_config.(SF SFTrm); - lazy (command_matchp cblx_format_regexp), Cobol_config.(SF SFCOBOLX); - lazy (command_matchp auto_format_regexp), Cobol_config.Auto; - ] + Option.value ~default:Cobol_config.Types.(SF SFFixed) @@ + List.find_map (fun (p, f) -> if Lazy.force p then Some f else None) + Cobol_config.Types.[ + lazy (filename_suffixp "free.cob"), (SF SFFree); + lazy (command_matchp free_flag_regexp), (SF SFFree); + lazy (command_matchp fixd_format_regexp), (SF SFFixed); + lazy (command_matchp free_format_regexp), (SF SFFree); + lazy (command_matchp cb85_format_regexp), (SF SFFixed); + lazy (command_matchp vrbl_format_regexp), (SF SFVariable); + lazy (command_matchp xopn_format_regexp), (SF SFXOpen); + lazy (command_matchp xcrd_format_regexp), (SF SFxCard); + lazy (command_matchp term_format_regexp), (SF SFTrm); + lazy (command_matchp cblx_format_regexp), (SF SFCOBOLX); + lazy (command_matchp auto_format_regexp), Auto; + ] let do_check_parse (test_filename, contents, _, { check_loc; check_command; _ }) = @@ -189,9 +190,9 @@ let do_check_parse (test_filename, contents, _, { check_loc; let source_format = guess_source_format ~filename ~command:check_command in let parse_simple input = input |> - Cobol_preproc.preprocessor + Cobol_preproc.Main.preprocessor ~options:Cobol_preproc.Options.{ default with source_format } |> - Cobol_parser.parse_simple + Cobol_parser.Main.parse_simple in try let input = setup_input ~filename contents in diff --git a/test/output-tests/preproc.ml b/test/output-tests/preproc.ml index 6abd13758..e509ee9ed 100644 --- a/test/output-tests/preproc.ml +++ b/test/output-tests/preproc.ml @@ -18,7 +18,7 @@ open Testsuite_utils let preprocess_file ~source_format ~config filename = Cobol_common.Diagnostics.show_n_forget ~min_level:Error @@ - Cobol_preproc.preprocess_file filename + Cobol_preproc.Main.preprocess_file filename ~options:Cobol_preproc.Options.{ source_format; config; verbose = false; libpath = [] } ~ppf:std_formatter @@ -26,19 +26,19 @@ let preprocess_file ~source_format ~config filename = let () = (* Print one token per line so we can diff outputs more easily. *) Pretty.pp_set_margin std_formatter 3; - let config = from_dialect Cobol_config.DIALECT.mf_strict in + let config = from_dialect Cobol_config.Dialect.mf_strict in deep_iter mf_root ~glob:"*.[cC][bB][lL]" ~f:begin fun path -> printf "@[<1>Pre-processing `%s':@\n" @@ mf_testsuite // path; - preprocess_file ~source_format:(Cobol_config.SF SFFixed) ~config + preprocess_file ~source_format:(Cobol_config.Types.SF SFFixed) ~config (mf_root // path); printf "@]@\nDone.@." end; - let config = Cobol_config.default in + let config = Cobol_config.Config.default in deep_iter ibm_root ~glob:"*.cbl" ~f:begin fun path -> printf "@[<1>Pre-processing `%s':@\n" @@ ibm_testsuite // path; - preprocess_file ~config ~source_format:(Cobol_config.SF SFFree) + preprocess_file ~config ~source_format:(Cobol_config.Types.SF SFFree) (ibm_root // path); printf "@]@\nDone.@." end; diff --git a/test/output-tests/reparse.ml b/test/output-tests/reparse.ml index 8da52513f..bb1ef1b98 100644 --- a/test/output-tests/reparse.ml +++ b/test/output-tests/reparse.ml @@ -18,12 +18,12 @@ open Testsuite_utils let reparse_file ~source_format ~config filename = let parse ~source_format input = - Cobol_parser.parse_simple + Cobol_parser.Main.parse_simple ~options:Cobol_parser.Options.{ default with recovery = DisableRecovery } @@ - Cobol_preproc.preprocessor + Cobol_preproc.Main.preprocessor ~options:Cobol_preproc.Options.{ default with libpath = []; @@ -33,15 +33,15 @@ let reparse_file ~source_format ~config filename = input in let print = - Format.asprintf "@[%a@]@." Cobol_ptree.pp_compilation_group + Format.asprintf "@[%a@]@." Cobol_ptree.Types.pp_compilation_group in - match Cobol_preproc.Input.from ~filename ~f:(parse ~source_format) with + match Cobol_preproc.Src_input.from ~filename ~f:(parse ~source_format) with | { result = Only Some cg; _ } -> ( Format.printf "Parse: OK. "; let contents = print cg in match parse ~source_format:(SF SFFree) (String { contents; filename }) with | { result = Only Some cg'; _ } -> - if Cobol_ptree.compare_compilation_group cg cg' = 0 then + if Cobol_ptree.Types.compare_compilation_group cg cg' = 0 then Format.printf "Reparse: OK." else Format.printf "Reparse: Different." @@ -52,19 +52,19 @@ let reparse_file ~source_format ~config filename = let () = (* Print one token per line so we can diff outputs more easily. *) Pretty.pp_set_margin std_formatter 3; - let config = from_dialect Cobol_config.DIALECT.mf_strict in + let config = from_dialect Cobol_config.Dialect.mf_strict in deep_iter mf_root ~glob:"*.[cC][bB][lL]" ~f:begin fun path -> printf "@[Re-parsing `%s':@ " @@ mf_testsuite // path; - reparse_file ~source_format:(Cobol_config.SF SFFixed) ~config + reparse_file ~source_format:(Cobol_config.Types.SF SFFixed) ~config (mf_root // path); printf "@]@." end; - let config = Cobol_config.default in + let config = Cobol_config.Config.default in deep_iter ibm_root ~glob:"*.cbl" ~f:begin fun path -> printf "@[Re-parsing `%s':@ " @@ ibm_testsuite // path; - reparse_file ~config ~source_format:(Cobol_config.SF SFFree) + reparse_file ~config ~source_format:(Cobol_config.Types.SF SFFree) (ibm_root // path); printf "@]@." end; diff --git a/test/output-tests/testsuite_utils.ml b/test/output-tests/testsuite_utils.ml index b12f1273a..237c89ff5 100644 --- a/test/output-tests/testsuite_utils.ml +++ b/test/output-tests/testsuite_utils.ml @@ -48,4 +48,4 @@ let mf_root = srcdir // mf_testsuite let from_dialect dialect = Cobol_common.Diagnostics.show_n_forget @@ - Cobol_config.from_dialect dialect + Cobol_config.Config.from_dialect dialect