├── .github ├── dependabot.yml └── workflows │ └── ci.yml ├── .gitignore ├── .ocamlformat ├── CHANGELOG.md ├── LICENSE ├── Makefile ├── README.md ├── assets └── readme_example.png ├── commitlint.config.js ├── dune-project ├── examples ├── dune └── main.ml ├── grace.opam ├── lib ├── ansi_renderer │ ├── config.ml │ ├── dune │ ├── grace_ansi_renderer.ml │ ├── grace_ansi_renderer.mli │ ├── import.ml │ ├── snippet.ml │ ├── snippet.mli │ └── snippet_renderer.ml ├── core │ ├── diagnostic.ml │ ├── diagnostic.mli │ ├── dune │ ├── grace.ml │ ├── grace.mli │ ├── import.ml │ ├── index.ml │ ├── index.mli │ ├── range.ml │ ├── range.mli │ ├── source.ml │ └── source.mli └── source_reader │ ├── dune │ ├── grace_source_reader.ml │ └── grace_source_reader.mli ├── package-lock.json ├── package.json ├── scripts ├── commit-msg-hook.sh ├── install-hooks.sh └── pre-commit-hook.sh └── test ├── ansi_renderer ├── dune └── test_ansi_renderer.ml ├── core ├── dune ├── import.ml └── test_range.ml └── source_reader ├── dune └── test_source_reader.ml /.github/dependabot.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | updates: 3 | - package-ecosystem: github-actions 4 | directory: / 5 | schedule: 6 | interval: weekly 7 | commit-message: 8 | prefix: "chore(deps/actions)" 9 | 10 | - package-ecosystem: npm 11 | directory: / 12 | schedule: 13 | interval: weekly 14 | commit-message: 15 | prefix: "chore(deps/npm)" 16 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: Continuous Integration 2 | 3 | on: 4 | push: 5 | branches: [main] 6 | pull_request: 7 | branches: [main] 8 | 9 | workflow_dispatch: 10 | 11 | jobs: 12 | commitlint: 13 | name: Lint commit messages 14 | runs-on: ubuntu-latest 15 | steps: 16 | - uses: actions/checkout@v4 17 | - uses: wagoid/commitlint-github-action@v5 18 | 19 | fmt: 20 | name: Format 21 | needs: [commitlint] 22 | runs-on: ubuntu-latest 23 | steps: 24 | - uses: actions/checkout@v4 25 | - uses: ocaml/setup-ocaml@v3 26 | with: 27 | ocaml-compiler: ocaml-base-compiler.4.14.0 28 | 29 | - name: Install ocamlformat 30 | run: make install-ocamlformat 31 | 32 | - name: Format code 33 | run: opam exec -- dune build @fmt 34 | 35 | build: 36 | name: Build and test 37 | needs: [fmt] 38 | runs-on: ${{ matrix.os }} 39 | strategy: 40 | fail-fast: false 41 | matrix: 42 | os: 43 | - macos-latest 44 | - ubuntu-latest 45 | ocaml-compiler: 46 | - ocaml-base-compiler.4.14.0 47 | - ocaml-base-compiler.5.0.0 48 | - ocaml-base-compiler.5.1.0 49 | - ocaml-base-compiler.5.2.0 50 | steps: 51 | - uses: actions/checkout@v4 52 | 53 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 54 | uses: ocaml/setup-ocaml@v3 55 | with: 56 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 57 | 58 | - name: Install opam dependencies 59 | run: opam install --deps-only --with-test . 60 | 61 | - name: Build project 62 | run: opam exec -- dune build @install 63 | 64 | - name: Run tests 65 | run: opam exec -- dune test 66 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | 11 | # ocamlbuild working directory 12 | _build/ 13 | 14 | # ocamlbuild targets 15 | *.byte 16 | *.native 17 | 18 | # oasis generated files 19 | setup.data 20 | setup.log 21 | 22 | # Merlin configuring file for Vim and Emacs 23 | .merlin 24 | 25 | # Dune generated files 26 | *.install 27 | 28 | # Local OPAM switch 29 | _opam/ 30 | 31 | # Attic scratchpad 32 | attic/ 33 | TODO.md 34 | 35 | # node modules 36 | node_modules 37 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.26.1 2 | profile=janestreet -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## Unreleased 2 | 3 | * fix(core): use `Format.pp_infinity` in `Message.to_string` for OCaml >5.2 ([#40](https://github.com/johnyob/grace/pull/40) 4 | 5 | ## 0.2.0 (2024-05-28) 6 | 7 | * fix(renderer): remove uncessary underlines when printing a unique 'multi-line `Top` marker' ([#31](https://github.com/johnyob/grace/pull/31)) 8 | * fix(renderer): replace unicode chars with ASCII in `Config.ascii` ([#27](https://github.com/johnyob/grace/pull/27)) 9 | * feat(renderer): add `NO_COLOR` and `TERM` support to `Config` ([#8](https://github.com/johnyob/grace/pull/8)) 10 | * feat(core,renderer): add support for error codes ([#30](https://github.com/johnyob/grace/pull/30)) 11 | * feat(renderer): add support for UTF8 encoding 🚀 ([#25](https://github.com/johnyob/grace/pull/25)) 12 | * feat(renderer): re-introduce support for compact diagnostic rendering ([#28](https://github.com/johnyob/grace/pull/28)) 13 | * refactor(renderer)!: move `grace.renderer` library to `grace.ansi_renderer` ([#29](https://github.com/johnyob/grace/pull/29)) 14 | 15 | ### BREAKING CHANGE 16 | 17 | * `Grace_rendering` has been removed. Use `Grace_ansi_renderer` instead. 18 | 19 | 20 | ## 0.1.0 (2024-01-03) 21 | 22 | Initial release 🎉 -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 Alistair O'Brien 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .DEFAULT_GOAL := all 2 | 3 | .PHONY: all 4 | all: build 5 | 6 | .PHONY: install-ocamlformat 7 | install-ocamlformat: 8 | opam install -y ocamlformat=0.26.1 9 | 10 | .PHONY: install-deps 11 | install-deps: install-switch install-ocamlformat 12 | opam install -y ocaml-lsp-server 13 | opam install -y --deps-only --with-test --with-doc . 14 | 15 | .PHONY: install-switch 16 | install-switch: 17 | opam switch create . 4.14.1 18 | 19 | .PHONY: build 20 | build: 21 | opam exec -- dune build 22 | 23 | .PHONY: install 24 | install: all 25 | opam exec -- dune install --root . 26 | 27 | .PHONY: test 28 | test: 29 | opam exec -- dune runtest 30 | 31 | .PHONY: clean 32 | clean: 33 | opam exec -- dune clean 34 | 35 | .PHONY: doc 36 | doc: 37 | opam exec -- dune build @doc 38 | 39 | .PHONY: fmt 40 | fmt: 41 | opam exec -- dune fmt 42 | 43 | .PHONY: watch 44 | watch: 45 | opam exec -- dune build @run -w --force --no-buffer 46 | 47 | .PHONY: utop 48 | utop: 49 | opam exec -- dune utop -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Grace 💅 2 | 3 | > A fancy diagnostics library that allows your compilers to exit with _grace_ 4 | 5 | Grace is an OCaml 🐪 library that includes a series of interfaces for building, reporting, and rendering beautiful compiler errors 📜. 6 | 7 |
8 | 9 |
10 | 11 | We're still actively working on Grace to support more use cases and improving the quality of the rendering engine. Contributions are very welcome! 12 | 13 | ## Features 14 | 15 | - 📐 Inline and multi-line error messages with associated priorities 16 | - 📂 Multi-file errors 17 | - ⚙️ Configurable rendering (styling and character set) 18 | - 💰 Rich and compact error rendering 19 | - 🌈 Colored messages (thanks to `Fmt`'s `style`) for ANSI terminals 20 | - 💪 Written in OCaml 21 | - 🔠 Unicode support 22 | - 💯 Error codes 23 | 24 | ### Planned Features 25 | 26 | - [ ] LSP integration 27 | - [ ] Accessibility features (improved color options, narratable renderers) 28 | - [ ] HTML renderer 29 | 30 | ## Installation 31 | 32 | This library is available on `opam`. To install 33 | ```sh 34 | opam install grace 35 | ``` 36 | 37 | Users of `dune` can then use this library by adding the appropriate libraries: 38 | 39 | ``` 40 | (library 41 | ... 42 | (libraries grace grace.ansi_renderer ...)) 43 | ``` 44 | 45 | ## Usage 46 | 47 | ```ocaml 48 | open! Grace 49 | 50 | (* Grace provides a [Source] API for in-memory representations of sources/files. *) 51 | let fizz : Source.t = 52 | `String 53 | { name = Some "fizz.ml" 54 | ; content = 55 | {| 56 | let fizz n = 57 | match n mod 5, n mod 3 with 58 | | 0, 0 -> `Fizz_buzz 59 | | 0, _ -> `Fizz 60 | | _, 0 -> `Buzz 61 | | _, _ -> n 62 | ;; 63 | |} 64 | } 65 | ;; 66 | 67 | (* Grace provides support for error codes. 68 | 69 | Error codes are arbitrary types with an explicit [code_to_string] function 70 | which converts the code into a short (googlable) error code. This allows 71 | library users to inspect (and match on) certain types of diagnostics. *) 72 | type code = Incompatible_types 73 | 74 | let code_to_string = function 75 | | Incompatible_types -> "E001" 76 | ;; 77 | 78 | (* Normally locations (ranges) would be taken from AST nodes, but for sake of 79 | this example we construct them directly. *) 80 | let diagnostic = 81 | let range start stop = 82 | Range.create ~source:fizz (Byte_index.of_int start) (Byte_index.of_int stop) 83 | in 84 | Diagnostic.( 85 | createf 86 | ~labels: 87 | Label. 88 | [ primaryf 89 | ~range:(range 116 117) 90 | "expected `[> `Buzz | `Fizz | `Fizz_buzz]`, found `int`" 91 | ; secondaryf ~range:(range 17 117) "`match` cases have incompatible types" 92 | ; secondaryf ~range:(range 57 67) "this is found to be of type `[> `Fizz_buzz]`" 93 | ; secondaryf ~range:(range 80 85) "this is found to be of type `[> `Fizz]`" 94 | ; secondaryf ~range:(range 98 103) "this is found to be of type `[> `Buzz]`" 95 | ] 96 | ~code:Incompatible_types 97 | Error 98 | "`match` cases have incompatible types") 99 | ;; 100 | 101 | let () = 102 | Format.printf 103 | "%a@." 104 | Grace_ansi_renderer.(pp_diagnostic ()) 105 | diagnostic 106 | ;; 107 | ``` 108 | 109 | ## Authors and Acknowledgement 110 | 111 | Authors: 112 | 113 | - Alistair O'Brien (`@johnyob`) 114 | 115 | `grace` was heavily inspired by all the work on compiler diagnostics in the Rust ecosystem: 116 | 117 | - `@brendanzab` for the `codespan` crate which _heavily_ influenced the design of `grace`'s rendering engine. 118 | - `ariadne` (`@zesterer`) for pushing the boundary on diagnostic rendering. 119 | - `rustc` and `@estebank`'s work on the state-of-the-art work on compiler diagnostics 120 | 121 | ## License 122 | 123 | This code is free, under the MIT license. 124 | -------------------------------------------------------------------------------- /assets/readme_example.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/johnyob/grace/3519e4b4884d9f83951489fce5075fb477bd762c/assets/readme_example.png -------------------------------------------------------------------------------- /commitlint.config.js: -------------------------------------------------------------------------------- 1 | module.exports = { extends: ["@commitlint/config-conventional"] }; -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.4) 2 | 3 | (name grace) 4 | 5 | (generate_opam_files true) 6 | 7 | (license MIT) 8 | 9 | (maintainers "alistair.obrien@trili.tech") 10 | 11 | (authors "Alistair O'Brien") 12 | 13 | (source 14 | (github johnyob/grace)) 15 | 16 | (package 17 | (name grace) 18 | (version 0.2.0) 19 | (synopsis 20 | "A fancy diagnostics library that allows your compilers to exit with grace") 21 | (depends 22 | (ocaml 23 | (>= 4.14.0)) 24 | dune 25 | core 26 | ppx_jane 27 | (fmt 28 | (>= 0.8.7)) 29 | dedent 30 | iter 31 | core_unix 32 | uutf 33 | ppx_optcomp)) 34 | -------------------------------------------------------------------------------- /examples/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name main) 4 | (libraries core dedent grace grace.ansi_renderer) 5 | (package grace)) 6 | -------------------------------------------------------------------------------- /examples/main.ml: -------------------------------------------------------------------------------- 1 | open! Grace 2 | 3 | (* Grace provides support for error codes. 4 | Instead of simply using strings, Grace stores error codes as arbitrary types (e.g. variants). 5 | 6 | This permits us to define a set of short error codes that are meaningful to the user, while 7 | still being able to match on the underlying variant when inspecting diagnostics. *) 8 | type code = Incompatible_types 9 | 10 | let code_to_string = function 11 | | Incompatible_types -> "E001" 12 | ;; 13 | 14 | (* Grace provides a [Source] API for in-memory representations of sources/files. *) 15 | let fizz : Source.t = 16 | `String 17 | { name = Some "fizz.ml" 18 | ; content = 19 | {| 20 | let fizz n = 21 | match n mod 5, n mod 3 with 22 | | 0, 0 -> `Fizz_buzz 23 | | 0, _ -> `Fizz 24 | | _, 0 -> `Buzz 25 | | _, _ -> n 26 | ;; 27 | |} 28 | } 29 | ;; 30 | 31 | let diagnostic = 32 | let range start stop = 33 | Range.create ~source:fizz (Byte_index.of_int start) (Byte_index.of_int stop) 34 | in 35 | Diagnostic.( 36 | createf 37 | ~labels: 38 | Label. 39 | [ primaryf 40 | ~range:(range 116 117) 41 | "expected `[> `Buzz | `Fizz | `Fizz_buzz]`, found `int`" 42 | ; secondaryf ~range:(range 17 117) "`match` cases have incompatible types" 43 | ; secondaryf ~range:(range 57 67) "this is found to be of type `[> `Fizz_buzz]`" 44 | ; secondaryf ~range:(range 80 85) "this is found to be of type `[> `Fizz]`" 45 | ; secondaryf ~range:(range 98 103) "this is found to be of type `[> `Buzz]`" 46 | ] 47 | ~code:Incompatible_types 48 | Error 49 | "`match` cases have incompatible types") 50 | ;; 51 | 52 | let () = 53 | Format.printf "%a@." Grace_ansi_renderer.(pp_diagnostic ~code_to_string ()) diagnostic 54 | ;; 55 | -------------------------------------------------------------------------------- /grace.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.2.0" 4 | synopsis: 5 | "A fancy diagnostics library that allows your compilers to exit with grace" 6 | maintainer: ["alistair.obrien@trili.tech"] 7 | authors: ["Alistair O'Brien"] 8 | license: "MIT" 9 | homepage: "https://github.com/johnyob/grace" 10 | bug-reports: "https://github.com/johnyob/grace/issues" 11 | depends: [ 12 | "ocaml" {>= "4.14.0"} 13 | "dune" {>= "3.4"} 14 | "core" 15 | "ppx_jane" 16 | "fmt" {>= "0.8.7"} 17 | "dedent" 18 | "iter" 19 | "core_unix" 20 | "uutf" 21 | "ppx_optcomp" 22 | "odoc" {with-doc} 23 | ] 24 | build: [ 25 | ["dune" "subst"] {dev} 26 | [ 27 | "dune" 28 | "build" 29 | "-p" 30 | name 31 | "-j" 32 | jobs 33 | "@install" 34 | "@runtest" {with-test} 35 | "@doc" {with-doc} 36 | ] 37 | ] 38 | dev-repo: "git+https://github.com/johnyob/grace.git" 39 | -------------------------------------------------------------------------------- /lib/ansi_renderer/config.ml: -------------------------------------------------------------------------------- 1 | open! Import 2 | open Diagnostic 3 | 4 | module Style_sheet = struct 5 | type style = Fmt.style list 6 | 7 | let not_color : Fmt.style -> bool = function 8 | | `None | `Bold | `Faint | `Italic | `Underline | `Reverse -> true 9 | | _ -> false 10 | ;; 11 | 12 | let no_color_style = List.filter ~f:not_color 13 | 14 | type t = 15 | { header_bug : style 16 | ; header_error : style 17 | ; header_warning : style 18 | ; header_note : style 19 | ; header_help : style 20 | ; header_message : style 21 | ; primary_label_bug : style 22 | ; primary_label_error : style 23 | ; primary_label_warning : style 24 | ; primary_label_note : style 25 | ; primary_label_help : style 26 | ; secondary_label : style 27 | ; line_number : style 28 | ; source_border : style 29 | ; note_bullet : style 30 | } 31 | 32 | let map t ~f = 33 | { header_bug = f t.header_bug 34 | ; header_error = f t.header_error 35 | ; header_warning = f t.header_warning 36 | ; header_note = f t.header_note 37 | ; header_help = f t.header_help 38 | ; header_message = f t.header_message 39 | ; primary_label_bug = f t.primary_label_bug 40 | ; primary_label_error = f t.primary_label_error 41 | ; primary_label_warning = f t.primary_label_warning 42 | ; primary_label_note = f t.primary_label_note 43 | ; primary_label_help = f t.primary_label_help 44 | ; secondary_label = f t.secondary_label 45 | ; line_number = f t.line_number 46 | ; source_border = f t.source_border 47 | ; note_bullet = f t.note_bullet 48 | } 49 | ;; 50 | 51 | let no_color t = map t ~f:no_color_style 52 | 53 | let default = 54 | let header color = [ `Bold; `Fg (`Hi color) ] in 55 | let primary_label color = [ `Fg color ] in 56 | { header_bug = header `Red 57 | ; header_error = header `Red 58 | ; header_warning = header `Yellow 59 | ; header_note = header `Green 60 | ; header_help = header `Cyan 61 | ; header_message = [ `Bold ] 62 | ; primary_label_bug = primary_label `Red 63 | ; primary_label_error = primary_label `Red 64 | ; primary_label_warning = primary_label `Yellow 65 | ; primary_label_note = primary_label `Green 66 | ; primary_label_help = primary_label `Cyan 67 | ; secondary_label = [ `Fg `Cyan ] 68 | ; line_number = [ `Fg `Cyan ] 69 | ; source_border = [ `Fg `Cyan ] 70 | ; note_bullet = [ `Fg `Cyan ] 71 | } 72 | ;; 73 | 74 | let header config (severity : Severity.t) = 75 | match severity with 76 | | Bug -> config.header_bug 77 | | Error -> config.header_error 78 | | Warning -> config.header_warning 79 | | Note -> config.header_note 80 | | Help -> config.header_help 81 | ;; 82 | 83 | let label config (priority : Priority.t) (severity : Severity.t) = 84 | match priority, severity with 85 | | Primary, Bug -> config.primary_label_bug 86 | | Primary, Error -> config.primary_label_error 87 | | Primary, Warning -> config.primary_label_warning 88 | | Primary, Note -> config.primary_label_note 89 | | Primary, Help -> config.primary_label_help 90 | | Secondary, _ -> config.secondary_label 91 | ;; 92 | end 93 | 94 | module Chars = struct 95 | type t = 96 | { snippet_start : string 97 | ; source_border_left : string 98 | ; source_border_left_break : string 99 | ; note_bullet : string 100 | ; single_primary_caret : string 101 | ; single_secondary_caret : string 102 | ; multi_primary_caret_start : string 103 | ; multi_primary_caret_end : string 104 | ; multi_secondary_caret_start : string 105 | ; multi_secondary_caret_end : string 106 | ; multi_top_left : string 107 | ; multi_top : string 108 | ; multi_bottom_left : string 109 | ; multi_bottom : string 110 | ; multi_left : string 111 | ; pointer_left : string 112 | } 113 | 114 | let ascii = 115 | { snippet_start = "-->" 116 | ; source_border_left = "|" 117 | ; source_border_left_break = "." 118 | ; note_bullet = "=" 119 | ; single_primary_caret = "^" 120 | ; single_secondary_caret = "-" 121 | ; multi_primary_caret_start = "^" 122 | ; multi_primary_caret_end = "^" 123 | ; multi_secondary_caret_start = "\'" 124 | ; multi_secondary_caret_end = "\'" 125 | ; multi_top_left = "/" 126 | ; multi_top = "-" 127 | ; multi_bottom_left = "\\" 128 | ; multi_bottom = "-" 129 | ; multi_left = "|" 130 | ; pointer_left = "|" 131 | } 132 | ;; 133 | 134 | let unicode = 135 | { snippet_start = "┌─" 136 | ; source_border_left = "│" 137 | ; source_border_left_break = "·" 138 | ; note_bullet = "=" 139 | ; single_primary_caret = "^" 140 | ; single_secondary_caret = "-" 141 | ; multi_primary_caret_start = "^" 142 | ; multi_primary_caret_end = "^" 143 | ; multi_secondary_caret_start = "\'" 144 | ; multi_secondary_caret_end = "\'" 145 | ; multi_top_left = "╭" 146 | ; multi_top = "─" 147 | ; multi_bottom_left = "╰" 148 | ; multi_bottom = "─" 149 | ; multi_left = "│" 150 | ; pointer_left = "│" 151 | } 152 | ;; 153 | end 154 | 155 | type t = 156 | { chars : Chars.t 157 | ; styles : Style_sheet.t 158 | ; use_ansi : bool 159 | } 160 | 161 | let no_color = 162 | match Sys.getenv "NO_COLOR" with 163 | | None | Some "" -> false 164 | | _ -> true 165 | ;; 166 | 167 | let is_rich_term = 168 | match Sys.getenv "TERM" with 169 | | None | Some "" | Some "dumb" -> false 170 | | _ -> true 171 | ;; 172 | 173 | let style_renderer t = if t.use_ansi then `Ansi_tty else `None 174 | 175 | let default = 176 | let styles = if no_color then Style_sheet.(no_color default) else Style_sheet.default in 177 | { chars = Chars.unicode; styles; use_ansi = is_rich_term } 178 | ;; 179 | -------------------------------------------------------------------------------- /lib/ansi_renderer/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name grace_ansi_renderer) 3 | (public_name grace.ansi_renderer) 4 | (libraries core fmt grace grace.source_reader iter uutf) 5 | (preprocess 6 | (pps ppx_jane ppx_optcomp))) 7 | -------------------------------------------------------------------------------- /lib/ansi_renderer/grace_ansi_renderer.ml: -------------------------------------------------------------------------------- 1 | open! Import 2 | module Config = Config 3 | 4 | let default_code_to_string _code = "E????" 5 | 6 | let of_snippet_renderer 7 | snippet_of_diagnostic 8 | ?(config = Config.default) 9 | ?(code_to_string = default_code_to_string) 10 | () 11 | ppf 12 | diagnostic 13 | = 14 | let snippet = Source_reader.with_reader @@ fun () -> snippet_of_diagnostic diagnostic in 15 | Snippet_renderer.pp_snippet ~config ~code_to_string ppf snippet 16 | ;; 17 | 18 | let pp_diagnostic ?config = of_snippet_renderer Snippet.of_diagnostic ?config 19 | 20 | let pp_compact_diagnostic ?config = 21 | of_snippet_renderer Snippet.compact_of_diagnostic ?config 22 | ;; 23 | -------------------------------------------------------------------------------- /lib/ansi_renderer/grace_ansi_renderer.mli: -------------------------------------------------------------------------------- 1 | open Grace 2 | module Config = Config 3 | 4 | val pp_diagnostic 5 | : ?config:Config.t 6 | -> ?code_to_string:('code -> string) 7 | -> unit 8 | -> 'code Diagnostic.t Fmt.t 9 | 10 | val pp_compact_diagnostic 11 | : ?config:Config.t 12 | -> ?code_to_string:('code -> string) 13 | -> unit 14 | -> 'code Diagnostic.t Fmt.t 15 | -------------------------------------------------------------------------------- /lib/ansi_renderer/import.ml: -------------------------------------------------------------------------------- 1 | include Core 2 | include Grace 3 | module Source_reader = Grace_source_reader 4 | module Iter = IterLabels 5 | 6 | module Format = struct 7 | include Format 8 | 9 | [%%if ocaml_version < (5, 2, 0)] 10 | 11 | let pp_max_margin = Int.max_value 12 | 13 | [%%else] 14 | 15 | let pp_max_margin = pp_infinity - 1 16 | 17 | [%%endif] 18 | end 19 | 20 | module Fmt = struct 21 | include Fmt 22 | 23 | let sp ppf () = Fmt.pf ppf " " 24 | let styled_multi style_multi t = List.fold_right style_multi ~init:t ~f:styled 25 | let with_style styles ppf t = styled_multi styles t ppf () 26 | 27 | let repeat ~width t ppf x = 28 | for _ = 1 to width do 29 | t ppf x 30 | done 31 | ;; 32 | 33 | let sps n ppf x = repeat ~width:n sp ppf x 34 | let newline ppf () = Fmt.pf ppf "@." 35 | end 36 | 37 | module List = struct 38 | include List 39 | 40 | let concat_map_with_next t ~f = 41 | let rec loop = function 42 | | [] -> [] 43 | | [ x ] -> f x ~next:None 44 | | x1 :: x2 :: t -> f x1 ~next:(Some x2) @ loop (x2 :: t) 45 | in 46 | loop t 47 | ;; 48 | 49 | let concat_map_with_next_and_prev t ~f = 50 | let rec loop t ~prev = 51 | match t with 52 | | [] -> [] 53 | | [ x ] -> f x ~prev ~next:None 54 | | x1 :: x2 :: t -> 55 | let t' = f x1 ~prev ~next:(Some x2) in 56 | t' @ loop (x2 :: t) ~prev:(last t') 57 | in 58 | loop t ~prev:None 59 | ;; 60 | end 61 | -------------------------------------------------------------------------------- /lib/ansi_renderer/snippet.ml: -------------------------------------------------------------------------------- 1 | open! Import 2 | open! Diagnostic 3 | module Source_descr = Source_reader.Source_descr 4 | 5 | let margin_length_of_string line_content = 6 | (* This is valid for UTF8 as all the whitespace characters we're 7 | interested in wrt a 'margin' have a width of 1. *) 8 | String.length line_content - String.length (String.lstrip line_content) 9 | ;; 10 | 11 | module Utf8 = struct 12 | let length s = 13 | let decoder = Uutf.decoder ~encoding:`UTF_8 (`String s) in 14 | let rec loop acc = 15 | match Uutf.decode decoder with 16 | | `Uchar _ -> loop (acc + 1) 17 | | `End -> acc 18 | | `Malformed _ -> raise (Invalid_argument "invalid UTF-8") 19 | | `Await -> assert false 20 | in 21 | loop 0 22 | ;; 23 | end 24 | 25 | module type Number = Index 26 | 27 | module Int_number = struct 28 | module T = struct 29 | type t = int [@@deriving compare, hash, sexp] 30 | end 31 | 32 | include T 33 | include Comparable.Make (T) 34 | 35 | let invariant t = Invariant.invariant [%here] t sexp_of_t (fun () -> assert (t >= 1)) 36 | let pp = Format.pp_print_int 37 | let to_string = Int.to_string 38 | 39 | let of_int t = 40 | invariant t; 41 | t 42 | ;; 43 | 44 | let initial = 1 45 | 46 | let add t off = 47 | let t = t + off in 48 | invariant t; 49 | t 50 | ;; 51 | 52 | let sub t off = 53 | let t = t - off in 54 | invariant t; 55 | t 56 | ;; 57 | 58 | let diff t1 t2 = t1 - t2 59 | end 60 | 61 | module Line_number = struct 62 | include Int_number 63 | 64 | let of_line_index (idx : Line_index.t) = (idx :> int) + 1 65 | end 66 | 67 | module Column_number = struct 68 | include Int_number 69 | 70 | let of_byte_index (idx : Byte_index.t) ~sd ~line = 71 | let content = Source_reader.(slicei sd (Line.start line) idx) in 72 | let length = Utf8.length content in 73 | length + 1 74 | ;; 75 | end 76 | 77 | module Multi_line_label = struct 78 | module Id = Int 79 | 80 | type t = 81 | | Top of 82 | { id : Id.t 83 | ; start : Column_number.t 84 | ; priority : Priority.t 85 | } 86 | | Bottom of 87 | { id : Id.t 88 | ; stop : Column_number.t 89 | ; priority : Priority.t 90 | ; label : Message.t 91 | } 92 | [@@deriving sexp] 93 | end 94 | 95 | module Line = struct 96 | type stag = 97 | { priority : Priority.t 98 | ; inline_labels : (Priority.t * Message.t) list 99 | } 100 | 101 | and segment = 102 | { content : string 103 | ; length : int 104 | ; stag : stag option 105 | } 106 | 107 | and t = 108 | { segments : segment list 109 | ; multi_line_labels : Multi_line_label.t list 110 | ; margin_length : int 111 | } 112 | [@@deriving sexp] 113 | end 114 | 115 | type block = 116 | { start : Line_index.t 117 | ; lines : Line.t list 118 | } 119 | 120 | and source = 121 | { source : Source.t 122 | ; locus : locus 123 | ; blocks : block list 124 | } 125 | 126 | and locus = Line_number.t * Column_number.t 127 | 128 | and sources = 129 | | Rich of source list 130 | | Compact of (Source.t * locus) list 131 | 132 | and 'code t = 133 | { severity : Severity.t 134 | ; message : Message.t 135 | ; code : 'code option 136 | ; sources : sources 137 | ; notes : Message.t list 138 | } 139 | [@@deriving sexp] 140 | 141 | let locus_of_labels ~sd (labels : Label.t list) = 142 | (* The locus is defined as the earliest highest priority position in the the set of labels *) 143 | let _, locus_idx = 144 | labels 145 | |> List.map ~f:(fun label -> label.priority, Range.start label.range) 146 | |> List.max_elt ~compare:[%compare: Diagnostic.Priority.t * Byte_index.t] 147 | |> Option.value_exn ~here:[%here] 148 | in 149 | let line = Source_reader.Line.of_byte_index sd locus_idx in 150 | Line_number.of_line_index line.idx, Column_number.of_byte_index locus_idx ~sd ~line 151 | ;; 152 | 153 | let group_labels_by_source labels = 154 | labels 155 | |> List.sort_and_group 156 | ~compare: 157 | (Comparable.lift Source.compare ~f:(fun (label : Label.t) -> 158 | Range.source label.range)) 159 | |> List.map ~f:(fun labels -> 160 | (* Invariants: 161 | + [List.length labels > 0] 162 | + Sources for each label are equal *) 163 | let source = Range.source (List.hd_exn labels).range in 164 | source, labels) 165 | ;; 166 | 167 | module Of_diagnostic = struct 168 | type 'a with_line = 169 | { line : Line_index.t 170 | ; it : 'a 171 | } 172 | 173 | let range_of_labels = function 174 | | [] -> assert false 175 | | { Label.range; _ } :: _ as labels -> 176 | List.fold_left 177 | labels 178 | ~f:(fun range label -> Range.merge range label.range) 179 | ~init:range 180 | ;; 181 | 182 | let line_of_range ~sd (line : Source_reader.Line.t) = 183 | let content = Source_reader.Line.slice ~sd line in 184 | { line = line.idx 185 | ; it = 186 | Line. 187 | { segments = [ { content; length = Utf8.length content; stag = None } ] 188 | ; multi_line_labels = [] 189 | ; margin_length = margin_length_of_string content 190 | } 191 | } 192 | ;; 193 | 194 | let line_of_idx ~sd (line_idx : Line_index.t) = 195 | line_of_range ~sd @@ Source_reader.Line.of_line_index sd line_idx 196 | ;; 197 | 198 | module Priority_count = struct 199 | type t = 200 | { primary : int 201 | ; secondary : int 202 | } 203 | 204 | let zero = { primary = 0; secondary = 0 } 205 | 206 | let start t ~priority : t = 207 | match priority with 208 | | Priority.Primary -> { t with primary = t.primary + 1 } 209 | | Secondary -> { t with secondary = t.secondary + 1 } 210 | ;; 211 | 212 | let stop t ~priority : t = 213 | match priority with 214 | | Priority.Primary -> 215 | assert (t.primary > 0); 216 | { t with primary = t.primary - 1 } 217 | | Secondary -> 218 | assert (t.secondary > 0); 219 | { t with secondary = t.secondary - 1 } 220 | ;; 221 | 222 | let priority = function 223 | | { primary = 0; secondary = 0 } -> None 224 | | { primary = 0; secondary = _ } -> Some Priority.Secondary 225 | | { primary = _; secondary = _ } -> Some Primary 226 | ;; 227 | end 228 | 229 | let add_eol_segment ~sd ~(line : Source_reader.Line.t) cursor rev_segments = 230 | let stop = Source_reader.Line.stop line in 231 | if (* If [cursor < stop -1], then we require a non-empty end-of-line segment *) 232 | Byte_index.(add cursor 1 < stop) 233 | then 234 | Line. 235 | { content = Source_reader.slicei sd cursor stop 236 | ; length = Byte_index.(diff stop cursor) 237 | ; stag = None 238 | } 239 | :: rev_segments 240 | else rev_segments 241 | ;; 242 | 243 | let end_segments ~sd ~(line : Source_reader.Line.t) cursor rev_segments = 244 | rev_segments |> add_eol_segment ~sd ~line cursor |> List.rev 245 | ;; 246 | 247 | let segments_of_labels ~sd ~(line : Source_reader.Line.t) (labels : Label.t list) = 248 | (* 1. Convert labels into a interval set consisting of start and stop points *) 249 | let points = 250 | let compare_point = 251 | (* We lexicographically compare the idx and then we order starting points before stopping points *) 252 | Comparable.lift 253 | [%compare: Byte_index.t * [ `Start | `Stop ]] 254 | ~f:(fun (idx, _, start_or_stop) -> 255 | let start_or_stop = 256 | match start_or_stop with 257 | | `Start _ -> `Start 258 | | `Stop -> `Stop 259 | in 260 | idx, start_or_stop) 261 | in 262 | labels 263 | |> List.concat_map ~f:(fun Label.{ range; priority; message } -> 264 | let start, stop = Range.split range in 265 | [ start, priority, `Start message; stop, priority, `Stop ]) 266 | |> List.sort ~compare:compare_point 267 | in 268 | let rev_segments, _, cursor, cursor_labels = 269 | (* 2. Iterate through the interval set, maintaining a: 270 | + List of (reversed) segments 271 | + A priority counter -- a cheap way of deducing the priority of the cursor 272 | + A cursor -- the current byte position we're in the interval set 273 | + A list of labels starting at the cursor ('cursor labels') 274 | *) 275 | let eol = Source_reader.Line.stop line in 276 | List.fold_left 277 | points 278 | ~init:([], Priority_count.zero, Source_reader.Line.start line, []) 279 | ~f: 280 | (fun 281 | (rev_segments, priority_count, cursor, cursor_labels) 282 | (idx, priority, start_or_stop) 283 | -> 284 | (* If the next point is at the current cursor and the cursor is before the 285 | end of the line ... *) 286 | if Byte_index.(cursor = idx) && Byte_index.(idx < eol) 287 | then ( 288 | let priority_count, cursor_msgs = 289 | match start_or_stop with 290 | | `Start msg -> 291 | (* and the point defined a start of a message, we increment the priority counter 292 | and add the label to the cursor labels. *) 293 | ( Priority_count.start priority_count ~priority 294 | , (priority, msg) :: cursor_labels ) 295 | | `Stop -> 296 | (* and the point defined a end of a message, we decrement the priority counter. *) 297 | Priority_count.stop priority_count ~priority, cursor_labels 298 | in 299 | rev_segments, priority_count, cursor, cursor_msgs) 300 | else ( 301 | (* otherwise, we create a segment from 'cursor' to 'idx' and set 'cursor' to 'idx' *) 302 | let content = Source_reader.slicei sd cursor idx in 303 | let segment = 304 | Line. 305 | { content 306 | ; length = Utf8.length content 307 | ; stag = 308 | Option.( 309 | Priority_count.priority priority_count 310 | >>| fun priority -> { priority; inline_labels = cursor_labels }) 311 | } 312 | in 313 | let priority_count, cursor_labels = 314 | match start_or_stop with 315 | | `Start msg -> 316 | Priority_count.start priority_count ~priority, [ priority, msg ] 317 | | `Stop -> Priority_count.stop priority_count ~priority, [] 318 | in 319 | segment :: rev_segments, priority_count, idx, cursor_labels)) 320 | in 321 | assert (List.is_empty cursor_labels); 322 | (* 3. Add end-of-line segment to end the line *) 323 | let segments = end_segments ~sd ~line cursor rev_segments in 324 | segments 325 | ;; 326 | 327 | let line_of_labels ~sd ~line labels multi_line_labels = 328 | let segments = segments_of_labels ~sd ~line labels in 329 | { line = line.idx 330 | ; it = 331 | Line. 332 | { segments 333 | ; multi_line_labels 334 | ; margin_length = margin_length_of_string (Source_reader.Line.slice ~sd line) 335 | } 336 | } 337 | ;; 338 | 339 | let add_contextual_lines ~sd lines = 340 | (* A contextual line is a line satisfying one of: 341 | + withing +/-1 lines of a multi-line label (top or bottom) ('multi line label contextual lines') 342 | + between two other rendered lines ('gap' contextual lines) *) 343 | let add_multi_line_label_contextual_lines = 344 | List.concat_map_with_next_and_prev 345 | ~f:(fun (l2 : Line.t with_line) ~prev:l1 ~next:l3 -> 346 | if List.is_empty l2.it.multi_line_labels 347 | then [ l2 ] 348 | else ( 349 | let next_line = Line_index.(add l2.line 1) in 350 | let prefix = 351 | match l1 with 352 | | None when Line_index.(l2.line > initial) -> 353 | (* No preceeding line and [l2] isn't the first line *) 354 | [ line_of_idx ~sd Line_index.(sub l2.line 1) ] 355 | | Some l1 when Line_index.(diff l2.line l1.line) > 1 -> 356 | (* Preceeding line is not the immediately preceeding line to [l2] *) 357 | [ line_of_idx ~sd Line_index.(sub l2.line 1) ] 358 | | _ -> [] 359 | in 360 | let postfix = 361 | match l3 with 362 | | None when Line_index.(next_line < (Source_reader.Line.last sd).idx) -> 363 | [ line_of_idx ~sd next_line ] 364 | | Some l3 when Line_index.(diff l3.line l2.line) > 1 -> 365 | [ line_of_idx ~sd next_line ] 366 | | _ -> [] 367 | in 368 | prefix @ [ l2 ] @ postfix)) 369 | in 370 | let add_gap_contextual_lines = 371 | List.concat_map_with_next ~f:(fun l1 ~next:l2 -> 372 | match l2 with 373 | | None -> [ l1 ] 374 | | Some l2 -> 375 | let line_delta = Line_index.(diff l2.line l1.line) in 376 | if line_delta <= 0 377 | then assert false 378 | else if line_delta = 1 379 | then [ l1 ] 380 | else if line_delta = 2 381 | then [ l1; line_of_idx ~sd Line_index.(add l1.line 1) ] 382 | else (* [line_delta > 2] *) 383 | [ l1 ]) 384 | in 385 | lines |> add_multi_line_label_contextual_lines |> add_gap_contextual_lines 386 | ;; 387 | 388 | let group = 389 | let splitting_threshold = 2 in 390 | let block ~start ~rest = { start = start.line; lines = start.it :: rest } in 391 | let rec loop = function 392 | | [] -> assert false 393 | | [ l ] -> l, [], [] 394 | | l1 :: ls -> 395 | let l2, ls, blocks = loop ls in 396 | if Line_index.(diff l2.line l1.line) >= splitting_threshold 397 | then l1, [], block ~start:l2 ~rest:ls :: blocks 398 | else l1, l2.it :: ls, blocks 399 | in 400 | function 401 | | [] -> [] 402 | | ls -> 403 | let l, ls, blocks = loop ls in 404 | block ~start:l ~rest:ls :: blocks 405 | ;; 406 | 407 | module Line_labels = struct 408 | type t = 409 | { mutable inline_labels : Label.t list 410 | ; mutable multi_line_labels : Multi_line_label.t list 411 | } 412 | 413 | let create () = { inline_labels = []; multi_line_labels = [] } 414 | 415 | let add_inline_label t inline_label = 416 | t.inline_labels <- inline_label :: t.inline_labels 417 | ;; 418 | 419 | let add_multi_line_label t multi_line_label = 420 | t.multi_line_labels <- multi_line_label :: t.multi_line_labels 421 | ;; 422 | end 423 | 424 | let lines_of_labels ~sd labels = 425 | let range = range_of_labels labels in 426 | let enumerated_labels = List.mapi labels ~f:(fun i label -> i, label) in 427 | let _, rev_lines = 428 | Iter.fold 429 | (Source_reader.lines_in_range sd range) 430 | ~init:(enumerated_labels, []) 431 | ~f:(fun (labels, rev_lines) (line : Source_reader.Line.t) -> 432 | let line_start, line_stop = Source_reader.Line.split line in 433 | (* 1. Initialize per-line state *) 434 | let line_labels = Line_labels.create () in 435 | (* 2. Split labels into [inline_labels] and [multi_line_labels] and filter labels that end at this line *) 436 | let labels = 437 | List.filter labels ~f:(fun ((id, label) : _ * Label.t) -> 438 | let label_start, label_stop = Range.split label.range in 439 | if Byte_index.(line_start <= label_start && label_stop <= line_stop) 440 | then ( 441 | (* Inline label *) 442 | Line_labels.add_inline_label line_labels label; 443 | false) 444 | else if Byte_index.(line_start <= label_start && label_start <= line_stop) 445 | then ( 446 | (* Multi-line label that starts *) 447 | Line_labels.add_multi_line_label line_labels 448 | @@ Multi_line_label.Top 449 | { id 450 | ; start = Column_number.of_byte_index label_start ~line ~sd 451 | ; priority = label.priority 452 | }; 453 | true) 454 | else if Byte_index.(label_start < line_start && line_stop < label_stop) 455 | then (* Multi-line label that goes through this line *) 456 | true 457 | else if Byte_index.(label_start < line_start && label_stop <= line_stop) 458 | then ( 459 | (* Multi-line label that stops through this line *) 460 | Line_labels.add_multi_line_label line_labels 461 | @@ Multi_line_label.Bottom 462 | { id 463 | ; stop = Column_number.of_byte_index label_stop ~line ~sd 464 | ; priority = label.priority 465 | ; label = label.message 466 | }; 467 | false) 468 | else (* Label starts on a later line *) 469 | true) 470 | in 471 | (* Add to [rev_lines] *) 472 | ( labels 473 | , line_of_labels 474 | ~sd 475 | ~line 476 | line_labels.inline_labels 477 | line_labels.multi_line_labels 478 | :: rev_lines )) 479 | in 480 | List.rev rev_lines 481 | ;; 482 | 483 | let block_of_labels ~sd labels = 484 | labels |> lines_of_labels ~sd |> add_contextual_lines ~sd |> group 485 | ;; 486 | 487 | let of_diagnostic Diagnostic.{ severity; message; code; labels; notes } = 488 | let sources = 489 | labels 490 | |> group_labels_by_source 491 | |> List.map ~f:(fun (source, labels) -> 492 | let sd = Source_reader.open_source source in 493 | { source 494 | ; locus = locus_of_labels ~sd labels 495 | ; blocks = block_of_labels ~sd labels 496 | }) 497 | in 498 | { severity; message; code; notes; sources = Rich sources } 499 | ;; 500 | end 501 | 502 | let of_diagnostic = Of_diagnostic.of_diagnostic 503 | 504 | module Compact_of_diagnostic = struct 505 | let of_diagnostic Diagnostic.{ severity; message; code; labels; notes } = 506 | let sources = 507 | labels 508 | |> group_labels_by_source 509 | |> List.map ~f:(fun (source, labels) -> 510 | let sd = Source_reader.open_source source in 511 | let locus = locus_of_labels ~sd labels in 512 | source, locus) 513 | in 514 | { severity; message; code; notes; sources = Compact sources } 515 | ;; 516 | end 517 | 518 | let compact_of_diagnostic = Compact_of_diagnostic.of_diagnostic 519 | -------------------------------------------------------------------------------- /lib/ansi_renderer/snippet.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Grace 3 | open! Diagnostic 4 | 5 | (** [Number]s are indexes (with different initial constraints) *) 6 | module type Number = Index 7 | 8 | module Line_number : sig 9 | include Number 10 | 11 | val of_line_index : Line_index.t -> t 12 | end 13 | 14 | module Column_number : Number 15 | 16 | module Multi_line_label : sig 17 | module Id : Identifiable.S 18 | 19 | (** A multi-line-label is defined by a [Top] and [Bottom] marker within a {!type:source}. *) 20 | type t = 21 | | Top of 22 | { id : Id.t (** The unique identifier. *) 23 | ; start : Column_number.t (** The column number of the start of the label. *) 24 | ; priority : Priority.t (** The priority of the label. *) 25 | } 26 | | Bottom of 27 | { id : Id.t (** The unique identifier. *) 28 | ; stop : Column_number.t (** The column number of the end of the label *) 29 | ; priority : Priority.t (** The priority of the label. *) 30 | ; label : Message.t (** The message of the label. *) 31 | } 32 | [@@deriving sexp] 33 | end 34 | 35 | module Line : sig 36 | (** A semantic tag *) 37 | type stag = 38 | { priority : Priority.t 39 | ; inline_labels : (Priority.t * Message.t) list 40 | } 41 | 42 | (** A segment is a string with an optional semantic tag. *) 43 | and segment = 44 | { content : string 45 | ; length : int 46 | ; stag : stag option 47 | } 48 | 49 | (** A line is a list of {!type:segment}s with {{!type:Multi_line_label.t} multi-line label}s. *) 50 | and t = 51 | { segments : segment list 52 | ; multi_line_labels : Multi_line_label.t list 53 | ; margin_length : int 54 | } 55 | [@@deriving sexp] 56 | end 57 | 58 | (** A block is a list of consecutive lines. *) 59 | type block = 60 | { start : Line_index.t 61 | (** The starting {{!type:Line_index.t} line index} of the block. *) 62 | ; lines : Line.t list (** The {{!type:Line.t} line}s in the block. *) 63 | } 64 | 65 | (** A source consists of multiple blocks within the same {{!type:Source.t} source}. *) 66 | and source = 67 | { source : Source.t (** The source. *) 68 | ; locus : locus (** The 'locus' position in the file. *) 69 | ; blocks : block list 70 | (** The list of {!type:block}s. The blocks are non-overlapping and sorted. *) 71 | } 72 | 73 | and locus = Line_number.t * Column_number.t 74 | 75 | and sources = 76 | | Rich of source list 77 | | Compact of (Source.t * locus) list 78 | 79 | (** The type of a snippet, an internal representation of a rendered diagnostic. *) 80 | and 'code t = 81 | { severity : Severity.t (** The severity of the diagnostic. *) 82 | ; message : Message.t (** The primary message of the diagnostic. *) 83 | ; code : 'code option (** The code associated with the diagnostic. *) 84 | ; sources : sources (** The sources associated with the diagnostic. *) 85 | ; notes : Message.t list (** The notes of the diagnostic. *) 86 | } 87 | [@@deriving sexp] 88 | 89 | (** [of_diagnostic diagnostic] returns the ('rich') snippet compiled from the [diagnostic]. *) 90 | val of_diagnostic : 'code Diagnostic.t -> 'code t 91 | 92 | (** [compact_of_diagnostic diagnostic] returns the 'compact' snippet compiled from the [diagnostic]. *) 93 | val compact_of_diagnostic : 'code Diagnostic.t -> 'code t 94 | -------------------------------------------------------------------------------- /lib/ansi_renderer/snippet_renderer.ml: -------------------------------------------------------------------------------- 1 | open! Import 2 | open Diagnostic 3 | open Snippet 4 | open Config 5 | module Multi_id = Multi_line_label.Id 6 | 7 | let pp_label_styled ~(config : Config.t) ~severity ~priority pp = 8 | Fmt.styled_multi (Style_sheet.label config.styles priority severity) pp 9 | ;; 10 | 11 | let pp_label_styled_string ~config ~severity ~priority = 12 | pp_label_styled ~config ~severity ~priority Fmt.string 13 | ;; 14 | 15 | module Chars = struct 16 | let pp_source_border_left ~(config : Config.t) ppf () = 17 | Fmt.( 18 | styled_multi config.styles.source_border string ppf config.chars.source_border_left) 19 | ;; 20 | 21 | let pp_source_border_left_break ~(config : Config.t) ppf () = 22 | Fmt.( 23 | styled_multi 24 | config.styles.source_border 25 | string 26 | ppf 27 | config.chars.source_border_left_break) 28 | ;; 29 | 30 | let pp_caret ~(config : Config.t) ~severity ~priority ppf () = 31 | let caret = 32 | match priority with 33 | | Priority.Primary -> config.chars.single_primary_caret 34 | | Secondary -> config.chars.single_secondary_caret 35 | in 36 | pp_label_styled_string ~config ~severity ~priority ppf caret 37 | ;; 38 | 39 | let pp_pointer_left ~(config : Config.t) ~severity ~priority ppf () = 40 | pp_label_styled_string ~config ~severity ~priority ppf config.chars.pointer_left 41 | ;; 42 | 43 | let pp_multi_top ~(config : Config.t) ~severity ~priority ppf () = 44 | pp_label_styled_string ~config ~severity ~priority ppf config.chars.multi_top 45 | ;; 46 | 47 | let pp_multi_bottom ~(config : Config.t) ~severity ~priority ppf () = 48 | pp_label_styled_string ~config ~severity ~priority ppf config.chars.multi_bottom 49 | ;; 50 | 51 | let pp_multi_caret_start ~(config : Config.t) ~severity ~priority ppf () = 52 | let caret_start = 53 | match priority with 54 | | Priority.Primary -> config.chars.multi_primary_caret_start 55 | | Secondary -> config.chars.multi_secondary_caret_start 56 | in 57 | pp_label_styled_string ~config ~severity ~priority ppf caret_start 58 | ;; 59 | 60 | let pp_multi_caret_end ~(config : Config.t) ~severity ~priority ppf () = 61 | let caret_end = 62 | match priority with 63 | | Priority.Primary -> config.chars.multi_primary_caret_end 64 | | Secondary -> config.chars.multi_secondary_caret_end 65 | in 66 | pp_label_styled_string ~config ~severity ~priority ppf caret_end 67 | ;; 68 | 69 | let pp_snippet_start ~(config : Config.t) ppf () = 70 | Fmt.styled_multi config.styles.source_border Fmt.string ppf config.chars.snippet_start 71 | ;; 72 | 73 | let pp_note_bullet ~(config : Config.t) ppf () = 74 | Fmt.styled_multi config.styles.note_bullet Fmt.string ppf config.chars.note_bullet 75 | ;; 76 | end 77 | 78 | let pp_severity ~(config : Config.t) ppf severity = 79 | Fmt.with_style (Style_sheet.header config.styles severity) ppf 80 | @@ fun ppf () -> Severity.pp ppf severity 81 | ;; 82 | 83 | let pp_header_message ~(config : Config.t) = 84 | Fmt.styled_multi config.styles.header_message Message.pp 85 | ;; 86 | 87 | let pp_message ~(config : Config.t) ~severity ~priority ppf message = 88 | Fmt.styled_multi 89 | (Style_sheet.label config.styles priority severity) 90 | Message.pp 91 | ppf 92 | message 93 | ;; 94 | 95 | type multi_kind = 96 | [ `Top of [ `Unique | `Non_unique ] 97 | | `Vertical 98 | | `Bottom 99 | ] 100 | 101 | module Multi_context = struct 102 | type t = 103 | { gutters : (Priority.t * multi_kind) Option_array.t 104 | ; bindings : int Multi_id.Table.t 105 | } 106 | 107 | let create ~len = 108 | { gutters = Option_array.create ~len; bindings = Multi_id.Table.create () } 109 | ;; 110 | 111 | let length t = Option_array.length t.gutters 112 | 113 | let def t ~multi_id ~top_kind ~priority prologue = 114 | assert (not (Hashtbl.mem t.bindings multi_id)); 115 | let gutter, _ = 116 | (* Find the next free available gutter (one such gutter *must* exist!) *) 117 | t.gutters 118 | |> Option_array.findi ~f:(fun _ gutter -> Option.is_none gutter) 119 | |> Option.value_exn ~here:[%here] 120 | in 121 | Hashtbl.set t.bindings ~key:multi_id ~data:gutter; 122 | (* Set gutter to `Top *) 123 | Option_array.set_some t.gutters gutter (priority, `Top top_kind); 124 | (* Execute 'prologue' for multi-line label *) 125 | prologue (); 126 | (* Set gutter to `Vertical *) 127 | Option_array.set_some t.gutters gutter (priority, `Vertical) 128 | ;; 129 | 130 | let free t ~multi_id epilogue = 131 | let gutter = Hashtbl.find_exn t.bindings multi_id in 132 | let priority, _ = Option_array.get_some_exn t.gutters gutter in 133 | (* Set gutter to `Bottom *) 134 | Option_array.set_some t.gutters gutter (priority, `Bottom); 135 | (* Execute 'epilogue' for multi-line label *) 136 | epilogue (); 137 | (* Remove bindings for multi-line label *) 138 | Option_array.set_none t.gutters gutter; 139 | Hashtbl.remove t.bindings multi_id 140 | ;; 141 | end 142 | 143 | let pp_multi_vertline ~(config : Config.t) ~severity ~priority ppf kind = 144 | let gutter = 145 | match kind with 146 | | `Top (`Unique | `Non_unique) -> config.chars.multi_top_left 147 | | `Vertical -> config.chars.multi_left 148 | | `Bottom -> config.chars.multi_bottom_left 149 | in 150 | pp_label_styled_string ~config ~severity ~priority ppf gutter 151 | ;; 152 | 153 | let pp_multi_underline ~(config : Config.t) ~severity ~priority ppf kind = 154 | match kind with 155 | | `Top `Non_unique -> Chars.pp_multi_top ~config ~severity ~priority ppf () 156 | | `Top `Unique -> 157 | (* For unique multi-lines, the underline is removed *) 158 | Fmt.sp ppf () 159 | | `Bottom -> Chars.pp_multi_bottom ~config ~severity ~priority ppf () 160 | | `Vertical -> Fmt.sp ppf () 161 | ;; 162 | 163 | let pp_multi_lines ~(config : Config.t) ~severity ppf (mctxt : Multi_context.t) = 164 | let set_sep, pr_sep = 165 | let sep = ref Fmt.sp in 166 | (fun sep' -> sep := sep'), fun () -> !sep ppf () 167 | in 168 | for i = 0 to Multi_context.length mctxt - 1 do 169 | match Option_array.get mctxt.gutters i with 170 | | None -> 171 | (* Print the [sep] for the missing gutter and a trailing separator. *) 172 | pr_sep (); 173 | pr_sep () 174 | | Some (priority, kind) -> 175 | (* Set the separate (if necessary) *) 176 | set_sep (fun ppf () -> pp_multi_underline ~config ~severity ~priority ppf kind); 177 | (* Print the gutter line and a trailing separator. *) 178 | pp_multi_vertline ~config ~severity ~priority ppf kind; 179 | pr_sep () 180 | done; 181 | (* Print a trailing separator *) 182 | pr_sep () 183 | ;; 184 | 185 | type context = 186 | { line_num_width : int 187 | ; multi_context : Multi_context.t 188 | } 189 | 190 | let pp_line_number ~(config : Config.t) ~ctxt ppf (lnum : Line_number.t) = 191 | Fmt.with_style config.styles.line_number ppf 192 | @@ fun ppf () -> Fmt.pf ppf "%*d" ctxt.line_num_width (lnum :> int) 193 | ;; 194 | 195 | let pp_source_line ~config ~severity ~ctxt ~lnum ppf (line : Line.t) = 196 | let pp_segment ppf (segment : Line.segment) = 197 | let content = 198 | (* FIXME: We should strip the content in [Snippet.of_diagnostic] *) 199 | String.rstrip segment.content ~drop:(function 200 | | '\n' | '\r' -> true 201 | | _ -> false) 202 | in 203 | match segment.stag with 204 | | Some { priority = Primary; _ } -> 205 | (* If primary, style the content *) 206 | pp_label_styled_string ~config ~severity ~priority:Primary ppf content 207 | | _ -> 208 | (* Otherwise, simply print the content *) 209 | Fmt.string ppf content 210 | in 211 | Fmt.( 212 | pf 213 | ppf 214 | "@[%a %a %a%a@]" 215 | (pp_line_number ~config ~ctxt) 216 | lnum 217 | (Chars.pp_source_border_left ~config) 218 | () 219 | (pp_multi_lines ~config ~severity) 220 | ctxt.multi_context 221 | (list ~sep:nop pp_segment) 222 | line.segments) 223 | ;; 224 | 225 | let pp_line_break ~config ~severity ~ctxt ppf () = 226 | Fmt.pf 227 | ppf 228 | "@[%*s %a %a@]" 229 | ctxt.line_num_width 230 | "" 231 | (Chars.pp_source_border_left_break ~config) 232 | () 233 | (pp_multi_lines ~config ~severity) 234 | ctxt.multi_context 235 | ;; 236 | 237 | (* prefixed box *) 238 | let pbox ~prefix pp ppf x = 239 | let s = Fmt.str_like ppf "%a" pp x in 240 | let lines = String.split_lines s in 241 | let nlines = List.length lines in 242 | List.iteri lines ~f:(fun i line -> 243 | Fmt.pf ppf "@[%s%s@]" prefix line; 244 | if i <> nlines - 1 then Fmt.newline ppf ()) 245 | ;; 246 | 247 | (* prefixed-with-indent box *) 248 | let pwibox ~prefix pp ppf x = 249 | let s = Fmt.str_like ppf "%a" pp x in 250 | let lines = String.split_lines s in 251 | let nlines = List.length lines in 252 | let nprefix = String.length prefix in 253 | List.iteri lines ~f:(fun i line -> 254 | if i = 0 255 | then Fmt.pf ppf "@[%s%s@]" prefix line 256 | else Fmt.pf ppf "@[%*s%s@]" nprefix "" line; 257 | if i <> nlines - 1 then Fmt.newline ppf ()) 258 | ;; 259 | 260 | (* line box *) 261 | let lbox ~config ~severity ~ctxt pp ppf x = 262 | let prefix = 263 | Fmt.str_like 264 | ppf 265 | "%*s %a %a" 266 | ctxt.line_num_width 267 | "" 268 | (Chars.pp_source_border_left ~config) 269 | () 270 | (pp_multi_lines ~config ~severity) 271 | ctxt.multi_context 272 | in 273 | pbox ~prefix pp ppf x 274 | ;; 275 | 276 | module Multi_line_label = struct 277 | let pp_underlines ~config ~severity ~priority ~width = 278 | Fmt.repeat ~width (pp_multi_underline ~config ~severity ~priority) 279 | ;; 280 | 281 | let pp_top ~config ~severity ppf (width, priority) = 282 | pp_underlines ~config ~severity ~priority ~width ppf (`Top `Non_unique); 283 | Chars.pp_multi_caret_start ~config ~severity ~priority ppf () 284 | ;; 285 | 286 | let pp_bottom ~config ~severity ppf (width, priority, label) = 287 | let prefix = 288 | Fmt.str_like 289 | ppf 290 | "%a%a " 291 | (pp_underlines ~config ~severity ~priority ~width) 292 | `Bottom 293 | (Chars.pp_multi_caret_end ~config ~severity ~priority) 294 | () 295 | in 296 | pwibox ~prefix (pp_message ~config ~severity ~priority) ppf label 297 | ;; 298 | 299 | let pp_content_top ~ctxt ~(top : Multi_line_label.t option) pp ppf x = 300 | match top with 301 | | Some mll -> 302 | (match mll with 303 | | Top { id = multi_id; priority; _ } -> 304 | Multi_context.def ctxt.multi_context ~multi_id ~top_kind:`Unique ~priority 305 | @@ fun () -> pp ppf x 306 | | _ -> assert false) 307 | | None -> pp ppf x 308 | ;; 309 | 310 | let pp ~config ~severity ~ctxt ppf (multi_line_label : Multi_line_label.t) = 311 | match multi_line_label with 312 | | Bottom { id; stop; priority; label } -> 313 | Multi_context.free ctxt.multi_context ~multi_id:id 314 | @@ fun () -> 315 | pp_multi_lines ~config ~severity ppf ctxt.multi_context; 316 | pp_bottom 317 | ~config 318 | ~severity 319 | ppf 320 | (* [-2] since we want a [-1] offset and [stop] is a column number (starting at 1) *) 321 | ((stop :> int) - 2, priority, label) 322 | | Top { id; start; priority } -> 323 | Multi_context.def ctxt.multi_context ~multi_id:id ~top_kind:`Non_unique ~priority 324 | @@ fun () -> 325 | pp_multi_lines ~config ~severity ppf ctxt.multi_context; 326 | (* [-1] since [start] is a column number (starting at 1) *) 327 | pp_top ~config ~severity ppf ((start :> int) - 1, priority) 328 | ;; 329 | end 330 | 331 | module Inline_labels = struct 332 | (** An inline segment with dangling pointers, with optional messages. *) 333 | type hanging_segment = 334 | { offset : Column_number.t (** The offset into the line *) 335 | ; length : int (** The length of the segment > 0 *) 336 | ; priority : Priority.t 337 | ; messages : Message.t list 338 | } 339 | 340 | type trailing_segment = 341 | { offset : Column_number.t 342 | ; length : int 343 | ; priority : Priority.t 344 | ; message : Message.t 345 | } 346 | 347 | (** A rendering IR for inline labels *) 348 | type t = 349 | { trailing_segment : trailing_segment option (** An optional trailing label *) 350 | ; hanging_segments : hanging_segment list 351 | (** A lexically sorted list of hanging segments *) 352 | } 353 | 354 | let is_empty { hanging_segments; trailing_segment } = 355 | List.is_empty hanging_segments && Option.is_none trailing_segment 356 | ;; 357 | 358 | let pp_trailing_label ~config ~severity = 359 | Fmt.( 360 | option ~none:nop 361 | @@ fun ppf ({ message; priority; _ } : trailing_segment) -> 362 | Fmt.pf ppf " %a" (pp_message ~config ~severity ~priority) message) 363 | ;; 364 | 365 | let pp_carets ~config ~severity ppf { hanging_segments; trailing_segment } = 366 | (* [cursor] is used to keep track of the position in the current line buffer *) 367 | let cursor = ref Column_number.initial in 368 | let pr_segment (offset, length, priority) = 369 | assert (Column_number.(!cursor <= offset)); 370 | (* Print spaces up until [range] *) 371 | Fmt.sps Column_number.(diff offset !cursor) ppf (); 372 | (* Print carets *) 373 | (* FIXME: This max 1 is to handle when the segment is empty. 374 | This only occurs with special zero-width segments (like EOL or EOF) *) 375 | Fmt.(repeat ~width:(max 1 length) @@ Chars.pp_caret ~config ~severity ~priority) 376 | ppf 377 | (); 378 | (* Update cursor to be stop *) 379 | cursor := Column_number.(add offset length) 380 | in 381 | (* Render the carets for hanging and trailing segments *) 382 | List.iter hanging_segments ~f:(fun { offset; length; priority; _ } -> 383 | pr_segment (offset, length, priority)); 384 | Option.iter trailing_segment ~f:(fun { offset; length; priority; _ } -> 385 | pr_segment (offset, length, priority)) 386 | ;; 387 | 388 | let pp_hanging_segments ~config ~severity ppf segments = 389 | let str_pointer_left priority = 390 | Fmt.str_like ppf "%a" (Chars.pp_pointer_left ~config ~severity ~priority) () 391 | in 392 | let pp_messages ~priority = 393 | let open Fmt in 394 | vbox @@ list ~sep:newline @@ hbox @@ pp_message ~config ~severity ~priority 395 | in 396 | let rec loop cursor pointers = function 397 | | [] -> 398 | (* Print the initial hanging pointers *) 399 | Fmt.pf ppf "%s" pointers 400 | | { offset; length; priority = _; messages = [] } :: segments -> 401 | assert (Column_number.(cursor <= offset)); 402 | (* In the case of an empty hanging segment, simply print the spaces and move the cursor *) 403 | let pointers = 404 | String.append 405 | pointers 406 | (String.make Column_number.(diff (add offset length) cursor) ' ') 407 | in 408 | loop Column_number.(add offset length) pointers segments 409 | | { offset; length = _; priority; messages = _ :: _ as messages } :: segments -> 410 | assert (Column_number.(cursor <= offset)); 411 | (* Prefix the pointers with spaces *) 412 | let pointers = 413 | String.append pointers (String.make Column_number.(diff offset cursor) ' ') 414 | in 415 | (* Print the pointers & messages above this message adding a pointer for this set of messages 416 | Invariant: offset + length >= offset + 1 <=> length > 0 *) 417 | loop 418 | Column_number.(add offset 1) 419 | String.(pointers ^ str_pointer_left priority) 420 | segments; 421 | Fmt.newline ppf (); 422 | (* Print the messages *) 423 | pbox ~prefix:pointers (pp_messages ~priority) ppf messages 424 | in 425 | loop Column_number.initial "" segments 426 | ;; 427 | 428 | let pp ~config ~severity ppf t = 429 | (* Print carets *) 430 | pp_carets ~config ~severity ppf t; 431 | (* Print trailing label *) 432 | pp_trailing_label ~config ~severity ppf t.trailing_segment; 433 | (* If non-empty, print the hanging segments *) 434 | if not (List.is_empty t.hanging_segments) 435 | then Fmt.pf ppf "@.%a" (pp_hanging_segments ~config ~severity) t.hanging_segments 436 | ;; 437 | 438 | let as_trailing_segment { priority; offset; length; messages } : trailing_segment option 439 | = 440 | match messages with 441 | | [ message ] -> Some { priority; offset; length; message } 442 | | _ -> None 443 | ;; 444 | 445 | let of_segments (segments : Line.segment list) : t = 446 | let rec loop (segments : Line.segment list) accu = 447 | let rev_segments, offset, prev_segment = accu in 448 | match segments with 449 | | [] -> 450 | (* Determine if the last segment is a trailing segment *) 451 | (* A trailing segment is defined by: 452 | - the last segment on the line 453 | - the span of the label in the trailing segment doesn't intersect any 454 | other label on the line 455 | *) 456 | (match Option.(prev_segment >>= as_trailing_segment) with 457 | | Some trailing_segment -> 458 | let hanging_segments = List.rev rev_segments in 459 | { hanging_segments; trailing_segment = Some trailing_segment } 460 | | None -> 461 | let hanging_segments = List.rev (Option.to_list prev_segment @ rev_segments) in 462 | { hanging_segments; trailing_segment = None }) 463 | | { stag = None; content = _; length } :: segments -> 464 | (* Segments with no semantic tag cannot be hanging (or trailing) segments *) 465 | loop segments (rev_segments, Column_number.(add offset length), prev_segment) 466 | | { stag = Some { priority; inline_labels }; content = _; length } :: segments -> 467 | let messages = 468 | (* Ensure that higher priority messages are printed first *) 469 | inline_labels 470 | |> List.sort 471 | ~compare: 472 | (Comparable.lift (Comparable.reverse Priority.compare) ~f:Tuple2.get1) 473 | |> List.map ~f:Tuple2.get2 474 | in 475 | loop 476 | segments 477 | ( Option.to_list prev_segment @ rev_segments 478 | , Column_number.add offset length 479 | , Some { priority; messages; offset; length } ) 480 | in 481 | loop segments ([], Column_number.initial, None) 482 | ;; 483 | end 484 | 485 | let pp_multi_line_label ~config ~severity ~ctxt ppf multi_line_label = 486 | Fmt.pf 487 | ppf 488 | "@[%*s %a %a@]" 489 | ctxt.line_num_width 490 | "" 491 | (Chars.pp_source_border_left ~config) 492 | () 493 | (Multi_line_label.pp ~config ~severity ~ctxt) 494 | multi_line_label 495 | ;; 496 | 497 | let pp_line ~config ~severity ~ctxt ~lnum ppf (line : Line.t) = 498 | (* Convert segments to inline labels *) 499 | let inline_labels = Inline_labels.of_segments line.segments in 500 | (* Render multi-line top in line content if: 501 | - unique top in multi_line_labels 502 | - top starts in the whitespace/start of new line *) 503 | let multi_line_labels, unique_top_multi_line_label = 504 | List.fold_right 505 | line.multi_line_labels 506 | ~init:([], None) 507 | ~f:(fun multi_line_label (mlls, utmll) -> 508 | match multi_line_label with 509 | | Top { start; _ } when (start :> int) - 1 <= line.margin_length -> 510 | (match utmll with 511 | | None -> mlls, Some multi_line_label 512 | | Some utmll -> multi_line_label :: utmll :: mlls, None) 513 | | _ -> multi_line_label :: mlls, utmll) 514 | in 515 | (* print_s 516 | [%message 517 | "Mll top" 518 | (margin_length : int) 519 | (multi_line_labels : Snippet.Multi_line_label.t list) 520 | (unique_top_multi_line_label : Snippet.Multi_line_label.t option)]; *) 521 | (* Print source line (with potential top multi-line label) *) 522 | Multi_line_label.pp_content_top 523 | ~ctxt 524 | ~top:unique_top_multi_line_label 525 | (pp_source_line ~config ~severity ~ctxt ~lnum) 526 | ppf 527 | line; 528 | (* Print inline labels (if any) *) 529 | if not (Inline_labels.is_empty inline_labels) 530 | then ( 531 | Fmt.newline ppf (); 532 | lbox ~config ~severity ~ctxt (Inline_labels.pp ~config ~severity) ppf inline_labels); 533 | (* Print multi-line labels (if any) *) 534 | List.iter multi_line_labels ~f:(fun multi_line_label -> 535 | Fmt.newline ppf (); 536 | pp_multi_line_label ~config ~severity ~ctxt ppf multi_line_label) 537 | ;; 538 | 539 | let pp_locus ~source ppf (line_num, col_num) = 540 | Fmt.pf 541 | ppf 542 | "@[%s:%a:%a@]" 543 | (Option.value (Source.name source) ~default:"unknown") 544 | Line_number.pp 545 | line_num 546 | Column_number.pp 547 | col_num 548 | ;; 549 | 550 | let pp_source_start ~config ~ctxt ~source ppf locus = 551 | Fmt.pf 552 | ppf 553 | "@[%*s %a %a@]" 554 | ctxt.line_num_width 555 | "" 556 | (Chars.pp_snippet_start ~config) 557 | () 558 | (pp_locus ~source) 559 | locus 560 | ;; 561 | 562 | let pp_line_gutter ~config ~ctxt ppf () = 563 | Fmt.pf 564 | ppf 565 | "@[%*s %a@]" 566 | ctxt.line_num_width 567 | "" 568 | (Chars.pp_source_border_left ~config) 569 | () 570 | ;; 571 | 572 | let pp_block ~config ~severity ~ctxt ppf ({ start; lines } : Snippet.block) = 573 | List.iteri lines ~f:(fun i line -> 574 | if i <> 0 then Fmt.newline ppf (); 575 | let lnum = Line_number.of_line_index @@ Line_index.add start i in 576 | pp_line ~config ~severity ~ctxt ~lnum ppf line) 577 | ;; 578 | 579 | let pp_source 580 | ~config 581 | ~severity 582 | ~line_num_width 583 | ~multi_width 584 | ppf 585 | ({ source; blocks; locus } : Snippet.source) 586 | = 587 | let ctxt = { multi_context = Multi_context.create ~len:multi_width; line_num_width } in 588 | pp_source_start ~config ~ctxt ~source ppf locus; 589 | if not (List.is_empty blocks) then Fmt.pf ppf "@."; 590 | List.iteri blocks ~f:(fun i block -> 591 | if i <> 0 592 | then ( 593 | Fmt.newline ppf (); 594 | pp_line_break ~config ~severity ~ctxt ppf ()); 595 | pp_block ~config ~severity ~ctxt ppf block) 596 | ;; 597 | 598 | let pp_code ~config ~code_to_string ~severity ppf code = 599 | Fmt.with_style (Style_sheet.header config.styles severity) ppf 600 | @@ fun ppf () -> 601 | Fmt.(option (any "[" ++ of_to_string code_to_string ++ any "]")) ppf code 602 | ;; 603 | 604 | let pp_header ~config ~code_to_string ~severity ~code ppf message = 605 | Fmt.pf 606 | ppf 607 | "@[%a%a: %a@]" 608 | (pp_severity ~config) 609 | severity 610 | (pp_code ~config ~code_to_string ~severity) 611 | code 612 | (pp_header_message ~config) 613 | message 614 | ;; 615 | 616 | let pp_note ~config ~line_num_width ppf note = 617 | pwibox 618 | ~prefix: 619 | (Fmt.str_like ppf "%*s %a " line_num_width "" (Chars.pp_note_bullet ~config) ()) 620 | Message.pp 621 | ppf 622 | note 623 | ;; 624 | 625 | let pp_rich_snippet 626 | ~config 627 | ~code_to_string 628 | ~line_num_width 629 | ~multi_width 630 | ppf 631 | (severity, message, code, sources) 632 | = 633 | pp_header ~config ~code_to_string ~severity ~code ppf message; 634 | if not (List.is_empty sources) then Fmt.newline ppf (); 635 | Fmt.(list ~sep:Fmt.newline (pp_source ~config ~severity ~line_num_width ~multi_width)) 636 | ppf 637 | sources 638 | ;; 639 | 640 | let pp_compact_snippet ~config ~code_to_string ppf (severity, message, code, sources) = 641 | match sources with 642 | | [] -> pp_header ~config ~code_to_string ~severity ~code ppf message 643 | | sources -> 644 | (Fmt.list ~sep:Fmt.newline 645 | @@ fun ppf (source, locus) -> 646 | Fmt.pf 647 | ppf 648 | "@[%a: %a@]" 649 | (pp_locus ~source) 650 | locus 651 | (pp_header ~config ~code_to_string ~severity ~code) 652 | message) 653 | ppf 654 | sources 655 | ;; 656 | 657 | let line_num_width sources = 658 | match sources with 659 | | Compact _ -> 0 660 | | Rich sources -> 661 | Int.max 662 | (sources 663 | |> List.map ~f:(fun { blocks; _ } -> 664 | match List.last blocks with 665 | | None -> 0 666 | | Some { start; lines; _ } -> 667 | let line_num = 668 | Line_number.of_line_index Line_index.(add start (List.length lines)) 669 | in 670 | Line_number.to_string line_num |> String.length) 671 | |> List.max_elt ~compare:Int.compare 672 | |> Option.value ~default:0) 673 | 3 674 | ;; 675 | 676 | let multi_width sources = 677 | let rec count_multi : Snippet.Line.t list -> int = function 678 | | [] -> 0 679 | | line :: lines -> 680 | List.count line.multi_line_labels ~f:(function 681 | | Top _ -> true 682 | | Bottom _ -> false) 683 | + count_multi lines 684 | in 685 | match sources with 686 | | Compact _ -> 0 687 | | Rich sources -> 688 | sources 689 | |> List.map ~f:(fun { Snippet.blocks; _ } -> 690 | let rec loop_blocks : Snippet.block list -> int = function 691 | | [] -> 0 692 | | { lines; _ } :: blocks -> count_multi lines + loop_blocks blocks 693 | in 694 | loop_blocks blocks) 695 | |> List.max_elt ~compare:Int.compare 696 | |> Option.value ~default:0 697 | ;; 698 | 699 | let pp_snippet 700 | ~config 701 | ~code_to_string 702 | ppf 703 | ({ severity; message; code; sources; notes } : 'code Snippet.t) 704 | = 705 | Fmt.set_style_renderer ppf (Config.style_renderer config); 706 | Format.pp_set_geometry ppf ~max_indent:2 ~margin:Format.pp_max_margin; 707 | let line_num_width = line_num_width sources in 708 | let multi_width = multi_width sources in 709 | Fmt.pf ppf "@["; 710 | (match sources with 711 | | Compact sources -> 712 | pp_compact_snippet ~config ~code_to_string ppf (severity, message, code, sources) 713 | | Rich sources -> 714 | pp_rich_snippet 715 | ~config 716 | ~code_to_string 717 | ~line_num_width 718 | ~multi_width 719 | ppf 720 | (severity, message, code, sources)); 721 | if not (List.is_empty notes) then Fmt.newline ppf (); 722 | Fmt.(list ~sep:Fmt.newline (pp_note ~config ~line_num_width)) ppf notes; 723 | Fmt.pf ppf "@]" 724 | ;; 725 | -------------------------------------------------------------------------------- /lib/core/diagnostic.ml: -------------------------------------------------------------------------------- 1 | open! Import 2 | 3 | type ('a, 'b) format = ('a, Format.formatter, unit, 'b) format4 4 | 5 | module Severity = struct 6 | module T = struct 7 | type t = 8 | | Help 9 | | Note 10 | | Warning 11 | | Error 12 | | Bug 13 | [@@deriving equal, compare, hash, sexp] 14 | end 15 | 16 | include T 17 | include Comparable.Make (T) 18 | 19 | let to_string = function 20 | | Help -> "help" 21 | | Error -> "error" 22 | | Warning -> "warning" 23 | | Note -> "note" 24 | | Bug -> "bug" 25 | ;; 26 | 27 | let pp = Format.pp_of_to_string to_string 28 | end 29 | 30 | module Priority = struct 31 | module T = struct 32 | type t = 33 | | Secondary 34 | | Primary 35 | [@@deriving equal, compare, hash, sexp] 36 | end 37 | 38 | include T 39 | include Comparable.Make (T) 40 | 41 | let is_primary = function 42 | | Primary -> true 43 | | Secondary -> false 44 | ;; 45 | 46 | let is_secondary = function 47 | | Primary -> false 48 | | Secondary -> true 49 | ;; 50 | 51 | let to_string = function 52 | | Primary -> "primary" 53 | | Secondary -> "secondary" 54 | ;; 55 | 56 | let pp = Format.pp_of_to_string to_string 57 | end 58 | 59 | module Message = struct 60 | module T = struct 61 | type t = Formatter.t -> unit 62 | 63 | let of_string str ppf = 64 | Format.(pp_print_list ~pp_sep:pp_force_newline pp_print_string) ppf 65 | @@ String.split_lines str 66 | ;; 67 | 68 | let to_string t = 69 | let buf = Buffer.create 512 in 70 | let ppf = Format.formatter_of_buffer buf in 71 | Format.pp_set_geometry ppf ~max_indent:2 ~margin:Format.pp_max_margin; 72 | t ppf; 73 | Format.pp_print_flush ppf (); 74 | Buffer.contents buf 75 | ;; 76 | 77 | let sexp_of_t = sexp_of_t_of_to_string to_string 78 | let t_of_sexp = t_of_sexp_of_of_string of_string 79 | let hash_fold_t state t = Hash.fold_string state (to_string t) 80 | let hash = Hash.of_fold hash_fold_t 81 | let compare = Comparable.lift Int.compare ~f:hash 82 | end 83 | 84 | include T 85 | include Comparable.Make (T) 86 | 87 | let create = of_string 88 | let createf = Format.dprintf 89 | let kcreatef = Format.kdprintf 90 | let pp ppf t = t ppf 91 | end 92 | 93 | module Label = struct 94 | type t = 95 | { range : Range.t 96 | ; priority : Priority.t 97 | ; message : Message.t 98 | } 99 | [@@deriving equal, compare, hash, sexp] 100 | 101 | let create ~range ~priority message = { range; priority; message } 102 | let createf ~range ~priority fmt = fmt |> Message.kcreatef @@ create ~range ~priority 103 | 104 | let kcreatef ~range ~priority kont fmt = 105 | fmt |> Message.kcreatef @@ fun msg -> kont (create ~range ~priority msg) 106 | ;; 107 | 108 | let primary = create ~priority:Primary 109 | let primaryf = createf ~priority:Primary 110 | let kprimaryf = kcreatef ~priority:Primary 111 | let secondary = create ~priority:Secondary 112 | let secondaryf = createf ~priority:Secondary 113 | let ksecondaryf = kcreatef ~priority:Secondary 114 | end 115 | 116 | type 'code t = 117 | { severity : Severity.t 118 | ; message : Message.t 119 | ; code : 'code option 120 | ; labels : Label.t list 121 | ; notes : Message.t list 122 | } 123 | [@@deriving sexp] 124 | 125 | let create ?(notes = []) ?(labels = []) ?code severity message = 126 | { notes; labels; severity; message; code } 127 | ;; 128 | 129 | let createf ?notes ?labels ?code severity fmt = 130 | fmt |> Message.kcreatef @@ create ?notes ?labels ?code severity 131 | ;; 132 | 133 | let kcreatef ?notes ?labels ?code kont severity fmt = 134 | fmt |> Message.kcreatef @@ fun msg -> kont (create ?notes ?labels ?code severity msg) 135 | ;; 136 | -------------------------------------------------------------------------------- /lib/core/diagnostic.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | (** The type of format strings associated with messages. 4 | 5 | + The input is always a [Format.formatter] 6 | + The result of [%a] and [%t] printing functions is [unit]. *) 7 | type ('a, 'b) format = ('a, Format.formatter, unit, 'b) format4 8 | 9 | module Severity : sig 10 | (** The type of severity. 11 | 12 | These are ordered in the following way: 13 | {[ 14 | let () = 15 | let open Severity in 16 | assert (Bug > Error); 17 | assert (Error > Warning); 18 | assert (Warning > Note); 19 | assert (Note > Help) 20 | ;; 21 | ]} *) 22 | 23 | type t = 24 | | Help (** A help message. *) 25 | | Note (** A note. *) 26 | | Warning (** A warning. *) 27 | | Error (** An error. *) 28 | | Bug (** An unexpected bug. *) 29 | [@@deriving equal, compare, hash, sexp] 30 | 31 | include Comparable.S with type t := t 32 | include Pretty_printer.S with type t := t 33 | 34 | val to_string : t -> string 35 | end 36 | 37 | module Priority : sig 38 | (** The type of priority. These are used to style the primary and secondary causes of a diagnostic. 39 | 40 | These are ordered in the following way: 41 | {[ 42 | let () = assert (Priority.(Primary > Secondary)) 43 | ]} *) 44 | 45 | type t = 46 | | Secondary 47 | (** Priority to describe labels that explain the secondary causes of a diagnostic. *) 48 | | Primary 49 | (** Priority to describe labels that explain the primary cause of a diagnostic. *) 50 | [@@deriving equal, compare, hash, sexp] 51 | 52 | include Comparable.S with type t := t 53 | include Pretty_printer.S with type t := t 54 | 55 | val is_primary : t -> bool 56 | val is_secondary : t -> bool 57 | val to_string : t -> string 58 | end 59 | 60 | module Message : sig 61 | (** The type of messages. 62 | 63 | Messages are unrendered formatted strings. The rendering is delayed till Grace's renderering engine 64 | since layout decisions are it's responsibility. 65 | 66 | A valid message must satisfy the following two conditions: 67 | + Messages must be encoded using ASCII. 68 | + Messages must not contain control characters such as the newline character [\n]. 69 | 70 | Equality and comparison of messages is performed on the hash of the messages rendered 71 | contents. *) 72 | type t = Format.formatter -> unit [@@deriving equal, hash, sexp] 73 | 74 | include Comparable.S with type t := t 75 | include Pretty_printer.S with type t := t 76 | 77 | (** [create str] converts the string [str] into a message. *) 78 | val create : string -> t 79 | 80 | (** [createf fmt ...] formats a message. *) 81 | val createf : ('a, t) format -> 'a 82 | 83 | (** [kcreatef kont fmt ...] is equivalent to [kont (createf fmt ...)]. *) 84 | val kcreatef : (t -> 'b) -> ('a, 'b) format -> 'a 85 | 86 | (** converts a {{!type:t} message} into a string by formatting it with the maximum admissible margin. *) 87 | val to_string : t -> string 88 | 89 | (** alias of {{!val:create} [Message.create]}. *) 90 | val of_string : string -> t 91 | end 92 | 93 | module Label : sig 94 | (** The type of labels. 95 | 96 | Labels describe an underlined region of code associated with a diagnostic. *) 97 | type t = 98 | { range : Range.t (** The range we are going to include in the rendered diagnostic. *) 99 | ; priority : Priority.t (** The priority (or style) of the label. *) 100 | ; message : Message.t 101 | (** A message providing additional information for the underlined code. *) 102 | } 103 | [@@deriving equal, hash, sexp] 104 | 105 | (** [create ~range ~priority message] constructs a label. 106 | 107 | @param range the range to underline. 108 | @param priority the priority of the label. *) 109 | val create : range:Range.t -> priority:Priority.t -> Message.t -> t 110 | 111 | (** [createf ~range ~priority fmt ...] constructs a label with a formatted message. 112 | 113 | @param range the range to underline. 114 | @param priority the priority of the label. *) 115 | val createf : range:Range.t -> priority:Priority.t -> ('a, t) format -> 'a 116 | 117 | (** [kcreatef ~range ~priority kont fmt ...] is equivalent to [kont (createf ~range ~priority fmt ...)]. 118 | 119 | @param range the range to underline. 120 | @param priority the priority of the label. *) 121 | val kcreatef 122 | : range:Range.t 123 | -> priority:Priority.t 124 | -> (t -> 'b) 125 | -> ('a, 'b) format 126 | -> 'a 127 | 128 | (** [primary ~range message] is equivalent to [create ~range ~priority:Primary message]. *) 129 | val primary : range:Range.t -> Message.t -> t 130 | 131 | (** [primaryf ~range fmt ...] is equivalent to [createf ~range ~priority:Primary fmt ...]. *) 132 | val primaryf : range:Range.t -> ('a, t) format -> 'a 133 | 134 | (** [kprimaryf ~range kont fmt ...] is equivalent to [kcreatef ~range ~priority:Primary kont fmt ...]. *) 135 | val kprimaryf : range:Range.t -> (t -> 'b) -> ('a, 'b) format -> 'a 136 | 137 | (** [secondary ~range message] is equivalent to [create ~range ~priority:Secondary message]. *) 138 | val secondary : range:Range.t -> Message.t -> t 139 | 140 | (** [secondaryf ~range fmt ...] is equivalent to [createf ~range ~priority:Secondary fmt ...]. *) 141 | val secondaryf : range:Range.t -> ('a, t) format -> 'a 142 | 143 | (** [ksecondaryf ~range kont fmt ...] is equivalent to [kcreatef ~range ~priority:Secondary kont fmt ...]. *) 144 | val ksecondaryf : range:Range.t -> (t -> 'b) -> ('a, 'b) format -> 'a 145 | end 146 | 147 | (** The type of diagnostics. *) 148 | type 'code t = 149 | { severity : Severity.t (** The overall severity of the diagnostic. *) 150 | ; message : Message.t 151 | (** The main message associated with the diagnostic. These should not include control characters (such as the newline character [\n]). 152 | To support compact rendering, the message should be specific enough to make sense on its own, without the additional context provided 153 | by labels and notes. *) 154 | ; code : 'code option (** The (optional) error code assicoated with the diagnostic *) 155 | ; labels : Label.t list 156 | (** Labels that describe the cause of the diagnostic. The order of the labels has no meaning, 157 | Grace's rendering engine will determine the order they appear. *) 158 | ; notes : Message.t list 159 | (** Notes that are associated with the primary cause of the diagnostic. *) 160 | } 161 | [@@deriving sexp] 162 | 163 | (** [create severity message] constructs a diagnostic with the [message]. 164 | 165 | @param notes additional notes associated with the primary cause of the diagnostic. 166 | @param labels used to describe the cause of the diagnostic. 167 | @param code the error code of the diagnostic. *) 168 | val create 169 | : ?notes:Message.t list 170 | -> ?labels:Label.t list 171 | -> ?code:'code 172 | -> Severity.t 173 | -> Message.t 174 | -> 'code t 175 | 176 | (** [createf severity fmt ...] formats a message and constructs a diagnostic. 177 | 178 | @param notes additional notes associated with the primary cause of the diagnostic. 179 | @param labels used to describe the cause of the diagnostic. 180 | @param code the error code of the diagnostic. *) 181 | val createf 182 | : ?notes:Message.t list 183 | -> ?labels:Label.t list 184 | -> ?code:'code 185 | -> Severity.t 186 | -> ('a, 'code t) format 187 | -> 'a 188 | 189 | (** [kcreatef kont severity fmt ...] is equivalent to [kont (createf severity fmt ...)]. 190 | 191 | @param notes additional notes associated with the primary cause of the diagnostic. 192 | @param labels used to describe the cause of the diagnostic. *) 193 | val kcreatef 194 | : ?notes:Message.t list 195 | -> ?labels:Label.t list 196 | -> ?code:'code 197 | -> ('code t -> 'b) 198 | -> Severity.t 199 | -> ('a, 'b) format 200 | -> 'a 201 | -------------------------------------------------------------------------------- /lib/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name grace) 3 | (public_name grace) 4 | (libraries core) 5 | (preprocess 6 | (pps ppx_jane ppx_optcomp))) 7 | -------------------------------------------------------------------------------- /lib/core/grace.ml: -------------------------------------------------------------------------------- 1 | include Index 2 | module Range = Range 3 | module Source = Source 4 | module Diagnostic = Diagnostic 5 | -------------------------------------------------------------------------------- /lib/core/grace.mli: -------------------------------------------------------------------------------- 1 | (* FIXME: Do about, etc *) 2 | (** A diagnostic is a message with associated debugging context for the user, for example a compiler error. *) 3 | 4 | include module type of Index (** @inline *) 5 | 6 | (** Source code ranges, also known as 'locations'. *) 7 | module Range = Range 8 | 9 | (** Source is a file-like abstraction. *) 10 | module Source = Source 11 | 12 | (** Diagnostic types and constructors. *) 13 | module Diagnostic = Diagnostic 14 | -------------------------------------------------------------------------------- /lib/core/import.ml: -------------------------------------------------------------------------------- 1 | include Core 2 | 3 | module Format = struct 4 | include Format 5 | 6 | let pp_of_to_string to_string ppf t = pp_print_string ppf (to_string t) 7 | 8 | [%%if ocaml_version < (5, 2, 0)] 9 | 10 | let pp_max_margin = Int.max_value 11 | 12 | [%%else] 13 | 14 | let pp_max_margin = pp_infinity - 1 15 | 16 | [%%endif] 17 | end 18 | 19 | let invalid_argf fmt = Format.kasprintf invalid_arg fmt 20 | let sexp_of_t_of_to_string to_string t = Sexp.Atom (to_string t) 21 | 22 | let t_of_sexp_of_of_string of_string sexp = 23 | match sexp with 24 | | Sexp.Atom str -> of_string str 25 | | Sexp.List _ -> 26 | invalid_argf "@[<2>expected sexp atom, recieved list: @[%a@]@]" Sexp.pp_hum sexp 27 | ;; 28 | -------------------------------------------------------------------------------- /lib/core/index.ml: -------------------------------------------------------------------------------- 1 | open! Import 2 | 3 | module type Index = sig 4 | type t = private int [@@deriving hash, sexp] 5 | 6 | include Comparable.S with type t := t 7 | include Invariant.S with type t := t 8 | include Pretty_printer.S with type t := t 9 | 10 | val to_string : t -> string 11 | val of_int : int -> t 12 | val initial : t 13 | val add : t -> int -> t 14 | val sub : t -> int -> t 15 | val diff : t -> t -> int 16 | end 17 | 18 | module Int_index = struct 19 | module T = struct 20 | type t = int [@@deriving compare, hash, sexp] 21 | end 22 | 23 | include T 24 | include Comparable.Make (T) 25 | 26 | let invariant t = 27 | (* FIXME: Register custom exceptions for pretty printing *) 28 | Invariant.invariant [%here] t sexp_of_t (fun () -> assert (t >= 0)) 29 | ;; 30 | 31 | let pp = Format.pp_print_int 32 | let to_string = Int.to_string 33 | 34 | let of_int t = 35 | invariant t; 36 | t 37 | ;; 38 | 39 | let initial = 0 40 | 41 | let add t off = 42 | let t = t + off in 43 | invariant t; 44 | t 45 | ;; 46 | 47 | let sub t off = 48 | let t = t - off in 49 | invariant t; 50 | t 51 | ;; 52 | 53 | let diff t1 t2 = t1 - t2 54 | end 55 | 56 | module Line_index = Int_index 57 | module Column_index = Int_index 58 | 59 | module Byte_index = struct 60 | include Int_index 61 | 62 | let of_lex Lexing.{ pos_cnum; _ } = of_int pos_cnum 63 | end 64 | -------------------------------------------------------------------------------- /lib/core/index.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | (** Index types are integer-like types that specify byte-indexed positions in a source file. 4 | All indices are 0-indexed and positive. 5 | 6 | Grace uses byte-indexed positions are they are the most portable location information. 7 | Alternatives include: 8 | - Character positions 9 | - Column and line numbers 10 | 11 | Neither alternatives are well-defined without contextual information (encodings, etc). *) 12 | 13 | module type Index = sig 14 | (** The type of indexes. An integer with the invariant that an index [t] satisfies [t >= 0]. *) 15 | type t = private int [@@deriving equal, compare, hash, sexp] 16 | 17 | include Comparable.S with type t := t 18 | include Invariant.S with type t := t 19 | include Pretty_printer.S with type t := t 20 | 21 | val to_string : t -> string 22 | 23 | (** [of_int n] creates the index [n]. 24 | 25 | @raise Invalid_argument if [n < 0]. *) 26 | val of_int : int -> t 27 | 28 | (** [initial] is the initial index, namely [0]. *) 29 | val initial : t 30 | 31 | (** [add t off] adds the offset [off] to the index [t]. *) 32 | val add : t -> int -> t 33 | 34 | (** [sub t off] subtracts the offset [off] from the index [t]. *) 35 | val sub : t -> int -> t 36 | 37 | (** [diff t1 t2] returns the (potentially negative) difference between [t1] and [t2]. *) 38 | val diff : t -> t -> int 39 | end 40 | 41 | module Line_index : Index 42 | module Column_index : Index 43 | 44 | module Byte_index : sig 45 | include Index (** @inline *) 46 | 47 | (** {1 Support for Lexing} *) 48 | 49 | (** [of_lex lex_pos] returns the byte index from the lexing position [lex_pos]. It is equivalent to [create (lex_pos.pos_cnum)]. *) 50 | val of_lex : Lexing.position -> t 51 | end 52 | -------------------------------------------------------------------------------- /lib/core/range.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | open Index 3 | 4 | module T = struct 5 | type t = 6 | { start : Byte_index.t 7 | ; stop : Byte_index.t 8 | ; source : Source.t 9 | } 10 | [@@deriving equal, hash, sexp] 11 | 12 | let compare t1 t2 = 13 | let start_cmp = Byte_index.compare t1.start t2.start in 14 | if start_cmp = 0 then Byte_index.compare t1.stop t2.stop else start_cmp 15 | ;; 16 | end 17 | 18 | include T 19 | include Comparable.Make (T) 20 | 21 | let check_invariants { start; stop; source } = 22 | (* 0 <= start <= stop <= eof *) 23 | if Byte_index.(start > stop) 24 | then 25 | invalid_argf 26 | "range start %a is greater than range stop %a" 27 | Byte_index.pp 28 | start 29 | Byte_index.pp 30 | stop 31 | (); 32 | let eos = Source.length source in 33 | if Byte_index.(stop > of_int eos) 34 | then 35 | invalid_argf 36 | "range beyond end of source; stop = %a > %d = eos" 37 | Byte_index.pp 38 | stop 39 | eos 40 | () 41 | ;; 42 | 43 | let invariant t = 44 | Invariant.invariant [%here] t [%sexp_of: t] (fun () -> check_invariants t) 45 | ;; 46 | 47 | let pp ppf { start; stop; source = _ } = 48 | Format.fprintf ppf "[%a, %a)" Byte_index.pp start Byte_index.pp stop 49 | ;; 50 | 51 | let create ~source start stop = 52 | let t = { start; stop; source } in 53 | check_invariants t; 54 | t 55 | ;; 56 | 57 | let initial source = create ~source Byte_index.initial Byte_index.initial 58 | 59 | let eos source = 60 | let eos_index = Byte_index.of_int @@ Source.length source in 61 | create ~source eos_index eos_index 62 | ;; 63 | 64 | let[@inline] source t = t.source 65 | let[@inline] start t = t.start 66 | let[@inline] stop t = t.stop 67 | let[@inline] split t = t.start, t.stop 68 | 69 | let merge t1 t2 = 70 | assert (Source.equal t1.source t2.source); 71 | let start = Byte_index.min t1.start t2.start in 72 | let stop = Byte_index.max t1.stop t2.stop in 73 | { start; stop; source = t1.source } 74 | ;; 75 | 76 | let inter t1 t2 = 77 | assert (Source.equal t1.source t2.source); 78 | let start = Byte_index.max t1.start t2.start in 79 | let stop = Byte_index.min t1.stop t2.stop in 80 | { start; stop; source = t1.source } 81 | ;; 82 | 83 | let are_disjoint t1 t2 = 84 | assert (Source.equal t1.source t2.source); 85 | let first, last = if Byte_index.(t1.stop < t2.stop) then t1, t2 else t2, t1 in 86 | Byte_index.(first.stop <= last.start) 87 | ;; 88 | 89 | let contains { start; stop; _ } elem = Byte_index.(start <= elem && elem < stop) 90 | 91 | let of_lex ?source (start, stop) = 92 | let source = Option.value source ~default:(`File start.Lexing.pos_fname) in 93 | create ~source (Byte_index.of_lex start) (Byte_index.of_lex stop) 94 | ;; 95 | 96 | let of_lexbuf ?source lexbuf = 97 | let source = Option.value source ~default:(`File lexbuf.Lexing.lex_curr_p.pos_fname) in 98 | create 99 | ~source 100 | (Byte_index.of_int @@ Lexing.lexeme_start lexbuf) 101 | (Byte_index.of_int @@ Lexing.lexeme_end lexbuf) 102 | ;; 103 | -------------------------------------------------------------------------------- /lib/core/range.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | open Index 3 | 4 | (** Grace's {e ranges} are opaque {{!type:Byte_index.t} byte index} intervals of the form {e \[start, stop)} 5 | (not including the byte at the [stop] index) within a given {{!type:Source.t} [source]}. 6 | 7 | A range is said to be valid if: 8 | + All indices are valid. 9 | + [start <= stop], note that [start = stop] is permitted, in this case, this denotes an empty range. 10 | + [stop <= eos], where [eos] is the end-of-source position, also known as the {{!val:Source.length} source length}, of [source] *) 11 | 12 | (** The abstract type of ranges. *) 13 | type t [@@deriving equal, compare, hash, sexp] 14 | 15 | include Comparable.S with type t := t 16 | include Invariant.S with type t := t 17 | include Pretty_printer.S with type t := t 18 | 19 | (** [create ~source start stop] builds the range {e \[start, stop)} (not including the byte at the ending position) from the byte indices [start] and [stop]. 20 | A range is empty if its start and stop indices are the same. 21 | 22 | @param source the associated source of the range. 23 | @raise Invalid_argument 24 | if the [start] is greater than [stop] or [stop] is greater than the end-of-source position in [source]. *) 25 | val create : source:Source.t -> Byte_index.t -> Byte_index.t -> t 26 | 27 | (** [initial source] is the initial range, namely {e \[0, 0)}. *) 28 | val initial : Source.t -> t 29 | 30 | (** [eos source] is the end-of-source range {e \[eos, eos)} for the given [source]. *) 31 | val eos : Source.t -> t 32 | 33 | (** [source t] returns the source associated with [t]. *) 34 | val source : t -> Source.t 35 | 36 | (** [start t] returns the {{!type:Byte_index.t} byte index} of the (inclusive) start position. *) 37 | val start : t -> Byte_index.t 38 | 39 | (** [stop t] returns the {{!type:Byte_index.t} byte index} of the (exclusive) stop position. *) 40 | val stop : t -> Byte_index.t 41 | 42 | (** [split t] returns the pair of {{!type:Byte_index.t} byte indices} of [t]. *) 43 | val split : t -> Byte_index.t * Byte_index.t 44 | 45 | (** [merge t1 t2] returns the merged interval {e \[start, stop)} where [start = min start1 start2] and [stop = max stop1 stop2]. 46 | 47 | @raise Invalid_argument 48 | if the two ranges have differing sources. The comparison of sources is performed by [Source.equal]. *) 49 | val merge : t -> t -> t 50 | 51 | (** [inter t1 t2] returns the intersectional interval {e \[start, stop)} where [start = min start1 start2] and [stop = max stop1 stop2]. 52 | 53 | @raise Invalid_argument 54 | if the two ranges have differing sources. The comparison of sources is performed by [Source.equal]. *) 55 | val inter : t -> t -> t 56 | 57 | (** [are_disjoint t1 t2] returns whether the two ranges [t1] and [t2] are disjoint. *) 58 | val are_disjoint : t -> t -> bool 59 | 60 | (** [contains t idx] returns whether the position [idx] is within the range [t]. *) 61 | val contains : t -> Byte_index.t -> bool 62 | 63 | (** {1 Support for Lexing} *) 64 | 65 | (** [of_lex (start, stop)] takes a pair of OCaml lexer positions and creates a range. It is equivalent to 66 | [make ~source:default (Byte_index.of_lex start) (Byte_index.of_lex stop)]. 67 | 68 | @param source 69 | The source of the new range. The default source is [`File start.pos_fname]. 70 | 71 | @raise Invalid_argument 72 | if the optional argument [source] is not given and [start.pos_fname] and [stop.pos_fname] differ. The comparison is done by [String.equal] without any path canonicalization. *) 73 | val of_lex : ?source:Source.t -> Lexing.position * Lexing.position -> t 74 | 75 | (** [of_lexbuf lexbuf] constructs a range from the current lexeme that [lexbuf] points to. It is [of_lex (Lexing.lexeme_start_p lexbuf, Lexing.lexeme_end_p lexbuf)]. 76 | 77 | @param source 78 | The source of the new range. The default source is [`File (Lexing.lexeme_start_p lexbuf).pos_fname]. *) 79 | val of_lexbuf : ?source:Source.t -> Lexing.lexbuf -> t 80 | -------------------------------------------------------------------------------- /lib/core/source.ml: -------------------------------------------------------------------------------- 1 | open! Import 2 | 3 | type reader = 4 | { id : int 5 | ; name : string option [@equal.ignore] [@compare.ignore] [@hash.ignore] 6 | ; length : int [@equal.ignore] [@compare.ignore] [@hash.ignore] 7 | ; unsafe_get : int -> char [@equal.ignore] [@compare.ignore] [@hash.ignore] 8 | } 9 | [@@deriving equal, compare, hash, sexp] 10 | 11 | let reader_name r = Option.value r.name ~default:(Int.to_string r.id) 12 | 13 | type string_source = 14 | { name : string option 15 | ; content : string 16 | } 17 | [@@deriving equal, compare, hash, sexp] 18 | 19 | type t = 20 | [ `File of string 21 | | `String of string_source 22 | | `Reader of reader 23 | ] 24 | [@@deriving equal, compare, hash, sexp] 25 | 26 | let name = function 27 | | `File name -> Some name 28 | | `String { name; _ } -> name 29 | | `Reader reader -> Some (reader_name reader) 30 | ;; 31 | 32 | let length = function 33 | | `File filename -> 34 | (try In_channel.(with_file filename ~f:length) |> Int64.to_int_exn with 35 | | _ -> invalid_argf "file size is larger than an OCaml 63-bit integer") 36 | | `String { content; _ } -> String.length content 37 | | `Reader { length; _ } -> length 38 | ;; 39 | -------------------------------------------------------------------------------- /lib/core/source.mli: -------------------------------------------------------------------------------- 1 | (** Grace provides the abstraction of a file called a 'source'. 2 | 3 | There are several benefits with providing a in-memory abstraction of a sources: 4 | + {b Virtual files}: It is often useful to invent temporary files (e.g. test input, command line input, REPL input). By providing a in-memory abstraction, Grace provides the ability to create virtual files. 5 | + {b Caching}: Caching sources is useful in many situations (e.g. LSP semantic analysis, reporting multiple errors in a single file in a diagnostic reporter, etc). *) 6 | 7 | (** A reader denotes an arbitrary byte source (potentially backed by a file, buffer, socket, etc). *) 8 | type reader = 9 | { id : int 10 | (** The unique identifier of the reader. Equality, comparison, hashing are all performed on this identifier. *) 11 | ; name : string option 12 | (** The name of the reader. The diagnostic render can use the name of the reader in place of a file path. *) 13 | ; length : int (** The length (in bytes) of the source. *) 14 | ; unsafe_get : int -> char 15 | (** [unsafe_get i] reads the [i]th byte without performing bounds checks. *) 16 | } 17 | [@@deriving equal, compare, hash, sexp] 18 | 19 | (** [reader_name reader] returns the name of the reader. If [reader.name] is [None], then identifier [reader.id] (converted to a string) is returned. *) 20 | val reader_name : reader -> string 21 | 22 | (** An in-memory string source. *) 23 | type string_source = 24 | { name : string option 25 | (** The name of a string source. The diagnostic render can use the name of a string source in place of a file path. *) 26 | ; content : string (** The content of a string source *) 27 | } 28 | [@@deriving equal, compare, hash, sexp] 29 | 30 | (** The type of sources. *) 31 | type t = 32 | [ `File of string (** A file source specified by its filename. *) 33 | | `String of string_source (** A in-memory string source. *) 34 | | `Reader of reader (** A reader-backed source. *) 35 | ] 36 | [@@deriving equal, compare, hash, sexp] 37 | 38 | (** [name src] returns the name of the source if it exists. *) 39 | val name : t -> string option 40 | 41 | (** [length src] returns the length or size in bytes of [src]. Interpreted as a {{!type:Index.Byte_index.t} byte_index}, this is known as the end-of-source position. 42 | 43 | @raise Invalid_argument if the file size is larger than an OCaml 63-bit integer. *) 44 | val length : t -> int 45 | -------------------------------------------------------------------------------- /lib/source_reader/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name grace_source_reader) 3 | (public_name grace.source_reader) 4 | (libraries core grace iter core_unix core_unix.bigstring_unix) 5 | (preprocess 6 | (pps ppx_jane))) 7 | -------------------------------------------------------------------------------- /lib/source_reader/grace_source_reader.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Grace 3 | open Core_unix 4 | 5 | let invalid_argf fmt = Format.kasprintf invalid_arg fmt 6 | let sys_errorf fmt = Format.kasprintf (fun s -> raise (Sys_error s)) fmt 7 | 8 | (** A file is abstracted as a (memory-mapped) bigstring *) 9 | type file = 10 | { descr : File_descr.t 11 | ; content : (Bigstring.t[@sexp.opaque]) [@equal.ignore] [@compare.ignore] [@hash.ignore] 12 | } 13 | [@@deriving equal, compare, hash, sexp] 14 | 15 | module File_table : sig 16 | (** The abstract type of the file table *) 17 | type t 18 | 19 | val create : unit -> t 20 | 21 | (** [open_file tbl fname] opens the file with filename [fname] *) 22 | val open_file : t -> string -> file 23 | 24 | (** [close_all_files tbl] closes all files, clearing the file table. *) 25 | val close_all_files : t -> unit 26 | end = struct 27 | type t = (string, file) Hashtbl.t 28 | 29 | let create () : t = Hashtbl.create (module String) 30 | 31 | let open_file t fname = 32 | Hashtbl.find_or_add t fname ~default:(fun () -> 33 | let fd = openfile ~mode:[ O_RDONLY ] fname in 34 | let content = 35 | try 36 | let size = -1 in 37 | Bigstring_unix.map_file ~shared:false fd size 38 | with 39 | | _ -> 40 | close fd; 41 | sys_errorf "could not read the file %s" fname 42 | in 43 | { descr = fd; content }) 44 | ;; 45 | 46 | let close_all_files t = 47 | Hashtbl.iter t ~f:(fun file -> close file.descr); 48 | Hashtbl.clear t 49 | ;; 50 | end 51 | 52 | module Source_descr = struct 53 | module T = struct 54 | type content = 55 | | File of file 56 | | String of string 57 | | Reader of Source.reader 58 | [@@deriving equal, compare, hash, sexp] 59 | 60 | type t = 61 | { content : content 62 | ; source : Source.t 63 | } 64 | [@@deriving equal, compare, hash, sexp] 65 | end 66 | 67 | include T 68 | include Hashable.Make (T) 69 | 70 | let[@inline] source t = t.source 71 | end 72 | 73 | let length (sd : Source_descr.t) = 74 | match sd.content with 75 | | File file -> Bigstring.length file.content 76 | | String string -> String.length string 77 | | Reader reader -> reader.length 78 | ;; 79 | 80 | let unsafe_get (sd : Source_descr.t) i = 81 | match sd.content with 82 | | File file -> Bigstring.unsafe_get file.content i 83 | | String str -> String.unsafe_get str i 84 | | Reader reader -> reader.unsafe_get i 85 | ;; 86 | 87 | let slice sd range = 88 | if not (Source.equal (Source_descr.source sd) (Range.source range)) 89 | then invalid_argf "mismatching source"; 90 | let start, stop = Range.split range in 91 | let buf = Buffer.create (Byte_index.diff stop start) in 92 | for i = (start :> int) to (stop :> int) - 1 do 93 | Buffer.add_char buf (unsafe_get sd i) 94 | done; 95 | Buffer.contents buf 96 | ;; 97 | 98 | let slicei sd (start : Byte_index.t) (stop : Byte_index.t) = 99 | let buf = Buffer.create (Byte_index.diff stop start) in 100 | for i = (start :> int) to (stop :> int) - 1 do 101 | Buffer.add_char buf (unsafe_get sd i) 102 | done; 103 | Buffer.contents buf 104 | ;; 105 | 106 | module Line_starts = struct 107 | (** The type of line starts. 108 | 109 | For computation of line numbers from ranges, we require a function mapping {{!type:Line_index.t} line indices} to {{!type:Byte_index.t} byte indicies} 110 | and the maximum line index. 111 | 112 | A valid [line_starts] for a [source] satisfies: 113 | + ... *) 114 | type t = 115 | { unsafe_get : int -> Byte_index.t 116 | ; length : int 117 | } 118 | 119 | type fn = Source_descr.t -> t 120 | 121 | let default_fn sd = 122 | let line_starts_array = 123 | (* Prefix with zero since no preceeding newline *) 124 | let line_starts = ref [ Byte_index.initial ] in 125 | for idx = 0 to length sd - 1 do 126 | match unsafe_get sd idx with 127 | | '\n' -> line_starts := Byte_index.of_int (idx + 1) :: !line_starts 128 | | _ -> () 129 | done; 130 | Array.of_list @@ List.rev !line_starts 131 | in 132 | { unsafe_get = (fun idx -> Array.unsafe_get line_starts_array (idx :> int)) 133 | ; length = Array.length line_starts_array 134 | } 135 | ;; 136 | 137 | let[@inline] length t = t.length 138 | let[@inline] unsafe_get t idx = t.unsafe_get idx 139 | 140 | let find t (idx : Byte_index.t) = 141 | (* Safety: t.line_starts is known to be non-empty, hence `Last_less_than_or_equal_to 142 | will always return an index *) 143 | Binary_search.binary_search 144 | t 145 | ~length 146 | ~get:unsafe_get 147 | ~compare:Byte_index.compare 148 | `Last_less_than_or_equal_to 149 | idx 150 | |> Option.value_exn ~here:[%here] 151 | ;; 152 | end 153 | 154 | type error = 155 | [ `Already_initialized 156 | | `Not_initialized 157 | ] 158 | 159 | exception Error of error 160 | 161 | type t = 162 | { line_starts_table : Line_starts.t Source_descr.Table.t 163 | ; file_table : File_table.t 164 | ; line_starts_fn : Line_starts.fn 165 | } 166 | 167 | let state : t option ref = ref None 168 | 169 | let get () = 170 | match !state with 171 | | Some t -> t 172 | | None -> raise @@ Error `Not_initialized 173 | ;; 174 | 175 | let init ?(line_starts_fn = Line_starts.default_fn) () = 176 | if Option.is_some !state then raise @@ Error `Already_initialized; 177 | state 178 | := Some 179 | { line_starts_fn 180 | ; file_table = File_table.create () 181 | ; line_starts_table = Source_descr.Table.create () 182 | } 183 | ;; 184 | 185 | let clear () = 186 | match !state with 187 | | None -> () 188 | | Some { file_table; _ } -> 189 | File_table.close_all_files file_table; 190 | state := None 191 | ;; 192 | 193 | let with_reader ?line_starts_fn f = 194 | Fun.protect 195 | (fun () -> 196 | init ?line_starts_fn (); 197 | f ()) 198 | ~finally:clear 199 | ;; 200 | 201 | let line_starts sd = 202 | let t = get () in 203 | Hashtbl.find_or_add t.line_starts_table sd ~default:(fun () -> t.line_starts_fn sd) 204 | ;; 205 | 206 | let open_source (source : Source.t) : Source_descr.t = 207 | let content = 208 | match source with 209 | | `File fname -> 210 | let file = File_table.open_file (get ()).file_table fname in 211 | Source_descr.File file 212 | | `String { content; _ } -> String content 213 | | `Reader reader -> Reader reader 214 | in 215 | { source; content } 216 | ;; 217 | 218 | module Line = struct 219 | type t = 220 | { idx : Line_index.t 221 | ; range : Range.t 222 | } 223 | [@@deriving sexp] 224 | 225 | let[@inline] start t = Range.start t.range 226 | let[@inline] stop t = Range.stop t.range 227 | let[@inline] split t = Range.split t.range 228 | 229 | let last sd = 230 | let idx = Line_index.of_int @@ Line_starts.length (line_starts sd) in 231 | let length = Byte_index.of_int @@ length sd in 232 | { idx; range = Range.create ~source:sd.source length length } 233 | ;; 234 | 235 | let offset sd (idx : Line_index.t) : Byte_index.t = 236 | let line_starts = line_starts sd in 237 | let last_line_index = Line_index.of_int @@ Line_starts.length line_starts in 238 | if Line_index.(initial <= idx && idx < last_line_index) 239 | then Line_starts.unsafe_get line_starts (idx :> int) 240 | else if Line_index.(idx = last_line_index) 241 | then Byte_index.of_int @@ length sd 242 | else 243 | invalid_argf 244 | "%a > %a: line index exceeds the last line index" 245 | Line_index.pp 246 | idx 247 | Line_index.pp 248 | last_line_index 249 | ;; 250 | 251 | let of_line_index sd (idx : Line_index.t) : t = 252 | let start = offset sd idx 253 | and stop = offset sd Line_index.(add idx 1) in 254 | { idx; range = Range.create ~source:sd.source start stop } 255 | ;; 256 | 257 | let of_byte_index sd (idx : Byte_index.t) : t = 258 | let line_starts = line_starts sd in 259 | Line_starts.find line_starts idx |> Line_index.of_int |> of_line_index sd 260 | ;; 261 | 262 | let[@inline] slice t ~sd = slice sd t.range 263 | end 264 | 265 | let lines sd : Line.t Iter.t = 266 | fun f -> 267 | let line_starts = line_starts sd in 268 | let stop = Line_starts.length line_starts in 269 | for line_idx = 0 to stop - 1 do 270 | f (Line.of_line_index sd @@ Line_index.of_int line_idx) 271 | done 272 | ;; 273 | 274 | let lines_in_range sd range : Line.t Iter.t = 275 | fun f -> 276 | if not (Source.equal (Source_descr.source sd) (Range.source range)) 277 | then invalid_argf "mismatching sources"; 278 | let line_starts = line_starts sd in 279 | let start, stop = Range.split range in 280 | for 281 | line_idx = Line_starts.find line_starts start to Line_starts.find line_starts stop 282 | do 283 | f (Line.of_line_index sd @@ Line_index.of_int line_idx) 284 | done 285 | ;; 286 | -------------------------------------------------------------------------------- /lib/source_reader/grace_source_reader.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Grace 3 | 4 | (** A source reader maintains a global table mapping source descriptors to their contents 5 | and their {i line starts}. *) 6 | 7 | module Source_descr : sig 8 | (** A source descriptor is a handle for an open {{!type:Grace.Source.t} source} *) 9 | 10 | type t [@@deriving equal, compare, hash, sexp] 11 | 12 | include Hashable.S with type t := t 13 | 14 | (** [source sd] returns the underlying source of the descriptor. *) 15 | val source : t -> Source.t 16 | end 17 | 18 | module Line_starts : sig 19 | (** The type of line starts. 20 | 21 | For computation of line numbers from ranges, we require a function mapping {{!type:Grace.Line_index.t} line indices} to {{!type:Grace.Byte_index.t} byte indicies} 22 | and the maximum line index. 23 | 24 | A valid [line_starts] for a [source] satisfies: 25 | + ... *) 26 | type t = 27 | { unsafe_get : int -> Byte_index.t 28 | ; length : int 29 | } 30 | 31 | (** A line starts {i function} maps a given {{!type:Source_descr.t} source (descriptor)} to its line starts. *) 32 | type fn = Source_descr.t -> t 33 | 34 | val default_fn : fn 35 | end 36 | 37 | type error = 38 | [ `Already_initialized 39 | | `Not_initialized 40 | ] 41 | 42 | exception Error of error 43 | 44 | (** [init ()] initializes the global source reader table. 45 | 46 | @param line_starts_fn the line starts function used for computing line starts. 47 | @raise Source_reader.Error if the reader is already initialized. *) 48 | val init : ?line_starts_fn:Line_starts.fn -> unit -> unit 49 | 50 | (** [clear ()] clears the global source reader table. *) 51 | val clear : unit -> unit 52 | 53 | (** [with_reader f] runs [f] with an initialized reader table, clearing it once [f] returns. 54 | 55 | @param line_starts_fn the line starts function used for computing line starts. 56 | @raise Source_reader.Error if the reader is already initialized. *) 57 | val with_reader : ?line_starts_fn:Line_starts.fn -> (unit -> 'a) -> 'a 58 | 59 | (** [open_source src] opens the [source], returning its descriptor. 60 | 61 | @raise Source_reader.Error if the reader is not initialized. *) 62 | val open_source : Source.t -> Source_descr.t 63 | 64 | (** [line_starts sd] returns the (possibly cached) line starts of the source [sd]. 65 | @raise Source_reader.Error if the reader is not initialized. *) 66 | val line_starts : Source_descr.t -> Line_starts.t 67 | 68 | (** [length sd] returns the length or size in bytes of [src]. 69 | 70 | It is semantically equivalent to [Source.length src]. *) 71 | val length : Source_descr.t -> int 72 | 73 | (** [unsafe_get sd i] reads the ith byte of the source without performing any bounds checks on [i]. *) 74 | val unsafe_get : Source_descr.t -> int -> char 75 | 76 | (** [slice sd range] reads the slice of bytes defined by [range]. 77 | 78 | @raise Invalid_argment 79 | if the source descriptor's underlying source is not equal to the range's source. *) 80 | val slice : Source_descr.t -> Range.t -> string 81 | 82 | val slicei : Source_descr.t -> Byte_index.t -> Byte_index.t -> string 83 | 84 | module Line : sig 85 | (** The type of a line. *) 86 | type t = 87 | { idx : Line_index.t 88 | ; range : Range.t 89 | } 90 | [@@deriving sexp] 91 | 92 | (** [of_line_index sd idx] returns the line at index [idx] in source [sd]. *) 93 | val of_line_index : Source_descr.t -> Line_index.t -> t 94 | 95 | (** [of_byte_index sd idx] returns the line containing [idx] in source [sd]. *) 96 | val of_byte_index : Source_descr.t -> Byte_index.t -> t 97 | 98 | (** [start t] returns the {{!type:Grace.Byte_index.t} byte index} of the (inclusive) start position of the line. *) 99 | val start : t -> Byte_index.t 100 | 101 | (** [stop t] returns the {{!type:Grace.Byte_index.t} byte index} of the (exclusive) stop position of the line. *) 102 | val stop : t -> Byte_index.t 103 | 104 | (** [split t] returns the pair of {{!type:Grace.Byte_index.t} byte indices} of the line [t]. *) 105 | val split : t -> Byte_index.t * Byte_index.t 106 | 107 | (** [last sd] returns the last line in the source [sd]. *) 108 | val last : Source_descr.t -> t 109 | 110 | (** [slice t ~sd] reads the slice of bytes defined by the line's [range]. 111 | 112 | @raise Invalid_argment 113 | if the source descriptor's underlying source is not equal to the line range's source. *) 114 | val slice : t -> sd:Source_descr.t -> string 115 | end 116 | 117 | (** [lines sd] returns an iterator over lines in source [sd]. *) 118 | val lines : Source_descr.t -> Line.t Iter.t 119 | 120 | (** [lines_in_range sd range] returns an iterator over lines in the [range] in [sd]. 121 | 122 | @raise Invalid_argment 123 | if the source descriptor's underlying source is not equal to the line range's source. *) 124 | val lines_in_range : Source_descr.t -> Range.t -> Line.t Iter.t 125 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "devDependencies": { 3 | "@commitlint/cli": "^18.4.3", 4 | "@commitlint/config-conventional": "^18.4.3", 5 | "conventional-changelog-cli": "^4.1.0" 6 | } 7 | } 8 | -------------------------------------------------------------------------------- /scripts/commit-msg-hook.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -euo pipefail 3 | 4 | COMMIT_FILE=$1 5 | COMMIT_MSG=$(cat "$COMMIT_FILE") 6 | 7 | # Check if the commit message follows commit linting rules 8 | if ! echo "$COMMIT_MSG" | npx commitlint; then 9 | echo "⚠️ Commit message does not follow commit linting rules ⚠️" 10 | exit 1 11 | fi -------------------------------------------------------------------------------- /scripts/install-hooks.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -euo pipefail 3 | 4 | cp ./scripts/pre-commit-hook.sh .git/hooks/pre-commit 5 | cp ./scripts/commit-msg-hook.sh .git/hooks/commit-msg 6 | chmod +x .git/hooks/pre-commit .git/hooks/commit-msg 7 | echo "Successfully installed git hooks (scripts/*-hook.sh) into .git/hooks/*" -------------------------------------------------------------------------------- /scripts/pre-commit-hook.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -euo pipefail 3 | 4 | # Often we want to avoid formatting unstaged changes (since they likely won't compile, etc) 5 | # So we stash them, run `make fmt`, then pop the stash if it was non-empty 6 | stash_flag=false 7 | if ! git diff --exit-code --quiet; then 8 | git stash save --keep-index 9 | stash_flag=true 10 | fi 11 | 12 | make fmt 13 | 14 | # Check if there are any changes 15 | if ! git diff --exit-code; then 16 | cat < pf ppf "@.@.@.") 20 | (fun ppf diagnostic -> 21 | pp_diagnostic ~config () ppf diagnostic; 22 | pf ppf "@.@."; 23 | pp_compact_diagnostic ~config () ppf diagnostic)) 24 | Fmt.stdout 25 | diagnostics 26 | ;; 27 | 28 | let pr_bad_diagnostics diagnostics = 29 | let open Grace_ansi_renderer in 30 | let config = Config.{ default with use_ansi = false } in 31 | Fmt.( 32 | list 33 | ~sep:(fun ppf () -> pf ppf "@.@.") 34 | (fun ppf diagnostic -> 35 | try pp_diagnostic ~config () ppf diagnostic with 36 | | exn -> Fmt.pf ppf "Raised: %s" (Exn.to_string exn))) 37 | Fmt.stdout 38 | diagnostics 39 | ;; 40 | 41 | (* Taken from https://github.com/brendanzab/codespan/blob/master/codespan-reporting/tests/term.rs *) 42 | 43 | let%expect_test "empty" = 44 | let diagnostics = 45 | let empty severity = 46 | Diagnostic. 47 | { severity 48 | ; message = (fun ppf -> Fmt.pf ppf "") 49 | ; labels = [] 50 | ; notes = [] 51 | ; code = None 52 | } 53 | in 54 | List.map ~f:empty Severity.[ Help; Note; Warning; Error; Bug ] 55 | in 56 | pr_diagnostics diagnostics; 57 | [%expect 58 | {| 59 | help: 60 | 61 | help: 62 | 63 | 64 | note: 65 | 66 | note: 67 | 68 | 69 | warning: 70 | 71 | warning: 72 | 73 | 74 | error: 75 | 76 | error: 77 | 78 | 79 | bug: 80 | 81 | bug: |}] 82 | ;; 83 | 84 | let%expect_test "same_line" = 85 | let source = 86 | source 87 | "one_line.rs" 88 | {| 89 | > fn main() { 90 | > let mut v = vec![Some("foo"), Some("bar")]; 91 | > v.push(v.pop().unwrap()); 92 | > } 93 | |} 94 | in 95 | let diagnostics = 96 | [ Diagnostic.createf 97 | ~labels: 98 | [ Label.primaryf 99 | ~range:(range ~source 71 72) 100 | "second mutable borrow occurs here" 101 | ; Label.secondaryf 102 | ~range:(range ~source 64 65) 103 | "first borrow later used by call" 104 | ; Label.secondaryf 105 | ~range:(range ~source 66 70) 106 | "first mutable borrow occurs here" 107 | ] 108 | Error 109 | "cannot borrow `v` as mutable more than once at a time" 110 | ; Diagnostic.createf 111 | ~notes: 112 | [ Message.create "For more information about this error, try `rustc --explain`" 113 | ] 114 | Error 115 | "aborting due to previous error" 116 | ] 117 | in 118 | pr_diagnostics diagnostics; 119 | [%expect 120 | {| 121 | error: cannot borrow `v` as mutable more than once at a time 122 | ┌─ one_line.rs:3:12 123 | 3 │ v.push(v.pop().unwrap()); 124 | │ - ---- ^ second mutable borrow occurs here 125 | │ │ │ 126 | │ │ first mutable borrow occurs here 127 | │ first borrow later used by call 128 | 129 | one_line.rs:3:12: error: cannot borrow `v` as mutable more than once at a time 130 | 131 | 132 | error: aborting due to previous error 133 | = For more information about this error, try `rustc --explain` 134 | 135 | error: aborting due to previous error 136 | = For more information about this error, try `rustc --explain` |}] 137 | ;; 138 | 139 | let%expect_test "overlapping" = 140 | let s1 = 141 | source 142 | "nested_impl_trait.rs" 143 | {| 144 | > use std::fmt::Debug; 145 | > 146 | > fn fine(x: impl Into) -> impl Into { x } 147 | > 148 | > fn bad_in_ret_position(x: impl Into) -> impl Into { x } 149 | |} 150 | in 151 | let s2 = 152 | source 153 | "typeck_type_placeholder_item.rs" 154 | {| 155 | > fn fn_test1() -> _ { 5 } 156 | > fn fn_test2(x: i32) -> (_, _) { (x, x) } 157 | |} 158 | in 159 | let s3 = 160 | source 161 | "libstd/thread/mod.rs" 162 | {| 163 | > #[stable(feature = "rust1", since = "1.0.0")] 164 | > pub fn spawn(self, f: F) -> io::Result> 165 | > where 166 | > F: FnOnce() -> T, 167 | > F: Send + 'static, 168 | > T: Send + 'static, 169 | > { 170 | > unsafe { self.spawn_unchecked(f) } 171 | > } 172 | |} 173 | in 174 | let s4 = 175 | source 176 | "no_send_res_ports.rs" 177 | {| 178 | > use std::thread; 179 | > use std::rc::Rc; 180 | > 181 | > #[derive(Debug)] 182 | > struct Port(Rc); 183 | > 184 | > fn main() { 185 | > #[derive(Debug)] 186 | > struct Foo { 187 | > _x: Port<()>, 188 | > } 189 | > 190 | > impl Drop for Foo { 191 | > fn drop(&mut self) {} 192 | > } 193 | > 194 | > fn foo(x: Port<()>) -> Foo { 195 | > Foo { 196 | > _x: x 197 | > } 198 | > } 199 | > 200 | > let x = foo(Port(Rc::new(()))); 201 | > 202 | > thread::spawn(move|| { 203 | > let y = x; 204 | > println!("{:?}", y); 205 | > }); 206 | > } 207 | |} 208 | in 209 | let diagnostics = 210 | Diagnostic. 211 | [ createf 212 | ~labels: 213 | Label. 214 | [ primaryf ~range:(range ~source:s1 129 139) "nested `impl Trait` here" 215 | ; secondaryf ~range:(range ~source:s1 119 140) "outer `impl Trait`" 216 | ] 217 | Error 218 | "nested `impl Trait` is not allowed" 219 | ; createf 220 | ~labels: 221 | Label. 222 | [ primaryf ~range:(range ~source:s2 17 18) "not allowed in type signatures" 223 | ; secondaryf 224 | ~range:(range ~source:s2 17 18) 225 | "help: replace with the correct return type: `i32`" 226 | ] 227 | Error 228 | "the type placeholder `_` is not allowed within types on item signatures" 229 | ; createf 230 | ~labels: 231 | Label. 232 | [ primaryf ~range:(range ~source:s2 49 50) "not allowed in type signatures" 233 | ; primaryf ~range:(range ~source:s2 52 53) "not allowed in type signatures" 234 | ; secondaryf 235 | ~range:(range ~source:s2 48 54) 236 | "help: replace with the correct return type: `(i32, i32)`" 237 | ] 238 | Error 239 | "the type placeholder `_` is not allowed within types on item signatures" 240 | ; createf 241 | ~labels: 242 | Label. 243 | [ primaryf 244 | ~range:(range ~source:s4 339 352) 245 | "`std::rc::Rc<()> cannot be sent between threads safely`" 246 | ; secondaryf 247 | ~range:(range ~source:s4 353 416) 248 | "within this `[closure@no_send_res_ports.rs:29:19: 33:6 x:main::Foo]`" 249 | ; secondaryf 250 | ~range:(range ~source:s3 141 145) 251 | "required by this bound in `std::thread::spawn`" 252 | ] 253 | ~notes: 254 | Message. 255 | [ create 256 | "help: within `[closure@no_send_res_ports.rs:29:19: 33:6 \ 257 | x:main::Foo]`, the trait `std::marker::Send` is not implemented for \ 258 | `std::rc::Rc<()>`" 259 | ; create "note: required because it appears within the type `Port<()>`" 260 | ; create "note: required because it appears within the type `main::Foo`" 261 | ; create 262 | "note: required because it appears within the type \ 263 | `[closure@no_send_res_ports.rs:29:19: 33:6 x:main::Foo]`" 264 | ] 265 | Error 266 | "`std::rc::Rc<()>` cannot be sent between threads safely" 267 | ; createf 268 | ~notes: 269 | Message. 270 | [ create "Some errors have detailed explanations: ..." 271 | ; create "For more information about an error, try `rustc --explain`" 272 | ] 273 | Error 274 | "aborting due 5 previous errors" 275 | ] 276 | in 277 | pr_diagnostics diagnostics; 278 | [%expect 279 | {| 280 | error: nested `impl Trait` is not allowed 281 | ┌─ nested_impl_trait.rs:5:56 282 | 5 │ fn bad_in_ret_position(x: impl Into) -> impl Into { x } 283 | │ ----------^^^^^^^^^^- 284 | │ │ │ 285 | │ │ nested `impl Trait` here 286 | │ outer `impl Trait` 287 | 288 | nested_impl_trait.rs:5:56: error: nested `impl Trait` is not allowed 289 | 290 | 291 | error: the type placeholder `_` is not allowed within types on item signatures 292 | ┌─ typeck_type_placeholder_item.rs:1:18 293 | 1 │ fn fn_test1() -> _ { 5 } 294 | │ ^ 295 | │ │ 296 | │ not allowed in type signatures 297 | │ help: replace with the correct return type: `i32` 298 | 299 | typeck_type_placeholder_item.rs:1:18: error: the type placeholder `_` is not allowed within types on item signatures 300 | 301 | 302 | error: the type placeholder `_` is not allowed within types on item signatures 303 | ┌─ typeck_type_placeholder_item.rs:2:28 304 | 2 │ fn fn_test2(x: i32) -> (_, _) { (x, x) } 305 | │ -^--^- 306 | │ ││ │ 307 | │ ││ not allowed in type signatures 308 | │ │not allowed in type signatures 309 | │ help: replace with the correct return type: `(i32, i32)` 310 | 311 | typeck_type_placeholder_item.rs:2:28: error: the type placeholder `_` is not allowed within types on item signatures 312 | 313 | 314 | error: `std::rc::Rc<()>` cannot be sent between threads safely 315 | ┌─ libstd/thread/mod.rs:5:8 316 | 5 │ F: Send + 'static, 317 | │ ---- required by this bound in `std::thread::spawn` 318 | ┌─ no_send_res_ports.rs:25:5 319 | 24 │ 320 | 25 │ thread::spawn(move|| { 321 | │ ^^^^^^^^^^^^^ `std::rc::Rc<()> cannot be sent between threads safely` 322 | │ ╭────────────────────' 323 | 26 │ │ let y = x; 324 | 27 │ │ println!("{:?}", y); 325 | 28 │ │ }); 326 | │ ╰───────' within this `[closure@no_send_res_ports.rs:29:19: 33:6 x:main::Foo]` 327 | 29 │ } 328 | = help: within `[closure@no_send_res_ports.rs:29:19: 33:6 x:main::Foo]`, the trait `std::marker::Send` is not implemented for `std::rc::Rc<()>` 329 | = note: required because it appears within the type `Port<()>` 330 | = note: required because it appears within the type `main::Foo` 331 | = note: required because it appears within the type `[closure@no_send_res_ports.rs:29:19: 33:6 x:main::Foo]` 332 | 333 | libstd/thread/mod.rs:5:8: error: `std::rc::Rc<()>` cannot be sent between threads safely 334 | no_send_res_ports.rs:25:5: error: `std::rc::Rc<()>` cannot be sent between threads safely 335 | = help: within `[closure@no_send_res_ports.rs:29:19: 33:6 x:main::Foo]`, the trait `std::marker::Send` is not implemented for `std::rc::Rc<()>` 336 | = note: required because it appears within the type `Port<()>` 337 | = note: required because it appears within the type `main::Foo` 338 | = note: required because it appears within the type `[closure@no_send_res_ports.rs:29:19: 33:6 x:main::Foo]` 339 | 340 | 341 | error: aborting due 5 previous errors 342 | = Some errors have detailed explanations: ... 343 | = For more information about an error, try `rustc --explain` 344 | 345 | error: aborting due 5 previous errors 346 | = Some errors have detailed explanations: ... 347 | = For more information about an error, try `rustc --explain` |}] 348 | ;; 349 | 350 | let%expect_test "same ranges" = 351 | let source = source "same_range" "::S { }" in 352 | let diagnostics = 353 | Diagnostic. 354 | [ createf 355 | ~labels: 356 | Label. 357 | [ primaryf ~range:(range ~source 4 5) "Unexpected '{'" 358 | ; secondaryf ~range:(range ~source 4 5) "Expected '('" 359 | ] 360 | Error 361 | "unexpected token" 362 | ] 363 | in 364 | pr_diagnostics diagnostics; 365 | [%expect 366 | {| 367 | error: unexpected token 368 | ┌─ same_range:1:5 369 | 1 │ ::S { } 370 | │ ^ 371 | │ │ 372 | │ Unexpected '{' 373 | │ Expected '(' 374 | 375 | same_range:1:5: error: unexpected token |}] 376 | ;; 377 | 378 | let%expect_test "multiline_overlapping" = 379 | let source = 380 | source 381 | "file.rs" 382 | {| 383 | > match line_index.compare(self.last_line_index()) { 384 | > Ordering::Less => Ok(self.line_starts()[line_index.to_usize()]), 385 | > Ordering::Equal => Ok(self.source_span().end()), 386 | > Ordering::Greater => LineIndexOutOfBoundsError { 387 | > given: line_index, 388 | > max: self.last_line_index() 389 | > }, 390 | > } 391 | |} 392 | in 393 | let diagnostics = 394 | Diagnostic. 395 | [ createf 396 | ~notes: 397 | [ Message.create 398 | "expected `Result`, found \ 399 | `LineIndexOutOfBoundsError`" 400 | ] 401 | ~labels: 402 | Label. 403 | [ secondaryf 404 | ~range:(range ~source 89 134) 405 | "this is found to be of type `Result`" 407 | ; primaryf 408 | ~range:(range ~source 230 350) 409 | "expected enum `Result`, found struct `LineIndexOutOfBoundsError`" 410 | ; secondaryf 411 | ~range:(range ~source 8 361) 412 | "`match` arms have incompatible types" 413 | ; secondaryf 414 | ~range:(range ~source 167 195) 415 | "this is found to be of type `Result`" 417 | ] 418 | Error 419 | "match arms have incompatible types" 420 | ] 421 | in 422 | pr_diagnostics diagnostics; 423 | [%expect 424 | {| 425 | error: match arms have incompatible types 426 | ┌─ file.rs:4:34 427 | 1 │ ╭ match line_index.compare(self.last_line_index()) { 428 | 2 │ │ Ordering::Less => Ok(self.line_starts()[line_index.to_usize()]), 429 | │ │ --------------------------------------------- this is found to be of type `Result` 430 | 3 │ │ Ordering::Equal => Ok(self.source_span().end()), 431 | │ │ ---------------------------- this is found to be of type `Result` 432 | 4 │ │ Ordering::Greater => LineIndexOutOfBoundsError { 433 | │ │ ╭───────────────────────────────────^ 434 | 5 │ │ │ given: line_index, 435 | 6 │ │ │ max: self.last_line_index() 436 | 7 │ │ │ }, 437 | │ │ ╰──────────────^ expected enum `Result`, found struct `LineIndexOutOfBoundsError` 438 | 8 │ │ } 439 | │ ╰────────────' `match` arms have incompatible types 440 | = expected `Result`, found `LineIndexOutOfBoundsError` 441 | 442 | file.rs:4:34: error: match arms have incompatible types 443 | = expected `Result`, found `LineIndexOutOfBoundsError` |}] 444 | ;; 445 | 446 | let%expect_test "unicode" = 447 | let source = source "unicode.rs" {|extern "路濫狼á́́" fn foo() {}|} in 448 | let diagnostics = 449 | Diagnostic. 450 | [ createf 451 | ~notes: 452 | [ Message.createf 453 | "@[valid ABIs:@.- aapcs@.- amdgpu-kernel@.- C@.- cdecl@.- efiapi@.- \ 454 | fastcall@.- msp430-interrupt@.- platform-intrinsic@.- ptx-kernel@.- \ 455 | Rust@.- rust-call@.- rust-intrinsic@.- stdcall@.- system@.- sysv64@.- \ 456 | thiscall@.- unadjusted@.- vectorcall@.- win64@.- x86-interrupt@]" 457 | ] 458 | ~labels:[ Label.primaryf ~range:(range ~source 7 24) "invalid ABI" ] 459 | Error 460 | "invalid ABI: found `路濫狼á́́`" 461 | ] 462 | in 463 | pr_diagnostics diagnostics; 464 | [%expect 465 | {| 466 | error: invalid ABI: found `路濫狼á́́` 467 | ┌─ unicode.rs:1:8 468 | 1 │ extern "路濫狼á́́" fn foo() {} 469 | │ ^^^^^^^^ invalid ABI 470 | = valid ABIs: 471 | - aapcs 472 | - amdgpu-kernel 473 | - C 474 | - cdecl 475 | - efiapi 476 | - fastcall 477 | - msp430-interrupt 478 | - platform-intrinsic 479 | - ptx-kernel 480 | - Rust 481 | - rust-call 482 | - rust-intrinsic 483 | - stdcall 484 | - system 485 | - sysv64 486 | - thiscall 487 | - unadjusted 488 | - vectorcall 489 | - win64 490 | - x86-interrupt 491 | 492 | unicode.rs:1:8: error: invalid ABI: found `路濫狼á́́` 493 | = valid ABIs: 494 | - aapcs 495 | - amdgpu-kernel 496 | - C 497 | - cdecl 498 | - efiapi 499 | - fastcall 500 | - msp430-interrupt 501 | - platform-intrinsic 502 | - ptx-kernel 503 | - Rust 504 | - rust-call 505 | - rust-intrinsic 506 | - stdcall 507 | - system 508 | - sysv64 509 | - thiscall 510 | - unadjusted 511 | - vectorcall 512 | - win64 513 | - x86-interrupt |}] 514 | ;; 515 | 516 | let%expect_test "unicode spans" = 517 | let source = source "moon_jump.rs" "🐄🌑🐄🌒🐄🌓🐄🌔🐄🌕🐄🌖🐄🌗🐄🌘🐄" in 518 | let invalid_start = 1 in 519 | let invalid_stop = String.length "🐄" - 1 in 520 | let diagnostics = 521 | Diagnostic. 522 | [ createf 523 | ~labels: 524 | [ Label.primaryf 525 | ~range:(range ~source invalid_start invalid_stop) 526 | "Invalid jump" 527 | ] 528 | Error 529 | "Cow may not jump during new moon." 530 | ; createf 531 | ~labels: 532 | [ Label.secondaryf 533 | ~range:(range ~source invalid_start (String.length "🐄")) 534 | "Cow range does not start at boundary." 535 | ] 536 | Note 537 | "Invalid unicode range" 538 | ; createf 539 | ~labels: 540 | [ Label.secondaryf 541 | ~range:(range ~source (String.length "🐄🌑") (String.length "🐄🌑🐄" - 1)) 542 | "Cow range does not end at boundary" 543 | ] 544 | Note 545 | "Invalid unicode range" 546 | ; createf 547 | ~labels: 548 | [ Label.secondaryf 549 | ~range:(range ~source invalid_start (String.length "🐄🌑🐄" - 1)) 550 | "Cow does not start or end at boundary." 551 | ] 552 | Note 553 | "Invalid unicode range" 554 | ] 555 | in 556 | pr_bad_diagnostics diagnostics; 557 | [%expect 558 | {| 559 | Raised: (Invalid_argument "invalid UTF-8") 560 | 561 | Raised: (Invalid_argument "invalid UTF-8") 562 | 563 | Raised: (Invalid_argument "invalid UTF-8") 564 | 565 | Raised: (Invalid_argument "invalid UTF-8") |}] 566 | ;; 567 | -------------------------------------------------------------------------------- /test/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_core) 3 | (modules import test_range) 4 | (libraries core fmt grace) 5 | (inline_tests) 6 | (preprocess 7 | (pps ppx_jane))) 8 | -------------------------------------------------------------------------------- /test/core/import.ml: -------------------------------------------------------------------------------- 1 | include Core 2 | include Grace 3 | 4 | let fail fn = 5 | match Or_error.try_with fn with 6 | | Ok _ -> raise_s [%message "Test failed to raise an error."] 7 | | Error err -> 8 | Format.printf 9 | "@[Test raised error as expected.@;Error: @[%a@]@]" 10 | Error.pp 11 | err 12 | ;; 13 | -------------------------------------------------------------------------------- /test/core/test_range.ml: -------------------------------------------------------------------------------- 1 | open! Import 2 | 3 | let source_length = 40 4 | 5 | let source : Source.t = 6 | `Reader 7 | { id = 0; name = Some "test"; length = source_length; unsafe_get = (fun _ -> 'a') } 8 | ;; 9 | 10 | let range start stop = 11 | Range.create ~source (Byte_index.of_int start) (Byte_index.of_int stop) 12 | ;; 13 | 14 | let range_generator = 15 | Quickcheck.Generator.( 16 | let open Let_syntax in 17 | let%bind idx = small_non_negative_int in 18 | let%map off = Int.gen_incl 0 (source_length - idx) in 19 | range idx (idx + off)) 20 | ;; 21 | 22 | let%expect_test _ = 23 | fail (fun () -> Byte_index.of_int (-1)); 24 | [%expect 25 | {| 26 | Test raised error as expected. 27 | Error: ("invariant failed" lib/core/index.ml:28:24 28 | (exn "Assert_failure lib/core/index.ml:28:55") -1) |}]; 29 | let print ~op ~op_name idx off = 30 | Fmt.pr 31 | "@[idx: %a@;off: %d@;idx %s off: %a@]@." 32 | Byte_index.pp 33 | idx 34 | off 35 | op_name 36 | Byte_index.pp 37 | (op idx off) 38 | in 39 | (* Add offset *) 40 | let idx = Byte_index.of_int 20 in 41 | List.iter [ 2; 10; -2 ] ~f:(fun off -> print ~op:Byte_index.add ~op_name:"+" idx off); 42 | [%expect 43 | {| 44 | idx: 20 45 | off: 2 46 | idx + off: 22 47 | idx: 20 48 | off: 10 49 | idx + off: 30 50 | idx: 20 51 | off: -2 52 | idx + off: 18 |}]; 53 | (* Subtract offset *) 54 | let idx = Byte_index.of_int 10 in 55 | List.iter [ 8; -3 ] ~f:(fun off -> print ~op:Byte_index.sub ~op_name:"-" idx off); 56 | [%expect 57 | {| 58 | idx: 10 59 | off: 8 60 | idx - off: 2 61 | idx: 10 62 | off: -3 63 | idx - off: 13 |}]; 64 | (* Add -ve offset invaliding [idx > 0] invariant *) 65 | fail (fun () -> 66 | let idx = Byte_index.of_int 2 in 67 | let off = -10 in 68 | print ~op:Byte_index.add ~op_name:"+" idx off); 69 | [%expect 70 | {| 71 | Test raised error as expected. 72 | Error: ("invariant failed" lib/core/index.ml:28:24 73 | (exn "Assert_failure lib/core/index.ml:28:55") -8) |}]; 74 | (* Subtract +ve offset invaliding [idx > 0] invariant *) 75 | fail (fun () -> 76 | let idx = Byte_index.of_int 10 in 77 | let off = 20 in 78 | print ~op:Byte_index.sub ~op_name:"-" idx off); 79 | [%expect 80 | {| 81 | Test raised error as expected. 82 | Error: ("invariant failed" lib/core/index.ml:28:24 83 | (exn "Assert_failure lib/core/index.ml:28:55") -10) |}] 84 | ;; 85 | 86 | let%test_unit _ = 87 | (* Identity *) 88 | Quickcheck.test range_generator ~f:(fun a -> assert (Range.(merge a a = a))) 89 | ;; 90 | 91 | let%test_unit _ = 92 | (* Commute *) 93 | Quickcheck.test 94 | Quickcheck.Generator.(tuple2 range_generator range_generator) 95 | ~f:(fun (a, b) -> assert (Range.(merge a b = merge b a))) 96 | ;; 97 | 98 | let%expect_test _ = 99 | let print a b = 100 | Fmt.pr 101 | "@[a: %a@;b: %a@;Range.merge a b: %a@;Range.inter a b: %a@]@." 102 | Range.pp 103 | a 104 | Range.pp 105 | b 106 | Range.pp 107 | (Range.merge a b) 108 | Range.pp 109 | (Range.inter a b) 110 | in 111 | (* Overlapping *) 112 | let a = range 1 5 in 113 | let b = range 3 10 in 114 | print a b; 115 | [%expect 116 | {| 117 | a: [1, 5) 118 | b: [3, 10) 119 | Range.merge a b: [1, 10) 120 | Range.inter a b: [3, 5) |}]; 121 | (* Subset *) 122 | let a = range 1 10 in 123 | let b = range 3 7 in 124 | print a b; 125 | [%expect 126 | {| 127 | a: [1, 10) 128 | b: [3, 7) 129 | Range.merge a b: [1, 10) 130 | Range.inter a b: [3, 7) |}]; 131 | (* Disjoint *) 132 | let a = range 1 10 in 133 | let b = range 10 20 in 134 | print a b; 135 | [%expect 136 | {| 137 | a: [1, 10) 138 | b: [10, 20) 139 | Range.merge a b: [1, 20) 140 | Range.inter a b: [10, 10) |}] 141 | ;; 142 | 143 | let%expect_test _ = 144 | let print a b = 145 | Fmt.pr 146 | "@[a: %a@;b: %a@;Range.are_disjoint a b: %b@]@." 147 | Range.pp 148 | a 149 | Range.pp 150 | b 151 | (Range.are_disjoint a b) 152 | in 153 | (* Overlapping *) 154 | let a = range 1 5 in 155 | let b = range 3 10 in 156 | print a b; 157 | [%expect {| 158 | a: [1, 5) 159 | b: [3, 10) 160 | Range.are_disjoint a b: false |}]; 161 | (* Subset *) 162 | let a = range 1 10 in 163 | let b = range 3 7 in 164 | print a b; 165 | [%expect {| 166 | a: [1, 10) 167 | b: [3, 7) 168 | Range.are_disjoint a b: false |}]; 169 | (* Disjoint *) 170 | let a = range 1 5 in 171 | let b = range 10 20 in 172 | print a b; 173 | [%expect {| 174 | a: [1, 5) 175 | b: [10, 20) 176 | Range.are_disjoint a b: true |}]; 177 | (* Off by one *) 178 | let b = range 5 10 in 179 | print a b; 180 | [%expect {| 181 | a: [1, 5) 182 | b: [5, 10) 183 | Range.are_disjoint a b: true |}]; 184 | let b = range 0 1 in 185 | print a b; 186 | [%expect {| 187 | a: [1, 5) 188 | b: [0, 1) 189 | Range.are_disjoint a b: true |}] 190 | ;; 191 | -------------------------------------------------------------------------------- /test/source_reader/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_source_reader) 3 | (libraries core fmt grace grace.source_reader) 4 | (inline_tests) 5 | (preprocess 6 | (pps ppx_jane))) 7 | -------------------------------------------------------------------------------- /test/source_reader/test_source_reader.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Grace 3 | module Source_reader = Grace_source_reader 4 | 5 | let () = Source_reader.init () 6 | let foo_content = "foo\nbar\r\n\nbaz" 7 | let foo : Source.t = `String { name = Some "foo_test"; content = foo_content } 8 | let foo_sd = Source_reader.open_source foo 9 | let pp_escaped_string ppf str = Fmt.pf ppf "%s" (String.escaped str) 10 | 11 | let pp_line_starts ppf (line_starts : Source_reader.Line_starts.t) = 12 | Fmt.pf ppf "@["; 13 | for i = 0 to line_starts.length - 1 do 14 | if i <> 0 then Fmt.comma ppf (); 15 | Byte_index.pp ppf (line_starts.unsafe_get i) 16 | done; 17 | Fmt.pf ppf "@]" 18 | ;; 19 | 20 | let%expect_test _ = 21 | Format.printf "%a" Format.(pp_print_option pp_print_string) (Source.name foo); 22 | [%expect {| foo_test |}] 23 | ;; 24 | 25 | let%expect_test _ = 26 | (* Line index *) 27 | let byte_idxs = List.map ~f:Byte_index.of_int [ 0; 7; 8; 9; 11; 100 ] in 28 | Format.printf "source: %a@." pp_escaped_string foo_content; 29 | List.iter byte_idxs ~f:(fun idx -> 30 | Format.printf 31 | "@[idx: %a@;Line.index idx: %a@]@." 32 | Byte_index.pp 33 | idx 34 | Line_index.pp 35 | (Source_reader.Line.of_byte_index foo_sd idx).idx); 36 | [%expect 37 | {| 38 | source: foo\nbar\r\n\nbaz 39 | idx: 0 40 | Line.index idx: 0 41 | idx: 7 42 | Line.index idx: 1 43 | idx: 8 44 | Line.index idx: 1 45 | idx: 9 46 | Line.index idx: 2 47 | idx: 11 48 | Line.index idx: 3 49 | idx: 100 50 | Line.index idx: 3 |}] 51 | ;; 52 | 53 | let%expect_test _ = 54 | (* Line starts *) 55 | let lines_starts = Source_reader.line_starts foo_sd in 56 | let last_line = Source_reader.Line.last foo_sd in 57 | Fmt.pr 58 | "@[source: %a@;line_starts: %a@;last: %a@]@." 59 | pp_escaped_string 60 | foo_content 61 | pp_line_starts 62 | lines_starts 63 | Line_index.pp 64 | last_line.idx; 65 | [%expect 66 | {| 67 | source: foo\nbar\r\n\nbaz 68 | line_starts: 0, 69 | 4, 70 | 9, 71 | 10 72 | last: 4 |}] 73 | ;; 74 | 75 | let%expect_test _ = 76 | (* Line ranges *) 77 | let line_idxs = List.map ~f:Line_index.of_int [ 0; 1; 2; 3 ] in 78 | Fmt.pr "source: %a@." pp_escaped_string foo_content; 79 | List.iter line_idxs ~f:(fun idx -> 80 | Fmt.pr 81 | "@[idx: %a@;Line.range idx: %a@]@." 82 | Line_index.pp 83 | idx 84 | Range.pp 85 | (Source_reader.Line.of_line_index foo_sd idx).range); 86 | [%expect 87 | {| 88 | source: foo\nbar\r\n\nbaz 89 | idx: 0 90 | Line.range idx: [0, 4) 91 | idx: 1 92 | Line.range idx: [4, 9) 93 | idx: 2 94 | Line.range idx: [9, 10) 95 | idx: 3 96 | Line.range idx: [10, 13) |}]; 97 | (* Line slices (tests Line.range + Source.slice) *) 98 | Fmt.pr "source: %a@." pp_escaped_string foo_content; 99 | List.iter line_idxs ~f:(fun idx -> 100 | Fmt.pr 101 | "@[idx: %a@;Line.slice idx: %a@]@." 102 | Line_index.pp 103 | idx 104 | pp_escaped_string 105 | Source_reader.Line.(of_line_index foo_sd idx |> slice ~sd:foo_sd)); 106 | [%expect 107 | {| 108 | source: foo\nbar\r\n\nbaz 109 | idx: 0 110 | Line.slice idx: foo\n 111 | idx: 1 112 | Line.slice idx: bar\r\n 113 | idx: 2 114 | Line.slice idx: \n 115 | idx: 3 116 | Line.slice idx: baz |}] 117 | ;; 118 | 119 | let%expect_test _ = 120 | (* Source length *) 121 | Fmt.pr 122 | "@[source: %a@;source length: %d@;Source_reader.length: %d@]" 123 | pp_escaped_string 124 | foo_content 125 | (String.length foo_content) 126 | (Source_reader.length foo_sd); 127 | [%expect 128 | {| 129 | source: foo\nbar\r\n\nbaz 130 | source length: 13 131 | Source_reader.length: 13 |}] 132 | ;; 133 | 134 | let () = Source_reader.clear () 135 | --------------------------------------------------------------------------------