diff --git a/.drom b/.drom index 3879d9edc..bfc3ae57a 100644 --- a/.drom +++ b/.drom @@ -5,17 +5,17 @@ version:0.9.0 # hash of toml configuration files # used for generation of all files -817e4b96072d8107ce0332774e85e0a5:. +b602227bcc8caec31bc7877658492520:. # end context for . # begin context for .github/workflows/workflow.yml # file .github/workflows/workflow.yml -fc10b0887fb072e04e5bcbdd5a0c6668:.github/workflows/workflow.yml +1ff6f1c9a62d2172393a77d0c39b0347:.github/workflows/workflow.yml # end context for .github/workflows/workflow.yml # begin context for .gitignore # file .gitignore -0727863b8e681aec0cc8d969f8cfb747:.gitignore +5d7ba25fe849cca450aff51db71881f3:.gitignore # end context for .gitignore # begin context for CHANGES.md @@ -30,7 +30,7 @@ d00f73c835ae4a1589d55ebda4ab381b:CHANGES.md # begin context for Makefile # file Makefile -8c1798510e3d14cdfd80b0ebd931773b:Makefile +720048052459a394dc73cc71e8ad9fdc:Makefile # end context for Makefile # begin context for README.md @@ -80,8 +80,7 @@ c8281f46ba9a11d0b61bc8ef67eaa357:docs/style.css # begin context for dune-project # file dune-project -0331551296e3a627ef039388cc6be5e9:dune-project -474ade77f279147fb20510c3425249bf:dune-project +ce7b96b842d3f265df300ce6c72e52d4:dune-project # end context for dune-project # begin context for opam/cobol_ast.opam @@ -186,7 +185,7 @@ dcf0ebaa8b12787df9efcaa0ce8cbbe5:opam/package-json.opam # begin context for opam/superbol_free_lib.opam # file opam/superbol_free_lib.opam -8af34e95431d46524a132682225e4c84:opam/superbol_free_lib.opam +c86beae68d4d0173c716a8449fc2dfaf:opam/superbol_free_lib.opam # end context for opam/superbol_free_lib.opam # begin context for opam/superbol_testutils.opam @@ -406,7 +405,7 @@ b9a14c96cce8e365e1d7494d078d73fe:src/lsp/superbol-free/linking_flags.sh # begin context for src/lsp/superbol_free_lib/dune # file src/lsp/superbol_free_lib/dune -6625329103c4f2ffacd92354431cce4e:src/lsp/superbol_free_lib/dune +562cdec92233a9d9156b6db06c636cde:src/lsp/superbol_free_lib/dune # end context for src/lsp/superbol_free_lib/dune # begin context for src/lsp/superbol_free_lib/version.mlt @@ -501,7 +500,7 @@ b9a14c96cce8e365e1d7494d078d73fe:src/lsp/superbol-free/linking_flags.sh # begin context for src/vscode/vscode-json/dune # file src/vscode/vscode-json/dune -452540098fd6ae61c5f364330d4ec493:src/vscode/vscode-json/dune +c57e4311cc67d76a32541e4dc3132913:src/vscode/vscode-json/dune # end context for src/vscode/vscode-json/dune # begin context for src/vscode/vscode-json/index.mld @@ -523,18 +522,3 @@ b9a14c96cce8e365e1d7494d078d73fe:src/lsp/superbol-free/linking_flags.sh # file src/vscode/vscode-languageclient-js-stubs/version.mlt 940d29cde7f16cd0916ed1d5f9c41154:src/vscode/vscode-languageclient-js-stubs/version.mlt # end context for src/vscode/vscode-languageclient-js-stubs/version.mlt - -# begin context for src/vscode/vscode-package-json/dune -# file src/vscode/vscode-package-json/dune -3daa53b1ba5e5b962bd4a4a2d126f35d:src/vscode/vscode-package-json/dune -# end context for src/vscode/vscode-package-json/dune - -# begin context for src/vscode/vscode-package-json/linking_flags.sh -# file src/vscode/vscode-package-json/linking_flags.sh -91c1ee3f5f358d3e2ffe2e7031ca4363:src/vscode/vscode-package-json/linking_flags.sh -# end context for src/vscode/vscode-package-json/linking_flags.sh - -# begin context for src/vscode/vscode-package-json/version.mlt -# file src/vscode/vscode-package-json/version.mlt -940d29cde7f16cd0916ed1d5f9c41154:src/vscode/vscode-package-json/version.mlt -# end context for src/vscode/vscode-package-json/version.mlt diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 28c63d2fb..5e99c3121 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-vscode-platform polka-js-stubs interop-js-stubs node-js-stubs vscode-js-stubs vscode-languageclient-js-stubs vscode-package-json vscode-json vscode-debugadapter vscode-debugprotocol superbol-free superbol_free_lib cobol_common cobol_parser ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_ast cobol_indent cobol_preproc cobol_data cobol_typeck superbol_testutils + - run: opam depext -y 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 cobol_common cobol_parser ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_ast cobol_indent cobol_preproc cobol_data cobol_typeck superbol_testutils # if: steps.cache-opam.outputs.cache-hit != 'true' - run: opam install -y opam/*.opam --deps-only --with-test diff --git a/.gitignore b/.gitignore index cddd5ff5a..500db8f6a 100644 --- a/.gitignore +++ b/.gitignore @@ -4,7 +4,6 @@ /node-js-stubs /vscode-js-stubs /vscode-languageclient-js-stubs -/vscode-package-json /vscode-json /vscode-debugadapter /vscode-debugprotocol diff --git a/Makefile b/Makefile index 0ad72ff84..88fdc2d08 100644 --- a/Makefile +++ b/Makefile @@ -20,7 +20,7 @@ all: build build: ./scripts/before.sh build opam exec -- dune build @install - ./scripts/copy-bin.sh superbol-vscode-platform polka-js-stubs interop-js-stubs node-js-stubs vscode-js-stubs vscode-languageclient-js-stubs vscode-package-json vscode-json vscode-debugadapter vscode-debugprotocol superbol-free superbol_free_lib cobol_common cobol_parser ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_ast cobol_indent cobol_preproc cobol_data cobol_typeck superbol_testutils + ./scripts/copy-bin.sh 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 cobol_common cobol_parser ebcdic_lib cobol_lsp ppx_cobcflags pretty cobol_config cobol_ast cobol_indent cobol_preproc cobol_data cobol_typeck superbol_testutils ./scripts/after.sh build build-deps: diff --git a/Makefile.header b/Makefile.header index c11b88a3e..509e849f6 100644 --- a/Makefile.header +++ b/Makefile.header @@ -1,14 +1,18 @@ # -*- Makefile -*- PROJECT=superbol_vscode_platform SRCDIR=src/vscode/superbol-vscode-platform +CP ?= cp -f # Emacs lsp-mode source directory (https://github.com/emacs-lsp/lsp-mode): # (could be a submodule) LSP_MODE_SRCDIR ?= ../lsp-mode +all: superbol-free +superbol-free: build + $(CP) _build/default/src/lsp/superbol-free/main.exe superbol-free + .PHONY: compile compile: build - cp -f _build/default/src/vscode/vscode-package-json/main.exe vscode-package-json yarn esbuild _build/default/$(SRCDIR)/$(PROJECT).bc.js \ --bundle \ --external:vscode \ @@ -32,6 +36,11 @@ compile-release: --sourcemap \ --sources-content=false +.PHONY: clean-execs +distclean: clean-execs +clean-execs: + rm -f superbol-free vscode-package-json + .PHONY: opam-cross opam-cross: diff --git a/README.md b/README.md index 9b2fcddca..2cb58f35e 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,6 @@ +[![Actions Status](https://github.com/ocamlpro/superbol-studio-oss/workflows/Main%20Workflow/badge.svg)](https://github.com/ocamlpro/superbol-studio-oss/actions) +[![Release](https://img.shields.io/github/release/ocamlpro/superbol-studio-oss.svg)](https://github.com/ocamlpro/superbol-studio-oss/releases) + # Superbol Studio OSS: A New Platform for COBOL ## Features diff --git a/drom.toml b/drom.toml index 35341d3d6..abb61bc9a 100644 --- a/drom.toml +++ b/drom.toml @@ -122,10 +122,6 @@ dir = "src/vscode/vscode-js-stubs" dir = "src/vscode/vscode-languageclient-js-stubs" # edit 'src/vscode/vscode-languageclient-js-stubs/package.toml' for package-specific options -[[package]] -dir = "src/vscode/vscode-package-json" -# edit 'src/vscode/vscode-package-json/package.toml' for package-specific options - [[package]] dir = "src/vscode/vscode-json" # edit 'src/vscode/vscode-json/package.toml' for package-specific options diff --git a/dune-project b/dune-project index 742009e12..c62bf989c 100644 --- a/dune-project +++ b/dune-project @@ -125,23 +125,6 @@ ) ) -(package - (name vscode-package-json) - (synopsis "The superbol-studio-oss project") - (description "This is the description\nof the superbol-studio-oss OCaml project\n") - (depends - (ocaml (>= 4.14.0)) - (vscode-json (= version)) - ezjsonm - (ez_file (and (>= 0.3.0) (< 1.0.0))) - ppx_deriving_encoding - ppx_inline_test - ppx_expect - odoc - ocamlformat - ) - ) - (package (name vscode-json) (synopsis "The superbol-studio-oss project") @@ -219,6 +202,7 @@ (description "This is the description\nof the superbol-studio-oss OCaml project\n") (depends (ocaml (>= 4.14.0)) + (vscode-json (= version)) (ez_file ( >= 0.3 )) (ez_cmdliner (and (>= 0.3.0) (< 1.0.0))) (cobol_typeck (= version)) diff --git a/opam/osx/superbol_free_lib-osx.opam b/opam/osx/superbol_free_lib-osx.opam index ef2215b22..23d8e56dc 100644 --- a/opam/osx/superbol_free_lib-osx.opam +++ b/opam/osx/superbol_free_lib-osx.opam @@ -50,6 +50,7 @@ install: [ depends: [ "ocaml" {>= "4.14.0"} "dune" {>= "2.8.0"} + "vscode-json-osx" {= version} "ez_file-osx" {>= "0.3"} "ez_cmdliner-osx" {>= "0.3.0" & < "1.0.0"} "cobol_typeck-osx" {= version} diff --git a/opam/osx/vscode-package-json-osx.opam b/opam/osx/vscode-package-json-osx.opam deleted file mode 100644 index b377eb905..000000000 --- a/opam/osx/vscode-package-json-osx.opam +++ /dev/null @@ -1,62 +0,0 @@ -# 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: "vscode-package-json" -version: "0.1.0" -license: "MIT" -synopsis: "The superbol-studio-oss project" -description: """\ -This is the description -of the superbol-studio-oss OCaml project -""" -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-vscode-platform" -doc: "https://ocamlpro.github.io/superbol-vscode-platform/sphinx" -bug-reports: "https://github.com/ocamlpro/superbol-vscode-platform/issues" -dev-repo: "git+https://github.com/ocamlpro/superbol-vscode-platform.git" -tags: "org:ocamlpro" -build: [ - ["dune" "subst"] {dev} - ["sh" "-c" "./scripts/before.sh build '%{name}%'"] - [ - "dune" - "build" - "-p" - "vscode-package-json" - "-x" - "osx" - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] - ["sh" "-c" "./scripts/after.sh build '%{name}%'"] -] -install: [ - ["sh" "-c" "./scripts/before.sh install '%{name}%'"] -] -depends: [ - "ocaml" {>= "4.14.0"} - "dune" {>= "2.8.0"} - "vscode-json-osx" {= version} - "ezjsonm-osx" {} - "ez_file-osx" {>= "0.3.0" & < "1.0.0"} - "ppx_deriving_encoding" {} - "ppx_inline_test" {with-test} - "ppx_expect" {with-test} - "odoc" {with-doc} - "ocamlformat" {with-test} -] -# Content of `opam-trailer` field: \ No newline at end of file diff --git a/opam/superbol_free_lib.opam b/opam/superbol_free_lib.opam index 15c529179..a9e55fde1 100644 --- a/opam/superbol_free_lib.opam +++ b/opam/superbol_free_lib.opam @@ -48,6 +48,7 @@ install: [ depends: [ "ocaml" {>= "4.14.0"} "dune" {>= "2.8.0"} + "vscode-json" {= version} "ez_file" {>= "0.3"} "ez_cmdliner" {>= "0.3.0" & < "1.0.0"} "cobol_typeck" {= version} diff --git a/opam/vscode-package-json.opam b/opam/vscode-package-json.opam deleted file mode 100644 index 43423f17e..000000000 --- a/opam/vscode-package-json.opam +++ /dev/null @@ -1,60 +0,0 @@ -# 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: "vscode-package-json" -version: "0.1.0" -license: "MIT" -synopsis: "The superbol-studio-oss project" -description: """\ -This is the description -of the superbol-studio-oss OCaml project -""" -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-vscode-platform" -doc: "https://ocamlpro.github.io/superbol-vscode-platform/sphinx" -bug-reports: "https://github.com/ocamlpro/superbol-vscode-platform/issues" -dev-repo: "git+https://github.com/ocamlpro/superbol-vscode-platform.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"} - "vscode-json" {= version} - "ezjsonm" {} - "ez_file" {>= "0.3.0" & < "1.0.0"} - "ppx_deriving_encoding" {} - "ppx_inline_test" {with-test} - "ppx_expect" {with-test} - "odoc" {with-doc} - "ocamlformat" {with-test} -] -# Content of `opam-trailer` field: \ No newline at end of file diff --git a/opam/windows/superbol_free_lib-windows.opam b/opam/windows/superbol_free_lib-windows.opam index 0d28f529d..edd95fd2c 100644 --- a/opam/windows/superbol_free_lib-windows.opam +++ b/opam/windows/superbol_free_lib-windows.opam @@ -50,6 +50,7 @@ install: [ depends: [ "ocaml" {>= "4.14.0"} "dune" {>= "2.8.0"} + "vscode-json-windows" {= version} "ez_file-windows" {>= "0.3"} "ez_cmdliner-windows" {>= "0.3.0" & < "1.0.0"} "cobol_typeck-windows" {= version} diff --git a/opam/windows/vscode-package-json-windows.opam b/opam/windows/vscode-package-json-windows.opam deleted file mode 100644 index e385b119d..000000000 --- a/opam/windows/vscode-package-json-windows.opam +++ /dev/null @@ -1,62 +0,0 @@ -# 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: "vscode-package-json" -version: "0.1.0" -license: "MIT" -synopsis: "The superbol-studio-oss project" -description: """\ -This is the description -of the superbol-studio-oss OCaml project -""" -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-vscode-platform" -doc: "https://ocamlpro.github.io/superbol-vscode-platform/sphinx" -bug-reports: "https://github.com/ocamlpro/superbol-vscode-platform/issues" -dev-repo: "git+https://github.com/ocamlpro/superbol-vscode-platform.git" -tags: "org:ocamlpro" -build: [ - ["dune" "subst"] {dev} - ["sh" "-c" "./scripts/before.sh build '%{name}%'"] - [ - "dune" - "build" - "-p" - "vscode-package-json" - "-x" - "windows" - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] - ["sh" "-c" "./scripts/after.sh build '%{name}%'"] -] -install: [ - ["sh" "-c" "./scripts/before.sh install '%{name}%'"] -] -depends: [ - "ocaml" {>= "4.14.0"} - "dune" {>= "2.8.0"} - "vscode-json-windows" {= version} - "ezjsonm-windows" {} - "ez_file-windows" {>= "0.3.0" & < "1.0.0"} - "ppx_deriving_encoding" {} - "ppx_inline_test" {with-test} - "ppx_expect" {with-test} - "odoc" {with-doc} - "ocamlformat" {with-test} -] -# Content of `opam-trailer` field: \ No newline at end of file diff --git a/src/lsp/cobol_ast/cobol_ast.ml b/src/lsp/cobol_ast/cobol_ast.ml index be858d119..2bde1d8b5 100644 --- a/src/lsp/cobol_ast/cobol_ast.ml +++ b/src/lsp/cobol_ast/cobol_ast.ml @@ -11,21 +11,17 @@ (* *) (**************************************************************************) -module Traversal = Traversal -module Helpers = Helpers - include Ast module Terms_visitor = Terms_visitor module Operands_visitor = Operands_visitor +module Terms_helpers = Terms_helpers + module Abstract = Abstract module Abstract_visitor = Abstract_visitor module Raw = Raw module Raw_visitor = Raw_visitor -(* module Raw_misc_sections_visitor = Raw_misc_sections_visitor *) -(* module Raw_data_sections_visitor = Raw_data_sections_visitor *) -(* module Raw_data_division_visitor = Raw_data_division_visitor *) -(* module Raw_proc_division_visitor = Raw_proc_division_visitor *) -(* module Raw_compilation_group_visitor = Raw_compilation_group_visitor *) + +module Testing_helpers = Testing_helpers diff --git a/src/lsp/cobol_ast/raw_data_sections_visitor.ml b/src/lsp/cobol_ast/raw_data_sections_visitor.ml index 7cf1c7241..e08ef10c1 100644 --- a/src/lsp/cobol_ast/raw_data_sections_visitor.ml +++ b/src/lsp/cobol_ast/raw_data_sections_visitor.ml @@ -18,7 +18,8 @@ open Cobol_common.Visitor.INFIX (* for `>>` (== `|>`) *) open Terms_visitor let todo x = Cobol_common.Visitor.todo __FILE__ x -let partial x = Cobol_common.Visitor.partial __FILE__ x +let partial modname line funcname = + Cobol_common.Visitor.partial __FILE__ modname line funcname (* --- *) @@ -85,7 +86,7 @@ struct end let todo x = todo __MODULE__ x - and partial x = partial __MODULE__ x + and partial line funcname = partial __MODULE__ line funcname let fold_data_level (v: _ #folder) = leaf v#fold_data_level diff --git a/src/lsp/cobol_ast/terms.ml b/src/lsp/cobol_ast/terms.ml index 2866721ce..79a38fff8 100644 --- a/src/lsp/cobol_ast/terms.ml +++ b/src/lsp/cobol_ast/terms.ml @@ -127,7 +127,7 @@ and qualname_or_alphanum = [qualname_|alnum_] term and qualname_or_intlit = [qualname_|int_] term and qualname_or_literal = [qualname_|lit_] term and strlit = strlit_ term -and strlit_or_intlit = [strlit_|int_] term (* strlit_or_intlit *) +and strlit_or_intlit = [strlit_|int_] term and binop = | BPlus @@ -149,15 +149,49 @@ and expression = | Unop of unop * expression | Binop of expression * binop * expression (* split arith/bool ? *) +(** Any form of condition {v c v} *) and _ cond = - (* TODO: group generalized expressions together (class, sign, omitted) *) - | Expr: expression -> [>simple_] cond (* exp (bool), ident (bool, cond, switch) *) - | Relation: expression * relop * expression -> [>simple_] cond (* general, bool, pointer *) - | ClassCond: expression * class_ -> [>simple_] cond (* exp = ident *) - | SignCond: expression * signz -> [>simple_] cond (* exp = arith exp *) - | Omitted: expression -> [>simple_] cond (* exp = ident *) - | Not: _ cond -> [>complex_] cond - | Logop: _ cond * logop * _ cond -> [>complex_] cond (* TODO: move logop left *) + | Expr: + expression -> [>simple_] cond (** expression used as a condition *) + | Relation: + binary_relation -> [>simple_] cond (** simple binary relation *) + | Abbrev: + abbrev_combined_relation -> [>simple_] cond (** abbreviated relation *) + | ClassCond: + expression * class_ -> [>simple_] cond (** class condition *) + | SignCond: + expression * signz -> [>simple_] cond (** {v e POSITIVE/NEGATIVE/ZERO v} *) + | Omitted: + expression -> [>simple_] cond (** {v c OMITTED v} *) + | Not: + _ cond -> [>complex_] cond (** {v NOT c v} *) + | Logop: + _ cond * logop * _ cond -> [>complex_] cond (** {v c c' v} *) + +and binary_relation = + expression * relop * expression (** {v e e' v} *) + +(** An abbreviated combined relation describes a non-parenthesized condition: + + - {v e e' v} if [not neg] holds (the + first item in the tuple); + + - {v NOT e e' v} otherwise. *) +and abbrev_combined_relation = + bool * binary_relation * logop * flat_combined_relation + +(** Suffix of non-parenthesized relational combined conditions ({v a v}) *) +and flat_combined_relation = + | FlatAmbiguous of + relop option * expression (** {v ? e v} *) + | FlatNotExpr of + expression (** {v NOT e v} *) + | FlatRel of + bool * binary_relation (** {v NOT? e e' v} *) + | FlatOther of + condition (** {v v} *) + | FlatComb of + (flat_combined_relation as 'x) * logop * 'x (** {v a' a'' v} *) and condition = [simple_|complex_] cond and simple_condition = simple_ cond @@ -591,10 +625,10 @@ module FMT = struct | Atom a -> pp_term ppf a | Unop (o, e) -> - fmt "@[<1>(%s@ %a)@]" ppf ([%derive.show: unop] o) pp_expression e + fmt "@[<1>(%a@ %a)@]" ppf pp_unop o pp_expression e | Binop (a, o, b) -> - fmt "@[<1>(%a@ %s@ %a)@]" ppf - pp_expression a ([%derive.show: binop] o) pp_expression b + fmt "@[<1>(%a@ %a@ %a)@]" ppf + pp_expression a pp_binop o pp_expression b and show_unop = function | UPlus -> "+" @@ -613,13 +647,20 @@ module FMT = struct | BXor -> "B-XOR" and pp_binop ppf o = string ppf (show_binop o) + and pp_binary_relation ppf (a, o, b) = + fmt "%a@ %a@ %a" ppf + pp_expression a pp_relop o pp_expression b + and pp_cond : type k. ?pos:_ -> k cond Pretty.printer = fun ?(pos = true) ppf -> function | Expr e -> fmt "%a%a" ppf not_ pos pp_expression e - | Relation (a, o, b) -> - fmt "@[<1>%a(%a@ %s@ %a)@]" ppf - not_ pos pp_expression a ([%derive.show: relop] o) pp_expression b + | Relation rel -> + fmt "%a@[<1>(%a)@]" ppf not_ pos pp_binary_relation rel + | Abbrev (neg, rel, o, comb) -> + fmt "%a@[<1>(%a%a@ %a@ %a)@]" ppf + not_ pos not_ (not neg) pp_binary_relation rel pp_logop o + pp_flat_combined_relation comb | ClassCond (e, c) -> fmt "%a@ %a%a" ppf pp_expression e not_ pos pp_class_ c | SignCond (e, s) -> @@ -631,6 +672,24 @@ module FMT = struct | Logop (a, o, b) -> fmt "@[<1>%a(%a@ %a@ %a)@]" ppf not_ pos (pp_cond ~pos:true) a pp_logop o (pp_cond ~pos:true) b + + and pp_flat_combined_relation ppf = function + | FlatAmbiguous (None, e) -> + pp_expression ppf e + | FlatAmbiguous (Some r, e) -> + fmt "%a@ %a" ppf pp_relop r pp_expression e + | FlatNotExpr e -> + fmt "NOT@ %a" ppf pp_expression e + | FlatRel (neg, rel) -> + fmt "%a%a" ppf not_ (not neg) pp_binary_relation rel + | FlatOther c -> + fmt "@[<1>(%a)@]" ppf pp_condition c + | FlatComb (c1, o, c2) -> + fmt "%a@ %a@ %a" ppf + pp_flat_combined_relation c1 + pp_logop o + pp_flat_combined_relation c2 + and pp_condition ppf = pp_cond ppf and not_ ppf = function false -> fmt "NOT@ " ppf | true -> () @@ -829,6 +888,7 @@ module UPCAST = struct let simple_cond: simple_condition -> condition = function | Expr _ as c -> c | Relation _ as c -> c + | Abbrev _ as c -> c | ClassCond _ as c -> c | SignCond _ as c -> c | Omitted _ as c -> c diff --git a/src/lsp/cobol_ast/terms_helpers.ml b/src/lsp/cobol_ast/terms_helpers.ml new file mode 100644 index 000000000..b258e90e4 --- /dev/null +++ b/src/lsp/cobol_ast/terms_helpers.ml @@ -0,0 +1,83 @@ +(**************************************************************************) +(* *) +(* 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 Terms + +let neg_simple_cond ~neg : simple_condition -> condition = + if not neg then UPCAST.simple_cond else fun c -> Not c +let neg_condition ~neg : condition -> condition = + if not neg then Fun.id else fun c -> Not c + +(** [expand_every_abbrev_cond cond] recursively substitutes every abbreviated + combined relation condition from [cond] by an equivalent non-abbreviated + condition (with abbreviated relations replaced with binary relations). *) +let rec expand_every_abbrev_cond + : type k. k cond -> _ cond = function + | Expr _ | Relation _ | ClassCond _ | SignCond _ | Omitted _ as c -> + c + | Abbrev a -> + expand_abbrev_cond a + | Not c -> + Not (expand_every_abbrev_cond c) + | Logop (c1, o, c2) -> + Logop (expand_every_abbrev_cond c1, o, expand_every_abbrev_cond c2) + +(** [expand_abbrev_cond abbrev_combined_relation], expands the non-parenthesized + relation condition encoded by [abbrev_combined_relation] ([= neg, + relation_condition, logop, flatop]). + + The result is an expression without any abbreviated combined relation + condition: {i [relation_condition] [logop] abbrev-combined-conditions} (or + {i NOT [relation_condition] [logop] abbrev-combined-conditions} if [neg] + holds), where [logop] and {i abbrev-combined-conditions} are given via + [logop], and [flatop]. *) +and expand_abbrev_cond: abbrev_combined_relation -> condition = + + let rec disambiguate ?cond_prefix flatop sr = + (* Recursively constructs a valid condition based on the non-parenthesized + relational combined condition [flatop], assuming [sr] is the most recent + subject and relation operator (when reading from the left of the + sentence, canceling out on non-relational conditions). + + If [cond_prefix] is given, places it with a conjunction at the + bottom-left of the result, i.e, substitutes the bottom-left node [c] with + [Logop (cond_prefix, LAnd, c)]. *) + let c, sr = match flatop, sr with + | FlatAmbiguous (Some rel, e), Some (subj, _) + | FlatAmbiguous (None, e), Some (subj, rel) -> + UPCAST.simple_cond @@ Relation (subj, rel, e), Some (subj, rel) + | FlatAmbiguous (_, e), None -> + Expr e, sr + | FlatNotExpr e, Some (subj, rel) -> + Not (UPCAST.simple_cond @@ Relation (subj, rel, e)), sr + | FlatNotExpr e, None -> + Not (UPCAST.simple_cond @@ Expr e), sr + | FlatRel (neg, (e1, rel, e2)), _ -> + neg_condition ~neg @@ Relation (e1, rel, e2), Some (e1, rel) + | FlatOther c, _ -> + expand_every_abbrev_cond c, None + | FlatComb (f1, logop, f2), sr -> + let c1, sr = disambiguate ?cond_prefix f1 sr in + let c2, sr = disambiguate f2 sr in + Logop (c1, logop, c2), sr + in + match flatop, cond_prefix with + | FlatComb _, _ | _, None -> c, sr + | _, Some c0 -> Logop (c0, LAnd, c), sr + in + + fun (neg, (e1, relop, e2), logop, flatop) -> + let c0 = neg_condition ~neg @@ Relation (e1, relop, e2) in + match logop with + | LOr -> Logop (c0, LOr, fst @@ disambiguate flatop (Some (e1, relop))) + | LAnd -> fst @@ disambiguate ~cond_prefix:c0 flatop (Some (e1, relop)) diff --git a/src/lsp/cobol_ast/terms_helpers.mli b/src/lsp/cobol_ast/terms_helpers.mli new file mode 100644 index 000000000..77128b499 --- /dev/null +++ b/src/lsp/cobol_ast/terms_helpers.mli @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* SuperBOL OSS Studio *) +(* *) +(* Copyright (c) 2022-2023 OCamlPro SAS *) +(* *) +(* All rights reserved. *) +(* This source code is licensed under the GNU Affero General Public *) +(* License version 3 found in the LICENSE.md file in the root directory *) +(* of this source tree. *) +(* *) +(**************************************************************************) + +(** Some utilities to construct or rewrite terms (mostly conditions for now) *) + +val neg_simple_cond: neg:bool -> Terms.simple_condition -> Terms.condition +val neg_condition: neg:bool -> Terms.condition -> Terms.condition + +val expand_every_abbrev_cond: 'k Terms.cond -> Terms.condition +val expand_abbrev_cond: Terms.abbrev_combined_relation -> Terms.condition diff --git a/src/lsp/cobol_ast/terms_visitor.ml b/src/lsp/cobol_ast/terms_visitor.ml index ba2f92b3b..d1ac66f5f 100644 --- a/src/lsp/cobol_ast/terms_visitor.ml +++ b/src/lsp/cobol_ast/terms_visitor.ml @@ -59,6 +59,7 @@ class ['a] folder = object method fold_class: (class_, 'a) fold = default method fold_cond: 'k. ('k cond, 'a) fold = default method fold_simple_cond: (simple_condition, 'a) fold = default + method fold_flat_combined_relation: (flat_combined_relation, 'a) fold = default method fold_logop: (logop, 'a) fold = default method fold_relop: (relop, 'a) fold = default method fold_rounding_mode: (rounding_mode, 'a) fold = default @@ -308,7 +309,8 @@ let fold_class (v: _ #folder) = let rec fold_cond: type k. _ #folder -> k cond -> _ = fun v -> handle v#fold_cond ~continue:begin fun (c: k cond) x -> match c with - | Expr _ | Omitted _ | Relation _ | ClassCond _ | SignCond _ as c -> x + | Expr _ | Omitted _ | Relation _ + | Abbrev _ | ClassCond _ | SignCond _ as c -> x >> fold_simple_cond v c | Not c -> x >> fold_cond v c @@ -323,10 +325,12 @@ and fold_simple_cond (v: _ #folder) = ~continue:begin fun c x -> match c with | Expr e | Omitted e -> x >> fold_expr v e - | Relation (e, r, f) -> x - >> fold_expr v e - >> fold_relop v r - >> fold_expr v f + | Relation rel -> x + >> fold_binary_relation v rel + | Abbrev (_n, rel, o, comb) -> x + >> fold_binary_relation v rel + >> fold_logop v o + >> fold_flat_combined_relation v comb | ClassCond (e, c) -> x >> fold_expr v e >> fold_class v c @@ -335,6 +339,30 @@ and fold_simple_cond (v: _ #folder) = >> fold_signz v s end +and fold_binary_relation (v: _ #folder) (e, r, f) x = x + >> fold_expr v e + >> fold_relop v r + >> fold_expr v f + +and fold_flat_combined_relation (v: _ #folder) = + handle v#fold_flat_combined_relation + ~continue:begin fun c x -> match c with + | FlatAmbiguous (r, e) -> x + >> fold_option ~fold:fold_relop v r + >> fold_expr v e + | FlatNotExpr e -> x + >> fold_expr v e + | FlatRel (neg, rel) -> x + >> fold_bool v neg + >> fold_binary_relation v rel + | FlatOther c -> x + >> fold_cond v c + | FlatComb (c1, o, c2) -> x + >> fold_flat_combined_relation v c1 + >> fold_logop v o + >> fold_flat_combined_relation v c2 + end + let fold_expression = fold_expr (* alias *) let fold_condition = fold_cond (* alias *) diff --git a/src/lsp/cobol_ast/helpers.ml b/src/lsp/cobol_ast/testing_helpers.ml similarity index 100% rename from src/lsp/cobol_ast/helpers.ml rename to src/lsp/cobol_ast/testing_helpers.ml diff --git a/src/lsp/cobol_common/visitor.ml b/src/lsp/cobol_common/visitor.ml index 3f335bbe0..0f285ce2e 100644 --- a/src/lsp/cobol_common/visitor.ml +++ b/src/lsp/cobol_common/visitor.ml @@ -57,6 +57,8 @@ module INFIX = struct end open INFIX +let in_testsuite = ref false + let report = (* to be kept until visitors are complete *) let module REPORTED = Hashtbl.Make (struct @@ -68,6 +70,9 @@ let report = (* to be kept until visitors are complete *) let reported_table = lazy (REPORTED.create 17) in fun k file_name module_name line_num func_name -> let tbl = Lazy.force reported_table in + let file_name = + if !in_testsuite then Filename.basename file_name else file_name in + let line_num = if !in_testsuite then 0 else line_num in if not (REPORTED.mem tbl (file_name, module_name, line_num, func_name)) then begin Pretty.error "@[<2>%s:%u:@ (%s.%s):@ %s@ visitor@ implementation@]@." diff --git a/src/lsp/cobol_parser/cobol_parser.ml b/src/lsp/cobol_parser/cobol_parser.ml index f1ed7d7ea..4ed6d1d10 100644 --- a/src/lsp/cobol_parser/cobol_parser.ml +++ b/src/lsp/cobol_parser/cobol_parser.ml @@ -65,7 +65,7 @@ module INTERNAL = struct (** {2 Parser with dummy source locations, that can be fed directly with a list of tokens} *) module Dummy = struct - module Tags: Cobol_ast.Helpers.TAGS = struct + module Tags: Cobol_ast.Testing_helpers.TAGS = struct let loc = Cobol_common.Srcloc.raw Lexing.(dummy_pos, dummy_pos) end diff --git a/src/lsp/cobol_parser/grammar.mly b/src/lsp/cobol_parser/grammar.mly index 4d74fa0ab..b75066c62 100644 --- a/src/lsp/cobol_parser/grammar.mly +++ b/src/lsp/cobol_parser/grammar.mly @@ -14,6 +14,7 @@ open PTree open Grammar_utils open Cobol_ast +open Cobol_ast.Terms_helpers open Cobol_common.Srcloc.INFIX let split_last l = @@ -2463,21 +2464,21 @@ complex_condition: | OR { LOr } %inline flat_relation_condition: - | n = ibo(NOT) c = relation_condition - suff = io (pair (logop, flat_combination_operand)) - { expand_relation_condition n c suff } + | neg = ibo(NOT) c = relation_condition + suff = io (pair (logop, flat_combination_operand)) + { relation_condition ~neg c suff } nonrel_condition: - | n = ibo(NOT) e = expression %prec lowest { neg_cond n @@ Expr e } - | n = ibo(NOT) c = extended_condition { neg_cond' n c } - | n = ibo(NOT) "(" c = complex_condition ")" { neg_cond' n c } + | n = ibo(NOT) e = expression %prec lowest { neg_simple_cond ~neg:n @@ Expr e } + | n = ibo(NOT) c = extended_condition { neg_condition ~neg:n c } + | n = ibo(NOT) "(" c = complex_condition ")" { neg_condition ~neg:n c } flat_combination_operand: | r = io(relop) e = expression { FlatAmbiguous (r, e) } | NOT e = expression { FlatNotExpr e } | n = ibo(NOT) c = relation_condition { FlatRel (n, c) } - | n = ibo(NOT) c = extended_condition { FlatOther (neg_cond' n c) } - | n = ibo(NOT) "(" c = complex_condition ")" { FlatOther (neg_cond' n c) } + | n = ibo(NOT) c = extended_condition { FlatOther (neg_condition ~neg:n c) } + | n = ibo(NOT) "(" c = complex_condition ")" { FlatOther (neg_condition ~neg:n c) } | flat_combination_operand logop flat_combination_operand { FlatComb ($1, $2, $3) } @@ -2486,11 +2487,11 @@ relation_condition: extended_condition: | e = expression io(IS) n = bo(NOT) c = class_condition - { neg_cond n @@ ClassCond (e, c) } (* exp = ident *) + { neg_simple_cond ~neg:n @@ ClassCond (e, c) } (* exp = ident *) | e = expression io(IS) n = bo(NOT) s = sign_condition - { neg_cond n @@ SignCond (e, s) } (* exp = arith exp *) + { neg_simple_cond ~neg:n @@ SignCond (e, s) } (* exp = arith exp *) | e = expression io(IS) n = bo(NOT) OMITTED - { neg_cond n @@ Omitted e } (* exp = ident *) + { neg_simple_cond ~neg:n @@ Omitted e } (* exp = ident *) relop [@recovery Eq] [@symbol ""]: | io(IS) n = ibo(NOT) GREATER THAN? diff --git a/src/lsp/cobol_parser/grammar_utils.ml b/src/lsp/cobol_parser/grammar_utils.ml index 8a9ed0e55..4b2cacfb9 100644 --- a/src/lsp/cobol_parser/grammar_utils.ml +++ b/src/lsp/cobol_parser/grammar_utils.ml @@ -22,69 +22,10 @@ module Overlay_manager = let name = __MODULE__ end) -let neg_cond neg : simple_condition -> condition = - if not neg then UPCAST.simple_cond else fun c -> Not c -and neg_cond' neg : condition -> condition = - if not neg then Fun.id else fun c -> Not c - -(** Suffix of non-parenthesized relational combined conditions, to decypher - abbreviations *) -type flat_combination_operand = - | FlatAmbiguous of relop option * expression (* relop? e *) - | FlatNotExpr of expression (* NOT e *) - | FlatRel of bool * (expression * relop * expression) (* NOT? rel *) - | FlatOther of condition (* extended- or parenthesized condition *) - | FlatComb of (flat_combination_operand as 'x) * logop * 'x (* _ AND/OR _ *) - -(** [expand_relation_condition neg relation_condition logop_n_flatop] expands - the non-parenthesized relation condition encoded by: - - - {i [relation_condition]} (or {i NOT [relation_condition]} if [neg] holds) - if [logop_n_flatop] is [None]; - - - {i [relation_condition] [logop] abbrev-combined-conditions} (or {i NOT - [relation_condition] [logop] abbrev-combined-conditions} if [neg] holds), - where [logop] and {i abbrev-combined-conditions} are given via - [logop_n_flatop]. *) -let expand_relation_condition = - let rec disambiguate ?cond_prefix flatop sr = - (* Recursively constructs a valid condition based on the non-parenthesized - relational combined condition [flatop], assuming [sr] is the most recent - subject and relation operator (when reading from the left of the - sentence, canceling out on non-relational conditions). - - If [cond_prefix] is given, places it with a conjunction at the - bottom-left of the result, i.e, substitutes the bottom-left node [c] with - [Logop (cond_prefix, LAnd, c)]. *) - let c, sr = match flatop, sr with - | FlatAmbiguous (Some rel, e), Some (subj, _) - | FlatAmbiguous (None, e), Some (subj, rel) -> - UPCAST.simple_cond @@ Relation (subj, rel, e), Some (subj, rel) - | FlatAmbiguous (_, e), None -> - Expr e, sr - | FlatNotExpr e, Some (subj, rel) -> - Not (UPCAST.simple_cond @@ Relation (subj, rel, e)), sr - | FlatNotExpr e, None -> - Not (UPCAST.simple_cond @@ Expr e), sr - | FlatRel (neg, (e1, rel, e2)), _ -> - neg_cond' neg @@ Relation (e1, rel, e2), Some (e1, rel) - | FlatOther c, _ -> - c, None - | FlatComb (f1, logop, f2), sr -> - let c1, sr = disambiguate ?cond_prefix f1 sr in - let c2, sr = disambiguate f2 sr in - Logop (c1, logop, c2), sr - in - match flatop, cond_prefix with - | FlatComb _, _ | _, None -> c, sr - | _, Some c0 -> Logop (c0, LAnd, c), sr - in - fun neg (e1, relop, e2) -> - let c0 = neg_cond' neg @@ Relation (e1, relop, e2) in - function +let relation_condition ~neg (binrel: binary_relation) = function | None -> - c0 + Cobol_ast.Terms_helpers.neg_condition ~neg @@ Relation binrel | Some (LOr, flatop) -> - Logop (c0, LOr, fst @@ disambiguate flatop (Some (e1, relop))) + Abbrev (neg, binrel, LOr, flatop) | Some (LAnd, flatop) -> - fst @@ disambiguate ~cond_prefix:c0 flatop (Some (e1, relop)) + Abbrev (neg, binrel, LAnd, flatop) diff --git a/src/lsp/cobol_parser/grammar_utils.mli b/src/lsp/cobol_parser/grammar_utils.mli index e6a47788a..b907e893d 100644 --- a/src/lsp/cobol_parser/grammar_utils.mli +++ b/src/lsp/cobol_parser/grammar_utils.mli @@ -11,34 +11,10 @@ (* *) (**************************************************************************) -open Cobol_ast - module Overlay_manager: Cobol_preproc.Src_overlay.MANAGER -val neg_cond: bool -> simple_condition -> condition -val neg_cond': bool -> condition -> condition - -(** Suffix of non-parenthesized relational combined conditions, to decypher - abbreviations *) -type flat_combination_operand = - | FlatAmbiguous of relop option * expression (* relop? e *) - | FlatNotExpr of expression (* NOT e *) - | FlatRel of bool * (expression * relop * expression) (* NOT? rel *) - | FlatOther of condition (* extended- or parenthesized condition *) - | FlatComb of (flat_combination_operand as 'x) * logop * 'x (* _ AND/OR _ *) - -(** [expand_relation_condition neg relation_condition logop_n_flatop] expands - the non-parenthesized relation condition encoded by: - - - {i [relation_condition]} (or {i NOT [relation_condition]} if [neg] holds) - if [logop_n_flatop] is [None]; - - - {i [relation_condition] [logop] abbrev-combined-conditions} (or {i NOT - [relation_condition] [logop] abbrev-combined-conditions} if [neg] holds), - where [logop] and {i abbrev-combined-conditions} are given via - [logop_n_flatop]. *) -val expand_relation_condition - : bool - -> expression * relop * expression - -> (logop * flat_combination_operand) option - -> condition +val relation_condition + : neg: bool + -> Cobol_ast.binary_relation + -> (Cobol_ast.logop * Cobol_ast.flat_combined_relation) option + -> Cobol_ast.condition diff --git a/src/lsp/superbol_free_lib/command_json_package.ml b/src/lsp/superbol_free_lib/command_json_package.ml new file mode 100644 index 000000000..9fe9408cf --- /dev/null +++ b/src/lsp/superbol_free_lib/command_json_package.ml @@ -0,0 +1,116 @@ +(**************************************************************************) +(* *) +(* 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 Ezcmd.V2 +open EZCMD.TYPES + +let print_result f file = + match f file with + | exception exn -> + Printf.eprintf "File %s: exception %s\n%!" file + ( Printexc.to_string exn) + | [], [] -> + Printf.eprintf "File %s checked OK\n%!" file + | warnings, [] -> + Printf.eprintf "Warnings found in file %s but OK\n%!" file; + List.iter (fun s -> Printf.eprintf " %s\n%!" s) warnings + | warnings, errors -> + Printf.eprintf "Errors found in file %s:\n%!" file; + List.iter (fun s -> Printf.eprintf " %s\n%!" s) errors; + match warnings with + | [] -> () + | _ -> + Printf.eprintf " Warnings also found\n%!"; + List.iter (fun s -> Printf.eprintf " %s\n%!" s) warnings + +type kind = + | MANIFEST + | TASKS + | SNIPPET + | GRAMMAR + | LANGUAGE + +let cmd = + let generate = ref None in + let kind = ref MANIFEST in + let files = ref [] in + let parse file = + print_result + (match !kind with + | TASKS -> + Vscode_json.Main.check_file + Vscode_json.Tasks.encoding + Vscode_json.Tasks.pp + | SNIPPET -> + Vscode_json.Main.check_file + Vscode_json.Snippets.snippets_enc + Vscode_json.Snippets.pp_snippets + | GRAMMAR -> + Vscode_json.Main.check_file + Vscode_json.Grammar.grammar_enc + Vscode_json.Grammar.pp_grammar + | LANGUAGE -> + Vscode_json.Main.check_file + Vscode_json.Language.language_enc + Vscode_json.Language.pp_language + | MANIFEST -> + Vscode_json.Main.check_project ~verbose:(!Globals.verbosity>1) + ) file + in + EZCMD.sub + "json vscode" + (fun () -> + match !generate, !files with + | None, [] -> + Printf.eprintf "Use either --gen TARGET, or provide files to read\n%!"; + exit 2 + | None, files -> + List.iter parse files + | Some file, [] -> + Vscode_json.Main.write_file file + Vscode_json.Manifest.vscode_enc Project.manifest + | Some _, _ -> + Printf.eprintf + "Actions --gen TARGET and parse files are exclusive\n%!"; + exit 2 + ) + ~args: ([ + [ "tasks" ], Arg.Unit (fun () -> kind := TASKS), + EZCMD.info "Parse files as .vscode/tasks.json files"; + + [ "snippets" ], Arg.Unit (fun () -> kind := SNIPPET), + EZCMD.info "Parse files as snippets/*.json files"; + + [ "grammar" ], Arg.Unit (fun () -> kind := GRAMMAR), + EZCMD.info "Parse files as syntaxes/*.json files"; + + [ "language" ], Arg.Unit (fun () -> kind := LANGUAGE), + EZCMD.info "Parse files as language/configuration *.json files"; + + [ "manifest" ], Arg.Unit (fun () -> kind := MANIFEST), + EZCMD.info "Parse files as package.json files"; + + [ "gen" ], Arg.String (fun s -> generate := Some s), + EZCMD.info ~docv:"FILE" "Generate FILE from current configuration"; + + [], Arg.Anons (fun list -> files := list), + EZCMD.info ~docv:"FILES" "JSON Files to parse"; + ]) + ~doc: + "parse VSODE JSON files or generate package.json" + ~man:[ + `S "DESCRIPTION"; + `Blocks [ + `P "" + ]; + ] diff --git a/src/lsp/superbol_free_lib/command_texi2rst.ml b/src/lsp/superbol_free_lib/command_texi2rst.ml index 64f63d68f..00208d612 100644 --- a/src/lsp/superbol_free_lib/command_texi2rst.ml +++ b/src/lsp/superbol_free_lib/command_texi2rst.ml @@ -91,16 +91,16 @@ end type line = inline list and inline = - | S of string - | M of LOCATION.t * string * line - | Q of line - + | STRING of string + | MACRO of LOCATION.t * string * line + | QUOTE of line type blocks = block list and block = EMPTY_LINE | LINE of line + | NODE of string | BLOCK of string * blocks | LEVEL of int * string option * line * blocks | ITEMS of string * string * ( line * blocks ) list @@ -118,10 +118,10 @@ type document = { let rec string_of_line line = String.concat "" (List.map (function - | S s -> s - | Q arg -> + | STRING s -> s + | QUOTE arg -> Printf.sprintf "@QUOTE[%s]" ( string_of_line arg ) - | M (_loc, macro, arg) -> + | MACRO (_loc, macro, arg) -> Printf.sprintf "@@%s{{%s}}" macro ( string_of_line arg )) line) @@ -159,7 +159,7 @@ type closer = | BRACE | QUOTE -let read filename = +let read ~path filename = let file = Filename.basename filename in let dirname = Filename.dirname filename in @@ -172,7 +172,7 @@ let read filename = let maybe b = let s = Buffer.contents b in Buffer.clear b; - if s = "" then [] else [ S s ] + if s = "" then [] else [ STRING s ] in let parse_line ic line = let len = String.length line in @@ -187,49 +187,52 @@ let read filename = else match line.[i] with | '}' -> - if braced <> BRACE then - INPUT.error ~ic "unbalanced closing brace" ; - i+1, maybe b + if braced <> BRACE then + INPUT.error ~ic "unbalanced closing brace" ; + i+1, maybe b | '@' -> - let i = i+1 in - if i = len then - if braced <> EOL then - INPUT.error ~ic "unexpected end of line" - else - len, maybe b + let i = i+1 in + if i = len then + if braced <> EOL then + INPUT.error ~ic "unexpected end of line" else - begin - let c = line.[i] in - match c with - | '{' | '}' | '@' | '.' | '!' | '?' -> - Buffer.add_char b c ; - iter (i+1) braced - | '\n' -> - iter (i+1) braced - | '*' -> - let before = maybe b in - let i, line = iter (i+1) braced in - i, before @ M (INPUT.loc ic, "linebreak", []) :: line - | _ -> - let before = maybe b in - let i, line = iter_macro i i braced in - i, before @ line - end + len, maybe b + else + begin + let c = line.[i] in + match c with + | '{' | '}' | '@' | '.' | '!' | '?' -> + Buffer.add_char b c ; + iter (i+1) braced + | '\n' -> + iter (i+1) braced + | '*' -> + let before = maybe b in + let i, line = iter (i+1) braced in + i, before @ MACRO (INPUT.loc ic, "linebreak", []) :: line + | _ -> + let before = maybe b in + let i, line = iter_macro i i braced in + i, before @ line + end | '`' when i+1 < len && line.[i+1] = '`' -> - let before = maybe b in - let i = i+2 in - let i, quoted = iter i QUOTE in - let i, line = iter i braced in - i, before @ Q quoted :: line + let before = maybe b in + let i = i+2 in + let i, quoted = iter i QUOTE in + let i, line = iter i braced in + i, before @ QUOTE quoted :: line | '\'' when i+1 < len && line.[i+1] = '\'' -> - if braced <> QUOTE then - INPUT.error ~ic "unbalanced ending quote"; + if braced <> QUOTE then begin + (* INPUT.error ~ic "unbalanced ending quote"; *) + Buffer.add_string b "''"; + iter (i+2) braced + end else let before = maybe b in let i = i+2 in i, before | c -> - Buffer.add_char b c ; - iter (i+1) braced + Buffer.add_char b c ; + iter (i+1) braced and iter_macro i pos0 braced = if i = len then @@ -237,30 +240,30 @@ let read filename = INPUT.error ~ic "unexpected end of line" else let macro = String.sub line pos0 (i-pos0) in - len, [ M (INPUT.loc ic, macro, []) ] + len, [ MACRO (INPUT.loc ic, macro, []) ] else match line.[i] with | '{' -> - let macro = String.sub line pos0 (i-pos0) in - let i, arg = iter (i+1) BRACE in - let i, line = iter i braced in - i, begin - match macro with - | "value" -> - let arg = string_of_line arg in - begin - match StringMap.find arg !map with - | s -> S s :: line - | exception Not_found -> - INPUT.error ~ic "Unknown variable %S" arg - end - | _ -> M (INPUT.loc ic, macro, arg) :: line - end + let macro = String.sub line pos0 (i-pos0) in + let i, arg = iter (i+1) BRACE in + let i, line = iter i braced in + i, begin + match macro with + | "value" -> + let arg = string_of_line arg in + begin + match StringMap.find arg !map with + | s -> STRING s :: line + | exception Not_found -> + INPUT.error ~ic "Unknown variable %S" arg + end + | _ -> MACRO (INPUT.loc ic, macro, arg) :: line + end | ' ' | '\t' -> - let macro = String.sub line pos0 (i-pos0) in - let i, line = iter (i+1) braced in - i, M (INPUT.loc ic, macro, []) :: line + let macro = String.sub line pos0 (i-pos0) in + let i, line = iter (i+1) braced in + i, MACRO (INPUT.loc ic, macro, []) :: line | _ -> iter_macro (i+1) pos0 braced in @@ -283,221 +286,249 @@ let read filename = Some number, title in - let rec iter_file file rev stack = - let filename = Filename.concat dirname file in + let find_file ?ic file = + + let rec find_in_path path file = + match path with + | [] -> + INPUT.error ?ic "Could not find file %S" file + | dir :: path -> + let filename = Filename.concat dir file in + if Sys.file_exists filename then + filename + else + find_in_path path file + in + find_in_path ( dirname :: path) file + in + let rec iter_file ?ic file rev stack = + let filename = find_file ?ic file in Printf.eprintf "Reading %S\n%!" filename; - let ic = INPUT.open_in filename in - iter_lines ic rev stack + match INPUT.open_in filename with + | ic -> iter_lines ic rev stack and iter_lines ic rev stack = match INPUT.input_line ic with | exception _ -> - INPUT.close_in ic; - rev, stack + INPUT.close_in ic; + rev, stack | line -> - let command, arg = split_command line in - match command with - - (* Discard these lines *) - | "@paragraphindent" - | "@sp" - | "@c" - | "@top" - | "@settitle" - | "\\input" - | "@page" - | "@unnumbered" - | "@printindex" - | "@bye" - | "@headings" - | "@oddheading" - | "@oddfooting" - | "@evenheading" - | "@evenfooting" - | "@validatemenus" - | "@node" - | "@contents" - | "@comment" - | "@comment*" - | "@setfilename" - | "@finalout" - | "@setchapternewpage" - | "@dircategory" - | "@*Document" - | "@*Updates:" - | "@vskip" - | "@insertcopying" - -> - iter_lines ic rev stack - - | "@cindex" -> - iter_lines ic (INDEX arg :: rev) stack - | "@set" -> - let name, value = EzString.cut_at arg ' ' in - map := StringMap.add name value !map; - iter_lines ic rev stack - | "@title" -> - title := Some ( parse_line ic arg ) ; - iter_lines ic rev stack - | "@subtitle" -> - subtitle := Some ( parse_line ic arg ) ; - iter_lines ic rev stack ; - | "@author" -> - authors := ( parse_line ic arg ) :: !authors ; - iter_lines ic rev stack - | "@include" -> - let rev, stack = - if arg = "Macros.texi" then rev, stack else - iter_file arg rev stack in - iter_lines ic rev stack - - | "@end" -> - iter_end ic rev stack arg - | "@enddict" -> - iter_end ic rev stack "table" - - | "@float" - | "@format" - | "@smallformat" - | "@cartouche" - | "@ifhtml" - | "@html" - | "@display" - | "@group" - | "@raggedright" - | "@example" - | "@smallexample" - | "@ifinfo" - | "@iftex" - | "@ifnottex" - | "@titlepage" - | "@quotation" - | "@direntry" - | "@copying" - | "@detailmenu" - | "@menu" - -> - let name = String.sub command 1 ( String.length command - 1 ) in - iter_lines ic [] ( ( name, RawBlock, rev ) :: stack ) - - | "@verbatim" - | "@tex" - -> - let name = String.sub command 1 ( String.length command - 1 ) in - let rec verbatim ic rev = - match INPUT.input_line ic with - | exception _ -> - INPUT.close_in ic; - INPUT.error ~ic "unclosed verbatim block" - | "@end verbatim" - | "@end tex" - -> List.rev rev - | line -> - verbatim ic ( LINE [S line] :: rev ) + let command, arg = split_command line in + match command with + + (* Discard these lines *) + | "@paragraphindent" + | "@sp" + | "@c" + | "@top" + | "@settitle" + | "\\input" + | "@page" + | "@unnumbered" + | "@printindex" + | "@bye" + | "@headings" + | "@oddheading" + | "@oddfooting" + | "@evenheading" + | "@evenfooting" + | "@validatemenus" + | "@contents" + | "@comment" + | "@comment*" + | "@setfilename" + | "@finalout" + | "@setchapternewpage" + | "@dircategory" + | "@*Document" + | "@*Updates:" + | "@vskip" + | "@insertcopying" + | "@exampleindent" + -> + iter_lines ic rev stack + + | "@node" -> + let arg, _ = EzString.cut_at arg ',' in + iter_lines ic (NODE arg :: rev) stack + | "@cindex" -> + iter_lines ic (INDEX arg :: rev) stack + | "@set" -> + let name, value = EzString.cut_at arg ' ' in + map := StringMap.add name value !map; + iter_lines ic rev stack + | "@title" -> + title := Some ( parse_line ic arg ) ; + iter_lines ic rev stack + | "@subtitle" -> + subtitle := Some ( parse_line ic arg ) ; + iter_lines ic rev stack ; + | "@author" -> + authors := ( parse_line ic arg ) :: !authors ; + iter_lines ic rev stack + | "@include" -> + let rev, stack = + if arg = "Macros.texi" then rev, stack else + iter_file ~ic arg rev stack in + iter_lines ic rev stack + + | "@verbatiminclude" -> + let lines = EzFile.read_lines_to_list (find_file ~ic arg) in + let lines = List.map (fun line -> LINE [STRING line]) lines in + iter_lines ic ( BLOCK("verbatim", lines ) :: rev ) stack + + | "@end" -> + iter_end ic rev stack arg + | "@enddict" -> + iter_end ic rev stack "table" + + | "@float" + | "@format" + | "@smallformat" + | "@cartouche" + | "@ifhtml" + | "@html" + | "@display" + | "@group" + | "@raggedright" + | "@example" + | "@smallexample" + | "@ifinfo" + | "@iftex" + | "@ifnottex" + | "@titlepage" + | "@quotation" + | "@direntry" + | "@copying" + | "@ignore" + | "@detailmenu" + | "@menu" + -> + let name = String.sub command 1 ( String.length command - 1 ) in + iter_lines ic [] ( ( name, RawBlock, rev ) :: stack ) + + | "@verbatim" + | "@tex" + -> + let name = String.sub command 1 ( String.length command - 1 ) in + let rec verbatim ic rev = + match INPUT.input_line ic with + | exception _ -> + INPUT.close_in ic; + INPUT.error ~ic "unclosed verbatim block" + | "@end verbatim" + | "@end tex" + -> List.rev rev + | line -> + verbatim ic ( LINE [STRING line] :: rev ) + in + (* TODO: because we don't interprete these lines, there are @w{} inside. *) + let verbatim = verbatim ic [] in + iter_lines ic ( BLOCK (name, verbatim) :: rev ) stack + + | "@multitable" + | "@table" + | "@vtable" + | "@itemize" + | "@enumerate" + -> + let name = String.sub command 1 ( String.length command - 1 ) in + iter_lines ic [] ( ( name, Items (arg, None, []), rev ) :: stack ) + + | "@headitem" (* TODO: for multitable *) + | "@item" + | "@itemx" (* TODO Must improve *) + (* TODO: ~~~~~~~~~~ in diagrams are removed by rst *) + -> + let arg = parse_line ic arg in + let stack = end_item ic rev stack (Some arg) in + iter_lines ic [] stack + + | "@chapter" + | "@newchapter" -> + iter_section ic rev stack 1 arg + | "@appendix" + | "@newappendix" -> + iter_section ic rev stack 1 arg + | "@newsection" + | "@section" -> + iter_section ic rev stack 2 arg + | "@subsection" + | "@newsubsection" -> + iter_section ic rev stack 3 arg + | "@newunit" + | "@subsubsection" -> + iter_section ic rev stack 4 arg + + | "@diagram" -> + let len = String.length arg in + if len < 3 || + arg.[0] <> '{' || arg.[len-1] <> '}' then + INPUT.error ~ic "invalid argument for @diagram"; + let arg = String.sub arg 1 (len-2) in + begin + match List.map String.trim @@ EzString.split arg ',' with + | [ title ; id1 ; id2 ; note ] -> + + if id1 <> id2 then + INPUT.warning ic "diagram with %s <> %s\n%!" + id1 id2; + + let lines = EzFile.read_lines_to_list + ( dirname // + Printf.sprintf "SYN-%s.texi" id1) in + let block = + DIAGRAM (title, List.map (fun s -> LINE [ STRING s]) lines) in - (* TODO: because we don't interprete these lines, there are @w{} inside. *) - let verbatim = verbatim ic [] in - iter_lines ic ( BLOCK (name, verbatim) :: rev ) stack - - | "@multitable" - | "@table" - | "@itemize" - | "@enumerate" - -> - let name = String.sub command 1 ( String.length command - 1 ) in - iter_lines ic [] ( ( name, Items (arg, None, []), rev ) :: stack ) - - | "@headitem" (* TODO: for multitable *) - | "@item" - | "@itemx" (* TODO Must improve *) - (* TODO: ~~~~~~~~~~ in diagrams are removed by rst *) - -> - let arg = parse_line ic arg in - let stack = end_item ic rev stack (Some arg) in - iter_lines ic [] stack - - | "@newchapter" -> - iter_section ic rev stack 1 arg - | "@newappendix" -> - iter_section ic rev stack 1 arg - | "@section" -> - iter_section ic rev stack 2 arg - | "@newsection" -> - iter_section ic rev stack 2 arg - | "@newsubsection" -> - iter_section ic rev stack 3 arg - | "@newunit" -> - iter_section ic rev stack 4 arg - - | "@diagram" -> - let len = String.length arg in - if len < 3 || - arg.[0] <> '{' || arg.[len-1] <> '}' then - INPUT.error ~ic "invalid argument for @diagram"; - let arg = String.sub arg 1 (len-2) in - begin - match List.map String.trim @@ EzString.split arg ',' with - | [ title ; id1 ; id2 ; note ] -> - - if id1 <> id2 then - INPUT.warning ic "diagram with %s <> %s\n%!" - id1 id2; - - let lines = EzFile.read_lines_to_list - ( dirname // - Printf.sprintf "SYN-%s.texi" id1) in - let block = - DIAGRAM (title, List.map (fun s -> LINE [ S s]) lines) - in - let note = - if note = "None" then [] - else - - let rev, _stack = - iter_file (Printf.sprintf "NOTE-%s.texi" note) [] [] - in - rev - in - iter_lines ic ( note @ block :: rev ) stack - | _ -> - INPUT.error ~ic "invalid arguments for @diagram"; - end + let note = + if note = "None" then [] + else - | _ -> - if line = "" then - iter_lines ic ( EMPTY_LINE :: rev ) stack - else - let line = parse_line ic line in - iter_lines ic ( LINE line :: rev ) stack + let rev, _stack = + iter_file ~ic (Printf.sprintf "NOTE-%s.texi" note) [] [] + in + rev + in + iter_lines ic ( note @ block :: rev ) stack + | _ -> + INPUT.error ~ic "invalid arguments for @diagram"; + end + + | _ -> + if line = "" then + iter_lines ic ( EMPTY_LINE :: rev ) stack + else + let line = parse_line ic line in + iter_lines ic ( LINE line :: rev ) stack and end_item ic rev stack item_arg = match stack with | [] -> - INPUT.error ~ic "@end/@item with empty stack" + INPUT.error ~ic "@end/@item with empty stack" | (name, Items (header, item_arg_before, items), rev_before) :: stack_before -> - let middle = - match item_arg_before, rev with - | None, rev -> - if not ( List.for_all (fun line -> - match line with - | EMPTY_LINE -> true - | _ -> false) rev) then - let items = - ( [], List.rev rev ) :: items - in - Items (header, item_arg, items) - else - Items (header, item_arg, items) - | Some item_arg_before, _ -> - let items = - ( item_arg_before, List.rev rev ) :: items - in - Items (header, item_arg, items) - in - (name, middle, rev_before) :: stack_before + let middle = + match item_arg_before, rev with + | None, rev -> + if not ( List.for_all (fun line -> + match line with + | EMPTY_LINE -> true + | _ -> false) rev) then + let items = + ( [], List.rev rev ) :: items + in + Items (header, item_arg, items) + else + Items (header, item_arg, items) + | Some item_arg_before, _ -> + let items = + ( item_arg_before, List.rev rev ) :: items + in + Items (header, item_arg, items) + in + (name, middle, rev_before) :: stack_before | (name, _, _) :: _ -> - INPUT.error ~ic "@item in %S block" name + INPUT.error ~ic "@item in %S block" name and iter_section ic rev stack level arg = let rev, stack = end_section ~ic rev stack level in @@ -507,62 +538,64 @@ let read filename = and end_section ?ic rev stack level = match stack with | [] -> - if level > 1 then - INPUT.error ?ic "[sub]section at topelevel"; - rev, stack + if level > 1 then + INPUT.error ?ic "[sub]section at toplevel"; + rev, stack | ("section", Level (level_before, number, title), rev_before ) :: stack_before -> - if level_before >= level then - let item = LEVEL (level_before, number, title, List.rev rev) in - let rev = item :: rev_before in - end_section rev stack_before level - else - rev, stack + if level_before >= level then + let item = LEVEL (level_before, number, title, List.rev rev) in + let rev = item :: rev_before in + end_section rev stack_before level + else + rev, stack | (name, _, _) :: _ -> - INPUT.error ?ic "missing @end %s\n%!" name + INPUT.error ?ic "missing @end %s\n%!" name and iter_end ic rev stack arg = let rev, stack = match arg with | "table" + | "vtable" | "multitable" | "enumerate" | "itemize" -> - [], end_item ic rev stack None + [], end_item ic rev stack None | _ -> rev, stack in begin match stack with | [] -> - INPUT.error ~ic "@end %s with empty stack" arg + INPUT.error ~ic "@end %s with empty stack" arg | ( name, content, rev_before ) :: stack_before -> - if name <> arg then - INPUT.error ~ic "@end %s but %S expected\n%!" - arg name ; - let rev = match name with - - | "iftex" - | "ifhtml" - | "titlepage" - | "direntry" - | "menu" - -> rev_before - - | "multitable" - | "table" - | "enumerate" - | "itemize" - -> - begin - match content with - | Items (header, None, items) -> - ITEMS ( name, header, List.rev items) :: rev_before - | _ -> assert false - end - - | _ -> BLOCK ( name, List.rev rev ) :: rev_before - in - iter_lines ic rev stack_before + if name <> arg then + INPUT.error ~ic "@end %s but %S expected\n%!" + arg name ; + let rev = match name with + + | "iftex" + | "ifhtml" + | "titlepage" + | "direntry" + | "menu" + -> rev_before + + | "multitable" + | "table" + | "vtable" + | "enumerate" + | "itemize" + -> + begin + match content with + | Items (header, None, items) -> + ITEMS ( name, header, List.rev items) :: rev_before + | _ -> assert false + end + + | _ -> BLOCK ( name, List.rev rev ) :: rev_before + in + iter_lines ic rev stack_before end @@ -591,6 +624,8 @@ let print_blocks oc doc = begin match item with | EMPTY_LINE -> Printf.fprintf oc "%sEMPTY_LINE\n" (spaces indent) + | NODE index -> + Printf.fprintf oc "%sNODE %s\n" (spaces indent) index | INDEX index -> Printf.fprintf oc "%sINDEX %s\n" (spaces indent) index | LINE line -> @@ -766,7 +801,7 @@ let rst_trim s = let rec rst_of_line ctx line = String.concat "" @@ List.map (function - | S s -> + | STRING s -> begin match ctx.math, ctx.verbatim with | true :: _, _ @@ -774,15 +809,16 @@ let rec rst_of_line ctx line = | _ -> rst_escape s end - | Q q -> Printf.sprintf "\"%s\"" ( rst_of_line ctx q ) + | QUOTE q -> Printf.sprintf "\"%s\"" ( rst_of_line ctx q ) - | M ( loc, name, arg) -> + | MACRO ( loc, name, arg) -> match name with | "_" -> rst_of_line ctx arg (****** texinfo generic macros *) + | "`" -> if List.hd ctx.verbatim = LiteralBlock then "`" else "\\`" | "TeX" -> "TeX" | "w" -> "" | "noindent" -> "" @@ -800,8 +836,8 @@ let rec rst_of_line ctx line = Printf.sprintf "\\ *%s*\\ " arg | "kbd" | "option" - | "env" -> rst_of_line ctx [ M (loc, "code", arg)] - | "sc" -> rst_of_line ctx [ M (loc, "small-caps", arg)] + | "env" -> rst_of_line ctx [ MACRO (loc, "code", arg)] + | "sc" -> rst_of_line ctx [ MACRO (loc, "small-caps", arg)] | "code" -> let arg = let verbatim_stack = ctx.verbatim in @@ -843,6 +879,7 @@ let rec rst_of_line ctx line = | "var" -> let arg = rst_of_line0 ctx arg in Printf.sprintf "<%s>" arg + | "emph" | "strong" | "b" -> @@ -889,43 +926,44 @@ let rec rst_of_line ctx line = | "anchoridx" -> - rst_of_line ctx [ M (loc, "idx", arg); - M (loc, "anchor", arg) ] + rst_of_line ctx [ MACRO (loc, "idx", arg); + MACRO (loc, "anchor", arg) ] | "define" | "itemdfn" -> - rst_of_line ctx [ M (loc, "idx", arg ) ; - M (loc, "dfn", arg ) ] + rst_of_line ctx [ MACRO (loc, "idx", arg ) ; + MACRO (loc, "dfn", arg ) ] | "directive" -> - rst_of_line ctx [ M (loc, "code", arg) ; S " CDF directive" ] + rst_of_line ctx [ MACRO (loc, "code", arg) ; + STRING " CDF directive" ] | "directiveref" -> with_pxref ctx loc "directive" arg | "envvarcompile" -> with_pxref ctx loc "code" ~arg ~prefix: [ - M (loc, "idx", arg @ [ S " Environment Variable"]) ; - M (loc, "idx", [ S " Environment Variables, "] @ arg) ; + MACRO (loc, "idx", arg @ [ STRING " Environment Variable"]) ; + MACRO (loc, "idx", [ STRING " Environment Variables, "] @ arg) ; ] ~suffix:" compilation-time environment variable" - [ S "Compilation Time Environment Variables" ] + [ STRING "Compilation Time Environment Variables" ] | "envvarruntime" -> rst_of_line ctx [ - M (loc, "idx", arg @ [ S " Environment Variable"]) ; - M (loc, "idx", [ S " Environment Variables, "] @ arg) ; - S " run-time environment variable" ] + MACRO (loc, "idx", arg @ [ STRING " Environment Variable"]) ; + MACRO (loc, "idx", [ STRING " Environment Variables, "] @ arg) ; + STRING " run-time environment variable" ] | "envvarruntimeref" -> with_pxref ctx loc "envvarruntime" ~arg - [ S "Run Time Environment Variables" ] + [ STRING "Run Time Environment Variables" ] | "envvarruntimerefs" -> with_pxref ctx loc "envvarruntime" ~arg ~suffix: " run-time environment variables" - [ S "Run Time Environment Variables" ] + [ STRING "Run Time Environment Variables" ] | "idx" -> let arg = rst_of_line0 ctx arg in add_index ctx arg; if List.hd ctx.verbatim = Block then "\\ " else "" | "intrinsic" -> - rst_of_line ctx [ M (loc, "code", arg) ; S " intrinsic function" ] + rst_of_line ctx [ MACRO (loc, "code", arg) ; STRING " intrinsic function" ] | "intrinsicref" -> with_pxref ctx loc "intrinsic" arg (* newappendix *) @@ -935,37 +973,37 @@ let rec rst_of_line ctx line = (* newsubsection *) (* newunit *) | "registertext" -> - rst_of_line ctx [ M (loc, "code", arg) ; S " special register" ] + rst_of_line ctx [ MACRO (loc, "code", arg) ; STRING " special register" ] | "register" -> - rst_of_line ctx [ M (loc, "idx", arg @ [ S " Special Register" ] ); - M (loc, "idx", [ S " Special Registers, " ] @ arg ); - M (loc, "registertext", arg); + rst_of_line ctx [ MACRO (loc, "idx", arg @ [ STRING " Special Register" ] ); + MACRO (loc, "idx", [ STRING " Special Registers, " ] @ arg ); + MACRO (loc, "registertext", arg); ] | "registerref" -> - with_pxref ctx loc "register" ~arg [ S "Special Registers" ] + with_pxref ctx loc "register" ~arg [ STRING "Special Registers" ] | "registerrefalt" -> with_pxrefalt ctx loc "register" arg | "statement" -> - rst_of_line ctx [ M (loc, "code", arg) ; S " statement" ] + rst_of_line ctx [ MACRO (loc, "code", arg) ; STRING " statement" ] | "statementref" -> with_pxref ctx loc "statement" arg | "statementrefalt" -> with_pxrefalt ctx loc "statement" arg | "subpgm" -> - rst_of_line ctx [ M (loc, "code", arg) ; S " built-in system subroutine" ] + rst_of_line ctx [ MACRO (loc, "code", arg) ; STRING " built-in system subroutine" ] | "subpgmref" -> with_pxref ctx loc "subpgm" arg | "switch" -> - rst_of_line ctx [ M (loc, "option", arg) ; S " switch" ] + rst_of_line ctx [ MACRO (loc, "option", arg) ; STRING " switch" ] | "switchidx" -> - rst_of_line ctx [ M (loc, "idx", [ S "Compiler Switches, " ] @ arg) ; - M (loc, "idx", arg @ [ S " Compiler Switch" ]) ; - M (loc, "switch", arg) ] + rst_of_line ctx [ MACRO (loc, "idx", [ STRING "Compiler Switches, " ] @ arg) ; + MACRO (loc, "idx", arg @ [ STRING " Compiler Switch" ]) ; + MACRO (loc, "switch", arg) ] | "syntaxidx" -> - rst_of_line ctx [ M (loc, "idx", arg); - M (loc, "code", arg); ] + rst_of_line ctx [ MACRO (loc, "idx", arg); + MACRO (loc, "code", arg); ] | "plainidx" -> - rst_of_line ctx ( [ M (loc, "idx", arg) ] @ arg ) + rst_of_line ctx ( [ MACRO (loc, "idx", arg) ] @ arg ) | "syntaxref" -> with_pxref ctx loc "code" arg | "syntaxrefalt" -> @@ -976,7 +1014,7 @@ let rec rst_of_line ctx line = with_pxref ctx loc "_" arg - | "t" -> rst_of_line ctx [ M (loc, "code", arg) ] + | "t" -> rst_of_line ctx [ MACRO (loc, "code", arg) ] | "key" -> let arg = rst_of_line0 ctx arg in @@ -1035,15 +1073,15 @@ and with_pxref ctx loc name ?arg ?(prefix=[]) ?suffix ref = | Some arg -> arg in let prefix = match suffix with - | None -> prefix @ [ M (loc, name, arg) ] - | Some suffix -> prefix @ [ M (loc, name, arg); S suffix ] + | None -> prefix @ [ MACRO (loc, name, arg) ] + | Some suffix -> prefix @ [ MACRO (loc, name, arg); STRING suffix ] in - rst_of_line ctx (prefix @ [ S " ("; M (loc, "pxref", ref); S ")" ]) + rst_of_line ctx (prefix @ [ STRING " ("; MACRO (loc, "pxref", ref); STRING ")" ]) and with_pxrefalt ctx loc name arg = match parse_args ctx arg with | [ text ; ref ] -> - with_pxref ctx loc name ~arg:[ S text ] [ S ref ] + with_pxref ctx loc name ~arg:[ STRING text ] [ STRING ref ] | _ -> assert false let rst_of_line = rst_of_line0 @@ -1083,7 +1121,7 @@ let output_level ctx oc level ?number title = let linebreaks line = if List.exists (function - M (_loc, "linebreak", []) -> true + MACRO (_loc, "linebreak", []) -> true | _ -> false ) line then let rec iter lines rev line = match line with @@ -1092,7 +1130,7 @@ let linebreaks line = ( match rev with | [] -> lines | _ -> List.rev rev :: lines ) - | M ( _loc, "linebreak", [] ) :: line -> + | MACRO ( _loc, "linebreak", [] ) :: line -> iter (List.rev rev :: lines ) [] line | inline :: line -> iter lines ( inline :: rev ) line @@ -1129,6 +1167,8 @@ and output_block ctx oc indent block = end | INDEX index -> add_index ctx index + | NODE index -> + add_anchor ctx index | EMPTY_LINE -> OUTPUT.fprintf oc "%s\n" indent ; place_for_indexes ctx oc indent ; @@ -1151,7 +1191,7 @@ and output_block ctx oc indent block = | DIAGRAM (title, blocks) -> if ctx.doc.basename = "gnucobqr" then begin place_for_indexes ctx oc "" ; - output_level ctx oc 2 [ S ( title ^ " Syntax") ] ; + output_level ctx oc 2 [ STRING ( title ^ " Syntax") ] ; end else OUTPUT.fprintf oc "%s%s Syntax\n" indent title; @@ -1202,7 +1242,7 @@ and output_block ctx oc indent block = OUTPUT.fprintf oc "%s\n" indent; ctx.verbatim <- verbatim_stack end; - | BLOCK ( ("ifnottex" | "ifinfo" ), _ ) -> () + | BLOCK ( ("ifnottex" | "ifinfo" | "ignore"), _ ) -> () | BLOCK (name, blocks) -> (* TODO *) begin @@ -1230,7 +1270,7 @@ and output_block ctx oc indent block = if style = "asis" then title else - [ M (LOCATION.any, style, title)] + [ MACRO (LOCATION.any, style, title)] in OUTPUT.fprintf oc "\n\n%s* %s\n\n" indent (rst_of_line ctx title); @@ -1321,50 +1361,51 @@ let to_rst doc dir = match block with | BLOCK ( "copying", blocks ) -> - let file = "copying.rst" in - ctx.files <- file :: ctx.files ; - let oc = OUTPUT.open_out ( dir // file ) in + let file = "copying.rst" in + ctx.files <- file :: ctx.files ; + let oc = OUTPUT.open_out ( dir // file ) in - OUTPUT.fprintf oc "%s" rst_header; - place_for_indexes ctx oc "" ; - output_level ctx oc 1 [ S "Copyright" ] ; - output_blocks ctx oc "" blocks ; + OUTPUT.fprintf oc "%s" rst_header; + place_for_indexes ctx oc "" ; + output_level ctx oc 1 [ STRING "Copyright" ] ; + output_blocks ctx oc "" blocks ; - List.iter (fun arg -> - OUTPUT.fprintf oc "\n\n.. [#] %s\n" arg; - ) ( List.rev ctx.footnotes ); + List.iter (fun arg -> + OUTPUT.fprintf oc "\n\n.. [#] %s\n" arg; + ) ( List.rev ctx.footnotes ); - if gen_files then OUTPUT.close_out oc + if gen_files then OUTPUT.close_out oc | LEVEL (1, number, title, blocks) -> - incr chapters ; - let file = Printf.sprintf "chapter%d.rst" !chapters in - ctx.files <- file :: ctx.files ; - ctx.footnotes <- [] ; - let oc = OUTPUT.open_out ( dir // file ) in - - OUTPUT.fprintf oc "%s" rst_header; - place_for_indexes ctx oc "" ; - output_level ctx oc 1 ?number title ; - output_blocks ctx oc "" blocks ; - - List.iter (fun arg -> - OUTPUT.fprintf oc "\n\n.. [#] %s\n" arg; - ) ( List.rev ctx.footnotes ); - - if gen_files then OUTPUT.close_out oc + incr chapters ; + let file = Printf.sprintf "chapter%d.rst" !chapters in + ctx.files <- file :: ctx.files ; + ctx.footnotes <- [] ; + let oc = OUTPUT.open_out ( dir // file ) in + + OUTPUT.fprintf oc "%s" rst_header; + place_for_indexes ctx oc "" ; + output_level ctx oc 1 ?number title ; + output_blocks ctx oc "" blocks ; + + List.iter (fun arg -> + OUTPUT.fprintf oc "\n\n.. [#] %s\n" arg; + ) ( List.rev ctx.footnotes ); + + if gen_files then OUTPUT.close_out oc | BLOCK ("ifnottex", _ ) -> () | BLOCK ("ifinfo", _ ) -> () | LINE line -> - Printf.eprintf "Discarding toplevel line %s\n%!" - ( string_of_line line ) + Printf.eprintf "Discarding toplevel line %s\n%!" + ( string_of_line line ) | EMPTY_LINE -> () + | NODE _ -> () | _ -> - Printf.eprintf "ERROR:<<<\n%!"; - print_blocks stderr [block]; - Printf.eprintf ">>>\n%!"; - assert false + Printf.eprintf "ERROR:<<<\n%!"; + print_blocks stderr [block]; + Printf.eprintf ">>>\n%!"; + assert false ) doc.content ; @@ -1434,9 +1475,9 @@ let to_rst doc dir = () -let action ~filename ?target () = +let action ~path ~filename ?target () = - let doc = read filename in + let doc = read ~path filename in match target with | None -> print_doc doc @@ -1448,18 +1489,23 @@ let action ~filename ?target () = let cmd = let filename = ref None in let target = ref None in + let path = ref [] in EZCMD.sub "texi2rst" (fun () -> + let path = List.rev !path in match !filename with | None -> Fatal.error "You must specify a filename" - | Some filename -> action ~filename ?target:!target () + | Some filename -> action ~path ~filename ?target:!target () ) ~args: [ [ "o" ], Arg.String (fun s -> target := Some s), EZCMD.info ~docv:"DIR" "Target directory for RST generation"; + [ "I" ], Arg.String (fun s -> path := s :: !path), + EZCMD.info ~docv:"DIR" "Add to lookup path for files"; + [], Arg.Anon (0, fun s -> filename := Some s), EZCMD.info ~docv:"FILE" ".texi file" diff --git a/src/lsp/superbol_free_lib/dune b/src/lsp/superbol_free_lib/dune index 6702b3b45..1dd6f8cb5 100644 --- a/src/lsp/superbol_free_lib/dune +++ b/src/lsp/superbol_free_lib/dune @@ -5,7 +5,7 @@ (public_name superbol_free_lib) (wrapped true) ; use field 'dune-libraries' to add libraries without opam deps - (libraries ez_file ez_cmdliner cobol_typeck cobol_parser cobol_lsp cobol_indent cobol_common cobol_ast ) + (libraries vscode-json ez_file ez_cmdliner cobol_typeck cobol_parser cobol_lsp cobol_indent cobol_common cobol_ast ) ; use field 'dune-flags' to set this value (flags (:standard)) ; use field 'dune-stanzas' to add more stanzas here diff --git a/src/lsp/superbol_free_lib/main.ml b/src/lsp/superbol_free_lib/main.ml index e835ba8f0..47adf108d 100644 --- a/src/lsp/superbol_free_lib/main.ml +++ b/src/lsp/superbol_free_lib/main.ml @@ -22,6 +22,7 @@ let public_subcommands = [ Command_texi2rst.cmd ; Command_indent_range.cmd; Command_indent_file.cmd; + Command_json_package.cmd; ] let main ?style_renderer ?utf_8 () = diff --git a/src/lsp/superbol_free_lib/package.toml b/src/lsp/superbol_free_lib/package.toml index b0bd76ec0..7b6b2ee27 100644 --- a/src/lsp/superbol_free_lib/package.toml +++ b/src/lsp/superbol_free_lib/package.toml @@ -56,15 +56,12 @@ skip = ["index.mld", "main.ml" ] cobol_ast = "version" cobol_common = "version" cobol_indent = "version" -#cobol_linting = "version" cobol_lsp = "version" cobol_parser = "version" cobol_typeck = "version" -#jcl_parser = "version" ez_file = ">=0.3" -#ocabol_lib = "version" -#ppx_cobcflags = "version" ez_cmdliner = "0.3.0" +vscode-json = "version" # package tools dependencies [tools] diff --git a/src/vscode/vscode-package-json/project.ml b/src/lsp/superbol_free_lib/project.ml similarity index 99% rename from src/vscode/vscode-package-json/project.ml rename to src/lsp/superbol_free_lib/project.ml index b21bbfe74..3262ff810 100644 --- a/src/vscode/vscode-package-json/project.ml +++ b/src/lsp/superbol_free_lib/project.ml @@ -42,7 +42,7 @@ let package = ~homepage: "https://ocamlpro.com/cobol" ~author: { author_name = "OCamlPro SAS" ; - author_email = "contact@ocamlpro.com" + author_email = Some "contact@ocamlpro.com" } ~keywords: [ "cobol" ; "gnucobol" ] ~main: "./out/superbol_vscode_platform.bc.js" diff --git a/src/vscode/vscode-package-json/project.mli b/src/lsp/superbol_free_lib/project.mli similarity index 100% rename from src/vscode/vscode-package-json/project.mli rename to src/lsp/superbol_free_lib/project.mli diff --git a/src/vscode/vscode-json/dune b/src/vscode/vscode-json/dune index 2b0a14eb7..e8c9de6d1 100644 --- a/src/vscode/vscode-json/dune +++ b/src/vscode/vscode-json/dune @@ -9,7 +9,7 @@ ; use field 'dune-flags' to set this value (flags (:standard)) ; use field 'dune-stanzas' to add more stanzas here - (preprocess (pps ppx_deriving_encoding)) + (preprocess (pps ppx_deriving_encoding ppx_deriving.show)) ) diff --git a/src/vscode/vscode-json/ezjsonm.ml b/src/vscode/vscode-json/ezjsonm.ml new file mode 100644 index 000000000..3493b6867 --- /dev/null +++ b/src/vscode/vscode-json/ezjsonm.ml @@ -0,0 +1,411 @@ +(* This file contains a small patch, see the SUPERBOL comments. + + We use the Jsonm.Uncut.decode function to parse Javascript comments + that are allowed by VSCODE in JSON files. + + *) + +(* + * Copyright (c) 2013 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* From http://erratique.ch/software/jsonm/doc/Jsonm.html#datamodel *) +type value = + [ `Null + | `Bool of bool + | `Float of float + | `String of string + | `A of value list + | `O of (string * value) list ] + +type t = + [ `A of value list + | `O of (string * value) list ] + +let value: t -> value = fun t -> (t :> value) + +module List = struct + include List + + (* Tail-recursive List.map *) + let map f l = rev (rev_map f l) +end + +type error_location = (int * int) * (int * int) +type read_value_error = [ + | `Error of error_location * Jsonm.error + | `Unexpected of [ `Lexeme of error_location * Jsonm.lexeme * string | `End_of_input ] +] +type read_error = [ read_value_error | `Not_a_t of value ] + +let json_of_src src : (value, [> read_value_error]) result = + let d = Jsonm.decoder src in + let exception Abort of read_value_error in + let module Stack = struct + type t = + | In_array of value list * t + | In_object of string * (string * value) list * t + | Empty + end + in + let loc () = Jsonm.decoded_range d in +(* BEGIN PATCH FOR SUPERBOL *) + let rec dec () = match Jsonm.Uncut.decode d with + | `Comment _ | `White _ -> dec () +(* END PATCH FOR SUPERBOL *) + | `Lexeme l -> l + | `Error e -> raise (Abort (`Error (loc (), e))) + | `End -> raise (Abort (`Unexpected `End_of_input)) + | `Await -> assert false + in + let rec value l stack = match l with + | `Os -> obj [] stack + | `As -> arr [] stack + | `Null + | `Bool _ + | `String _ + | `Float _ as l -> continue l stack + | _ -> + raise (Abort (`Unexpected (`Lexeme (loc (), l, "value")))) + and arr so_far stack = match dec () with + | `Ae -> continue (`A (List.rev so_far)) stack + | l -> + let stack = Stack.In_array (so_far, stack) in + value l stack + and obj so_far stack = match dec () with + | `Oe -> continue (`O (List.rev so_far)) stack + | `Name n -> + let stack = Stack.In_object (n, so_far, stack) in + value (dec ()) stack + | l -> + raise (Abort (`Unexpected (`Lexeme (loc (), l, "object fields")))) + and continue v stack = + match stack with + | Stack.In_array (vs, stack) -> + let so_far = (v :: vs) in + arr so_far stack + | Stack.In_object (n, ms, stack) -> + let so_far = ((n,v) :: ms) in + obj so_far stack + | Stack.Empty -> v + in + try Ok (value (dec ()) Empty) + with Abort (#read_value_error as err) -> Error err + +let value_to_dst ?(minify=true) dst json = + let module Stack = struct + type t = + | In_array of value list * t + | In_object of (string * value) list * t + | Empty + end + in + let enc e l = ignore (Jsonm.encode e (`Lexeme l)) in + let rec t v e stack = match v with + | `A vs -> + enc e `As; + arr vs e stack + | `O ms -> + enc e `Os; + obj ms e stack + and value v e stack = match v with + | `Null | `Bool _ | `Float _ | `String _ as v -> + enc e v; + continue e stack + | #t as x -> t (x :> t) e stack + and arr vs e stack = match vs with + | v :: vs' -> + let stack = Stack.In_array (vs', stack) in + value v e stack + | [] -> enc e `Ae; continue e stack + and obj ms e stack = match ms with + | (n, v) :: ms -> + enc e (`Name n); + let stack = Stack.In_object (ms, stack) in + value v e stack + | [] -> enc e `Oe; continue e stack + and continue e stack = match stack with + | Stack.In_array (vs, stack) -> arr vs e stack + | Stack.In_object (ms, stack) -> obj ms e stack + | Stack.Empty -> () + in + let e = Jsonm.encoder ~minify dst in + value json e Stack.Empty; + ignore (Jsonm.encode e `End) + +let value_to_buffer ?minify buf json = + value_to_dst ?minify (`Buffer buf) json + +let to_buffer ?minify buf json = value_to_buffer ?minify buf (json :> value) + +let value_to_string ?minify json = + let buf = Buffer.create 1024 in + value_to_buffer ?minify buf json; + Buffer.contents buf + +let to_string ?minify json = value_to_string ?minify (json :> value) + +let value_to_channel ?minify oc json = + value_to_dst ?minify (`Channel oc) json + +let to_channel ?minify oc json = value_to_channel ?minify oc (json :> value) + +exception Parse_error of value * string + +let parse_error t fmt = + Printf.kprintf (fun msg -> + raise (Parse_error (t, msg)) + ) fmt + +let wrap t = `A [t] + +let unwrap = function + | `A [t] -> t + | v -> parse_error (v :> value) "Not unwrappable" + +let read_error_description : [< read_error ] -> string = function + | `Error (_loc, err) -> + Format.asprintf "%a" Jsonm.pp_error err + | `Unexpected `End_of_input -> + Format.sprintf "Unexpected end of input" + | `Unexpected (`Lexeme (_loc, _l, expectation)) -> + Format.sprintf "Unexpected input when parsing a %s" expectation + | `Not_a_t _value -> + "We expected a well-formed JSON document (array or object)" + +let read_error_location : [< read_error ] -> error_location option = function + | `Error (loc, _) -> Some loc + | `Unexpected `End_of_input -> None + | `Unexpected (`Lexeme (loc, _l, _expectation)) -> Some loc + | `Not_a_t _value -> None + +let value_from_src_result src = json_of_src src + +let value_from_src src = + match value_from_src_result src with + | Ok t -> t + | Error e -> parse_error `Null "JSON.of_buffer %s" (read_error_description e) + +let value_from_string_result str = value_from_src_result (`String str) +let value_from_string str = value_from_src (`String str) + +let value_from_channel_result chan = value_from_src_result (`Channel chan) +let value_from_channel chan = value_from_src (`Channel chan) + +let ensure_document_result: [> value] -> ([> t], [> read_error]) result = function + | #t as t -> Ok t + | value -> Error (`Not_a_t value) + +let ensure_document: [> value] -> [> t] = function + | #t as t -> t + | t -> raise (Parse_error (t, "not a valid JSON array/object")) + +let from_string str = value_from_string str |> ensure_document +let from_channel chan = value_from_channel chan |> ensure_document + +let from_string_result str = + Result.bind (value_from_string_result str) ensure_document_result +let from_channel_result chan = + Result.bind (value_from_channel_result chan) ensure_document_result + +(* unit *) +let unit () = `Null + +let get_unit = function + | `Null -> () + | j -> parse_error j "Ezjsonm.get_unit" + +(* bool *) +let bool b = `Bool b + +let get_bool = function + | `Bool b -> b + | j -> parse_error j "Ezjsonm.get_bool" + +(* string *) +let string s = `String s + +let get_string = function + | `String s -> s + | j -> parse_error j "Ezjsonm.get_string" + +(* int *) +let int i = `Float (float_of_int i) +let int32 i = `Float (Int32.to_float i) +let int64 i = `Float (Int64.to_float i) + +let get_int = function + | `Float f -> int_of_float f + | j -> parse_error j "Ezjsonm.get_int" + +let get_int32 = function + | `Float f -> Int32.of_float f + | j -> parse_error j "Ezjsonm.get_int32" + +let get_int64 = function + | `Float f -> Int64.of_float f + | j -> parse_error j "Ezjsonm.get_int64" + +(* float *) +let float f = `Float f + +let get_float = function + | `Float f -> f + | j -> parse_error j "Ezjsonm.get_float" + +(* list *) +let list fn l = + `A (List.map fn l) + +let get_list fn = function + | `A ks -> List.map fn ks + | j -> parse_error j "Ezjsonm.get_list" + +(* string lists *) +let strings strings = list string strings + +let get_strings = get_list get_string + +(* options *) +let option fn = function + | None -> `Null + | Some x -> `A [fn x] + +let get_option fn = function + | `Null -> None + | `A [j] -> Some (fn j) + | j -> parse_error j "Ezjsonm.get_option" + +(* dict *) +let dict d = `O d + +let get_dict = function + | `O d -> d + | j -> parse_error j "Ezjsonm.get_dict" + +(* pairs *) +let pair fk fv (k, v) = + `A [fk k; fv v] + +let get_pair fk fv = function + | `A [k; v] -> (fk k, fv v) + | j -> parse_error j "Ezjsonm.get_pair" + +(* triple *) + +let triple fa fb fc (a, b, c) = + `A [fa a; fb b; fc c] + +let get_triple fa fb fc = function + | `A [a; b; c] -> (fa a, fb b, fc c) + | j -> parse_error j "Ezjsonm.get_triple" + +let mem t path = + let rec aux j p = match p, j with + | [] , _ -> true + | h::tl, `O o -> List.mem_assoc h o && aux (List.assoc h o) tl + | _ -> false in + aux t path + +let find t path = + let rec aux j p = match p, j with + | [] , j -> j + | h::tl, `O o -> aux (List.assoc h o) tl + | _ -> raise Not_found in + aux t path + +let find_opt t path = + try Some (find t path) with Not_found -> None + +let map_dict f dict label = + let rec aux acc = function + | [] -> + begin match f `Null with + | None -> List.rev acc + | Some j -> List.rev_append acc [label, j] + end + | (l,j) as e :: dict -> + if l = label then + match f j with + | None -> List.rev_append acc dict + | Some j -> List.rev_append acc ((l,j)::dict) + else + aux (e::acc) dict in + aux [] dict + +let map f t path = + let rec aux t = function + | [] -> f t + | h::tl -> + match t with + | `O d -> Some (`O (map_dict (fun t -> aux t tl) d h)) + | _ -> None in + match aux t path with + | None -> raise Not_found + | Some j -> j + +let update t path v = + map (fun _ -> v) t path + +exception Not_utf8 + +let is_valid_utf8 str = + try + Uutf.String.fold_utf_8 (fun _ _ -> function + | `Malformed _ -> raise Not_utf8 + | _ -> () + ) () str; + true + with Not_utf8 -> false + +let encode_string str = + if is_valid_utf8 str + then string str + else + let `Hex h = Hex.of_string str in + `O [ "hex", string h ] + +let decode_string = function + | `String str -> Some str + | `O [ "hex", `String str ] -> Some (Hex.to_string (`Hex str)) + | _ -> None + +let decode_string_exn j = + match decode_string j with + | Some s -> s + | None -> parse_error j "Ezjsonm.decode_string_exn" + +let rec of_sexp = function + | Sexplib0.Sexp.Atom x -> encode_string x + | Sexplib0.Sexp.List l -> list of_sexp l + +let value_of_sexp = of_sexp + +let t_of_sexp s = match value_of_sexp s with + | `A x -> `A x + | `O x -> `O x + | _ -> failwith "Ezjsonm: t_of_sexp encountered a value (fragment) rather than a t" + +let rec to_sexp json = + match decode_string json with + | Some s -> Sexplib0.Sexp.Atom s + | None -> + match json with + | `A l -> Sexplib0.Sexp.List (List.map to_sexp l) + | _ -> parse_error json "Ezjsonm.to_sexp" + +let sexp_of_value = to_sexp + +let sexp_of_t t = sexp_of_value @@ value t diff --git a/src/vscode/vscode-json/ezjsonm.mli b/src/vscode/vscode-json/ezjsonm.mli new file mode 100644 index 000000000..816789e34 --- /dev/null +++ b/src/vscode/vscode-json/ezjsonm.mli @@ -0,0 +1,272 @@ +(* + * Copyright (c) 2013 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(** An easy interface on top of the [Jsonm] library. + + This version provides more convenient (but far less flexible) + input and output functions that go to and from [string] values. + This avoids the need to write signal code, which is useful for + quick scripts that manipulate JSON. + + More advanced users should go straight to the [Jsonm] library and + use it directly, rather than be saddled with the Ezjsonm interface + below. +*) + +(** {2 Basic types} *) + +type value = + [ `Null + | `Bool of bool + | `Float of float + | `String of string + | `A of value list + | `O of (string * value) list ] +(** JSON fragments. *) + +type t = + [ `A of value list + | `O of (string * value) list ] +(** Well-formed JSON documents. *) + +val value: t -> value +(** Cast a JSON well-formed document into a JSON fragment. *) + +val wrap: value -> [> t] +(** [wrap v] wraps the value [v] into a JSON array. To use when it is + not possible to statically know that [v] is a value JSON value. *) + +val unwrap: t -> value +(** [unwrap t] is the reverse of [wrap]. It expects [t] to be a + singleton JSON object and it return the unique element. *) + +(** {2 Reading JSON documents and values} *) +val from_channel: in_channel -> [> t] +(** Read a JSON document from an input channel. *) + +val from_string: string -> [> t] +(** Read a JSON document from a string. *) + +val value_from_channel: in_channel -> value +(** Read a JSON value from an input channel. *) + +val value_from_string: string -> value +(** Read a JSON value from a string. *) + +val value_from_src: Jsonm.src -> value +(** Low-level function to read directly from a [Jsonm] source. *) + +(** {2 Reading JSON documents and values -- with proper errors} *) + +type error_location = (int * int) * (int * int) +(** Error locations in a source document follow the Jsonm representation + of pairs of pairs [((start_line, start_col), (end_line, end_col))] + with 0-indexed lines and 1-indexed columns. *) + +type read_value_error = [ + | `Error of error_location * Jsonm.error + | `Unexpected of [ `Lexeme of error_location * Jsonm.lexeme * string | `End_of_input ] +] +type read_error = [ read_value_error | `Not_a_t of value ] + +val read_error_description : [< read_error ] -> string +(** A human-readable description of an error -- without using the error location. *) + +val read_error_location : [< read_error ] -> error_location option +(** If the error is attached to a specific location in the buffer, + return this location. *) + +val from_channel_result: in_channel -> ([> t], [> read_error]) result +(** See {!from_channel}. *) + +val from_string_result: string -> ([> t], [> read_error]) result +(** See {!from_string}. *) + +val value_from_channel_result: in_channel -> (value, [> read_value_error]) result +(** See {!value_from_channel}. *) + +val value_from_string_result: string -> (value, [> read_value_error]) result +(** See {!value_from_string}. *) + +val value_from_src_result: Jsonm.src -> (value, [> read_value_error]) result +(** See {!value_from_src}. *) + +(** {2 Writing JSON documents and values} *) + +val to_channel: ?minify:bool -> out_channel -> t -> unit +(** Write a JSON document to an output channel. *) + +val to_buffer: ?minify:bool -> Buffer.t -> t -> unit +(** Write a JSON document to a buffer. *) + +val to_string: ?minify:bool -> t -> string +(** Write a JSON document to a string. This goes via an intermediate + buffer and so may be slow on large documents. *) + +val value_to_channel: ?minify:bool -> out_channel -> value -> unit +(** Write a JSON value to an output channel. *) + +val value_to_buffer: ?minify:bool -> Buffer.t -> value -> unit +(** Write a JSON value to a buffer. *) + +val value_to_string: ?minify:bool -> value -> string +(** Write a JSON value to a string. This goes via an intermediate + buffer and so may be slow on large documents. *) + +val value_to_dst: ?minify:bool -> Jsonm.dst-> value -> unit +(** Low-level function to write directly to a [Jsonm] destination. *) + +(** {2 Constructors} *) + +val unit: unit -> value +(** Same as [`Null]. *) + +val bool: bool -> value +(** Same as [`Bool b]. *) + +val string: string -> value +(** Same as [`String s]. *) + +val strings: string list -> [> t] +(** Same as [`A [`String s1; ..; `String sn]]. *) + +val int: int -> value +(** Same as [`Float (float_of_int i)]. *) + +val int32: int32 -> value +(** Same as [`Float (Int32.to_float i)] *) + +val int64: int64 -> value +(** Same as [`Float (Int64.to_float i)] *) + +val float: float -> value +(** Some as [`Float f]. *) + +val list: ('a -> value) -> 'a list -> [> t] +(** Build a list of values. *) + +val option: ('a -> value) -> 'a option -> value +(** Either [`Null] or a JSON value. *) + +val dict: (string * value) list -> [> t] +(** Build a dictionnary. *) + +val pair: ('a -> value) -> ('b -> value) -> ('a * 'b) -> [> t] +(** Build a pair. *) + +val triple: ('a -> value) -> ('b -> value) -> ('c -> value) -> + ('a * 'b * 'c) -> [> t] +(** Build a triple. *) + +(** {2 Accessors} *) + +exception Parse_error of value * string +(** All the following accessor functions expect the provided JSON + document to be of a certain kind. In case this is not the case, + [Parse_error] is raised. *) + +val get_unit: value -> unit +(** Check that the JSON document is [`Null]. *) + +val get_bool: value -> bool +(** Extract [b] from [`Bool b]. *) + +val get_string: value -> string +(** Extract [s] from [`String s]. *) + +val get_strings: value -> string list +(** Extract [s1;..;sn] from [`A [`String s1; ...; `String sn]]. *) + +val get_int: value -> int +(** Extract an integer. *) + +val get_int32: value -> int32 +(** Extract a 32-bits integer. *) + +val get_int64: value -> int64 +(** Extract a 64-bits integer. *) + +val get_float: value -> float +(** Extract a float. *) + +val get_list: (value -> 'a) -> value -> 'a list +(** Extract elements from a JSON array. *) + +val get_option: (value -> 'a) -> value -> 'a option +(** Extract an optional document. *) + +val get_dict: value -> (string * value) list +(** Extract the elements from a dictionnary document. *) + +val get_pair: (value -> 'a) -> (value -> 'b) -> value -> ('a * 'b) +(** Extract the pair. *) + +val get_triple: (value -> 'a) -> (value -> 'b) -> (value -> 'c) -> + value -> ('a * 'b * 'c) +(** Extract the triple. *) + +(** {2 High-level functions} *) + +val mem: value -> string list -> bool +(** [mem v path] is true if the given path is valid for the JSON document [v]. *) + +val find: value -> string list -> value +(** Find the sub-document addressed by the given path. Raise + [Not_found] if the path is invalid. *) + +val find_opt : value -> string list -> value option +(** Find the sub-document addressed by the given path. Returns + [None] if the path is invalid. *) + +val update: value -> string list -> value option -> value +(** Update the sub-document addressed by the given path. If the + provided value is [None], then removes the sub-document. *) + +val map: (value -> value option) -> value -> string list -> value +(** Apply a given function to a subdocument. *) + +val encode_string: string -> value +(** Convert a (possibly non-valid UTF8) string to a JSON object.*) + +val decode_string: value -> string option +(** Convert a JSON object to a (possibly non-valid UTF8) + string. Return [None] if the JSON object is not a valid string. *) + +val decode_string_exn: value -> string +(** Convert a JSON object to a (possibly non-valid UTF8) string. *) + +val to_sexp: value -> Sexplib0.Sexp.t +(** Convert a JSON fragment to an S-expression. *) + +val sexp_of_value: value -> Sexplib0.Sexp.t +(** An alias of [to_sexp] *) + +val sexp_of_t: t -> Sexplib0.Sexp.t +(** Convert a JSON object to an S-expression *) + +val of_sexp: Sexplib0.Sexp.t -> value +(** Convert an S-expression to a JSON fragment *) + +val value_of_sexp: Sexplib0.Sexp.t -> value +(** AN alias of [of_sexp] *) + +val t_of_sexp: Sexplib0.Sexp.t -> t +(** Convert an S-expression to a JSON object *) + +(** {2 Error handling} *) + +val parse_error: value -> ('a, unit, string, 'b) format4 -> 'a +(** Raise [Parse_error] *) diff --git a/src/vscode/vscode-json/grammar.ml b/src/vscode/vscode-json/grammar.ml index 46998756c..f8d1d90ad 100644 --- a/src/vscode/vscode-json/grammar.ml +++ b/src/vscode/vscode-json/grammar.ml @@ -17,18 +17,18 @@ type capture_pattern = { pattern_include : string ; [@key "include"] } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type capture = { capture_name : string option ; capture_patterns : capture_pattern list option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type captures = (string * capture) list [@assoc] -[@@deriving json_encoding] +[@@deriving json_encoding,show] -type endCaptures = captures +type endCaptures = captures [@@deriving show] let endCaptures_enc = let open Json_encoding in @@ -56,10 +56,10 @@ type pattern = { pat_contentName : string option ; pat_while : string option ; } -[@@deriving json_encoding {recursive}] +[@@deriving json_encoding {recursive}, show] type patterns = (string * pattern) list [@assoc] -[@@deriving json_encoding] +[@@deriving json_encoding,show] type grammar = { @@ -76,7 +76,7 @@ type grammar = { schema : string option ; [@key "$schema"] injectionSelector : string option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let schema = {|{ "$schema": "http://json-schema.org/schema#", diff --git a/src/vscode/vscode-json/language.ml b/src/vscode/vscode-json/language.ml index 0944e4ea4..c84f21865 100644 --- a/src/vscode/vscode-json/language.ml +++ b/src/vscode/vscode-json/language.ml @@ -17,23 +17,23 @@ type comments = { lineComment : string option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type markers = { marker_start : string ; marker_end : string ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type folding = ( string * markers ) list [@assoc] (* "markers" *) -[@@deriving json_encoding] +[@@deriving json_encoding,show] type pair = { pair_open : string ; pair_close : string ; pair_notIn : string list ; [@dft []] } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let pair_enc = let open Json_encoding in @@ -53,7 +53,7 @@ type onEnterRule = { endTest : string option ; action : ( string * string ) list ;[@assoc] [@dft []] } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type language = { comments : comments option ; @@ -64,4 +64,4 @@ type language = { folding : folding ; [@dft []] onEnterRules : onEnterRule list ; [@dft []] } -[@@deriving json_encoding] +[@@deriving json_encoding,show] diff --git a/src/vscode/vscode-json/main.ml b/src/vscode/vscode-json/main.ml index 9c6a50f51..e12c9a104 100644 --- a/src/vscode/vscode-json/main.ml +++ b/src/vscode/vscode-json/main.ml @@ -62,6 +62,7 @@ let write_file filename encoding p = type state = { dir : string ; + verbose : bool ; mutable warnings : string list ; mutable errors : string list ; } @@ -96,23 +97,33 @@ let check_encoding state encoding ~field ?error file = let filename = state.dir // file in if Sys.file_exists filename then let s = EzFile.read_file filename in + if state.verbose then + Printf.eprintf " Check encoding of %s\n%!" filename; match Json_encoding.destruct encoding s with | Ok _ -> () | Error s -> add_error ?error state "Could not destruct %S in field %s:\n %s" filename field s + | exception exn -> + add_error ?error state + "File %S raised exception %s" filename (Printexc.to_string exn) open Manifest -let check_project file = +let check_project ?(verbose=false) file = + if verbose then + Printf.eprintf "Checking project file %S\n%!" file; match read_file file Manifest.vscode_enc with | Error s -> [], [s] | Ok p -> + if verbose then + Printf.eprintf " File OK\n%!"; let dir = Filename.dirname file in let dir = match dir with | "." | "./" -> "" | _ -> dir in let state = { + verbose ; warnings = [] ; errors = []; dir ; @@ -180,7 +191,9 @@ let check_project file = end ; state.warnings, state.errors -let check_file encoding file = +let check_file encoding pp file = match read_file file encoding with | Error s -> [], [s] - | Ok _p -> [], [] + | Ok p -> + pp Format.std_formatter p; + [], [] diff --git a/src/vscode/vscode-json/main.mli b/src/vscode/vscode-json/main.mli index 48a9a469a..ec6d763f9 100644 --- a/src/vscode/vscode-json/main.mli +++ b/src/vscode/vscode-json/main.mli @@ -19,8 +19,11 @@ type 'a result = type errors = (* warnings *) string list * (* errors *) string list -val check_project : string -> errors -val check_file : 'a Json_encoding.encoding -> string -> errors +val check_project : ?verbose:bool -> string -> errors +val check_file : + 'a Json_encoding.encoding -> + ( Format.formatter -> 'a -> unit) -> + string -> errors val read_file : string -> 'a Json_encoding.encoding -> 'a result val write_file : string -> 'a Json_encoding.encoding -> 'a -> unit diff --git a/src/vscode/vscode-json/manifest.ml b/src/vscode/vscode-json/manifest.ml index 8701a6eb2..3a08bfa8e 100644 --- a/src/vscode/vscode-json/manifest.ml +++ b/src/vscode/vscode-json/manifest.ml @@ -48,7 +48,10 @@ let filename = file type any = Json_repr.ezjsonm [@@deriving json_encoding] -type 'a list_or_one = 'a list + +type 'a list_or_one = 'a list [@@deriving show] + +let pp_any _fmt _ezjsonm = () let list_or_one_enc encoding = let open Json_encoding in @@ -67,26 +70,39 @@ type repository = { type_ : string option ; [@key "type"] url : string ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type engines = { vscode : string ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let engines ~vscode = { vscode } type author = { author_name : string ; - author_email : string ; + author_email : string option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] + +let author_enc = + let open Json_encoding in + union [ + case string + (function { author_email = None ; author_name } -> Some author_name + | _ -> None) + (fun author_name -> { author_name ; author_email = None }) ; + case author_enc + (function { author_email = None ; _ } -> None + | a -> Some a) + (fun s -> s) ; + ] type bug = { bug_url : string option ; bug_email : string option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type package = { name : string ; @@ -105,7 +121,7 @@ type package = { devDependencies : (string * string) list [@assoc] ; [@dft []] bugs : bug option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let package ~displayName ~description @@ -143,7 +159,7 @@ let package type breakpoint = { language : string ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type color_defaults = { color_dark : string option ; @@ -151,20 +167,20 @@ type color_defaults = { color_highContrast : string option ; color_highContrastLight : string option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type color = { color_id : string ; color_description : string ; color_defaults : color_defaults ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type command_icon = { icon_light : string ; (* path *) icon_dark : string ; (* path *) } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let command_icon_enc = Json_encoding.union [ @@ -184,7 +200,7 @@ type command = { command_icon : command_icon option ; command_enablement : string option ; (* Javascript condition *) } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let command ~command ~title ?category ?icon ?enablement () = { command_command = command ; @@ -220,7 +236,7 @@ type property = { prop_maximum : int option ; prop_minItems : int option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let property ?title: prop_title @@ -310,7 +326,7 @@ type configuration = { conf_title : string option ; conf_properties : ( string * property ) list [@assoc] ; [@dft []] } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let configuration ?title properties = { conf_type = None ; conf_title = title ; @@ -319,7 +335,7 @@ let configuration ?title properties = type selector = { filenamePattern : string ; (* glob *) } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type customEditor = { edit_viewType : string ; @@ -327,7 +343,7 @@ type customEditor = { edit_selector : selector list ; edit_priority : string option ; (* "default" or "option" *) } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type debugger = { debugger_type : string ; (* unique ID *) @@ -363,7 +379,7 @@ type debugger = { IntelliSense when editing a launch.json. *) } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type grammar = { (* TextMate grammar for syntax highlighting *) @@ -373,26 +389,26 @@ type grammar = { (* TextMate grammar for syntax highlighting *) grammar_injectTo : string list ; [@dft []] grammar_embeddedLanguages : (string * string) list [@assoc] ; [@dft []] } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type icon = { icon_description : string ; icon_default : (string * string) list [@assoc] ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type iconTheme = { iconTheme_id : string ; iconTheme_label : string ; iconTheme_path : string ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type jsonValidation = { jsonValidation_fileMatch : string ; (* ".json" *) jsonValidation_url : string ; (* scheme URL *) } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type keybinding = { key_command : string ; @@ -401,7 +417,7 @@ type keybinding = { key_when : string option ; (* Javascript condition *) key_args : (string * string) list [@assoc] ; [@dft []] } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let keybinding ~key ?mac ?when_ ?( args = [] ) @@ -421,10 +437,10 @@ type language = { lang_filenames : string list ; [@dft []] lang_filenamePatterns : string list ; [@dft []] lang_firstLine : string option ; - lang_configuration : string option ; (* path *) + lang_configuration : string option ; [@dft None](* path *) lang_icon : command_icon option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let language ?( extensions = [] ) @@ -454,7 +470,7 @@ type menu = { menu_key : string option ; menu_submenu : string option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let menu ?command ?group ?when_ ?key ?submenu () = { menu_command = command ; @@ -465,7 +481,7 @@ let menu ?command ?group ?when_ ?key ?submenu () = } -type fileLocation = string list +type fileLocation = string list [@@deriving show] let fileLocation_enc = let open Json_encoding in @@ -497,7 +513,7 @@ type problemPattern = { pat_loop : bool option ; pat_patterns : problemPattern list ; [@dft []] (* instead of regexp *) } -[@@deriving json_encoding {recursive}] +[@@deriving json_encoding {recursive}, show] let problemPattern ?name @@ -531,6 +547,7 @@ let problemPattern type pattern = ProblemPattern of problemPattern | ProblemName of string +[@@deriving show] let pattern_enc = let open Json_encoding in @@ -552,7 +569,8 @@ type problemMatcher = { pm_source : string option ; pm_severity : string option ; (* info, error, warning *) } -[@@deriving json_encoding] +[@@deriving json_encoding,show] + let problemMatcher ~name ?owner ?(fileLocation = []) ?( pattern = []) ?source ?severity () = { @@ -570,14 +588,14 @@ type productIconTheme = { pit_label : string ; pit_path : string ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] (* A set of completions for a specific language *) type snippet = { snippet_language : string ; snippet_path : string ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let snippet ~language ~path = { snippet_language = language ; snippet_path = path } @@ -586,7 +604,7 @@ type submenu = { submenu_id : string ; submenu_label : string ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let submenu ~id ~label = { submenu_id = id ; submenu_label = label } @@ -595,7 +613,7 @@ type taskDefinition = { task_required : string list ; [@dft []] task_properties : ( string * any ) list [@assoc] ; [@dft []] } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let taskDefinition ~type_ ?(required = []) ?(properties = []) () = { task_type = type_ ; @@ -610,7 +628,7 @@ type view = { view_icon : string option; view_contextualTitle : string option; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let view ~id ~name ?when_ ?icon ?contextualTitle () = { view_id = id ; @@ -625,7 +643,7 @@ type viewsContainer = { vc_title : string ; vc_icon : string option; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let viewsContainer ~id ~title ?icon () = { vc_id = id ; vc_title = title ; vc_icon = icon } @@ -634,17 +652,18 @@ type viewsWelcome = { vw_contents : string ; vw_when : string option; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let viewsWelcome ~view ~contents ?when_ () = { vw_view = view ; vw_contents = contents ; vw_when = when_ } type configurationDefaults = ( string * any ) list [@assoc] -[@@deriving json_encoding] +[@@deriving json_encoding,show] type configurationDefault = | Default of string | Defaults of ( string * any ) list +[@@deriving show] let configurationDefault_enc = let open Json_encoding in @@ -696,7 +715,7 @@ type contributes = { typescriptServerPlugins : any option ; walkthroughs : any option ; } - [@@deriving json_encoding] + [@@deriving json_encoding,show] let contributes ?( breakpoints = [] ) ?( colors = [] ) @@ -759,14 +778,14 @@ let contributes type sponsor = { sponsor_url : string ; [@key "url"] } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let sponsor sponsor_url = { sponsor_url } type galleryBanner = { gallery_color : string option ; gallery_theme : string option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let galleryBanner ?color ?theme () = { gallery_color = color ; gallery_theme = theme } @@ -785,7 +804,7 @@ type marketplace = { sponsor : sponsor option ; galleryBanner : galleryBanner option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let marketplace ?(categories=[]) ?icon ?preview ?(badges=[]) diff --git a/src/vscode/vscode-json/package.toml b/src/vscode/vscode-json/package.toml index 30195487b..854f26ee0 100644 --- a/src/vscode/vscode-json/package.toml +++ b/src/vscode/vscode-json/package.toml @@ -43,7 +43,7 @@ gen-version = "version.ml" # preprocessing options # preprocess = "per-module (((action (run ./toto.sh %{input-file})) mod))" -preprocess = "pps ppx_deriving_encoding" +preprocess = "pps ppx_deriving_encoding ppx_deriving.show" # files to skip while updating at package level # skip = [] diff --git a/src/vscode/vscode-json/snippets.ml b/src/vscode/vscode-json/snippets.ml index b52a94fed..25edc6f80 100644 --- a/src/vscode/vscode-json/snippets.ml +++ b/src/vscode/vscode-json/snippets.ml @@ -18,11 +18,11 @@ type snippet = { scope : string option ; description : string option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] (* paths to files are available from the 'path' field of the 'snippets' field of 'package.json' *) type snippets = ( string * snippet ) list [@assoc] -[@@deriving json_encoding] +[@@deriving json_encoding,show] diff --git a/src/vscode/vscode-json/tasks.ml b/src/vscode/vscode-json/tasks.ml index 9d5ee472b..f44b61906 100644 --- a/src/vscode/vscode-json/tasks.ml +++ b/src/vscode/vscode-json/tasks.ml @@ -19,6 +19,7 @@ let version = "2.0.0" type 'a string_or = | String of string | Or of 'a +[@@deriving show] let string_or_enc encoding = let open Json_encoding in @@ -57,7 +58,7 @@ type runOptions = { *) runOn : string option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type problemPattern = { (** @@ -138,7 +139,7 @@ type problemPattern = { *) loop : bool option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] (** @@ -162,7 +163,7 @@ type backgroundMatcher = { *) endsPattern : string option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] (** @@ -229,7 +230,7 @@ type problemMatcher = { *) background : backgroundMatcher option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type presentationOptions = { @@ -277,13 +278,13 @@ type presentationOptions = { *) group : string option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type groupDescription = { kind : string option ; (* 'build' | 'test' *) isDefault : bool } -[@@deriving json_encoding] +[@@deriving json_encoding,show] (** @@ -293,7 +294,7 @@ type taskDescription = { (** * The task's name *) - label : string; + label : string option; (** * The type of a custom task. Tasks of type "shell" are executed @@ -344,7 +345,7 @@ type taskDescription = { dependsOn : string Manifest.list_or_one ; [@dft []] dependsOrder : string option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type shellDescription = { @@ -359,7 +360,7 @@ type shellDescription = { *) args : string list ; [@dft []] } -[@@deriving json_encoding] +[@@deriving json_encoding,show] (** * Options to be passed to the external program or shell @@ -382,7 +383,7 @@ type commandOptions = { *) shell: shellDescription option ; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type baseTaskConfiguration = { (** @@ -428,9 +429,9 @@ type baseTaskConfiguration = { * The configuration of the available tasks. A tasks.json file can either * contain a global problemMatcher property or a tasks property but not both. *) - (* TODO tasks: taskDescription list; [@dft []] *) + tasks: taskDescription list; [@dft []] } -[@@deriving json_encoding] +[@@deriving json_encoding,show] type taskConfiguration = { base : baseTaskConfiguration ; [@merge] @@ -454,6 +455,7 @@ type taskConfiguration = { *) linux: baseTaskConfiguration option; } -[@@deriving json_encoding] +[@@deriving json_encoding,show] let encoding = taskConfiguration_enc +let pp = pp_taskConfiguration diff --git a/src/vscode/vscode-package-json/dune b/src/vscode/vscode-package-json/dune deleted file mode 100644 index 44186b347..000000000 --- a/src/vscode/vscode-package-json/dune +++ /dev/null @@ -1,41 +0,0 @@ -; generated by drom from package skeleton 'driver' -(executable - (name main) - (public_name vscode-package-json) - (package vscode-package-json) - ; use field 'dune-libraries' to add libraries without opam deps - (libraries vscode-json ezjsonm ez_file ) - (flags (:standard (:include linking.sexp))) - ; use field 'dune-stanzas' to add more stanzas here - (preprocess (pps ppx_deriving_encoding)) - (enabled_if (= %{context_name} "default")) - - ) - -; Use `static-clibs` to specify static C libs (without lib prefix) -; and `static-macos-clibs` and `static-alpine-clibs` for system specific deps -(rule - (targets linking.sexp) - (enabled_if (<> %{ocaml-config:system} mingw64)) - (deps (file linking_flags.sh)) - (action (with-stdout-to %{targets} - (run bash linking_flags.sh linking.sexp %{env:LINKING_MODE=dynamic} %{ocaml-config:system} )))) - -(rule - (targets linking.sexp) - (enabled_if (= %{ocaml-config:system} mingw64)) - (deps (file linking_flags.sh)) - (action (with-stdout-to %{targets} - (run bash -c "echo '()' > linking.sexp")))) - - -(rule - (targets version.ml) - (deps (:script version.mlt) package.toml) - (action (with-stdout-to %{targets} (run %{ocaml} unix.cma %{script})))) - -(documentation - (package vscode-package-json)) - -; use field 'dune-trailer' to add more stuff here - diff --git a/src/vscode/vscode-package-json/linking_flags.sh b/src/vscode/vscode-package-json/linking_flags.sh deleted file mode 100644 index 7fcc1f1c6..000000000 --- a/src/vscode/vscode-package-json/linking_flags.sh +++ /dev/null @@ -1,79 +0,0 @@ -#!/bin/sh - -set -ue - -# This script is called by dune to generate the linking flags for static builds -# (on the limited set of supported platforms). It only returns an empty set of -# flags for the default dynamic linking mode. - -LC_ALL=C - -help_exit() { - echo "Usage: $0 descriptiveID dynamic|static linux|macosx [extra-libs]" >&2 - exit 2 -} - -echo2() { - echo "$*" >&2 - echo "$*" -} - -[ $# -lt 3 ] && help_exit - -descID="$1" -shift - -echo2 ";; $descID" -echo2 ";; generated by $0" - -case "$1" in - dynamic) echo2 "()"; exit 0;; - static) ;; - *) echo "Invalid linking mode '$1'." >&2; help_exit -esac - -shift - -## Static linking configuration ## - -# The linked C libraries list may need updating on changes to the dependencies. -# -# To get the correct list for manual linking, the simplest way is to set the -# flags to `-verbose`, while on the normal `autolink` mode, then extract them -# from the gcc command-line. -# The Makefile contains a target to automate this: `make detect-libs`. - -case "$1" in - linux) - case $(. /etc/os-release && echo $ID) in - alpine) - COMMON_LIBS="bigstringaf_stubs cstruct_stubs camlstr unix c" - # `m` and `pthread` are built-in musl - echo2 '(-noautolink' - echo2 ' -cclib -Wl,-Bstatic' - echo2 ' -cclib -static-libgcc' - for l in $COMMON_LIBS; do - echo2 " -cclib -l$l" - done - echo2 ' -cclib -static)' - ;; - *) - echo2 "Error: static linking is only supported in Alpine, to avoids glibc constraints (use scripts/static-build.sh to build through an Alpine Docker container)" >&2 - exit 3 - esac - ;; - macosx) - COMMON_LIBS=" unix" - # `m` and `pthread` are built-in in libSystem - echo2 '(-noautolink' - for l in $COMMON_LIBS; do - if [ "${l%.a}" != "${l}" ]; then echo2 " -cclib $l" - else echo2 " -cclib -l$l" - fi - done - echo2 ')' - ;; - *) - echo "Static linking is not supported for your platform. See $0 to contribute." >&2 - exit 3 -esac diff --git a/src/vscode/vscode-package-json/linking_flags.sh.drom-tpl b/src/vscode/vscode-package-json/linking_flags.sh.drom-tpl deleted file mode 100644 index f7d60d8d2..000000000 --- a/src/vscode/vscode-package-json/linking_flags.sh.drom-tpl +++ /dev/null @@ -1,79 +0,0 @@ -#!/bin/sh - -set -ue - -# This script is called by dune to generate the linking flags for static builds -# (on the limited set of supported platforms). It only returns an empty set of -# flags for the default dynamic linking mode. - -LC_ALL=C - -help_exit() { - echo "Usage: $0 descriptiveID dynamic|static linux|macosx [extra-libs]" >&2 - exit 2 -} - -echo2() { - echo "$*" >&2 - echo "$*" -} - -[ $# -lt 3 ] && help_exit - -descID="$1" -shift - -echo2 ";; $descID" -echo2 ";; generated by $0" - -case "$1" in - dynamic) echo2 "()"; exit 0;; - static) ;; - *) echo "Invalid linking mode '$1'." >&2; help_exit -esac - -shift - -## Static linking configuration ## - -# The linked C libraries list may need updating on changes to the dependencies. -# -# To get the correct list for manual linking, the simplest way is to set the -# flags to `-verbose`, while on the normal `autolink` mode, then extract them -# from the gcc command-line. -# The Makefile contains a target to automate this: `make detect-libs`. - -case "$1" in - linux) - case $(. /etc/os-release && echo $ID) in - alpine) - COMMON_LIBS="!(static-alpine-clibs) camlstr unix c" - # `m` and `pthread` are built-in musl - echo2 '(-noautolink' - echo2 ' -cclib -Wl,-Bstatic' - echo2 ' -cclib -static-libgcc' - for l in $COMMON_LIBS; do - echo2 " -cclib -l$l" - done - echo2 ' -cclib -static)' - ;; - *) - echo2 "Error: static linking is only supported in Alpine, to avoids glibc constraints (use scripts/static-build.sh to build through an Alpine Docker container)" >&2 - exit 3 - esac - ;; - macosx) - COMMON_LIBS="!(static-macos-clibs) unix" - # `m` and `pthread` are built-in in libSystem - echo2 '(-noautolink' - for l in $COMMON_LIBS; do - if [ "${l%.a}" != "${l}" ]; then echo2 " -cclib $l" - else echo2 " -cclib -l$l" - fi - done - echo2 ')' - ;; - *) - echo "Static linking is not supported for your platform. See $0 to contribute." >&2 - exit 3 -esac diff --git a/src/vscode/vscode-package-json/main.ml b/src/vscode/vscode-package-json/main.ml deleted file mode 100644 index 4b608eb81..000000000 --- a/src/vscode/vscode-package-json/main.ml +++ /dev/null @@ -1,46 +0,0 @@ -(**************************************************************************) -(* *) -(* SuperBOL OSS Studio *) -(* *) -(* *) -(* Copyright (c) 2023 OCamlPro SAS *) -(* *) -(* All rights reserved. *) -(* This source code is licensed under the MIT license found in the *) -(* LICENSE.md file in the root directory of this source tree. *) -(* *) -(* *) -(**************************************************************************) - -let read = ref false - -let print_result f file = - read := true; - match f file with - | [], [] -> - Printf.eprintf "File %s checked OK\n%!" file - | warnings, [] -> - Printf.eprintf "Warnings found in file %s but OK\n%!" file; - List.iter (fun s -> Printf.eprintf " %s\n%!" s) warnings - | warnings, errors -> - Printf.eprintf "Errors found in file %s:\n%!" file; - List.iter (fun s -> Printf.eprintf " %s\n%!" s) errors; - match warnings with - | [] -> () - | _ -> - Printf.eprintf " Warnings also found\n%!"; - List.iter (fun s -> Printf.eprintf " %s\n%!" s) warnings - -let () = - Arg.parse [ - "--tasks", - Arg.String - (print_result (Vscode_json.Main.check_file Vscode_json.Tasks.encoding)), - "FILE Parse file FILE as a tasks.json file"; - - ] - (print_result Vscode_json.Main.check_project) - "package-json [FILES]: parse files or generate file" ; - - if not !read then - Vscode_json.Main.write_file "-" Vscode_json.Manifest.vscode_enc Project.manifest diff --git a/src/vscode/vscode-package-json/package.toml b/src/vscode/vscode-package-json/package.toml deleted file mode 100644 index cb256eff0..000000000 --- a/src/vscode/vscode-package-json/package.toml +++ /dev/null @@ -1,80 +0,0 @@ - -# name of package -name = "vscode-package-json" -skeleton = "program" - -# 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 = "program" - -# 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_encoding" - -# files to skip while updating at package level -# skip = [] - -# package library dependencies -# [dependencies] -# ez_file = ">=0.1 <1.3" -# base-unix = { libname = "unix", version = ">=base" } -[dependencies] -ez_file = "0.3.0" -ezjsonm = "" -vscode-json = "version" - -# package tools dependencies -[tools] -ppx_deriving_encoding = "" - -# 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] -dune-flags = ":standard (:include linking.sexp)" -dune-stanzas = """ - (enabled_if (= %{context_name} \"default\")) -""" -static-alpine-clibs = "bigstringaf_stubs cstruct_stubs" diff --git a/src/vscode/vscode-package-json/version.mlt b/src/vscode/vscode-package-json/version.mlt deleted file mode 100644 index 1bcf00592..000000000 --- a/src/vscode/vscode-package-json/version.mlt +++ /dev/null @@ -1,30 +0,0 @@ -#!/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_parsing/test_combined_relations_parsing.ml b/test/cobol_parsing/test_combined_relations_parsing.ml index 3ee76dec3..59b6bdf0c 100644 --- a/test/cobol_parsing/test_combined_relations_parsing.ml +++ b/test/cobol_parsing/test_combined_relations_parsing.ml @@ -14,17 +14,20 @@ open Alcotest open Cobol_ast -open Cobol_ast.Helpers.Make (Cobol_parser.INTERNAL.Dummy.Tags) +open Cobol_ast.Testing_helpers.Make (Cobol_parser.INTERNAL.Dummy.Tags) open Cobol_parser.INTERNAL.Tokens open Cobol_parser.INTERNAL.Grammar open Cobol_parser.INTERNAL.Dummy let condition: condition testable = testable pp_condition (=) let parse_condition = parse_list_as standalone_condition +let expand_condition = Cobol_ast.Terms_helpers.expand_every_abbrev_cond let check_condition toks cond = - check condition "correct consitions parsing" cond (parse_condition toks) + check condition "correct conditions parsing" cond + (expand_condition @@ parse_condition toks) and fail_condition toks = - check_raises "syntax-error" Error (fun () -> ignore @@ parse_condition toks) + check_raises "syntax-error" Error + (fun () -> ignore @@ parse_condition toks) ;; let test_conditions = diff --git a/test/lsp/lsp_formatting.ml b/test/lsp/lsp_formatting.ml index 334c300dd..5962cb99d 100644 --- a/test/lsp/lsp_formatting.ml +++ b/test/lsp/lsp_formatting.ml @@ -401,10 +401,10 @@ let%expect_test "formatting-request-whole-program" = end_with_postproc [%expect.output]; [%expect {| {"params":{"diagnostics":[],"uri":"file://__rootdir__/superbol.toml"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} - src/lsp/cobol_ast/raw_misc_sections_visitor.ml:66: + raw_misc_sections_visitor.ml:0: (Cobol_ast__Raw_misc_sections_visitor.fold_select_clause): missing visitor implementation - src/lsp/cobol_ast/raw_data_sections_visitor.ml:280: + raw_data_sections_visitor.ml:0: (Cobol_ast__Raw_data_sections_visitor.fold_file_section): missing visitor implementation {"params":{"diagnostics":[{"message":"Source format `auto` is not supported yet, using `fixed`","range":{"end":{"character":0,"line":0},"start":{"character":0,"line":0}},"severity":2}],"uri":"file://__rootdir__/prog.cob"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} diff --git a/test/lsp/lsp_references.ml b/test/lsp/lsp_references.ml index ab58c9767..d8cb3d0b0 100644 --- a/test/lsp/lsp_references.ml +++ b/test/lsp/lsp_references.ml @@ -15,6 +15,9 @@ open EzCompat (* StringMap *) open Lsp.Types open Lsp_testing +(* Used to remove full-path and lines in the test files *) +let () = + Cobol_common.Visitor.in_testsuite := true let print_references ~projdir server (doc, positions) : unit = let server, prog = add_cobol_doc server ~projdir "prog.cob" doc in @@ -57,7 +60,7 @@ let%expect_test "simple-references-requests" = end_with_postproc [%expect.output]; [%expect {| {"params":{"diagnostics":[],"uri":"file://__rootdir__/superbol.toml"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} - src/lsp/cobol_ast/raw_data_sections_visitor.ml:231: + raw_data_sections_visitor.ml:0: (Cobol_ast__Raw_data_sections_visitor.fold_data_clause): partial visitor implementation {"params":{"diagnostics":[{"message":"Source format `auto` is not supported yet, using `fixed`","range":{"end":{"character":0,"line":0},"start":{"character":0,"line":0}},"severity":2}],"uri":"file://__rootdir__/prog.cob"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"} diff --git a/test/output-tests/gnucobol.ml b/test/output-tests/gnucobol.ml index be8234551..40d4cf86f 100644 --- a/test/output-tests/gnucobol.ml +++ b/test/output-tests/gnucobol.ml @@ -40,12 +40,28 @@ let target = (** [pp_relloc ppf filename] prints [filename] relative to [srcdir] if the latter is a directory (prefix) of [filename]. Otherwise, prints [filename] as a whole. *) + (* let pp_relloc = let srcdir_prefix = srcdir ^ Ez_file.FileOS.dir_separator_string in fun ppf s -> - match EzString.chop_prefix ~prefix:srcdir_prefix s with - | Some s -> Fmt.string ppf s - | None -> Fmt.string ppf s + let s = + match EzString.chop_prefix ~prefix:srcdir_prefix s with + | Some s -> s + | None -> s + in + Fmt.string ppf s +*) + +let pp_relloc ppf s = + let path = EzString.split s '/' in + let rec iter path = + match path with + | [] -> s + | "import" :: "gnucobol" :: _ -> String.concat "/" path + | _ :: path -> iter path + in + let s = iter path in + Fmt.string ppf s let make_n_enter_rundir () = Superbol_testutils.Tempdir.make_n_enter "superbol-gnucobol-tests" diff --git a/test/output-tests/preproc.ml b/test/output-tests/preproc.ml index 24cec6c1a..a7246e34a 100644 --- a/test/output-tests/preproc.ml +++ b/test/output-tests/preproc.ml @@ -16,8 +16,22 @@ open Ez_file open FileString.OP open Cobol_preproc +let find_dir anchor = + let curdir = Sys.getcwd () in + let rec iter path = + if Sys.file_exists (path // anchor) then + path + else + let path' = Filename.dirname path in + if path = path' then + Printf.kprintf failwith "Anchor %S not found from %s" anchor curdir; + iter path' + in + iter curdir + let deep_iter = FileString.(make_select iter_dir) ~deep:true -let srcdir = try Unix.getenv "DUNE_SOURCEROOT" with Not_found -> "." +let srcdir = try Unix.getenv "DUNE_SOURCEROOT" with Not_found -> + find_dir "test" let testsuites = "test/testsuite" let ibm_testsuite = testsuites // "ibm/ibmmainframes.com" let ibm_root = srcdir // ibm_testsuite