From e9fb51497480c7c055c8fcd15bd61e869773f965 Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Thu, 1 Feb 2024 14:35:09 +0100 Subject: [PATCH 01/10] Refactoring: remove library interfaces Library interfaces are generally a wrong good idea: it hides modules that could be useful later, it renames modules whose source files are then harder to locate, it may contain code that should be in other modules. So, we must avoid them. --- .../{cobol_common.ml => errors.ml} | 30 ---- .../{cobol_common.mli => errors.mli} | 19 --- src/lsp/cobol_common/srcloc.ml | 1 + src/lsp/cobol_common/srcloc.mli | 1 + .../{cobol_config.ml => config.ml} | 16 +- .../{cobol_config.mli => config.mli} | 10 +- src/lsp/cobol_config/default.ml | 4 +- src/lsp/cobol_config/dialect.ml | 129 +++++++++++++++ src/lsp/cobol_config/types.ml | 154 ++---------------- src/lsp/cobol_data/data_picture.ml | 2 +- src/lsp/cobol_data/data_picture.mli | 2 +- src/lsp/cobol_data/group.ml | 4 +- src/lsp/cobol_indent/indenter.mli | 4 +- src/lsp/cobol_lsp/lsp_folding.ml | 1 + src/lsp/cobol_lsp/lsp_request.ml | 4 +- src/lsp/cobol_lsp/lsp_semtoks.ml | 1 + src/lsp/cobol_parser/parser_engine.ml | 2 +- src/lsp/cobol_parser/parser_options.ml | 4 +- src/lsp/cobol_parser/text_lexer.ml | 4 +- src/lsp/cobol_parser/text_lexer.mli | 2 +- src/lsp/cobol_parser/text_tokenizer.mli | 2 +- src/lsp/cobol_preproc/preproc_engine.ml | 4 +- src/lsp/cobol_preproc/preproc_engine.mli | 16 +- src/lsp/cobol_preproc/preproc_grammar.mly | 2 +- src/lsp/cobol_preproc/preproc_grammar_sig.ml | 2 +- src/lsp/cobol_preproc/preproc_options.ml | 8 +- src/lsp/cobol_preproc/preproc_trace.mli | 18 +- src/lsp/cobol_preproc/preproc_utils.ml | 2 +- src/lsp/cobol_preproc/preproc_utils.mli | 2 +- src/lsp/cobol_preproc/src_format.ml | 4 +- src/lsp/cobol_preproc/src_format.mli | 4 +- src/lsp/cobol_preproc/src_input.mli | 23 +++ src/lsp/cobol_preproc/src_reader.ml | 2 +- src/lsp/cobol_preproc/src_reader.mli | 6 +- src/lsp/cobol_typeck/old_group_builder.ml | 2 +- src/lsp/cobol_typeck/old_group_builder.mli | 2 +- src/lsp/cobol_typeck/old_typeck_engine.ml | 2 +- src/lsp/cobol_typeck/typeck_diagnostics.ml | 2 +- src/lsp/cobol_typeck/typeck_engine.ml | 4 +- src/lsp/cobol_typeck/typeck_engine.mli | 4 +- src/lsp/cobol_typeck/typeck_units.ml | 2 +- src/lsp/cobol_typeck/typeck_units.mli | 2 +- src/lsp/superbol_free_lib/common_args.ml | 14 +- src/lsp/superbol_free_lib/globals.ml | 2 +- src/lsp/superbol_free_lib/main.ml | 4 +- src/lsp/superbol_free_lib/vscode_extension.ml | 4 +- src/lsp/superbol_project/project_config.ml | 17 +- src/lsp/superbol_project/project_config.mli | 4 +- .../superbol_project/project_diagnostics.ml | 4 +- 49 files changed, 268 insertions(+), 290 deletions(-) rename src/lsp/cobol_common/{cobol_common.ml => errors.ml} (68%) rename src/lsp/cobol_common/{cobol_common.mli => errors.mli} (73%) rename src/lsp/cobol_config/{cobol_config.ml => config.ml} (96%) rename src/lsp/cobol_config/{cobol_config.mli => config.mli} (92%) create mode 100644 src/lsp/cobol_config/dialect.ml create mode 100644 src/lsp/cobol_preproc/src_input.mli 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/data_picture.ml b/src/lsp/cobol_data/data_picture.ml index 68ef72f1d..d542dc7d8 100644 --- a/src/lsp/cobol_data/data_picture.ml +++ b/src/lsp/cobol_data/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/data_picture.mli index b679078f3..e1d32d493 100644 --- a/src/lsp/cobol_data/data_picture.mli +++ b/src/lsp/cobol_data/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/group.ml b/src/lsp/cobol_data/group.ml index cdd351bba..7d8a69ee9 100644 --- a/src/lsp/cobol_data/group.ml +++ b/src/lsp/cobol_data/group.ml @@ -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_indent/indenter.mli b/src/lsp/cobol_indent/indenter.mli index 99d0751ec..784e4dfa9 100644 --- a/src/lsp/cobol_indent/indenter.mli +++ b/src/lsp/cobol_indent/indenter.mli @@ -13,8 +13,8 @@ (*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 -> filename:string 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_request.ml b/src/lsp/cobol_lsp/lsp_request.ml index bcb075bd1..fd30c99a1 100644 --- a/src/lsp/cobol_lsp/lsp_request.ml +++ b/src/lsp/cobol_lsp/lsp_request.ml @@ -257,7 +257,7 @@ let handle_range_formatting registry params = in let edit_list = Cobol_indent.indent_range - ~dialect:(Cobol_config.dialect project.config.cobol_config) + ~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)) ~filename:(Lsp.Uri.to_path doc.uri) @@ -273,7 +273,7 @@ let handle_formatting registry params = try let editList = Cobol_indent.indent_range - ~dialect:(Cobol_config.dialect project.config.cobol_config) + ~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)) ~filename:(Lsp.Uri.to_path doc.uri) diff --git a/src/lsp/cobol_lsp/lsp_semtoks.ml b/src/lsp/cobol_lsp/lsp_semtoks.ml index 937d85a14..1101da229 100644 --- a/src/lsp/cobol_lsp/lsp_semtoks.ml +++ b/src/lsp/cobol_lsp/lsp_semtoks.ml @@ -11,6 +11,7 @@ (* *) (**************************************************************************) +open Cobol_common.Srcloc.TYPES open Cobol_common (* Srcloc, Visitor *) open Cobol_common.Srcloc.INFIX open Cobol_parser.Tokens diff --git a/src/lsp/cobol_parser/parser_engine.ml b/src/lsp/cobol_parser/parser_engine.ml index 87fbcac08..95c9e1914 100644 --- a/src/lsp/cobol_parser/parser_engine.ml +++ b/src/lsp/cobol_parser/parser_engine.ml @@ -13,7 +13,7 @@ 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 *) diff --git a/src/lsp/cobol_parser/parser_options.ml b/src/lsp/cobol_parser/parser_options.ml index a218d9165..8bf991162 100644 --- a/src/lsp/cobol_parser/parser_options.ml +++ b/src/lsp/cobol_parser/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/text_lexer.ml b/src/lsp/cobol_parser/text_lexer.ml index 233dcbf34..b1d41c9b8 100644 --- a/src/lsp/cobol_parser/text_lexer.ml +++ b/src/lsp/cobol_parser/text_lexer.ml @@ -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..9aab8a2ad 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 diff --git a/src/lsp/cobol_parser/text_tokenizer.mli b/src/lsp/cobol_parser/text_tokenizer.mli index 0acc6b21a..cadadccfd 100644 --- a/src/lsp/cobol_parser/text_tokenizer.mli +++ b/src/lsp/cobol_parser/text_tokenizer.mli @@ -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/preproc_engine.ml b/src/lsp/cobol_preproc/preproc_engine.ml index fdfffa666..73f168b59 100644 --- a/src/lsp/cobol_preproc/preproc_engine.ml +++ b/src/lsp/cobol_preproc/preproc_engine.ml @@ -37,7 +37,7 @@ and preprocessor_persist = overlay_manager: (module Src_overlay.MANAGER); replacing: Preproc_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; @@ -96,7 +96,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 diff --git a/src/lsp/cobol_preproc/preproc_engine.mli b/src/lsp/cobol_preproc/preproc_engine.mli index 96acbc782..830ba1585 100644 --- a/src/lsp/cobol_preproc/preproc_engine.mli +++ b/src/lsp/cobol_preproc/preproc_engine.mli @@ -42,22 +42,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,8 +83,8 @@ 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 diff --git a/src/lsp/cobol_preproc/preproc_grammar.mly b/src/lsp/cobol_preproc/preproc_grammar.mly index 98bbe9bbe..ca86d9df7 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 diff --git a/src/lsp/cobol_preproc/preproc_grammar_sig.ml b/src/lsp/cobol_preproc/preproc_grammar_sig.ml index 98b509b78..66d7bee45 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 diff --git a/src/lsp/cobol_preproc/preproc_options.ml b/src/lsp/cobol_preproc/preproc_options.ml index 2c8e9acc6..ca1884e7c 100644 --- a/src/lsp/cobol_preproc/preproc_options.ml +++ b/src/lsp/cobol_preproc/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_trace.mli b/src/lsp/cobol_preproc/preproc_trace.mli index 92816c69f..3167a2a44 100644 --- a/src/lsp/cobol_preproc/preproc_trace.mli +++ b/src/lsp/cobol_preproc/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; + 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 + : loc: Cobol_common.Srcloc.t -> compdir:Preproc_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_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..bd276c79a 100644 --- a/src/lsp/cobol_preproc/preproc_utils.mli +++ b/src/lsp/cobol_preproc/preproc_utils.mli @@ -14,7 +14,7 @@ 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 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_preproc/src_input.mli b/src/lsp/cobol_preproc/src_input.mli new file mode 100644 index 000000000..a42ac71c7 --- /dev/null +++ b/src/lsp/cobol_preproc/src_input.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* 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 t = + | String of { contents: string; filename: string } + | Channel of { ic: in_channel; filename: string } + +(* [string ~filename content] *) +val string : filename:string -> string -> t + +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..b50d5e1ad 100644 --- a/src/lsp/cobol_preproc/src_reader.ml +++ b/src/lsp/cobol_preproc/src_reader.ml @@ -86,7 +86,7 @@ let decode_compiler_directive ~dialect compdir_text = let open Preproc_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) -> diff --git a/src/lsp/cobol_preproc/src_reader.mli b/src/lsp/cobol_preproc/src_reader.mli index e19f12533..c09fa09f7 100644 --- a/src/lsp/cobol_preproc/src_reader.mli +++ b/src/lsp/cobol_preproc/src_reader.mli @@ -33,7 +33,7 @@ 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) @@ -41,12 +41,12 @@ val fold_lines -> 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 + : dialect: Cobol_config.Types.dialect -> Text.t -> ((Text.t * Preproc_directives.compiler_directive with_loc * Text.t) option, Text.t * Preproc_diagnostics.error * Text.t) result diff --git a/src/lsp/cobol_typeck/old_group_builder.ml b/src/lsp/cobol_typeck/old_group_builder.ml index c16aa5947..d7497b571 100644 --- a/src/lsp/cobol_typeck/old_group_builder.ml +++ b/src/lsp/cobol_typeck/old_group_builder.ml @@ -81,7 +81,7 @@ 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; currency_signs; _ } s = diff --git a/src/lsp/cobol_typeck/old_group_builder.mli b/src/lsp/cobol_typeck/old_group_builder.mli index 0f684123a..05485d1cc 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_config.Types.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 diff --git a/src/lsp/cobol_typeck/old_typeck_engine.ml b/src/lsp/cobol_typeck/old_typeck_engine.ml index e5fc7ead9..15815e687 100644 --- a/src/lsp/cobol_typeck/old_typeck_engine.ml +++ b/src/lsp/cobol_typeck/old_typeck_engine.ml @@ -22,7 +22,7 @@ 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) diff --git a/src/lsp/cobol_typeck/typeck_diagnostics.ml b/src/lsp/cobol_typeck/typeck_diagnostics.ml index 25eb1e41b..e28de566a 100644 --- a/src/lsp/cobol_typeck/typeck_diagnostics.ml +++ b/src/lsp/cobol_typeck/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/typeck_engine.ml index 7548c40db..df9dd1c3f 100644 --- a/src/lsp/cobol_typeck/typeck_engine.ml +++ b/src/lsp/cobol_typeck/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 | Only Some cg | WithArtifacts (Some cg, _) -> Typeck_units.of_compilation_group config cg -let translate_diagnostics ?(config = Cobol_config.default) (output, diags) = +let translate_diagnostics ?(config = Cobol_config.Config.default) (output, diags) = DIAGS.result output ~diags:(Typeck_diagnostics.translate ~config diags) diff --git a/src/lsp/cobol_typeck/typeck_engine.mli b/src/lsp/cobol_typeck/typeck_engine.mli index ca43fe17b..212ac5830 100644 --- a/src/lsp/cobol_typeck/typeck_engine.mli +++ b/src/lsp/cobol_typeck/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 val translate_diagnostics - : ?config: Cobol_config.t + : ?config: Cobol_config.Types.t -> Typeck_outputs.t * Typeck_diagnostics.t -> Typeck_outputs.t Cobol_common.Diagnostics.with_diags diff --git a/src/lsp/cobol_typeck/typeck_units.ml b/src/lsp/cobol_typeck/typeck_units.ml index 1d8fd5364..c348a26bf 100644 --- a/src/lsp/cobol_typeck/typeck_units.ml +++ b/src/lsp/cobol_typeck/typeck_units.ml @@ -119,7 +119,7 @@ end (** This function builds the internal representation of full compilation groups. *) let of_compilation_group - : Cobol_config.t -> Cobol_ptree.compilation_group -> + : Cobol_config.Types.t -> Cobol_ptree.compilation_group -> Typeck_outputs.t * Typeck_diagnostics.t = fun config compilation_group_ptree -> Cobol_ptree.Visitor.fold_compilation_group diff --git a/src/lsp/cobol_typeck/typeck_units.mli b/src/lsp/cobol_typeck/typeck_units.mli index 6d8300da1..0e6b9c56b 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_config.Types.t -> Cobol_ptree.compilation_group -> Typeck_outputs.t * Typeck_diagnostics.t 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 From 8d633b055ebc1ccdbaa20db6451892a8af9222c0 Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Thu, 1 Feb 2024 15:08:46 +0100 Subject: [PATCH 02/10] Introduce Cobol_data_old to replace Cobol_data.OLD --- .drom | 32 +- .github/workflows/workflow.yml | 2 +- Makefile | 2 +- drom.toml | 4 + dune-project | 16 + opam/cobol_data_old.opam | 55 ++++ opam/cobol_data_types.opam | 55 ++++ opam/cobol_unit.opam | 1 + src/lsp/cobol_data/data_types.ml | 216 ------------- src/lsp/cobol_data/{data_item.ml => item.ml} | 38 ++- .../cobol_data/{data_memory.ml => memory.ml} | 0 .../{data_memory.mli => memory.mli} | 0 .../{data_picture.ml => picture.ml} | 0 .../{data_picture.mli => picture.mli} | 0 .../{data_printer.ml => printer.ml} | 14 +- src/lsp/cobol_data/types.ml | 292 ++++++++++++------ .../{data_visitor.ml => visitor.ml} | 6 +- .../compilation_unit.ml | 0 src/lsp/cobol_data_old/dune | 26 ++ src/lsp/{cobol_data => cobol_data_old}/env.ml | 0 .../{cobol_data => cobol_data_old}/group.ml | 0 .../{cobol_data => cobol_data_old}/group.mli | 0 .../mangling.ml | 0 .../mangling.mli | 0 src/lsp/cobol_data_old/package.toml | 77 +++++ .../picture.ml} | 28 +- .../{cobol_data => cobol_data_old}/qualmap.ml | 0 .../qualmap.mli | 0 src/lsp/cobol_data_old/types.ml | 104 +++++++ src/lsp/cobol_data_old/version.mlt | 30 ++ src/lsp/cobol_typeck/old_env_builder.ml | 12 +- src/lsp/cobol_typeck/old_env_builder.mli | 4 +- src/lsp/cobol_typeck/old_group_builder.ml | 48 ++- src/lsp/cobol_typeck/old_group_builder.mli | 4 +- src/lsp/cobol_typeck/old_prog_builder.ml | 5 +- src/lsp/cobol_typeck/old_typeck_engine.ml | 5 +- src/lsp/cobol_unit/dune | 2 +- src/lsp/cobol_unit/package.toml | 1 + test/cobol_data/dune | 2 +- test/cobol_data/test_qualified_map.ml | 32 +- test/cobol_parsing/parser_testing.ml | 4 +- test/cobol_parsing/test_appending_large.ml | 2 +- test/cobol_parsing/test_cutnpaste_large.ml | 2 +- test/cobol_preprocessing/preproc_testing.ml | 10 +- test/config_parsing/test_gnucobol_config.ml | 8 +- test/output-tests/gnucobol.ml | 31 +- test/output-tests/preproc.ml | 8 +- test/output-tests/reparse.ml | 8 +- test/output-tests/testsuite_utils.ml | 2 +- 49 files changed, 719 insertions(+), 469 deletions(-) create mode 100644 opam/cobol_data_old.opam create mode 100644 opam/cobol_data_types.opam delete mode 100644 src/lsp/cobol_data/data_types.ml rename src/lsp/cobol_data/{data_item.ml => item.ml} (62%) rename src/lsp/cobol_data/{data_memory.ml => memory.ml} (100%) rename src/lsp/cobol_data/{data_memory.mli => memory.mli} (100%) rename src/lsp/cobol_data/{data_picture.ml => picture.ml} (100%) rename src/lsp/cobol_data/{data_picture.mli => picture.mli} (100%) rename src/lsp/cobol_data/{data_printer.ml => printer.ml} (96%) rename src/lsp/cobol_data/{data_visitor.ml => visitor.ml} (98%) rename src/lsp/{cobol_data => cobol_data_old}/compilation_unit.ml (100%) create mode 100644 src/lsp/cobol_data_old/dune rename src/lsp/{cobol_data => cobol_data_old}/env.ml (100%) rename src/lsp/{cobol_data => cobol_data_old}/group.ml (100%) rename src/lsp/{cobol_data => cobol_data_old}/group.mli (100%) rename src/lsp/{cobol_data => cobol_data_old}/mangling.ml (100%) rename src/lsp/{cobol_data => cobol_data_old}/mangling.mli (100%) create mode 100644 src/lsp/cobol_data_old/package.toml rename src/lsp/{cobol_data/cobol_data.ml => cobol_data_old/picture.ml} (58%) rename src/lsp/{cobol_data => cobol_data_old}/qualmap.ml (100%) rename src/lsp/{cobol_data => cobol_data_old}/qualmap.mli (100%) create mode 100644 src/lsp/cobol_data_old/types.ml create mode 100644 src/lsp/cobol_data_old/version.mlt diff --git a/.drom b/.drom index f19bd048e..8fa52b6ad 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:. +cc894e743bb85460e00abcdaf8d9fae5:. # end context for . # begin context for .github/workflows/workflow.yml # file .github/workflows/workflow.yml -b5d1e8c2eb697e9b85aff82f2b2ed8de:.github/workflows/workflow.yml +5429d9f0846180852fae7d2e49e767e8:.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 +f77bb2a3fc45e32226c8cad8171cd91c: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 +972a09725c93d6b9991e532be3dc6c8a: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 @@ -130,7 +140,7 @@ fc02e4984b73153fecd9d70c4ccab428:opam/cobol_typeck.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 +308,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 @@ -360,7 +380,7 @@ ef30db283bff57bd7bfea9b29e9178fd:src/lsp/cobol_typeck/dune # 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..ce26db25d 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_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..37632e74f 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_unit ez_toml ezr_toml ./scripts/after.sh build build-deps: diff --git a/drom.toml b/drom.toml index d4293d5ac..c22d15fda 100644 --- a/drom.toml +++ b/drom.toml @@ -200,6 +200,10 @@ 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 diff --git a/dune-project b/dune-project index c1f802a96..942572800 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") @@ -391,6 +406,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_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_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 62% rename from src/lsp/cobol_data/data_item.ml rename to src/lsp/cobol_data/item.ml index d77717770..8c04b9361 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 diff --git a/src/lsp/cobol_data/data_memory.ml b/src/lsp/cobol_data/memory.ml similarity index 100% rename from src/lsp/cobol_data/data_memory.ml rename to src/lsp/cobol_data/memory.ml diff --git a/src/lsp/cobol_data/data_memory.mli b/src/lsp/cobol_data/memory.mli similarity index 100% rename from src/lsp/cobol_data/data_memory.mli rename to src/lsp/cobol_data/memory.mli diff --git a/src/lsp/cobol_data/data_picture.ml b/src/lsp/cobol_data/picture.ml similarity index 100% rename from src/lsp/cobol_data/data_picture.ml rename to src/lsp/cobol_data/picture.ml diff --git a/src/lsp/cobol_data/data_picture.mli b/src/lsp/cobol_data/picture.mli similarity index 100% rename from src/lsp/cobol_data/data_picture.mli rename to src/lsp/cobol_data/picture.mli diff --git a/src/lsp/cobol_data/data_printer.ml b/src/lsp/cobol_data/printer.ml similarity index 96% rename from src/lsp/cobol_data/data_printer.ml rename to src/lsp/cobol_data/printer.ml index 22fcac566..8b7d17e50 100644 --- a/src/lsp/cobol_data/data_printer.ml +++ b/src/lsp/cobol_data/printer.ml @@ -11,13 +11,13 @@ (* *) (**************************************************************************) -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'_opt = Fmt.option pp_int' @@ -30,10 +30,10 @@ let pp_literal'_list = Fmt.list Cobol_ptree.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) @@ -244,8 +244,8 @@ let pp_record_renaming: record_renaming Pretty.printer = T (Fmt.field "from" (fun r -> r.renaming_from) Cobol_ptree.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); ] diff --git a/src/lsp/cobol_data/types.ml b/src/lsp/cobol_data/types.ml index 1ba8d6cc6..9510a1970 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.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 - | 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.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: 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.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.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: Memory.offset; + renaming_size: 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_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 100% rename from src/lsp/cobol_data/env.ml rename to src/lsp/cobol_data_old/env.ml diff --git a/src/lsp/cobol_data/group.ml b/src/lsp/cobol_data_old/group.ml similarity index 100% rename from src/lsp/cobol_data/group.ml rename to src/lsp/cobol_data_old/group.ml diff --git a/src/lsp/cobol_data/group.mli b/src/lsp/cobol_data_old/group.mli similarity index 100% rename from src/lsp/cobol_data/group.mli rename to src/lsp/cobol_data_old/group.mli diff --git a/src/lsp/cobol_data/mangling.ml b/src/lsp/cobol_data_old/mangling.ml similarity index 100% rename from src/lsp/cobol_data/mangling.ml rename to src/lsp/cobol_data_old/mangling.ml diff --git a/src/lsp/cobol_data/mangling.mli b/src/lsp/cobol_data_old/mangling.mli similarity index 100% rename from src/lsp/cobol_data/mangling.mli rename to src/lsp/cobol_data_old/mangling.mli 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_data/cobol_data.ml b/src/lsp/cobol_data_old/picture.ml similarity index 58% rename from src/lsp/cobol_data/cobol_data.ml rename to src/lsp/cobol_data_old/picture.ml index 99641af48..f3dd52d3e 100644 --- a/src/lsp/cobol_data/cobol_data.ml +++ b/src/lsp/cobol_data_old/picture.ml @@ -11,30 +11,4 @@ (* *) (**************************************************************************) -(** 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 +include Cobol_data.Picture diff --git a/src/lsp/cobol_data/qualmap.ml b/src/lsp/cobol_data_old/qualmap.ml similarity index 100% rename from src/lsp/cobol_data/qualmap.ml rename to src/lsp/cobol_data_old/qualmap.ml diff --git a/src/lsp/cobol_data/qualmap.mli b/src/lsp/cobol_data_old/qualmap.mli similarity index 100% rename from src/lsp/cobol_data/qualmap.mli rename to src/lsp/cobol_data_old/qualmap.mli diff --git a/src/lsp/cobol_data_old/types.ml b/src/lsp/cobol_data_old/types.ml new file mode 100644 index 000000000..65d3f1b73 --- /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.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.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 *) 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_typeck/old_env_builder.ml b/src/lsp/cobol_typeck/old_env_builder.ml index ec4acb977..5924a2c83 100644 --- a/src/lsp/cobol_typeck/old_env_builder.ml +++ b/src/lsp/cobol_typeck/old_env_builder.ml @@ -15,8 +15,6 @@ open Cobol_ptree 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 index 5f7e0beff..bd061fb6f 100644 --- a/src/lsp/cobol_typeck/old_env_builder.mli +++ b/src/lsp/cobol_typeck/old_env_builder.mli @@ -15,6 +15,6 @@ open Cobol_ptree 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 index d7497b571..52e7862e3 100644 --- a/src/lsp/cobol_typeck/old_group_builder.ml +++ b/src/lsp/cobol_typeck/old_group_builder.ml @@ -15,8 +15,6 @@ open Cobol_ptree 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 @@ -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 @@ -83,13 +81,13 @@ let rec from_item_descrs config prog_env data_group : _ with_diags = 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 index 05485d1cc..a3911ebcb 100644 --- a/src/lsp/cobol_typeck/old_group_builder.mli +++ b/src/lsp/cobol_typeck/old_group_builder.mli @@ -15,6 +15,6 @@ open Cobol_common.Diagnostics.TYPES val working_data_of_compilation_unit' : Cobol_config.Types.t - -> Cobol_data.OLD.PROG_ENV.t + -> Cobol_data_old.Env.PROG_ENV.t -> Cobol_ptree.compilation_unit Cobol_ptree.with_loc - -> Cobol_data.OLD.Group.t' Cobol_ptree.with_loc list with_diags + -> Cobol_data_old.Group.t' Cobol_ptree.with_loc list with_diags diff --git a/src/lsp/cobol_typeck/old_prog_builder.ml b/src/lsp/cobol_typeck/old_prog_builder.ml index 3d09c7484..fc0d7b3b3 100644 --- a/src/lsp/cobol_typeck/old_prog_builder.ml +++ b/src/lsp/cobol_typeck/old_prog_builder.ml @@ -11,7 +11,6 @@ (* *) (**************************************************************************) -module Cobol_data = Cobol_data.OLD module Env_builder = Old_env_builder module Group_builder = Old_group_builder @@ -21,7 +20,7 @@ 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 +34,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 index 15815e687..9627b0748 100644 --- a/src/lsp/cobol_typeck/old_typeck_engine.ml +++ b/src/lsp/cobol_typeck/old_typeck_engine.ml @@ -13,11 +13,10 @@ (** 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 @@ -25,7 +24,7 @@ let analyze_compilation_group 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_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/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/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_qualified_map.ml b/test/cobol_data/test_qualified_map.ml index e959e5ab1..64ad34dae 100644 --- a/test/cobol_data/test_qualified_map.ml +++ b/test/cobol_data/test_qualified_map.ml @@ -11,8 +11,6 @@ (* *) (**************************************************************************) -module Cobol_data = Cobol_data.OLD - open Cobol_ptree open Cobol_common.Srcloc.INFIX @@ -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..256e1f967 100644 --- a/test/cobol_parsing/parser_testing.ml +++ b/test/cobol_parsing/parser_testing.ml @@ -16,7 +16,7 @@ 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; @@ -143,7 +143,7 @@ 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 = 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_cutnpaste_large.ml b/test/cobol_parsing/test_cutnpaste_large.ml index 7202b3db4..b981832d7 100644 --- a/test/cobol_parsing/test_cutnpaste_large.ml +++ b/test/cobol_parsing/test_cutnpaste_large.ml @@ -28,7 +28,7 @@ let check_new_ptree i n ~ptree0 ptree' diags = 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_preprocessing/preproc_testing.ml b/test/cobol_preprocessing/preproc_testing.ml index ad584b658..40d2f56e2 100644 --- a/test/cobol_preprocessing/preproc_testing.ml +++ b/test/cobol_preprocessing/preproc_testing.ml @@ -21,7 +21,7 @@ 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 @@ -32,7 +32,7 @@ let preprocess 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 @@ @@ -48,8 +48,8 @@ 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 @@ @@ -86,7 +86,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 = 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/output-tests/gnucobol.ml b/test/output-tests/gnucobol.ml index 3933d03e0..02ededab2 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 @@ -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; _ }) = diff --git a/test/output-tests/preproc.ml b/test/output-tests/preproc.ml index 6abd13758..deae014e9 100644 --- a/test/output-tests/preproc.ml +++ b/test/output-tests/preproc.ml @@ -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..fec2a6640 100644 --- a/test/output-tests/reparse.ml +++ b/test/output-tests/reparse.ml @@ -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 From 683eb2e62e005a2bfd0971fff1bf8333d26cd1b2 Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Thu, 1 Feb 2024 15:34:29 +0100 Subject: [PATCH 03/10] Remove cobol_indent/cobol_indent.ml --- src/lsp/cobol_indent/cobol_indent.ml | 26 ------------------- src/lsp/cobol_indent/indent_check.ml | 2 +- src/lsp/cobol_indent/indent_check.mli | 4 +-- src/lsp/cobol_indent/indent_config.ml | 2 +- src/lsp/cobol_indent/indent_config.mli | 4 +-- src/lsp/cobol_indent/indent_keywords.ml | 2 +- src/lsp/cobol_indent/indent_keywords.mli | 10 +++---- .../{indenter.ml => indent_main.ml} | 11 +++++++- .../{indenter.mli => indent_main.mli} | 14 ++++++++-- src/lsp/cobol_indent/indent_util.ml | 2 +- src/lsp/cobol_indent/indent_util.mli | 2 +- .../cobol_indent/{indent_type.ml => types.ml} | 0 src/lsp/cobol_lsp/lsp_request.ml | 12 ++++----- .../superbol_free_lib/command_indent_file.ml | 5 ++-- .../superbol_free_lib/command_indent_range.ml | 7 +++-- 15 files changed, 47 insertions(+), 56 deletions(-) delete mode 100644 src/lsp/cobol_indent/cobol_indent.ml rename src/lsp/cobol_indent/{indenter.ml => indent_main.ml} (88%) rename src/lsp/cobol_indent/{indenter.mli => indent_main.mli} (76%) rename src/lsp/cobol_indent/{indent_type.ml => types.ml} (100%) 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 88% rename from src/lsp/cobol_indent/indenter.ml rename to src/lsp/cobol_indent/indent_main.ml index 8ff9ac072..1d9ec39ed 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 = @@ -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 76% rename from src/lsp/cobol_indent/indenter.mli rename to src/lsp/cobol_indent/indent_main.mli index 784e4dfa9..29068b070 100644 --- a/src/lsp/cobol_indent/indenter.mli +++ b/src/lsp/cobol_indent/indent_main.mli @@ -16,7 +16,17 @@ val indent_range : 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/lsp_request.ml b/src/lsp/cobol_lsp/lsp_request.ml index fd30c99a1..b4750f9de 100644 --- a/src/lsp/cobol_lsp/lsp_request.ml +++ b/src/lsp/cobol_lsp/lsp_request.ml @@ -224,7 +224,7 @@ let handle_references state (params: ReferenceParams.t) = (** {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 @@ -250,16 +250,16 @@ let handle_range_formatting registry params = Lsp_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 + 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) @@ -272,10 +272,10 @@ let handle_formatting registry params = Lsp_server.find_document doc registry in try let editList = - Cobol_indent.indent_range + 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 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} From 255e302813d1d7381d3dcdb1941b746d8739db30 Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Thu, 1 Feb 2024 18:19:43 +0100 Subject: [PATCH 04/10] Remove cobol_preproc.ml --- src/lsp/cobol_indent/indent_main.ml | 2 +- src/lsp/cobol_lsp/lsp_document.ml | 4 +- src/lsp/cobol_parser/parser_engine.ml | 36 +++++++++--------- src/lsp/cobol_parser/parser_engine.mli | 7 ++-- src/lsp/cobol_preproc/cobol_preproc.ml | 37 ------------------- .../{preproc_directives.ml => directives.ml} | 0 .../{preproc_options.ml => options.ml} | 0 src/lsp/cobol_preproc/preproc_grammar.mly | 10 ++--- src/lsp/cobol_preproc/preproc_grammar_sig.ml | 8 ++-- src/lsp/cobol_preproc/preproc_utils.mli | 4 +- .../{preproc_engine.ml => preprocess.ml} | 24 ++++++------ .../{preproc_engine.mli => preprocess.mli} | 15 ++++---- src/lsp/cobol_preproc/src_reader.ml | 6 +-- src/lsp/cobol_preproc/src_reader.mli | 4 +- src/lsp/cobol_preproc/text_processor.ml | 10 ++--- src/lsp/cobol_preproc/text_processor.mli | 18 ++++----- .../{preproc_trace.ml => trace.ml} | 2 +- .../{preproc_trace.mli => trace.mli} | 4 +- src/lsp/superbol_free_lib/command_pp.ml | 6 +-- test/cobol_parsing/parser_testing.ml | 14 +++---- test/cobol_preprocessing/preproc_testing.ml | 29 ++++++++------- test/output-tests/gnucobol.ml | 4 +- test/output-tests/preproc.ml | 2 +- test/output-tests/reparse.ml | 4 +- 24 files changed, 109 insertions(+), 141 deletions(-) delete mode 100644 src/lsp/cobol_preproc/cobol_preproc.ml rename src/lsp/cobol_preproc/{preproc_directives.ml => directives.ml} (100%) rename src/lsp/cobol_preproc/{preproc_options.ml => options.ml} (100%) rename src/lsp/cobol_preproc/{preproc_engine.ml => preprocess.ml} (96%) rename src/lsp/cobol_preproc/{preproc_engine.mli => preprocess.mli} (92%) rename src/lsp/cobol_preproc/{preproc_trace.ml => trace.ml} (97%) rename src/lsp/cobol_preproc/{preproc_trace.mli => trace.mli} (94%) diff --git a/src/lsp/cobol_indent/indent_main.ml b/src/lsp/cobol_indent/indent_main.ml index 1d9ec39ed..a965fbbe7 100644 --- a/src/lsp/cobol_indent/indent_main.ml +++ b/src/lsp/cobol_indent/indent_main.ml @@ -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.Preprocess.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 diff --git a/src/lsp/cobol_lsp/lsp_document.ml b/src/lsp/cobol_lsp/lsp_document.ml index 760ddde48..c8930645d 100644 --- a/src/lsp/cobol_lsp/lsp_document.ml +++ b/src/lsp/cobol_lsp/lsp_document.ml @@ -72,7 +72,7 @@ let rewindable_parse ({ project; textdoc; _ } as doc) = recovery = EnableRecovery { silence_benign_recoveries = true }; config = project.config.cobol_config; } @@ - Cobol_preproc.preprocessor + Cobol_preproc.Preprocess.preprocessor ~options:Cobol_preproc.Options.{ default with libpath = Lsp_project.libpath_for ~uri:(uri doc) project; @@ -116,7 +116,7 @@ let reparse_and_analyze ?position ({ copybook; rewinder; textdoc; _ } as doc) = | Some position, Some rewinder -> check doc @@ Cobol_parser.rewind_and_parse rewinder ~position @@ - Cobol_preproc.reset_preprocessor_for_string @@ + Cobol_preproc.Preprocess.reset_preprocessor_for_string @@ Lsp.Text_document.text textdoc (** Creates a record for a document that is not yet parsed or analyzed. *) diff --git a/src/lsp/cobol_parser/parser_engine.ml b/src/lsp/cobol_parser/parser_engine.ml index 95c9e1914..8d2fea4c1 100644 --- a/src/lsp/cobol_parser/parser_engine.ml +++ b/src/lsp/cobol_parser/parser_engine.ml @@ -38,19 +38,19 @@ 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.Preprocess.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_preproc.Preprocess.preprocessor -> (Cobol_ptree.compilation_group option, 'm) output DIAGS.with_diags type 'm rewindable_parsing = ?options:parser_options - -> Cobol_preproc.preprocessor + -> Cobol_preproc.Preprocess.preprocessor -> (((Cobol_ptree.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.Preprocess.t; (* also holds diagnostics *) tokzr: 'm Tokzr.state; persist: 'm persist; } @@ -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.Preprocess.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.Preprocess.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.Preprocess.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.Preprocess.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.Preprocess.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.Preprocess.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.Preprocess.rev_log ps.preproc.pp; + rev_comments = Cobol_preproc.Preprocess.rev_comments ps.preproc.pp; + rev_ignored = Cobol_preproc.Preprocess.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.Preprocess.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.Preprocess.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.Preprocess.preprocessor -> ((('a option, 'm) output as 'x) * 'x rewinder) with_diags = fun ~options ~memory ~make_checkpoint pp -> let res, rwps = @@ -581,7 +581,7 @@ let parse (type m) ~(memory: m memory) ?(options = Parser_options.default) - : Cobol_preproc.preprocessor -> + : Cobol_preproc.Preprocess.t -> (Cobol_ptree.compilation_group option, m) output with_diags = parse_once ~options ~memory ~make_checkpoint:Grammar.Incremental.compilation_group @@ -593,7 +593,7 @@ let rewindable_parse (type m) ~(memory: m memory) ?(options = Parser_options.default) - : Cobol_preproc.preprocessor -> + : Cobol_preproc.Preprocess.t -> (((Cobol_ptree.compilation_group option, m) output as 'x) * 'x rewinder) with_diags = rewindable_parse ~options ~memory diff --git a/src/lsp/cobol_parser/parser_engine.mli b/src/lsp/cobol_parser/parser_engine.mli index db0525f37..dacadca8f 100644 --- a/src/lsp/cobol_parser/parser_engine.mli +++ b/src/lsp/cobol_parser/parser_engine.mli @@ -37,7 +37,7 @@ 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_preproc.Preprocess.t -> (Cobol_ptree.compilation_group option, 'm) output Cobol_common.Diagnostics.with_diags @@ -60,7 +60,7 @@ 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_preproc.Preprocess.preprocessor -> (((Cobol_ptree.compilation_group option, 'm) output as 'x) * 'x rewinder) Cobol_common.Diagnostics.with_diags @@ -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.Preprocess.t as 'r) -> 'r (* val rewindable_parse *) (* : memory:'m memory -> 'm rewindable_parsing *) 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_options.ml b/src/lsp/cobol_preproc/options.ml similarity index 100% rename from src/lsp/cobol_preproc/preproc_options.ml rename to src/lsp/cobol_preproc/options.ml diff --git a/src/lsp/cobol_preproc/preproc_grammar.mly b/src/lsp/cobol_preproc/preproc_grammar.mly index ca86d9df7..5e21684d8 100644 --- a/src/lsp/cobol_preproc/preproc_grammar.mly +++ b/src/lsp/cobol_preproc/preproc_grammar.mly @@ -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 66d7bee45..01ce85e6e 100644 --- a/src/lsp/cobol_preproc/preproc_grammar_sig.ml +++ b/src/lsp/cobol_preproc/preproc_grammar_sig.ml @@ -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.mli b/src/lsp/cobol_preproc/preproc_utils.mli index bd276c79a..0b646c0f9 100644 --- a/src/lsp/cobol_preproc/preproc_utils.mli +++ b/src/lsp/cobol_preproc/preproc_utils.mli @@ -17,11 +17,11 @@ open Cobol_common.Diagnostics.TYPES 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/preproc_engine.ml b/src/lsp/cobol_preproc/preprocess.ml similarity index 96% rename from src/lsp/cobol_preproc/preproc_engine.ml rename to src/lsp/cobol_preproc/preprocess.ml index 73f168b59..ffe9d56a4 100644 --- a/src/lsp/cobol_preproc/preproc_engine.ml +++ b/src/lsp/cobol_preproc/preprocess.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,7 +35,7 @@ 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.Types.dialect; source_format: Src_format.any option; (* to keep auto-detecting on reset *) @@ -44,6 +44,8 @@ and preprocessor_persist = 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 } @@ -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/preprocess.mli similarity index 92% rename from src/lsp/cobol_preproc/preproc_engine.mli rename to src/lsp/cobol_preproc/preprocess.mli index 830ba1585..4058dc5a8 100644 --- a/src/lsp/cobol_preproc/preproc_engine.mli +++ b/src/lsp/cobol_preproc/preprocess.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 @@ -88,30 +89,30 @@ val fold_source_lines -> ?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/src_reader.ml b/src/lsp/cobol_preproc/src_reader.ml index b50d5e1ad..1e6bdd511 100644 --- a/src/lsp/cobol_preproc/src_reader.ml +++ b/src/lsp/cobol_preproc/src_reader.ml @@ -83,7 +83,7 @@ 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.Types.SFFree in @@ -92,11 +92,11 @@ let decode_compiler_directive ~dialect compdir_text = | 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 c09fa09f7..3ae86a2a5 100644 --- a/src/lsp/cobol_preproc/src_reader.mli +++ b/src/lsp/cobol_preproc/src_reader.mli @@ -36,7 +36,7 @@ val fold_lines : 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 @@ -47,7 +47,7 @@ val print_lines val try_compiler_directive : dialect: Cobol_config.Types.dialect -> Text.t - -> ((Text.t * Preproc_directives.compiler_directive with_loc * Text.t) option, + -> ((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 94% rename from src/lsp/cobol_preproc/preproc_trace.mli rename to src/lsp/cobol_preproc/trace.mli index 3167a2a44..e48cf9b1a 100644 --- a/src/lsp/cobol_preproc/preproc_trace.mli +++ b/src/lsp/cobol_preproc/trace.mli @@ -26,7 +26,7 @@ module TYPES: sig } | CompilerDirective of { - compdir: Preproc_directives.compiler_directive; + compdir: Directives.compiler_directive; loc: Cobol_common.Srcloc.t; } @@ -49,7 +49,7 @@ val append -> log -> log val new_compdir : loc: Cobol_common.Srcloc.t - -> compdir:Preproc_directives.compiler_directive + -> compdir:Directives.compiler_directive -> log -> log val copy_done : loc: Cobol_common.Srcloc.t diff --git a/src/lsp/superbol_free_lib/command_pp.ml b/src/lsp/superbol_free_lib/command_pp.ml index 0880e1081..f993bf817 100644 --- a/src/lsp/superbol_free_lib/command_pp.ml +++ b/src/lsp/superbol_free_lib/command_pp.ml @@ -63,10 +63,10 @@ let cmd = ~default: common.preproc_options.source_format } in input |> - Cobol_preproc.preprocessor ~options:preproc_options |> + Cobol_preproc.Preprocess.preprocessor ~options:preproc_options |> Cobol_parser.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) -> ( @@ -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.Preprocess.text_of_file file ~options:common.preproc_options in let s = diff --git a/test/cobol_parsing/parser_testing.ml b/test/cobol_parsing/parser_testing.ml index 256e1f967..049e7a3b1 100644 --- a/test/cobol_parsing/parser_testing.ml +++ b/test/cobol_parsing/parser_testing.ml @@ -21,7 +21,7 @@ let preproc = Cobol_common.Srcloc.TESTING.register_file_contents ~filename contents; String { filename; contents } |> - Cobol_preproc.preprocessor + Cobol_preproc.Preprocess.preprocessor ~options:Cobol_preproc.Options.{ default with libpath = []; @@ -149,7 +149,7 @@ let rewindable_parse = let DIAGS.{ result = Only ptree, rewinder; diags } = String { filename = "prog.cob"; contents = prog } |> - Cobol_preproc.preprocessor + Cobol_preproc.Preprocess.preprocessor ~options:Cobol_preproc.Options.{ verbose; libpath = []; source_format; config = Option.value config ~default:default.config; @@ -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.Preprocess.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.Preprocess.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.Preprocess.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.Preprocess.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.Preprocess.reset_preprocessor_for_string prog in loop (succ i) rewinder end diff --git a/test/cobol_preprocessing/preproc_testing.ml b/test/cobol_preprocessing/preproc_testing.ml index 40d2f56e2..48eaafd54 100644 --- a/test/cobol_preprocessing/preproc_testing.ml +++ b/test/cobol_preprocessing/preproc_testing.ml @@ -24,10 +24,10 @@ let preprocess ?(source_format = Cobol_config.Types.(SF SFFixed)) contents = DIAGS.show_n_forget ~ppf:Fmt.stdout @@ - Cobol_preproc.preprocess_input + Cobol_preproc.Preprocess.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) @@ -36,10 +36,10 @@ let show_text contents = let text = DIAGS.show_n_forget ~ppf:Fmt.stdout @@ - Cobol_preproc.text_of_input + Cobol_preproc.Preprocess.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 @@ -53,7 +53,7 @@ let show_source_lines contents = DIAGS.show_n_forget ~ppf:Fmt.stdout @@ - Cobol_preproc.fold_source_lines ~dialect ~source_format + Cobol_preproc.Preprocess.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.Preprocess.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.Preprocess.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") @@ -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.Preprocess.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.Preprocess.reset_preprocessor_for_string free_format_contents |> show_all_text |> - Cobol_preproc.reset_preprocessor_for_string fixed_format_contents |> + Cobol_preproc.Preprocess.reset_preprocessor_for_string fixed_format_contents |> show_all_text |> ignore diff --git a/test/output-tests/gnucobol.ml b/test/output-tests/gnucobol.ml index 02ededab2..673588e2c 100644 --- a/test/output-tests/gnucobol.ml +++ b/test/output-tests/gnucobol.ml @@ -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 @@ -190,7 +190,7 @@ 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.Preprocess.preprocessor ~options:Cobol_preproc.Options.{ default with source_format } |> Cobol_parser.parse_simple in diff --git a/test/output-tests/preproc.ml b/test/output-tests/preproc.ml index deae014e9..960476584 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.Preprocess.preprocess_file filename ~options:Cobol_preproc.Options.{ source_format; config; verbose = false; libpath = [] } ~ppf:std_formatter diff --git a/test/output-tests/reparse.ml b/test/output-tests/reparse.ml index fec2a6640..4e9afe147 100644 --- a/test/output-tests/reparse.ml +++ b/test/output-tests/reparse.ml @@ -23,7 +23,7 @@ let reparse_file ~source_format ~config filename = default with recovery = DisableRecovery } @@ - Cobol_preproc.preprocessor + Cobol_preproc.Preprocess.preprocessor ~options:Cobol_preproc.Options.{ default with libpath = []; @@ -35,7 +35,7 @@ let reparse_file ~source_format ~config filename = let print = Format.asprintf "@[%a@]@." Cobol_ptree.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 From 414bee62bbb30cc3df9581bde4fae57fb428e7ce Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Thu, 1 Feb 2024 18:33:34 +0100 Subject: [PATCH 05/10] Remove cobol_ptree.ml --- src/lsp/cobol_data/item.ml | 2 +- src/lsp/cobol_data/memory.ml | 4 +- src/lsp/cobol_data/memory.mli | 6 +- src/lsp/cobol_data/printer.ml | 30 ++++----- src/lsp/cobol_data/types.ml | 46 ++++++------- src/lsp/cobol_data_old/env.ml | 18 +++--- src/lsp/cobol_data_old/group.ml | 6 +- src/lsp/cobol_data_old/group.mli | 4 +- src/lsp/cobol_data_old/mangling.ml | 2 +- src/lsp/cobol_data_old/mangling.mli | 2 +- src/lsp/cobol_data_old/qualmap.ml | 4 +- src/lsp/cobol_data_old/qualmap.mli | 2 +- src/lsp/cobol_data_old/types.ml | 12 ++-- src/lsp/cobol_lsp/lsp_document.ml | 2 +- src/lsp/cobol_lsp/lsp_lookup.ml | 18 +++--- src/lsp/cobol_lsp/lsp_notify.mli | 6 +- src/lsp/cobol_lsp/lsp_request.ml | 4 +- src/lsp/cobol_lsp/lsp_semtoks.ml | 4 +- src/lsp/cobol_lsp/lsp_semtoks.mli | 2 +- src/lsp/cobol_parser/grammar.mly | 14 ++-- src/lsp/cobol_parser/grammar_post_actions.ml | 2 +- src/lsp/cobol_parser/grammar_recover.ml | 8 +-- src/lsp/cobol_parser/grammar_tokens.mly | 14 ++-- src/lsp/cobol_parser/grammar_utils.ml | 2 +- src/lsp/cobol_parser/grammar_utils.mli | 6 +- src/lsp/cobol_parser/parser_engine.ml | 8 +-- src/lsp/cobol_parser/parser_engine.mli | 6 +- src/lsp/cobol_parser/parser_outputs.ml | 2 +- src/lsp/cobol_parser/text_lexer.mli | 2 +- src/lsp/cobol_parser/text_tokenizer.ml | 12 ++-- src/lsp/cobol_parser/text_tokenizer.mli | 2 +- src/lsp/cobol_ptree/cobol_ptree.ml | 22 ------- .../cobol_ptree/compilation_group_visitor.ml | 2 +- src/lsp/cobol_ptree/data_division_visitor.ml | 2 +- src/lsp/cobol_ptree/data_sections_visitor.ml | 2 +- .../{pTree_dummies.ml => dummies.ml} | 2 +- src/lsp/cobol_ptree/misc_sections_visitor.ml | 2 +- src/lsp/cobol_ptree/proc_division_visitor.ml | 2 +- src/lsp/cobol_ptree/statements_visitor.ml | 2 +- .../cobol_ptree/{pTree_types.ml => types.ml} | 0 src/lsp/cobol_typeck/cobol_validation.ml | 4 +- src/lsp/cobol_typeck/cobol_validation.mli | 2 +- src/lsp/cobol_typeck/old_env_builder.ml | 2 +- src/lsp/cobol_typeck/old_env_builder.mli | 2 +- src/lsp/cobol_typeck/old_group_builder.ml | 2 +- src/lsp/cobol_typeck/old_group_builder.mli | 4 +- src/lsp/cobol_typeck/old_prog_builder.ml | 2 +- src/lsp/cobol_typeck/typeck_clauses.ml | 30 ++++----- src/lsp/cobol_typeck/typeck_config.ml | 2 +- src/lsp/cobol_typeck/typeck_config.mli | 2 +- .../cobol_typeck/typeck_data_diagnostics.ml | 64 +++++++++---------- src/lsp/cobol_typeck/typeck_data_items.ml | 30 ++++----- src/lsp/cobol_typeck/typeck_data_items.mli | 2 +- src/lsp/cobol_typeck/typeck_outputs.ml | 4 +- src/lsp/cobol_typeck/typeck_procedure.ml | 10 +-- src/lsp/cobol_typeck/typeck_procedure.mli | 2 +- .../typeck_procedure_diagnostics.ml | 6 +- src/lsp/cobol_typeck/typeck_units.ml | 4 +- src/lsp/cobol_typeck/typeck_units.mli | 2 +- src/lsp/cobol_unit/unit_procedure.ml | 4 +- src/lsp/cobol_unit/unit_procedure.mli | 6 +- src/lsp/cobol_unit/unit_qual.ml | 28 ++++---- src/lsp/cobol_unit/unit_qualmap.ml | 8 +-- src/lsp/cobol_unit/unit_qualmap.mli | 10 +-- src/lsp/cobol_unit/unit_types.ml | 8 +-- src/lsp/superbol_free_lib/command_pp.ml | 4 +- test/cobol_data/test_qualified_map.ml | 2 +- test/cobol_parsing/test_appending.ml | 2 +- .../test_combined_relations_parsing.ml | 2 +- test/cobol_parsing/test_cutnpaste_large.ml | 2 +- test/cobol_parsing/testing_helpers.ml | 2 +- test/cobol_unit/test_qualmap.ml | 2 +- test/output-tests/reparse.ml | 4 +- 73 files changed, 263 insertions(+), 285 deletions(-) delete mode 100644 src/lsp/cobol_ptree/cobol_ptree.ml rename src/lsp/cobol_ptree/{pTree_dummies.ml => dummies.ml} (99%) rename src/lsp/cobol_ptree/{pTree_types.ml => types.ml} (100%) diff --git a/src/lsp/cobol_data/item.ml b/src/lsp/cobol_data/item.ml index 8c04b9361..ecf9240b6 100644 --- a/src/lsp/cobol_data/item.ml +++ b/src/lsp/cobol_data/item.ml @@ -50,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/memory.ml b/src/lsp/cobol_data/memory.ml index 74ac596e5..1c1430d25 100644 --- a/src/lsp/cobol_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/memory.mli b/src/lsp/cobol_data/memory.mli index 2988b1ac4..ed389ec46 100644 --- a/src/lsp/cobol_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/printer.ml b/src/lsp/cobol_data/printer.ml index 8b7d17e50..6bed95bde 100644 --- a/src/lsp/cobol_data/printer.ml +++ b/src/lsp/cobol_data/printer.ml @@ -19,13 +19,13 @@ open Cobol_common.Srcloc.INFIX 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 *) @@ -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,8 +240,8 @@ 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) Memory.pp_offset); @@ -250,7 +250,7 @@ let pp_record_renaming: record_renaming Pretty.printer = ] 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 9510a1970..8d6e04587 100644 --- a/src/lsp/cobol_data/types.ml +++ b/src/lsp/cobol_data/types.ml @@ -34,20 +34,20 @@ type usage = | Bit of (* [`boolean] *) picture | Display of (* [any] *) picture | Float_binary of { width: [`W32|`W64|`W128]; (* +COB2002 *) - endian: Cobol_ptree.endianness_mode } + endian: Cobol_ptree.Types.endianness_mode } | Float_decimal of { width: [`W16 | `W34]; (* +COB2002 *) - endian: Cobol_ptree.endianness_mode; - encoding: Cobol_ptree.encoding_mode } + 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.name with_loc (* tmp *) + | Function_pointer of Cobol_ptree.Types.name with_loc (* tmp *) | Index | National of (* [any] *) picture - | Object_reference of Cobol_ptree.object_reference_kind option (* tmp *) + | Object_reference of Cobol_ptree.Types.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 *) + | 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 = @@ -84,8 +84,8 @@ and item_definition = and field_definition = { - field_qualname: Cobol_ptree.qualname with_loc option; - field_redefines: Cobol_ptree.qualname with_loc option; (* redef only *) + 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; @@ -99,7 +99,7 @@ and field_layout = | Elementary_field of { usage: usage; - init_value: Cobol_ptree.literal with_loc option; + init_value: Cobol_ptree.Types.literal with_loc option; } | Struct_field of { @@ -112,14 +112,14 @@ and table_definition = table_offset: Memory.offset; table_size: 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_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.qualname with_loc list; + range_indexes: Cobol_ptree.Types.qualname with_loc list; } and span = | Fixed_span of fixed_span (* OCCURS _ TIMES *) @@ -134,11 +134,11 @@ 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; + occurs_depending: Cobol_ptree.Types.qualname with_loc; } and dynamic_span = { - occurs_dynamic_capacity: Cobol_ptree.qualname with_loc option; + 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; @@ -147,8 +147,8 @@ and dynamic_span = 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 *) + 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, @@ -165,12 +165,12 @@ and condition_name = and record_renamings = record_renaming with_loc list and record_renaming = { - renaming_name: Cobol_ptree.qualname with_loc; + 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.qualname with_loc; - renaming_thru: Cobol_ptree.qualname with_loc option; + renaming_from: Cobol_ptree.Types.qualname with_loc; + renaming_thru: Cobol_ptree.Types.qualname with_loc option; } and renamed_item_layout = | Renamed_elementary of @@ -184,8 +184,8 @@ and renamed_item_layout = (* type data_const_record = *) (* { *) -(* const_name: Cobol_ptree.name with_loc; *) -(* const_descr: Cobol_ptree.constant_item_descr; *) +(* const_name: Cobol_ptree.Types.name with_loc; *) +(* const_descr: Cobol_ptree.Types.constant_item_descr; *) (* const_layout: const_layout; *) (* } *) @@ -210,7 +210,7 @@ type data_definition = { 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 *) + 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_old/env.ml b/src/lsp/cobol_data_old/env.ml index 37c464592..7a525a1b8 100644 --- a/src/lsp/cobol_data_old/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_old/group.ml b/src/lsp/cobol_data_old/group.ml index 7d8a69ee9..7e11e3a06 100644 --- a/src/lsp/cobol_data_old/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 diff --git a/src/lsp/cobol_data_old/group.mli b/src/lsp/cobol_data_old/group.mli index a5d2e8893..88dff820a 100644 --- a/src/lsp/cobol_data_old/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_old/mangling.ml b/src/lsp/cobol_data_old/mangling.ml index 33323c151..0c0328bba 100644 --- a/src/lsp/cobol_data_old/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_old/mangling.mli b/src/lsp/cobol_data_old/mangling.mli index ba3b7e373..2b439b491 100644 --- a/src/lsp/cobol_data_old/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/qualmap.ml b/src/lsp/cobol_data_old/qualmap.ml index 5828622aa..452e18c08 100644 --- a/src/lsp/cobol_data_old/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_old/qualmap.mli b/src/lsp/cobol_data_old/qualmap.mli index 55fac073d..ab6e92531 100644 --- a/src/lsp/cobol_data_old/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 index 65d3f1b73..cfa6b4bdc 100644 --- a/src/lsp/cobol_data_old/types.ml +++ b/src/lsp/cobol_data_old/types.ml @@ -66,7 +66,7 @@ type elementary_data_class = 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 + | Group of data_type Cobol_ptree.Types.with_loc list leveled [@@deriving show] and 'a leveled = { (* TODO: no need to keep levels *) @@ -77,17 +77,17 @@ and 'a leveled = { (* TODO: no need to keep levels * 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.with_loc; + elements_type: data_type Cobol_ptree.Types.with_loc; length: table_length; } and table_length = - | Fixed of Cobol_ptree.integer + | 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.integer; - max_size: Cobol_ptree.integer; - depending: Cobol_ptree.qualname Cobol_ptree.with_loc; + 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 *) diff --git a/src/lsp/cobol_lsp/lsp_document.ml b/src/lsp/cobol_lsp/lsp_document.ml index c8930645d..235950c3b 100644 --- a/src/lsp/cobol_lsp/lsp_document.ml +++ b/src/lsp/cobol_lsp/lsp_document.ml @@ -32,7 +32,7 @@ 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 diff --git a/src/lsp/cobol_lsp/lsp_lookup.ml b/src/lsp/cobol_lsp/lsp_lookup.ml index 0792d9939..051b7e6fb 100644 --- a/src/lsp/cobol_lsp/lsp_lookup.ml +++ b/src/lsp/cobol_lsp/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,7 +85,7 @@ 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 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_request.ml b/src/lsp/cobol_lsp/lsp_request.ml index b4750f9de..8ac96986c 100644 --- a/src/lsp/cobol_lsp/lsp_request.ml +++ b/src/lsp/cobol_lsp/lsp_request.ml @@ -58,7 +58,7 @@ let focus_on_name_in_defintions = true let find_data_definition Lsp_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; _ }; _ } @@ -91,7 +91,7 @@ let find_proc_definition Lsp_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 -> diff --git a/src/lsp/cobol_lsp/lsp_semtoks.ml b/src/lsp/cobol_lsp/lsp_semtoks.ml index 1101da229..010173ecc 100644 --- a/src/lsp/cobol_lsp/lsp_semtoks.ml +++ b/src/lsp/cobol_lsp/lsp_semtoks.ml @@ -159,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 @@ -167,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 *) 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_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/parser_engine.ml b/src/lsp/cobol_parser/parser_engine.ml index 8d2fea4c1..bd73eaa0c 100644 --- a/src/lsp/cobol_parser/parser_engine.ml +++ b/src/lsp/cobol_parser/parser_engine.ml @@ -46,12 +46,12 @@ and position = type 'm simple_parsing = ?options:parser_options -> Cobol_preproc.Preprocess.preprocessor - -> (Cobol_ptree.compilation_group option, 'm) output DIAGS.with_diags + -> (Cobol_ptree.Types.compilation_group option, 'm) output DIAGS.with_diags type 'm rewindable_parsing = ?options:parser_options -> Cobol_preproc.Preprocess.preprocessor - -> (((Cobol_ptree.compilation_group option, 'm) output as 'x) * + -> (((Cobol_ptree.Types.compilation_group option, 'm) output as 'x) * 'x rewinder) DIAGS.with_diags (* --- *) @@ -582,7 +582,7 @@ let parse ~(memory: m memory) ?(options = Parser_options.default) : Cobol_preproc.Preprocess.t -> - (Cobol_ptree.compilation_group option, m) output with_diags = + (Cobol_ptree.Types.compilation_group option, m) output with_diags = parse_once ~options ~memory ~make_checkpoint:Grammar.Incremental.compilation_group @@ -594,7 +594,7 @@ let rewindable_parse ~(memory: m memory) ?(options = Parser_options.default) : Cobol_preproc.Preprocess.t -> - (((Cobol_ptree.compilation_group option, m) output as 'x) * 'x rewinder) + (((Cobol_ptree.Types.compilation_group option, m) output as 'x) * 'x rewinder) with_diags = rewindable_parse ~options ~memory ~make_checkpoint:Grammar.Incremental.compilation_group diff --git a/src/lsp/cobol_parser/parser_engine.mli b/src/lsp/cobol_parser/parser_engine.mli index dacadca8f..6b101dbed 100644 --- a/src/lsp/cobol_parser/parser_engine.mli +++ b/src/lsp/cobol_parser/parser_engine.mli @@ -38,7 +38,7 @@ open Parser_outputs type 'm simple_parsing = ?options:Parser_options.parser_options -> Cobol_preproc.Preprocess.t - -> (Cobol_ptree.compilation_group option, 'm) output + -> (Cobol_ptree.Types.compilation_group option, 'm) output Cobol_common.Diagnostics.with_diags (* val parse *) @@ -61,7 +61,7 @@ val parse_with_artifacts type 'm rewindable_parsing = ?options:parser_options -> Cobol_preproc.Preprocess.preprocessor - -> (((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 (** Rewinder for parsing functions that produce results of type ['x] *) @@ -106,7 +106,7 @@ 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} *) diff --git a/src/lsp/cobol_parser/parser_outputs.ml b/src/lsp/cobol_parser/parser_outputs.ml index 0d88ed5ad..74bb32cb0 100644 --- a/src/lsp/cobol_parser/parser_outputs.ml +++ b/src/lsp/cobol_parser/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/text_lexer.mli b/src/lsp/cobol_parser/text_lexer.mli index 9aab8a2ad..f714f8ac4 100644 --- a/src/lsp/cobol_parser/text_lexer.mli +++ b/src/lsp/cobol_parser/text_lexer.mli @@ -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 cadadccfd..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 diff --git a/src/lsp/cobol_ptree/cobol_ptree.ml b/src/lsp/cobol_ptree/cobol_ptree.ml deleted file mode 100644 index 4793159e4..000000000 --- a/src/lsp/cobol_ptree/cobol_ptree.ml +++ /dev/null @@ -1,22 +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 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 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_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/old_env_builder.ml b/src/lsp/cobol_typeck/old_env_builder.ml index 5924a2c83..036552605 100644 --- a/src/lsp/cobol_typeck/old_env_builder.ml +++ b/src/lsp/cobol_typeck/old_env_builder.ml @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open Cobol_ptree +open Cobol_ptree.Types open Cobol_common.Srcloc.INFIX open Cobol_common.Diagnostics.TYPES diff --git a/src/lsp/cobol_typeck/old_env_builder.mli b/src/lsp/cobol_typeck/old_env_builder.mli index bd061fb6f..a16cf6eb8 100644 --- a/src/lsp/cobol_typeck/old_env_builder.mli +++ b/src/lsp/cobol_typeck/old_env_builder.mli @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open Cobol_ptree +open Cobol_ptree.Types open Cobol_common.Diagnostics.TYPES val for_compilation_unit diff --git a/src/lsp/cobol_typeck/old_group_builder.ml b/src/lsp/cobol_typeck/old_group_builder.ml index 52e7862e3..c0036485c 100644 --- a/src/lsp/cobol_typeck/old_group_builder.ml +++ b/src/lsp/cobol_typeck/old_group_builder.ml @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open Cobol_ptree +open Cobol_ptree.Types open Cobol_common.Srcloc.INFIX open Cobol_common.Diagnostics.TYPES diff --git a/src/lsp/cobol_typeck/old_group_builder.mli b/src/lsp/cobol_typeck/old_group_builder.mli index a3911ebcb..1537ce2f1 100644 --- a/src/lsp/cobol_typeck/old_group_builder.mli +++ b/src/lsp/cobol_typeck/old_group_builder.mli @@ -16,5 +16,5 @@ open Cobol_common.Diagnostics.TYPES val working_data_of_compilation_unit' : Cobol_config.Types.t -> Cobol_data_old.Env.PROG_ENV.t - -> Cobol_ptree.compilation_unit Cobol_ptree.with_loc - -> Cobol_data_old.Group.t' Cobol_ptree.with_loc list with_diags + -> 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_prog_builder.ml b/src/lsp/cobol_typeck/old_prog_builder.ml index fc0d7b3b3..66dcb3b52 100644 --- a/src/lsp/cobol_typeck/old_prog_builder.ml +++ b/src/lsp/cobol_typeck/old_prog_builder.ml @@ -14,7 +14,7 @@ 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 diff --git a/src/lsp/cobol_typeck/typeck_clauses.ml b/src/lsp/cobol_typeck/typeck_clauses.ml index db1c4da99..d8039687b 100644 --- a/src/lsp/cobol_typeck/typeck_clauses.ml +++ b/src/lsp/cobol_typeck/typeck_clauses.ml @@ -20,11 +20,11 @@ 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..160629c94 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 diff --git a/src/lsp/cobol_typeck/typeck_config.mli b/src/lsp/cobol_typeck/typeck_config.mli index b7821991a..f08e361ec 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 + -> Cobol_ptree.Types.compilation_unit with_loc -> output * Typeck_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..551c66158 100644 --- a/src/lsp/cobol_typeck/typeck_data_items.ml +++ b/src/lsp/cobol_typeck/typeck_data_items.ml @@ -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; @@ -50,11 +50,11 @@ 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; @@ -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 } @@ -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,7 +590,7 @@ 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 } = @@ -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..ce25efbe6 100644 --- a/src/lsp/cobol_typeck/typeck_data_items.mli +++ b/src/lsp/cobol_typeck/typeck_data_items.mli @@ -21,5 +21,5 @@ type output = val of_compilation_unit : Cobol_unit.Types.unit_config - -> Cobol_ptree.compilation_unit with_loc + -> Cobol_ptree.Types.compilation_unit with_loc -> output * Typeck_diagnostics.t diff --git a/src/lsp/cobol_typeck/typeck_outputs.ml b/src/lsp/cobol_typeck/typeck_outputs.ml index ef55f7b85..d8bcbaa6b 100644 --- a/src/lsp/cobol_typeck/typeck_outputs.ml +++ b/src/lsp/cobol_typeck/typeck_outputs.ml @@ -30,7 +30,7 @@ type artifacts = type outputs = { - ptree: Cobol_ptree.compilation_group; + ptree: Cobol_ptree.Types.compilation_group; group: Cobol_unit.Types.group; artifacts: artifacts; } @@ -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_procedure.ml b/src/lsp/cobol_typeck/typeck_procedure.ml index 3893e5712..d2905f682 100644 --- a/src/lsp/cobol_typeck/typeck_procedure.ml +++ b/src/lsp/cobol_typeck/typeck_procedure.ml @@ -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); @@ -173,7 +173,7 @@ let references ~(data_definitions: Cobol_unit.Types.data_definitions) procedure 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 diff --git a/src/lsp/cobol_typeck/typeck_procedure.mli b/src/lsp/cobol_typeck/typeck_procedure.mli index cef1c1249..0cc8b81d0 100644 --- a/src/lsp/cobol_typeck/typeck_procedure.mli +++ b/src/lsp/cobol_typeck/typeck_procedure.mli @@ -21,5 +21,5 @@ type output = val of_compilation_unit : data_definitions: Cobol_unit.Types.data_definitions - -> Cobol_ptree.compilation_unit with_loc + -> Cobol_ptree.Types.compilation_unit with_loc -> output * Typeck_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 c348a26bf..b04d1174e 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; _ } @@ -119,7 +119,7 @@ end (** This function builds the internal representation of full compilation groups. *) let of_compilation_group - : Cobol_config.Types.t -> Cobol_ptree.compilation_group -> + : Cobol_config.Types.t -> Cobol_ptree.Types.compilation_group -> Typeck_outputs.t * Typeck_diagnostics.t = fun config compilation_group_ptree -> Cobol_ptree.Visitor.fold_compilation_group diff --git a/src/lsp/cobol_typeck/typeck_units.mli b/src/lsp/cobol_typeck/typeck_units.mli index 0e6b9c56b..d36a82b43 100644 --- a/src/lsp/cobol_typeck/typeck_units.mli +++ b/src/lsp/cobol_typeck/typeck_units.mli @@ -13,5 +13,5 @@ val of_compilation_group : Cobol_config.Types.t - -> Cobol_ptree.compilation_group + -> Cobol_ptree.Types.compilation_group -> Typeck_outputs.t * Typeck_diagnostics.t diff --git a/src/lsp/cobol_unit/unit_procedure.ml b/src/lsp/cobol_unit/unit_procedure.ml index 9290bf639..c66d2ca5f 100644 --- a/src/lsp/cobol_unit/unit_procedure.ml +++ b/src/lsp/cobol_unit/unit_procedure.ml @@ -17,7 +17,7 @@ open Unit_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 @@ -30,7 +30,7 @@ let rec find 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 diff --git a/src/lsp/cobol_unit/unit_procedure.mli b/src/lsp/cobol_unit/unit_procedure.mli index 14446cd17..025484b4a 100644 --- a/src/lsp/cobol_unit/unit_procedure.mli +++ b/src/lsp/cobol_unit/unit_procedure.mli @@ -15,12 +15,12 @@ val find : ?in_section: Unit_types.procedure_section - -> Cobol_ptree.qualname + -> Cobol_ptree.Types.qualname -> Unit_types.procedure -> Unit_types.procedure_block val full_qn : ?in_section: Unit_types.procedure_section - -> Cobol_ptree.qualname + -> Cobol_ptree.Types.qualname -> Unit_types.procedure - -> Cobol_ptree.qualname + -> Cobol_ptree.Types.qualname diff --git a/src/lsp/cobol_unit/unit_qual.ml b/src/lsp/cobol_unit/unit_qual.ml index efbf20fe5..0edb0faa4 100644 --- a/src/lsp/cobol_unit/unit_qual.ml +++ b/src/lsp/cobol_unit/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/unit_qualmap.ml index 0bb81c071..30b15d4d7 100644 --- a/src/lsp/cobol_unit/unit_qualmap.ml +++ b/src/lsp/cobol_unit/unit_qualmap.ml @@ -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@]" diff --git a/src/lsp/cobol_unit/unit_qualmap.mli b/src/lsp/cobol_unit/unit_qualmap.mli index 0c6f6dd4b..0f605e127 100644 --- a/src/lsp/cobol_unit/unit_qualmap.mli +++ b/src/lsp/cobol_unit/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/unit_types.ml index 8d992106f..68b583a7d 100644 --- a/src/lsp/cobol_unit/unit_types.ml +++ b/src/lsp/cobol_unit/unit_types.ml @@ -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/superbol_free_lib/command_pp.ml b/src/lsp/superbol_free_lib/command_pp.ml index f993bf817..6ee752266 100644 --- a/src/lsp/superbol_free_lib/command_pp.ml +++ b/src/lsp/superbol_free_lib/command_pp.ml @@ -71,7 +71,7 @@ let cmd = 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 ) diff --git a/test/cobol_data/test_qualified_map.ml b/test/cobol_data/test_qualified_map.ml index 64ad34dae..9b478db5e 100644 --- a/test/cobol_data/test_qualified_map.ml +++ b/test/cobol_data/test_qualified_map.ml @@ -11,7 +11,7 @@ (* *) (**************************************************************************) -open Cobol_ptree +open Cobol_ptree.Types open Cobol_common.Srcloc.INFIX type t = 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_combined_relations_parsing.ml b/test/cobol_parsing/test_combined_relations_parsing.ml index abb4ec70a..dacf6e2f0 100644 --- a/test/cobol_parsing/test_combined_relations_parsing.ml +++ b/test/cobol_parsing/test_combined_relations_parsing.ml @@ -13,7 +13,7 @@ open Alcotest -open Cobol_ptree +open Cobol_ptree.Types open Testing_helpers.Make (Cobol_parser.INTERNAL.Dummy.Tags) open Cobol_parser.INTERNAL.Tokens open Cobol_parser.INTERNAL.Grammar diff --git a/test/cobol_parsing/test_cutnpaste_large.ml b/test/cobol_parsing/test_cutnpaste_large.ml index b981832d7..303a7e395 100644 --- a/test/cobol_parsing/test_cutnpaste_large.ml +++ b/test/cobol_parsing/test_cutnpaste_large.ml @@ -23,7 +23,7 @@ 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 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_unit/test_qualmap.ml b/test/cobol_unit/test_qualmap.ml index 8479d96f7..01d5cf9e7 100644 --- a/test/cobol_unit/test_qualmap.ml +++ b/test/cobol_unit/test_qualmap.ml @@ -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/output-tests/reparse.ml b/test/output-tests/reparse.ml index 4e9afe147..0e81cc3ab 100644 --- a/test/output-tests/reparse.ml +++ b/test/output-tests/reparse.ml @@ -33,7 +33,7 @@ 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.Src_input.from ~filename ~f:(parse ~source_format) with | { result = Only Some cg; _ } -> ( @@ -41,7 +41,7 @@ let reparse_file ~source_format ~config filename = 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." From 4b14d4dac736d4c0ce5eadd73a8a617e51189f95 Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Thu, 1 Feb 2024 22:23:12 +0100 Subject: [PATCH 06/10] Remove cobol_typeck/cobol_typeck.ml --- .drom | 23 +++++- .github/workflows/workflow.yml | 2 +- Makefile | 2 +- drom.toml | 4 + dune-project | 17 ++++ opam/cobol_typeck_old.opam | 57 +++++++++++++ src/lsp/cobol_lsp/lsp_document.ml | 4 +- src/lsp/cobol_typeck/cobol_typeck.ml | 24 ------ src/lsp/cobol_typeck/cobol_typeck.mli | 28 ------- .../{typeck_diagnostics.ml => diagnostics.ml} | 0 .../{old_typeck_engine.ml => engine.ml} | 17 ++-- .../{typeck_engine.mli => engine.mli} | 6 +- .../{typeck_outputs.ml => outputs.ml} | 0 src/lsp/cobol_typeck/typeck_clauses.ml | 2 +- src/lsp/cobol_typeck/typeck_config.ml | 4 +- src/lsp/cobol_typeck/typeck_config.mli | 2 +- src/lsp/cobol_typeck/typeck_data_items.ml | 12 +-- src/lsp/cobol_typeck/typeck_data_items.mli | 4 +- src/lsp/cobol_typeck/typeck_procedure.ml | 22 +++--- src/lsp/cobol_typeck/typeck_procedure.mli | 4 +- src/lsp/cobol_typeck/typeck_units.ml | 16 ++-- src/lsp/cobol_typeck/typeck_units.mli | 2 +- src/lsp/cobol_typeck_old/dune | 26 ++++++ .../env_builder.ml} | 0 .../env_builder.mli} | 0 .../group_builder.ml} | 2 +- .../group_builder.mli} | 0 src/lsp/cobol_typeck_old/package.toml | 79 +++++++++++++++++++ .../prog_builder.ml} | 3 - .../typeck_engine.ml | 15 ++-- src/lsp/cobol_typeck_old/version.mlt | 30 +++++++ test/cobol_typeck/dune | 2 +- test/cobol_typeck/typeck_testing.ml | 4 +- 33 files changed, 292 insertions(+), 121 deletions(-) create mode 100644 opam/cobol_typeck_old.opam delete mode 100644 src/lsp/cobol_typeck/cobol_typeck.ml delete mode 100644 src/lsp/cobol_typeck/cobol_typeck.mli rename src/lsp/cobol_typeck/{typeck_diagnostics.ml => diagnostics.ml} (100%) rename src/lsp/cobol_typeck/{old_typeck_engine.ml => engine.ml} (74%) rename src/lsp/cobol_typeck/{typeck_engine.mli => engine.mli} (88%) rename src/lsp/cobol_typeck/{typeck_outputs.ml => outputs.ml} (100%) create mode 100644 src/lsp/cobol_typeck_old/dune rename src/lsp/{cobol_typeck/old_env_builder.ml => cobol_typeck_old/env_builder.ml} (100%) rename src/lsp/{cobol_typeck/old_env_builder.mli => cobol_typeck_old/env_builder.mli} (100%) rename src/lsp/{cobol_typeck/old_group_builder.ml => cobol_typeck_old/group_builder.ml} (99%) rename src/lsp/{cobol_typeck/old_group_builder.mli => cobol_typeck_old/group_builder.mli} (100%) create mode 100644 src/lsp/cobol_typeck_old/package.toml rename src/lsp/{cobol_typeck/old_prog_builder.ml => cobol_typeck_old/prog_builder.ml} (97%) rename src/lsp/{cobol_typeck => cobol_typeck_old}/typeck_engine.ml (75%) create mode 100644 src/lsp/cobol_typeck_old/version.mlt diff --git a/.drom b/.drom index 8fa52b6ad..f0f0e1cb2 100644 --- a/.drom +++ b/.drom @@ -5,12 +5,12 @@ version:0.9.0 # hash of toml configuration files # used for generation of all files -cc894e743bb85460e00abcdaf8d9fae5:. +93d2e460909a3ddf6a2ed971ff2e8639:. # end context for . # begin context for .github/workflows/workflow.yml # file .github/workflows/workflow.yml -5429d9f0846180852fae7d2e49e767e8:.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 -f77bb2a3fc45e32226c8cad8171cd91c: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 -972a09725c93d6b9991e532be3dc6c8a:dune-project +22badd64255c88417b1d5ed3a0d03754:dune-project # end context for dune-project # begin context for opam/cobol_common.opam @@ -138,6 +138,11 @@ 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 76d88c1b0a68e0af28464a34049d254c:opam/cobol_unit.opam @@ -378,6 +383,16 @@ 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 461e7b0db5a7aaf9cf342be193d92cd5:src/lsp/cobol_unit/dune diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index ce26db25d..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_data_old 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 37632e74f..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_data_old 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 c22d15fda..8d3dbaa05 100644 --- a/drom.toml +++ b/drom.toml @@ -208,6 +208,10 @@ dir = "src/lsp/cobol_data_old" 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 942572800..2a77d9e0f 100644 --- a/dune-project +++ b/dune-project @@ -399,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") 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/src/lsp/cobol_lsp/lsp_document.ml b/src/lsp/cobol_lsp/lsp_document.ml index 235950c3b..3c4aff173 100644 --- a/src/lsp/cobol_lsp/lsp_document.ml +++ b/src/lsp/cobol_lsp/lsp_document.ml @@ -92,8 +92,8 @@ 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 end 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/typeck_diagnostics.ml b/src/lsp/cobol_typeck/diagnostics.ml similarity index 100% rename from src/lsp/cobol_typeck/typeck_diagnostics.ml rename to src/lsp/cobol_typeck/diagnostics.ml diff --git a/src/lsp/cobol_typeck/old_typeck_engine.ml b/src/lsp/cobol_typeck/engine.ml similarity index 74% rename from src/lsp/cobol_typeck/old_typeck_engine.ml rename to src/lsp/cobol_typeck/engine.ml index 9627b0748..b5da1546d 100644 --- a/src/lsp/cobol_typeck/old_typeck_engine.ml +++ b/src/lsp/cobol_typeck/engine.ml @@ -13,21 +13,16 @@ (** Type-checking and validation of COBOL compilation groups *) -module Prog_builder = Old_prog_builder - module DIAGS = Cobol_common.Diagnostics -module CU = Cobol_data_old.Compilation_unit -module CUs = CU.SET -let analyze_compilation_group +let compilation_group (type m) : ?config: _ -> m Cobol_parser.Outputs.parsed_compilation_group -> _ = fun ?(config = Cobol_config.Config.default) -> function | Only None | WithArtifacts (None, _) -> - DIAGS.result (Cobol_data_old.Compilation_unit.SET.empty, None) + Outputs.none, Diagnostics.none | Only Some cg | WithArtifacts (Some cg, _) -> - match Prog_builder.compilation_group config cg with - | { diags; _ } when DIAGS.Set.has_errors diags -> - DIAGS.result ~diags (CUs.empty, Some cg) - | { diags; result } -> - DIAGS.result ~diags (result, Some cg) + Typeck_units.of_compilation_group config cg + +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 88% rename from src/lsp/cobol_typeck/typeck_engine.mli rename to src/lsp/cobol_typeck/engine.mli index 212ac5830..2341c58a9 100644 --- a/src/lsp/cobol_typeck/typeck_engine.mli +++ b/src/lsp/cobol_typeck/engine.mli @@ -14,9 +14,9 @@ val compilation_group : ?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.Types.t - -> Typeck_outputs.t * Typeck_diagnostics.t - -> Typeck_outputs.t Cobol_common.Diagnostics.with_diags + -> 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 100% rename from src/lsp/cobol_typeck/typeck_outputs.ml rename to src/lsp/cobol_typeck/outputs.ml diff --git a/src/lsp/cobol_typeck/typeck_clauses.ml b/src/lsp/cobol_typeck/typeck_clauses.ml index d8039687b..0beaa8e9f 100644 --- a/src/lsp/cobol_typeck/typeck_clauses.ml +++ b/src/lsp/cobol_typeck/typeck_clauses.ml @@ -14,7 +14,7 @@ open Cobol_data.Types open Cobol_common.Srcloc.TYPES open Cobol_common.Srcloc.INFIX -open Typeck_diagnostics +open Diagnostics module PIC = Cobol_data.Picture diff --git a/src/lsp/cobol_typeck/typeck_config.ml b/src/lsp/cobol_typeck/typeck_config.ml index 160629c94..55d2d1c66 100644 --- a/src/lsp/cobol_typeck/typeck_config.ml +++ b/src/lsp/cobol_typeck/typeck_config.ml @@ -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 f08e361ec..f30f9d200 100644 --- a/src/lsp/cobol_typeck/typeck_config.mli +++ b/src/lsp/cobol_typeck/typeck_config.mli @@ -18,4 +18,4 @@ type output = Cobol_unit.Types.unit_config val of_compilation_unit : ?parent_config:Cobol_unit.Types.unit_config -> Cobol_ptree.Types.compilation_unit with_loc - -> output * Typeck_diagnostics.t + -> output * Diagnostics.t diff --git a/src/lsp/cobol_typeck/typeck_data_items.ml b/src/lsp/cobol_typeck/typeck_data_items.ml index 551c66158..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; } (* --- *) @@ -44,7 +44,7 @@ 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 *) @@ -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 }; @@ -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 = @@ -597,7 +597,7 @@ let on_item acc ~at_level 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 diff --git a/src/lsp/cobol_typeck/typeck_data_items.mli b/src/lsp/cobol_typeck/typeck_data_items.mli index ce25efbe6..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.Types.compilation_unit with_loc - -> output * Typeck_diagnostics.t + -> output * Diagnostics.t diff --git a/src/lsp/cobol_typeck/typeck_procedure.ml b/src/lsp/cobol_typeck/typeck_procedure.ml index d2905f682..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' = @@ -161,14 +161,14 @@ 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 @@ -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 0cc8b81d0..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.Types.compilation_unit with_loc - -> output * Typeck_diagnostics.t + -> output * Diagnostics.t diff --git a/src/lsp/cobol_typeck/typeck_units.ml b/src/lsp/cobol_typeck/typeck_units.ml index b04d1174e..6727718f8 100644 --- a/src/lsp/cobol_typeck/typeck_units.ml +++ b/src/lsp/cobol_typeck/typeck_units.ml @@ -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 @@ -120,7 +120,7 @@ end groups. *) let of_compilation_group : Cobol_config.Types.t -> Cobol_ptree.Types.compilation_group -> - Typeck_outputs.t * Typeck_diagnostics.t = + 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 d36a82b43..afdd31eaf 100644 --- a/src/lsp/cobol_typeck/typeck_units.mli +++ b/src/lsp/cobol_typeck/typeck_units.mli @@ -14,4 +14,4 @@ val of_compilation_group : Cobol_config.Types.t -> Cobol_ptree.Types.compilation_group - -> Typeck_outputs.t * Typeck_diagnostics.t + -> 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 100% rename from src/lsp/cobol_typeck/old_env_builder.ml rename to src/lsp/cobol_typeck_old/env_builder.ml diff --git a/src/lsp/cobol_typeck/old_env_builder.mli b/src/lsp/cobol_typeck_old/env_builder.mli similarity index 100% rename from src/lsp/cobol_typeck/old_env_builder.mli rename to src/lsp/cobol_typeck_old/env_builder.mli diff --git a/src/lsp/cobol_typeck/old_group_builder.ml b/src/lsp/cobol_typeck_old/group_builder.ml similarity index 99% rename from src/lsp/cobol_typeck/old_group_builder.ml rename to src/lsp/cobol_typeck_old/group_builder.ml index c0036485c..5e64bf597 100644 --- a/src/lsp/cobol_typeck/old_group_builder.ml +++ b/src/lsp/cobol_typeck_old/group_builder.ml @@ -57,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 *) diff --git a/src/lsp/cobol_typeck/old_group_builder.mli b/src/lsp/cobol_typeck_old/group_builder.mli similarity index 100% rename from src/lsp/cobol_typeck/old_group_builder.mli rename to src/lsp/cobol_typeck_old/group_builder.mli 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 97% rename from src/lsp/cobol_typeck/old_prog_builder.ml rename to src/lsp/cobol_typeck_old/prog_builder.ml index 66dcb3b52..7bd77fa64 100644 --- a/src/lsp/cobol_typeck/old_prog_builder.ml +++ b/src/lsp/cobol_typeck_old/prog_builder.ml @@ -11,9 +11,6 @@ (* *) (**************************************************************************) -module Env_builder = Old_env_builder -module Group_builder = Old_group_builder - open Cobol_ptree.Types open Cobol_common.Srcloc.INFIX open Cobol_common.Diagnostics.TYPES diff --git a/src/lsp/cobol_typeck/typeck_engine.ml b/src/lsp/cobol_typeck_old/typeck_engine.ml similarity index 75% rename from src/lsp/cobol_typeck/typeck_engine.ml rename to src/lsp/cobol_typeck_old/typeck_engine.ml index df9dd1c3f..192bba020 100644 --- a/src/lsp/cobol_typeck/typeck_engine.ml +++ b/src/lsp/cobol_typeck_old/typeck_engine.ml @@ -14,15 +14,18 @@ (** Type-checking and validation of COBOL compilation groups *) module DIAGS = Cobol_common.Diagnostics +module CU = Cobol_data_old.Compilation_unit +module CUs = CU.SET -let compilation_group +let analyze_compilation_group (type m) : ?config: _ -> m Cobol_parser.Outputs.parsed_compilation_group -> _ = fun ?(config = Cobol_config.Config.default) -> function | Only None | WithArtifacts (None, _) -> - Typeck_outputs.none, Typeck_diagnostics.none + DIAGS.result (Cobol_data_old.Compilation_unit.SET.empty, None) | Only Some cg | WithArtifacts (Some cg, _) -> - Typeck_units.of_compilation_group config cg - -let translate_diagnostics ?(config = Cobol_config.Config.default) (output, diags) = - DIAGS.result output ~diags:(Typeck_diagnostics.translate ~config diags) + match Prog_builder.compilation_group config cg with + | { diags; _ } when DIAGS.Set.has_errors diags -> + DIAGS.result ~diags (CUs.empty, Some cg) + | { diags; result } -> + DIAGS.result ~diags (result, Some cg) 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/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..b5831be16 100644 --- a/test/cobol_typeck/typeck_testing.ml +++ b/test/cobol_typeck/typeck_testing.ml @@ -24,8 +24,8 @@ let show_diagnostics ?(show_data = false) ?(verbose = false) 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 From 7acdf52a3d937a14ff79349316736ef2c30edc47 Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Thu, 1 Feb 2024 22:34:35 +0100 Subject: [PATCH 07/10] remove cobol_unit/cobol_unit.ml --- src/lsp/cobol_typeck/outputs.ml | 2 +- src/lsp/cobol_unit/cobol_unit.ml | 26 ------------------- .../{unit_collections.ml => collections.ml} | 2 +- .../cobol_unit/{unit_group.ml => group.ml} | 6 ++--- .../{unit_printer.ml => printer.ml} | 6 ++--- .../{unit_procedure.ml => procedure.ml} | 10 +++---- .../{unit_procedure.mli => procedure.mli} | 10 +++---- src/lsp/cobol_unit/{unit_qual.ml => qual.ml} | 0 .../{unit_qualmap.ml => qualmap.ml} | 6 ++--- .../{unit_qualmap.mli => qualmap.mli} | 0 .../cobol_unit/{unit_types.ml => types.ml} | 2 +- .../{unit_visitor.ml => visitor.ml} | 6 ++--- 12 files changed, 25 insertions(+), 51 deletions(-) delete mode 100644 src/lsp/cobol_unit/cobol_unit.ml rename src/lsp/cobol_unit/{unit_collections.ml => collections.ml} (99%) rename src/lsp/cobol_unit/{unit_group.ml => group.ml} (91%) rename src/lsp/cobol_unit/{unit_printer.ml => printer.ml} (91%) rename src/lsp/cobol_unit/{unit_procedure.ml => procedure.ml} (83%) rename src/lsp/cobol_unit/{unit_procedure.mli => procedure.mli} (86%) rename src/lsp/cobol_unit/{unit_qual.ml => qual.ml} (100%) rename src/lsp/cobol_unit/{unit_qualmap.ml => qualmap.ml} (98%) rename src/lsp/cobol_unit/{unit_qualmap.mli => qualmap.mli} (100%) rename src/lsp/cobol_unit/{unit_types.ml => types.ml} (98%) rename src/lsp/cobol_unit/{unit_visitor.ml => visitor.ml} (96%) diff --git a/src/lsp/cobol_typeck/outputs.ml b/src/lsp/cobol_typeck/outputs.ml index d8bcbaa6b..b14c47b7c 100644 --- a/src/lsp/cobol_typeck/outputs.ml +++ b/src/lsp/cobol_typeck/outputs.ml @@ -31,7 +31,7 @@ type artifacts = type outputs = { ptree: Cobol_ptree.Types.compilation_group; - group: Cobol_unit.Types.group; + group: Cobol_unit.Group.TYPES.group; artifacts: artifacts; } type t = outputs diff --git a/src/lsp/cobol_unit/cobol_unit.ml b/src/lsp/cobol_unit/cobol_unit.ml deleted file mode 100644 index 506ba18e0..000000000 --- a/src/lsp/cobol_unit/cobol_unit.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 Qual = Unit_qual -module Qualmap = Unit_qualmap - -module Types = struct - include Unit_types - include Unit_group.TYPES -end - -module Group = Unit_group -module Procedure = Unit_procedure -module Collections = Unit_collections -module Printer = Unit_printer -module Visitor = Unit_visitor 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/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/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 83% rename from src/lsp/cobol_unit/unit_procedure.ml rename to src/lsp/cobol_unit/procedure.ml index c66d2ca5f..7897582eb 100644 --- a/src/lsp/cobol_unit/unit_procedure.ml +++ b/src/lsp/cobol_unit/procedure.ml @@ -13,7 +13,7 @@ (** Utilities to deal with sections/paragraphs of PROCEDURE DIVISIONs *) -open Unit_types +open Types let rec find ?(in_section: procedure_section option) @@ -22,10 +22,10 @@ let rec find : 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 @@ -35,8 +35,8 @@ let rec full_qn = 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 86% rename from src/lsp/cobol_unit/unit_procedure.mli rename to src/lsp/cobol_unit/procedure.mli index 025484b4a..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 + : ?in_section: Types.procedure_section -> Cobol_ptree.Types.qualname - -> Unit_types.procedure - -> Unit_types.procedure_block + -> Types.procedure + -> Types.procedure_block val full_qn - : ?in_section: Unit_types.procedure_section + : ?in_section: Types.procedure_section -> Cobol_ptree.Types.qualname - -> Unit_types.procedure + -> 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 100% rename from src/lsp/cobol_unit/unit_qual.ml rename to src/lsp/cobol_unit/qual.ml diff --git a/src/lsp/cobol_unit/unit_qualmap.ml b/src/lsp/cobol_unit/qualmap.ml similarity index 98% rename from src/lsp/cobol_unit/unit_qualmap.ml rename to src/lsp/cobol_unit/qualmap.ml index 30b15d4d7..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 (* --- *) @@ -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 100% rename from src/lsp/cobol_unit/unit_qualmap.mli rename to src/lsp/cobol_unit/qualmap.mli diff --git a/src/lsp/cobol_unit/unit_types.ml b/src/lsp/cobol_unit/types.ml similarity index 98% rename from src/lsp/cobol_unit/unit_types.ml rename to src/lsp/cobol_unit/types.ml index 68b583a7d..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; } 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)) From 04583497b778545bac844d8715cfe6e047e7d7f2 Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Thu, 1 Feb 2024 22:59:39 +0100 Subject: [PATCH 08/10] Remove cobol_lsp/cobol_lsp.ml --- .../cobol_lsp/{cobol_lsp.ml => alltypes.ml} | 36 ++------ .../{lsp_diagnostics.ml => diagnostics.ml} | 4 +- .../{lsp_diagnostics.mli => diagnostics.mli} | 0 .../{lsp_document.ml => document.ml} | 12 +-- .../cobol_lsp/{lsp_lookup.ml => lookup.ml} | 8 +- .../cobol_lsp/{lsp_server_loop.ml => loop.ml} | 14 +-- .../{lsp_server_loop.mli => loop.mli} | 6 +- src/lsp/cobol_lsp/lsp_completion.ml | 19 ++-- src/lsp/cobol_lsp/lsp_notif.ml | 14 +-- src/lsp/cobol_lsp/lsp_notif.mli | 2 +- src/lsp/cobol_lsp/lsp_semtoks.ml | 8 +- .../{lsp_position.ml => position.ml} | 0 .../{lsp_position.mli => position.mli} | 0 .../cobol_lsp/{lsp_project.ml => project.ml} | 4 +- .../{lsp_project.mli => project.mli} | 0 ...{lsp_project_cache.ml => project_cache.ml} | 38 ++++---- ...sp_project_cache.mli => project_cache.mli} | 8 +- .../cobol_lsp/{lsp_request.ml => request.ml} | 92 +++++++++---------- .../{lsp_request.mli => request.mli} | 16 ++-- .../cobol_lsp/{lsp_server.ml => server.ml} | 54 +++++------ .../cobol_lsp/{lsp_server.mli => server.mli} | 12 +-- src/lsp/cobol_lsp/{lsp_utils.ml => utils.ml} | 0 .../cobol_lsp/{lsp_utils.mli => utils.mli} | 0 src/lsp/superbol_free_lib/command_lsp.ml | 8 +- test/lsp/lsp_definition.ml | 4 +- test/lsp/lsp_formatting.ml | 4 +- test/lsp/lsp_hover.ml | 2 +- test/lsp/lsp_references.ml | 2 +- test/lsp/lsp_testing.ml | 11 +-- test/lsp/lsp_testing.mli | 7 +- 30 files changed, 181 insertions(+), 204 deletions(-) rename src/lsp/cobol_lsp/{cobol_lsp.ml => alltypes.ml} (54%) rename src/lsp/cobol_lsp/{lsp_diagnostics.ml => diagnostics.ml} (96%) rename src/lsp/cobol_lsp/{lsp_diagnostics.mli => diagnostics.mli} (100%) rename src/lsp/cobol_lsp/{lsp_document.ml => document.ml} (96%) rename src/lsp/cobol_lsp/{lsp_lookup.ml => lookup.ml} (96%) rename src/lsp/cobol_lsp/{lsp_server_loop.ml => loop.ml} (92%) rename src/lsp/cobol_lsp/{lsp_server_loop.mli => loop.mli} (92%) rename src/lsp/cobol_lsp/{lsp_position.ml => position.ml} (100%) rename src/lsp/cobol_lsp/{lsp_position.mli => position.mli} (100%) rename src/lsp/cobol_lsp/{lsp_project.ml => project.ml} (97%) rename src/lsp/cobol_lsp/{lsp_project.mli => project.mli} (100%) rename src/lsp/cobol_lsp/{lsp_project_cache.ml => project_cache.ml} (81%) rename src/lsp/cobol_lsp/{lsp_project_cache.mli => project_cache.mli} (95%) rename src/lsp/cobol_lsp/{lsp_request.ml => request.ml} (86%) rename src/lsp/cobol_lsp/{lsp_request.mli => request.mli} (85%) rename src/lsp/cobol_lsp/{lsp_server.ml => server.ml} (83%) rename src/lsp/cobol_lsp/{lsp_server.mli => server.mli} (90%) rename src/lsp/cobol_lsp/{lsp_utils.ml => utils.ml} (100%) rename src/lsp/cobol_lsp/{lsp_utils.mli => utils.mli} (100%) diff --git a/src/lsp/cobol_lsp/cobol_lsp.ml b/src/lsp/cobol_lsp/alltypes.ml similarity index 54% rename from src/lsp/cobol_lsp/cobol_lsp.ml rename to src/lsp/cobol_lsp/alltypes.ml index d94955588..119389ed3 100644 --- a/src/lsp/cobol_lsp/cobol_lsp.ml +++ b/src/lsp/cobol_lsp/alltypes.ml @@ -11,32 +11,10 @@ (* *) (**************************************************************************) -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 +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/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 96% rename from src/lsp/cobol_lsp/lsp_document.ml rename to src/lsp/cobol_lsp/document.ml index 3c4aff173..46ff390bf 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; @@ -75,7 +75,7 @@ let rewindable_parse ({ project; textdoc; _ } as doc) = Cobol_preproc.Preprocess.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 } @@ @@ -123,7 +123,7 @@ let reparse_and_analyze ?position ({ copybook; rewinder; textdoc; _ } as doc) = 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 { @@ -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 96% rename from src/lsp/cobol_lsp/lsp_lookup.ml rename to src/lsp/cobol_lsp/lookup.ml index 051b7e6fb..cc5d5fbc8 100644 --- a/src/lsp/cobol_lsp/lsp_lookup.ml +++ b/src/lsp/cobol_lsp/lookup.ml @@ -92,8 +92,8 @@ let rec qualname_at_pos ~filename (qn: Cobol_ptree.Types.qualname) pos = | 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_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_semtoks.ml b/src/lsp/cobol_lsp/lsp_semtoks.ml index 010173ecc..12a33049a 100644 --- a/src/lsp/cobol_lsp/lsp_semtoks.ml +++ b/src/lsp/cobol_lsp/lsp_semtoks.ml @@ -98,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 @@ -109,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 @@ -548,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 | _ -> @@ -563,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_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 86% rename from src/lsp/cobol_lsp/lsp_request.ml rename to src/lsp/cobol_lsp/request.ml index 8ac96986c..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,24 +39,24 @@ 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.Types.qualname) (cu: Cobol_unit.Types.cobol_unit) = match Cobol_unit.Qualmap.find qn cu.unit_data.data_items.named with @@ -88,7 +88,7 @@ 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.Types.qualname) (cu: Cobol_unit.Types.cobol_unit) = @@ -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,7 +218,7 @@ 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) @@ -226,16 +226,16 @@ let handle_references state (params: ReferenceParams.t) = 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,10 +244,10 @@ let lsp_text_edit Cobol_indent.Types.{ 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.Types.{ @@ -267,9 +267,9 @@ 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_main.indent_range @@ -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/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/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 = { From 29b5666797e221946bb590eafd1f7ab82b682bbb Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Thu, 1 Feb 2024 23:16:39 +0100 Subject: [PATCH 09/10] Remove cobol_parser/cobol_parser.ml --- .drom | 4 +- src/lsp/cobol_lsp/document.ml | 10 +-- src/lsp/cobol_lsp/lsp_semtoks.ml | 2 +- src/lsp/cobol_parser/cobol_parser.ml | 66 ------------------- src/lsp/cobol_parser/dune | 2 +- .../{text_keywords.ml => keywords.ml} | 0 .../{text_keywords.mli => keywords.mli} | 0 .../{parser_engine.ml => main.ml} | 49 ++++++++++++-- .../{parser_engine.mli => main.mli} | 23 ++++++- .../{parser_options.ml => options.ml} | 0 .../{parser_outputs.ml => outputs.ml} | 0 src/lsp/cobol_parser/package.toml | 2 +- src/lsp/cobol_parser/text_lexer.ml | 6 +- src/lsp/superbol_free_lib/command_pp.ml | 2 +- test/cobol_data/test_memory.ml | 2 +- test/cobol_parsing/parser_testing.ml | 14 ++-- .../test_combined_relations_parsing.ml | 8 +-- test/cobol_typeck/typeck_testing.ml | 2 +- test/cobol_unit/test_qualmap.ml | 2 +- test/output-tests/gnucobol.ml | 2 +- test/output-tests/reparse.ml | 2 +- 21 files changed, 92 insertions(+), 106 deletions(-) delete mode 100644 src/lsp/cobol_parser/cobol_parser.ml rename src/lsp/cobol_parser/{text_keywords.ml => keywords.ml} (100%) rename src/lsp/cobol_parser/{text_keywords.mli => keywords.mli} (100%) rename src/lsp/cobol_parser/{parser_engine.ml => main.ml} (94%) rename src/lsp/cobol_parser/{parser_engine.mli => main.mli} (91%) rename src/lsp/cobol_parser/{parser_options.ml => options.ml} (100%) rename src/lsp/cobol_parser/{parser_outputs.ml => outputs.ml} (100%) diff --git a/.drom b/.drom index f0f0e1cb2..ca0d126ef 100644 --- a/.drom +++ b/.drom @@ -5,7 +5,7 @@ version:0.9.0 # hash of toml configuration files # used for generation of all files -93d2e460909a3ddf6a2ed971ff2e8639:. +902350756f0d7d15400b20a907430e9e:. # end context for . # begin context for .github/workflows/workflow.yml @@ -345,7 +345,7 @@ e74b6a4502967712b07002d1fb8b4292:src/lsp/cobol_data_old/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 diff --git a/src/lsp/cobol_lsp/document.ml b/src/lsp/cobol_lsp/document.ml index 46ff390bf..e99e1b7d2 100644 --- a/src/lsp/cobol_lsp/document.ml +++ b/src/lsp/cobol_lsp/document.ml @@ -34,7 +34,7 @@ module TYPES = struct and rewinder = (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,7 +66,7 @@ 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 }; @@ -95,7 +95,7 @@ let check doc ptree = 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,7 +115,7 @@ 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_parser.Main.rewind_and_parse rewinder ~position @@ Cobol_preproc.Preprocess.reset_preprocessor_for_string @@ Lsp.Text_document.text textdoc @@ -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 diff --git a/src/lsp/cobol_lsp/lsp_semtoks.ml b/src/lsp/cobol_lsp/lsp_semtoks.ml index 12a33049a..68a8f4254 100644 --- a/src/lsp/cobol_lsp/lsp_semtoks.ml +++ b/src/lsp/cobol_lsp/lsp_semtoks.ml @@ -14,7 +14,7 @@ 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 } 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/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 94% rename from src/lsp/cobol_parser/parser_engine.ml rename to src/lsp/cobol_parser/main.ml index bd73eaa0c..fea41c2c9 100644 --- a/src/lsp/cobol_parser/parser_engine.ml +++ b/src/lsp/cobol_parser/main.ml @@ -15,8 +15,8 @@ module DIAGS = Cobol_common.Diagnostics 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 @@ -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 @@ -580,7 +580,7 @@ let rewindable_parse let parse (type m) ~(memory: m memory) - ?(options = Parser_options.default) + ?(options = Options.default) : Cobol_preproc.Preprocess.t -> (Cobol_ptree.Types.compilation_group option, m) output with_diags = parse_once ~options ~memory @@ -592,7 +592,7 @@ let parse_with_artifacts = parse ~memory:Eidetic let rewindable_parse (type m) ~(memory: m memory) - ?(options = Parser_options.default) + ?(options = Options.default) : Cobol_preproc.Preprocess.t -> (((Cobol_ptree.Types.compilation_group option, m) output as 'x) * 'x rewinder) with_diags = @@ -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 91% rename from src/lsp/cobol_parser/parser_engine.mli rename to src/lsp/cobol_parser/main.mli index 6b101dbed..015c772d7 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,7 +36,7 @@ open Parser_outputs (** Simple parsing functions traverse the inputs once to produce a result. *) type 'm simple_parsing - = ?options:Parser_options.parser_options + = ?options:Options.parser_options -> Cobol_preproc.Preprocess.t -> (Cobol_ptree.Types.compilation_group option, 'm) output Cobol_common.Diagnostics.with_diags @@ -113,3 +113,20 @@ val rewind_and_parse 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 100% rename from src/lsp/cobol_parser/parser_options.ml rename to src/lsp/cobol_parser/options.ml diff --git a/src/lsp/cobol_parser/parser_outputs.ml b/src/lsp/cobol_parser/outputs.ml similarity index 100% rename from src/lsp/cobol_parser/parser_outputs.ml rename to src/lsp/cobol_parser/outputs.ml 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 b1d41c9b8..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 (* --- *) diff --git a/src/lsp/superbol_free_lib/command_pp.ml b/src/lsp/superbol_free_lib/command_pp.ml index 6ee752266..2c4182f98 100644 --- a/src/lsp/superbol_free_lib/command_pp.ml +++ b/src/lsp/superbol_free_lib/command_pp.ml @@ -64,7 +64,7 @@ let cmd = in input |> Cobol_preproc.Preprocess.preprocessor ~options:preproc_options |> - Cobol_parser.parse_simple ~options:common.parser_options + Cobol_parser.Main.parse_simple ~options:common.parser_options 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; 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_parsing/parser_testing.ml b/test/cobol_parsing/parser_testing.ml index 049e7a3b1..fbf9eb373 100644 --- a/test/cobol_parsing/parser_testing.ml +++ b/test/cobol_parsing/parser_testing.ml @@ -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; @@ -154,7 +154,7 @@ let rewindable_parse 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; diff --git a/test/cobol_parsing/test_combined_relations_parsing.ml b/test/cobol_parsing/test_combined_relations_parsing.ml index dacf6e2f0..af1c39625 100644 --- a/test/cobol_parsing/test_combined_relations_parsing.ml +++ b/test/cobol_parsing/test_combined_relations_parsing.ml @@ -14,10 +14,10 @@ open Alcotest open Cobol_ptree.Types -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 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_typeck/typeck_testing.ml b/test/cobol_typeck/typeck_testing.ml index b5831be16..cc68413db 100644 --- a/test/cobol_typeck/typeck_testing.ml +++ b/test/cobol_typeck/typeck_testing.ml @@ -18,7 +18,7 @@ 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; diff --git a/test/cobol_unit/test_qualmap.ml b/test/cobol_unit/test_qualmap.ml index 01d5cf9e7..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 diff --git a/test/output-tests/gnucobol.ml b/test/output-tests/gnucobol.ml index 673588e2c..4a4251ba8 100644 --- a/test/output-tests/gnucobol.ml +++ b/test/output-tests/gnucobol.ml @@ -192,7 +192,7 @@ let do_check_parse (test_filename, contents, _, { check_loc; input |> Cobol_preproc.Preprocess.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/reparse.ml b/test/output-tests/reparse.ml index 0e81cc3ab..02cf9bfe2 100644 --- a/test/output-tests/reparse.ml +++ b/test/output-tests/reparse.ml @@ -18,7 +18,7 @@ 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 From 03cf06fab4f6cfa11be1fc0408b394fdfacf5718 Mon Sep 17 00:00:00 2001 From: Fabrice Le Fessant Date: Thu, 1 Feb 2024 23:21:00 +0100 Subject: [PATCH 10/10] Rename cobol_preproc/preprocess.ml into cobol_preproc/main.ml --- src/lsp/cobol_indent/indent_main.ml | 2 +- src/lsp/cobol_lsp/document.ml | 4 +-- src/lsp/cobol_parser/main.ml | 36 +++++++++---------- src/lsp/cobol_parser/main.mli | 6 ++-- .../cobol_preproc/{preprocess.ml => main.ml} | 0 .../{preprocess.mli => main.mli} | 0 src/lsp/superbol_free_lib/command_pp.ml | 4 +-- test/cobol_parsing/parser_testing.ml | 14 ++++---- test/cobol_preprocessing/preproc_testing.ml | 16 ++++----- test/output-tests/gnucobol.ml | 2 +- test/output-tests/preproc.ml | 2 +- test/output-tests/reparse.ml | 2 +- 12 files changed, 44 insertions(+), 44 deletions(-) rename src/lsp/cobol_preproc/{preprocess.ml => main.ml} (100%) rename src/lsp/cobol_preproc/{preprocess.mli => main.mli} (100%) diff --git a/src/lsp/cobol_indent/indent_main.ml b/src/lsp/cobol_indent/indent_main.ml index a965fbbe7..507bab36b 100644 --- a/src/lsp/cobol_indent/indent_main.ml +++ b/src/lsp/cobol_indent/indent_main.ml @@ -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.Preprocess.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 diff --git a/src/lsp/cobol_lsp/document.ml b/src/lsp/cobol_lsp/document.ml index e99e1b7d2..3f91a5dc1 100644 --- a/src/lsp/cobol_lsp/document.ml +++ b/src/lsp/cobol_lsp/document.ml @@ -72,7 +72,7 @@ let rewindable_parse ({ project; textdoc; _ } as doc) = recovery = EnableRecovery { silence_benign_recoveries = true }; config = project.config.cobol_config; } @@ - Cobol_preproc.Preprocess.preprocessor + Cobol_preproc.Main.preprocessor ~options:Cobol_preproc.Options.{ default with libpath = Project.libpath_for ~uri:(uri doc) project; @@ -116,7 +116,7 @@ let reparse_and_analyze ?position ({ copybook; rewinder; textdoc; _ } as doc) = | Some position, Some rewinder -> check doc @@ Cobol_parser.Main.rewind_and_parse rewinder ~position @@ - Cobol_preproc.Preprocess.reset_preprocessor_for_string @@ + 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. *) diff --git a/src/lsp/cobol_parser/main.ml b/src/lsp/cobol_parser/main.ml index fea41c2c9..5be32258c 100644 --- a/src/lsp/cobol_parser/main.ml +++ b/src/lsp/cobol_parser/main.ml @@ -38,19 +38,19 @@ type 'x rewinder = ('x * ('x rewinder)) with_diags; } and preprocessor_rewind = - ?new_position: Lexing.position -> (Cobol_preproc.Preprocess.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.Preprocess.preprocessor + -> Cobol_preproc.Main.preprocessor -> (Cobol_ptree.Types.compilation_group option, 'm) output DIAGS.with_diags type 'm rewindable_parsing = ?options:parser_options - -> Cobol_preproc.Preprocess.preprocessor + -> 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.Preprocess.t; (* also holds diagnostics *) + pp: Cobol_preproc.Main.preprocessor; (* also holds diagnostics *) tokzr: 'm Tokzr.state; persist: 'm persist; } @@ -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.Preprocess.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.Preprocess.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.Preprocess.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.Preprocess.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.Preprocess.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.Preprocess.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.Preprocess.rev_log ps.preproc.pp; - rev_comments = Cobol_preproc.Preprocess.rev_comments ps.preproc.pp; - rev_ignored = Cobol_preproc.Preprocess.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.Preprocess.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.Preprocess.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.Preprocess.preprocessor + -> Cobol_preproc.Main.preprocessor -> ((('a option, 'm) output as 'x) * 'x rewinder) with_diags = fun ~options ~memory ~make_checkpoint pp -> let res, rwps = @@ -581,7 +581,7 @@ let parse (type m) ~(memory: m memory) ?(options = Options.default) - : Cobol_preproc.Preprocess.t -> + : Cobol_preproc.Main.t -> (Cobol_ptree.Types.compilation_group option, m) output with_diags = parse_once ~options ~memory ~make_checkpoint:Grammar.Incremental.compilation_group @@ -593,7 +593,7 @@ let rewindable_parse (type m) ~(memory: m memory) ?(options = Options.default) - : Cobol_preproc.Preprocess.t -> + : Cobol_preproc.Main.t -> (((Cobol_ptree.Types.compilation_group option, m) output as 'x) * 'x rewinder) with_diags = rewindable_parse ~options ~memory diff --git a/src/lsp/cobol_parser/main.mli b/src/lsp/cobol_parser/main.mli index 015c772d7..7fa5e18d0 100644 --- a/src/lsp/cobol_parser/main.mli +++ b/src/lsp/cobol_parser/main.mli @@ -37,7 +37,7 @@ open Outputs (** Simple parsing functions traverse the inputs once to produce a result. *) type 'm simple_parsing = ?options:Options.parser_options - -> Cobol_preproc.Preprocess.t + -> Cobol_preproc.Main.preprocessor -> (Cobol_ptree.Types.compilation_group option, 'm) output Cobol_common.Diagnostics.with_diags @@ -60,7 +60,7 @@ val parse_with_artifacts {!rewinder} that may then be given to {!rewind_and_parse}. *) type 'm rewindable_parsing = ?options:parser_options - -> Cobol_preproc.Preprocess.preprocessor + -> Cobol_preproc.Main.preprocessor -> (((Cobol_ptree.Types.compilation_group option, 'm) output as 'x) * 'x rewinder) Cobol_common.Diagnostics.with_diags @@ -74,7 +74,7 @@ and 'x rewinder of the input. *) and preprocessor_rewind = ?new_position:Lexing.position -> - (Cobol_preproc.Preprocess.t as 'r) -> 'r + (Cobol_preproc.Main.t as 'r) -> 'r (* val rewindable_parse *) (* : memory:'m memory -> 'm rewindable_parsing *) diff --git a/src/lsp/cobol_preproc/preprocess.ml b/src/lsp/cobol_preproc/main.ml similarity index 100% rename from src/lsp/cobol_preproc/preprocess.ml rename to src/lsp/cobol_preproc/main.ml diff --git a/src/lsp/cobol_preproc/preprocess.mli b/src/lsp/cobol_preproc/main.mli similarity index 100% rename from src/lsp/cobol_preproc/preprocess.mli rename to src/lsp/cobol_preproc/main.mli diff --git a/src/lsp/superbol_free_lib/command_pp.ml b/src/lsp/superbol_free_lib/command_pp.ml index 2c4182f98..2651b0322 100644 --- a/src/lsp/superbol_free_lib/command_pp.ml +++ b/src/lsp/superbol_free_lib/command_pp.ml @@ -63,7 +63,7 @@ let cmd = ~default: common.preproc_options.source_format } in input |> - Cobol_preproc.Preprocess.preprocessor ~options:preproc_options |> + Cobol_preproc.Main.preprocessor ~options:preproc_options |> Cobol_parser.Main.parse_simple ~options:common.parser_options in let my_text = Cobol_preproc.Src_input.from ~filename:file ~f:parse in @@ -96,7 +96,7 @@ let cmd = let text = let common = common_get () in Cobol_common.Diagnostics.show_n_forget @@ - Cobol_preproc.Preprocess.text_of_file file + Cobol_preproc.Main.text_of_file file ~options:common.preproc_options in let s = diff --git a/test/cobol_parsing/parser_testing.ml b/test/cobol_parsing/parser_testing.ml index fbf9eb373..9ad7b88d8 100644 --- a/test/cobol_parsing/parser_testing.ml +++ b/test/cobol_parsing/parser_testing.ml @@ -21,7 +21,7 @@ let preproc = Cobol_common.Srcloc.TESTING.register_file_contents ~filename contents; String { filename; contents } |> - Cobol_preproc.Preprocess.preprocessor + Cobol_preproc.Main.preprocessor ~options:Cobol_preproc.Options.{ default with libpath = []; @@ -149,7 +149,7 @@ let rewindable_parse = let DIAGS.{ result = Only ptree, rewinder; diags } = String { filename = "prog.cob"; contents = prog } |> - Cobol_preproc.Preprocess.preprocessor + Cobol_preproc.Main.preprocessor ~options:Cobol_preproc.Options.{ verbose; libpath = []; source_format; config = Option.value config ~default:default.config; @@ -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.Preprocess.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.Preprocess.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.Preprocess.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.Preprocess.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.Preprocess.reset_preprocessor_for_string prog + Cobol_preproc.Main.reset_preprocessor_for_string prog in loop (succ i) rewinder end diff --git a/test/cobol_preprocessing/preproc_testing.ml b/test/cobol_preprocessing/preproc_testing.ml index 48eaafd54..0e0b892f4 100644 --- a/test/cobol_preprocessing/preproc_testing.ml +++ b/test/cobol_preprocessing/preproc_testing.ml @@ -24,7 +24,7 @@ let preprocess ?(source_format = Cobol_config.Types.(SF SFFixed)) contents = DIAGS.show_n_forget ~ppf:Fmt.stdout @@ - Cobol_preproc.Preprocess.preprocess_input + Cobol_preproc.Main.preprocess_input ~options:Cobol_preproc.Options.{ default with verbose; libpath = []; source_format } @@ Cobol_preproc.Src_input.String { filename; contents } @@ -36,7 +36,7 @@ let show_text contents = let text = DIAGS.show_n_forget ~ppf:Fmt.stdout @@ - Cobol_preproc.Preprocess.text_of_input + Cobol_preproc.Main.text_of_input ~options:Cobol_preproc.Options.{ default with verbose; libpath = []; source_format } @@ Cobol_preproc.Src_input.String { filename; contents } @@ -53,7 +53,7 @@ let show_source_lines contents = DIAGS.show_n_forget ~ppf:Fmt.stdout @@ - Cobol_preproc.Preprocess.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,10 +71,10 @@ let show_source_lines end let rec show_all_text pp = - match Cobol_preproc.Preprocess.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.Preprocess.diags pp); + (Cobol_preproc.Main.diags pp); pp | text, pp -> Pretty.out "%a@\n" Cobol_preproc.Text.pp_text text; @@ -98,12 +98,12 @@ let preprocess_n_then_cut_n_paste_right_of_indicator Pretty.out "fixed: %a@." show_lines fixed_lines; Pretty.out " free: %a@." show_lines free_lines; Cobol_preproc.Src_input.string ~filename fixed_format_contents |> - Cobol_preproc.Preprocess.preprocessor + Cobol_preproc.Main.preprocessor ~options:Cobol_preproc.Options.{ default with verbose; libpath = []; source_format } |> show_all_text |> - Cobol_preproc.Preprocess.reset_preprocessor_for_string free_format_contents |> + Cobol_preproc.Main.reset_preprocessor_for_string free_format_contents |> show_all_text |> - Cobol_preproc.Preprocess.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/output-tests/gnucobol.ml b/test/output-tests/gnucobol.ml index 4a4251ba8..d2ba6d1a4 100644 --- a/test/output-tests/gnucobol.ml +++ b/test/output-tests/gnucobol.ml @@ -190,7 +190,7 @@ 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.Preprocess.preprocessor + Cobol_preproc.Main.preprocessor ~options:Cobol_preproc.Options.{ default with source_format } |> Cobol_parser.Main.parse_simple in diff --git a/test/output-tests/preproc.ml b/test/output-tests/preproc.ml index 960476584..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.preprocess_file filename + Cobol_preproc.Main.preprocess_file filename ~options:Cobol_preproc.Options.{ source_format; config; verbose = false; libpath = [] } ~ppf:std_formatter diff --git a/test/output-tests/reparse.ml b/test/output-tests/reparse.ml index 02cf9bfe2..bb1ef1b98 100644 --- a/test/output-tests/reparse.ml +++ b/test/output-tests/reparse.ml @@ -23,7 +23,7 @@ let reparse_file ~source_format ~config filename = default with recovery = DisableRecovery } @@ - Cobol_preproc.Preprocess.preprocessor + Cobol_preproc.Main.preprocessor ~options:Cobol_preproc.Options.{ default with libpath = [];