Merge pull request #332 from nberth/copyexts

Make copybook extensions configurable
OCamlPro · Jul 30, 2024 · 52a1f6c · 52a1f6c
2 parents 6775bab + 4f46bc7
commit 52a1f6c
Show file tree

Hide file tree

Showing 32 changed files with 440 additions and 186 deletions.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -3,7 +3,8 @@
 ## [0.1.4] Next release
 
 ### Added
-- COBOL language configuration for highlighting matching brackets and auto-insertion of line numbers in fixed- format code [#330](https://github.com/OCamlPro/superbol-studio-oss/pull/330)
+- Configuration setting for copybook filename extensions [#332](https://github.com/OCamlPro/superbol-studio-oss/pull/332)
+- COBOL language configuration for highlighting matching brackets and auto-insertion of line numbers in fixed-format code [#330](https://github.com/OCamlPro/superbol-studio-oss/pull/330)
 
 ### Fixed
 - Word wrapping in presence of hyphens [#330](https://github.com/OCamlPro/superbol-studio-oss/pull/330)

diff --git a/package.json b/package.json
diff --git a/src/lsp/cobol_common/copybook.ml b/src/lsp/cobol_common/copybook.ml
@@ -16,28 +16,53 @@ open Ez_file.V1
 
 type fileloc = [ `Word of string | `Alphanum of string ]
 
-type lookup_info =
+type lookup_config =
   {
-    libname: string;
-    libpath: string list;
+    lookup_path: string list;
+    lookup_exts: string list;
+  }
+
+type lookup_error =
+  {
+    lookup_libname: string;
+    lookup_config: lookup_config;
   }
 
 (** Filename extensions that we should treat as copybooks and not main
     programs. *)
 let copybook_extensions =  (* this must be a subset of {!libfile_extensions}. *)
-  [".CPY"; ".cpy";
-   ".CBX"; ".cbx"]
+  ["cpy"; "cbx"]
 
 let libfile_extensions =
-  [".CPY"; ".CBL"; ".COB"; ".CBX";
-   ".cpy"; ".cbl"; ".cob"; ".cbx"; ""]
+  ["cpy"; "cbl"; "cob"; "cbx"]
+
+let lookup_config ?(libexts = libfile_extensions) libpath =
+  {
+    lookup_path = libpath;
+    lookup_exts = List.map String.lowercase_ascii libexts;
+  }
 
-type directory = {
-  dir : string ;
-  files : string StringMap.t ; (* key is basename in lowercase *)
-}
+let pp_lookup_config ppf { lookup_path; lookup_exts } =
+  let pp_path ppf = function
+    | [] -> Pretty.string ppf "<empty>"
+    | path -> Pretty.path ppf path
+  in
+  Pretty.print ppf
+    "@[- search@ path:@ %a@]@;\
+     @[- filename@ extensions:@ %a@]"
+    pp_path lookup_path Fmt.(list ~sep:sp @@ fmt "%S") lookup_exts
 
-let find_lib ~libpath ?(exts=libfile_extensions) ?fromfile ?libname textname : _ result =
+(* --- *)
+
+type directory =
+  {
+    dir: string;
+    files: string StringMap.t;                (* key is basename in lowercase *)
+  }
+
+let find_lib ~lookup_config:({ lookup_path = libpath;
+                               lookup_exts = libexts } as lookup_config)
+    ?fromfile ?libname textname : (string, lookup_error) result =
   let libpath = match libname, fromfile with
     | None, _ ->
         libpath
@@ -47,49 +72,53 @@ let find_lib ~libpath ?(exts=libfile_extensions) ?fromfile ?libname textname : _
     | Some (`Word d | `Alphanum d), _ ->
         [d]
   in
-  let libpath_files = List.map (fun dir ->
-      { dir ;
-        files =
-          let files = try Sys.readdir dir with _ -> [||] in
-          let map = ref StringMap.empty in
-          Array.iter (fun file ->
-              let base = String.lowercase_ascii file in
-              map := StringMap.add base file !map
-            ) files ;
-          !map
-      }
-    ) libpath
+  let libpath_files =
+    List.map begin fun dir ->
+      let files =
+        let files = try Sys.readdir dir with Sys_error _ -> [||] in
+        let map = ref StringMap.empty in
+        Array.iter begin fun file ->
+          map := StringMap.add (String.lowercase_ascii file) file !map
+        end files;
+        !map
+      in
+      { dir; files }
+    end libpath
   in
-  let exts = List.map String.lowercase_ascii exts in
   let try_file libname exts =
     let base = String.lowercase_ascii libname in
+    let without_ext d =
+      Ok (Filename.concat d.dir @@ StringMap.find base d.files)
+    and with_ext d ext =
+      Ok (Filename.concat d.dir @@ StringMap.find (base ^ "." ^ ext) d.files)
+    in
     let rec iter_path path =
       match path with
-      | [] -> Error { libname; libpath }
-      | d :: path ->
-        iter_exts d path exts
-
+      | [] -> Error { lookup_libname = libname;
+                      lookup_config = { lookup_config with
+                                        lookup_path = libpath } }
+      | d :: path -> iter_exts d path exts
     and iter_exts d path exts =
       match exts with
-      | [] -> iter_path path
-      | ext :: exts ->
-        let file = base ^ ext in
-        match StringMap.find file d.files with
-        | exception Not_found -> iter_exts d path exts
-        | file -> Ok ( Filename.concat d.dir file )
+      | [] -> (try without_ext d with Not_found -> iter_path path)
+      | ext :: exts -> (try with_ext d ext with Not_found -> iter_exts d path exts)
     in
     iter_path libpath_files
   in
+  (* Note: GnuCOBOL handles copybook names given as string literals or plain
+     text-words in the same way (except for distinct case-folding, that we don't
+     handle yet).
+
+     TODO: to handle case folding, a copybook name that is given as a text-word
+     should be put in uppercase unless [lookup_fold=Lower]. *)
   match textname with
-  | `Alphanum w ->                       (* assume no more filename extension  *)
-      try_file w [""]
+  | `Alphanum w
   | `Word w ->
-      match try_file w exts with
+      match try_file w libexts with
       | Ok lib -> Ok lib
-      | Error err -> Error { err with libname = w }
+      | Error err -> Error { err with lookup_libname = w }
 
-let pp_lookup_error ppf { libname; libpath } =
-  (* TODO: `note addendum about search path *)
+let pp_lookup_error ppf { lookup_libname; lookup_config } =
   Pretty.print ppf
-    "@[Library@ `%s'@ not@ found@ in@ search@ path@ (search@ path:@ @[%a@])@]"
-    libname Pretty.path libpath
+    "@[<v>@[Library@ `%s'@ not@ found@]@;%a@]"
+    lookup_libname pp_lookup_config lookup_config
diff --git a/src/lsp/cobol_common/copybook.mli b/src/lsp/cobol_common/copybook.mli
@@ -13,24 +13,36 @@
 
 type fileloc = [ `Word of string | `Alphanum of string ]
 
-type lookup_info =
+type lookup_config =
   {
-    libname: string;
-    libpath: string list;
+    lookup_path: string list;
+    lookup_exts: string list;
   }
 
+val pp_lookup_config: lookup_config Pretty.printer
+
+val lookup_config
+  : ?libexts: string list
+  -> string list
+  -> lookup_config
+
+type lookup_error =
+  {
+    lookup_libname: string;
+    lookup_config: lookup_config;
+  }
+
+val pp_lookup_error: lookup_error Pretty.printer
+
 (* --- *)
 
 val copybook_extensions: string list
 
-val pp_lookup_error: lookup_info Pretty.printer
-
-(** [find_lib ~libpath ?exts ?fromfile ?libname txtname] attempts to locate a file
-    containing the copybook [txtname], which is a file named [txtname], possibly
-    appended with an extension from {[".CPY"; ".CBL"; ".COB"; ".CBX"; ".cpy";
-    ".cbl"; ".cob"; ".cbx"]} (considered in order), {e unless} [txtname] is
-    given as an alphanumeric literal ({i e.g, [txtname = `Alphanum filname] ---
-    in which case no extension is assumed).
+(** [find_lib ~lookup_config ?fromfile ?libname txtname] attempts to locate a
+    file containing the copybook [txtname], which is a file named [txtname],
+    possibly appended with an extension from [libexts] (considered in order), {e
+    unless} [txtname] is given as an alphanumeric literal ({i e.g, [txtname =
+    `Alphanum filname] --- in which case no extension is assumed).
 
     If [libname] is not provided, then the file is searched within the
     directories listed in [libpath] (considered in order).  Otherwise, a single
@@ -42,9 +54,8 @@ val pp_lookup_error: lookup_info Pretty.printer
     of the path in the provided order.
  *)
 val find_lib
-  : libpath:string list
-  -> ?exts:string list
+  : lookup_config: lookup_config
   -> ?fromfile:string
   -> ?libname:fileloc
   -> fileloc
-  -> (string, lookup_info) result
+  -> (string, lookup_error) result
diff --git a/src/lsp/cobol_lsp/lsp_document.ml b/src/lsp/cobol_lsp/lsp_document.ml
@@ -77,7 +77,8 @@ let rewindable_parse ({ project; textdoc; _ } as doc) =
   Cobol_preproc.preprocessor
     ~options:Cobol_preproc.Options.{
         default with
-        libpath = Lsp_project.libpath_for ~uri:(uri doc) project;
+        copybook_lookup_config =
+          Lsp_project.copybook_lookup_config_for ~uri:(uri doc) project;
         config = project.config.cobol_config;
         source_format = project.config.source_format
       } @@

diff --git a/src/lsp/cobol_lsp/lsp_project.ml b/src/lsp/cobol_lsp/lsp_project.ml
@@ -67,8 +67,9 @@ let for_ ~rootdir ~layout =
 let in_existing_dir dirname ~layout =
   for_ ~rootdir:(Superbol_project.rootdir_at ~dirname) ~layout
 
-let libpath_for ~uri project =
-  Superbol_project.libpath_for ~filename:(Lsp.Uri.to_path uri) project
+let copybook_lookup_config_for ~uri project =
+  Superbol_project.copybook_lookup_config_for ~filename:(Lsp.Uri.to_path uri)
+    project
 
 let detect_copybook ~uri project =
   Superbol_project.detect_copybook ~filename:(Lsp.Uri.to_path uri) project
@@ -99,8 +100,9 @@ let update_source_format { config; _ } str : bool =
 let update_dialect ({ config; _ } as project) str : bool =
   try
     let { result; diags } =
-      Superbol_project.Config.cobol_config_from_dialect_name
-        ~verbose:false str in
+      Superbol_project.Config.cobol_config_from_dialect_name str
+        ~verbose:false
+    in
     if result = config.cobol_config            (* note: structural comparison *)
     then false
     else begin
@@ -123,13 +125,24 @@ let update_copybooks: t -> Yojson.Safe.t -> bool = fun { config; _ } json ->
   in
   try
     let libpath = convert_each to_libdir json in
-    if libpath = config.libpath              (* note: structural comparison *)
+    if libpath = config.libpath                (* note: structural comparison *)
     then false
     else (config.libpath <- libpath; true)
   with
     Yojson.Safe.Util.(Type_error _ | Undefined _) as e ->
       Pretty.invalid_arg "%s: %a" (Yojson.Safe.to_string json) Fmt.exn e
 
+let update_copyexts: t -> Yojson.Safe.t -> bool = fun { config; _ } json ->
+  let open Yojson.Safe.Util in
+  try
+    let libexts = convert_each to_string json in
+    if libexts = config.libexts                (* note: structural comparison *)
+    then false
+    else (config.libexts <- libexts; true)
+  with
+    Yojson.Safe.Util.(Type_error _ | Undefined _) as e ->
+      Pretty.invalid_arg "%s: %a" (Yojson.Safe.to_string json) Fmt.exn e
+
 (** [update_project_config assoc project] updates the configuration of [project]
     according to key/value paires in [assoc]; returns [true] whenever the
     configuration upon termination differs from the configuration upon call. *)
@@ -155,6 +168,7 @@ let update_project_config assoc project : bool =
     "dialect", from_string ~f:update_dialect;
     "source-format", from_string ~f:update_source_format;
     "copybooks", update_copybooks;
+    "copyexts", update_copyexts;
   ]
 
 
@@ -198,6 +212,9 @@ let get_project_config ?(flat = true) project : Yojson.Safe.t =
 
       "copybooks",
       `List copybooks;
+
+      "copyexts",
+      `List (List.map (fun s -> `String s) config.libexts);
     ]
   in
   if flat

diff --git a/src/lsp/cobol_lsp/lsp_project.mli b/src/lsp/cobol_lsp/lsp_project.mli
@@ -52,10 +52,10 @@ val in_existing_dir: string -> layout:layout -> t
     {!Superbol_project.rootdir_for}. *)
 val rootdir_for: uri:Lsp.Uri.t -> layout:layout -> rootdir
 
-(** [libpath_for ~uri project] constructs a list of directory names where
-    copybooks are looked up, for a source file at the given URI, in the given
-    project. *)
-val libpath_for: uri:Lsp.Uri.t -> t -> string list
+(** [copybook_lookup_config_for ~uri project] constructs a copybook lookup
+    configuration for a source file at the given URI, in the given project. *)
+val copybook_lookup_config_for
+  : uri:Lsp.Uri.t -> t -> Cobol_common.Copybook.lookup_config
 
 (** [detect_copybook ~uri project] indicates whether a document at the given URI
     for [project] should be treated as a copybook. *)

diff --git a/src/lsp/cobol_preproc/preproc_diagnostics.ml b/src/lsp/cobol_preproc/preproc_diagnostics.ml
@@ -16,7 +16,7 @@ open Cobol_common.Srcloc.INFIX
 
 type error =
   | Copybook_lookup_error of { copyloc: srcloc option;
-                               lnf: Cobol_common.Copybook.lookup_info }
+                               lnf: Cobol_common.Copybook.lookup_error }
   | Cyclic_copy of { copyloc: srcloc; filename: string }
   | Feature_error of Cobol_config.DIAG.error
   | Forbidden of { loc: srcloc; stuff: forbidden_stuff }