├── .github ├── CODEOWNERS └── workflows │ └── test-emacs.yml ├── .gitignore ├── .ocp-indent ├── CHANGES.md ├── CODE_OF_CONDUCT.md ├── CONTRIBUTING.md ├── LICENSE ├── Makefile ├── README.md ├── dune ├── dune-project ├── dune-workspace.dev ├── examples ├── custom-utop │ ├── README.md │ ├── dune │ └── myutop.ml └── interact │ ├── dune │ ├── test_program.ml │ └── test_program.mli ├── man ├── dune ├── utop-full.1 ├── utop.1 └── utoprc.5 ├── screenshot.png ├── src ├── lib │ ├── dune │ ├── uTop.ml │ ├── uTop.mli │ ├── uTop_compat.ml │ ├── uTop_complete.ml │ ├── uTop_complete.mli │ ├── uTop_history.ml │ ├── uTop_history.mli │ ├── uTop_lexer.mli │ ├── uTop_lexer.mll │ ├── uTop_main.ml │ ├── uTop_main.mli │ ├── uTop_private.ml │ ├── uTop_styles.ml │ ├── uTop_styles.mli │ └── uTop_token.ml └── top │ ├── Eldev │ ├── dune │ ├── expunge │ ├── dune │ └── modules.ml │ ├── utop.el │ └── utop.ml ├── test ├── dune ├── test_lib.ml └── test_lib.mli ├── utop.opam ├── utoprc-dark └── utoprc-light /.github/CODEOWNERS: -------------------------------------------------------------------------------- 1 | * @rgrinberg 2 | -------------------------------------------------------------------------------- /.github/workflows/test-emacs.yml: -------------------------------------------------------------------------------- 1 | name: Test Emacs 2 | 3 | on: 4 | push: 5 | paths: ['**.el'] 6 | pull_request: 7 | paths: ['**.el'] 8 | 9 | jobs: 10 | test: 11 | runs-on: ubuntu-latest 12 | continue-on-error: ${{matrix.emacs_version == 'snapshot'}} 13 | 14 | strategy: 15 | matrix: 16 | emacs_version: ['26.3', '27.1', '28.1', 'snapshot'] 17 | 18 | steps: 19 | - name: Set up Emacs 20 | uses: purcell/setup-emacs@master 21 | with: 22 | version: ${{matrix.emacs_version}} 23 | 24 | - name: Install Eldev 25 | run: curl -fsSL https://raw.github.com/doublep/eldev/master/webinstall/github-eldev | sh 26 | 27 | - name: Check out the source code 28 | uses: actions/checkout@v2 29 | 30 | - name: Test the project 31 | run: | 32 | cd src/top 33 | # eldev -p -dtT -C test --expect 100 34 | eldev -dtT -C compile --warnings-as-errors 35 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | .merlin 3 | *.install 4 | *.elc 5 | .*.swp 6 | .eldev 7 | 8 | /result* 9 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | JaneStreet 2 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | 2.15.0 (2024-11-25) 2 | ------------------ 3 | 4 | * Add support for OCaml 5.3 (#489, @anmonteiro, @anmonteiro, @Octachron) 5 | 6 | 2.14.0 (2024-02-26) 7 | ------------------- 8 | 9 | * Add support for OCaml 5.2 (#470, fixes #466, @leostera, @ManasJayanth, 10 | @huwaireb) 11 | 12 | 2.13.1 (2023-07-07) 13 | ------------------- 14 | 15 | * Fix unavailable expunge on Windows (#447, @jonahbeckford) 16 | 17 | 2.13.0 (2023-07-03) 18 | ------------------- 19 | 20 | * Fix behavior of utop -stdin (#434, fixes #433, @tuohy) 21 | 22 | * Handle bounds with `Zed.next_error` (#442, @tmattio) 23 | 24 | * Load files from XDG directories (the legacy paths still work). (#431, 25 | @Skyb0rg007) 26 | 27 | * Remove deprecated values `prompt_continue`, `prompt_comment`, `smart_accept`, 28 | `new_prompt_hooks`, `at_new_prompt` (#427, @emillon) 29 | 30 | * Require OCaml 4.11.0 or newer. (#444, @emillon) 31 | 32 | 2.12.1 (2023-04-21) 33 | ------------------- 34 | 35 | * Fix regression with unit qualification when a `Unit` module is in scope with 36 | no `()` constructor (#429, fixes #428, @emillon) 37 | 38 | * emacs: add completion-at-point implementation (#406, fixes #261, @j-shilling) 39 | 40 | 2.12.0 (2023-04-17) 41 | ------------------- 42 | 43 | * Add support for OCaml 5.1 (#421, @emillon) 44 | 45 | * Mark `prompt_continue`, `prompt_comment`, `smart_accept`, `new_prompt_hooks`, 46 | `at_new_prompt` as deprecated (they have been documented as such since 2012 47 | and most of them are ignored) (#415, @emillon) 48 | 49 | * Qualify `()` constructor in generated expressions. (#418, fixes #417, @emillon) 50 | 51 | 2.11.0 (2023-01-05) 52 | ------------------- 53 | 54 | * Bump the compatibility to 4.08+ (#393 @emillon) 55 | * Load `@toplevel_printer` annotated printers for functors (#378 @metavinek) 56 | * Do not display a backtrace when exiting normally (#399 #398 @emillon) 57 | 58 | 2.10.0 (2022-10-06) 59 | ------------------ 60 | 61 | * Use dependencies compatible with OCaml 5: 62 | - Use zed 3.2.0, based on uucp, uutf, and uuseg instead of camomile 63 | - Use logs.lwt instead of `lwt_logs` 64 | 65 | 2.9.2 (2022-06-15) 66 | ------------------ 67 | 68 | * Add support for OCaml 5.0 (#377 @dra27) 69 | 70 | 2.9.1 (2022-03-28) 71 | ------------------ 72 | 73 | * Add support for OCaml 5.0 (#371 @favonia) 74 | 75 | 2.9.0 (2021-12-09) 76 | ------------------ 77 | 78 | * Add support for OCaml 4.14 (#360 @kit-ty-kate) 79 | * Document options in utop(1) manpage (#364 #365 @lindig) 80 | 81 | 2.8.0 (2021-06-18) 82 | ------------------ 83 | 84 | * If the current working directory is the home directory, then 85 | do not load `.ocamlinit` (@hyphenrf @copy #338) 86 | * With OCaml 4.12.0 and later, the toplevel uses the toplevel 87 | state to exit with the right status code (#348 @octachron) 88 | * Fix color highlight for errors (#350 @chripell) 89 | * Add support for OCaml 4.13 (#353 @kit-ty-kate) 90 | 91 | Emacs mode fixes: 92 | * Company text-completion fixes (@leungbk #340) 93 | * `utop-query-arguments` always returns `(utop-arguments)` whether 94 | it sets the utop-command or not (@dansanduleac #347) 95 | * Fix completion returning bogus candidates (#352 @chripell @rgrinberg) 96 | 97 | 2.7.0 (2021-01-06) 98 | ------------------ 99 | 100 | * add support for OCaml 4.12 (@emillon, #339) 101 | 102 | 2.6.0 (2020-05-30) 103 | ------------------ 104 | 105 | * compatible with OCaml 4.11 (@kit-ty-kate, #322) 106 | * switch to the new parser exposed since 4.11 107 | * Vi edit mode: register support 108 | 109 | 2.5.0 (2020-04-26) 110 | ------------------ 111 | 112 | ### Additions 113 | 114 | * add `#edit_mode_vi` and `#edit_mode_default` mode to set the editing mode(@kandu) 115 | * Backport the `#use_output` directive (@diml, #313) 116 | 117 | ### General 118 | 119 | * Load init file from ~/.config/utop/init.ml as per XDG conventions (@copy, #144) 120 | * Add OCaml 4.09 and 4.10 to the CI matrix (@kit-ty-kate, #310) 121 | * Add documentation for dune utop usage in emacs (@samarthkishor, #307) 122 | 123 | 2.4.3 (2019-12-31) 124 | ------------------ 125 | 126 | * add support for OCaml 4.10 127 | 128 | 2.4.2 (2019-09-18) 129 | ------------------ 130 | 131 | * Add support for OCaml 4.09.0 (@octachron @avsm, #299) 132 | 133 | 2.4.1 (2019-08-09) 134 | ------------------ 135 | 136 | ### General 137 | 138 | * Remove camlp4 remnants (@XVilka, #290) (@kandu, #293) 139 | * Allow to statically link utop (@diml, #285) (@hongchangwu, #286) 140 | 141 | ### Misc 142 | 143 | * Remove broken elisp (m-plamann, #292) 144 | * Add OCaml 4.08 build in Travis CI (XVilka, #291) 145 | 146 | 2.4.0 (2019-05-17) 147 | ------------------ 148 | 149 | ### General 150 | 151 | * Better support for wide and combined glyph (@kandu) 152 | * Added tips for simpe prompt without fancy features (Marshall Abrams, #279) 153 | * Correct quoting for Windows command shell (Dmitry Bely, #272) 154 | 155 | ### Additions 156 | 157 | * 4.08 compatibility (#284) 158 | * module `UTop`: add `get_load_path` and `set_load_path` to manage the include directories (#284) 159 | 160 | ### Breaking 161 | 162 | * module `UTop`: `val load_path : string list ref` is removed (#284) 163 | 164 | 2.3.0 (2019-01-31) 165 | ------------------ 166 | 167 | The new feature in this release is to automatically install 168 | printers marked with `[@@ocaml.toplevel_printer]` (#269 @diml). 169 | Adding this annotation to your libraries will remove the need 170 | to have a separate `top` package to install the printers. 171 | 172 | For example, in the [uri](https://github.com/mirage/ocaml-uri) 173 | library, the old printing function for `Uri.t` was: 174 | 175 | ``` 176 | val pp_hum : Format.formatter -> t -> unit 177 | ``` 178 | 179 | Just adding this annotation results in `Uri.t` values being automatically 180 | pretty printed in this version of utop. 181 | 182 | ``` 183 | val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer] 184 | ``` 185 | 186 | * Add cool screenshot to README (#259 @rizo) and update links (#257 @bobot) 187 | * Improve robustness by using more tail-recursive functions (#251 @gpetiot) 188 | * Remove deprecation warnings in newer compilers (#246 @ncihnegn) 189 | * Minimum OCaml version supported is now 4.03.0 (#254 @XVilka) 190 | * Publish API documentation online and add `doc:` entry to opam file (#270 @avsm) 191 | * Port build to dune from jbuilder (#268 @avsm) 192 | * Upgrade local opam metadata to opam 2.0 format (#268 @avsm) 193 | 194 | 2.2.0 (2018-07-15) 195 | ------------------ 196 | 197 | * 4.07.0 compatibility (#238, @hcarty) 198 | * Fix compatibility with latest tuareg-mode (#241, @Wilfred) 199 | * Do not expand include directories (#242, @sliquister) 200 | 201 | 2.1.0 (2018-02-28) 202 | ------------------ 203 | 204 | * Add support for company-mode based completion in utop.el (#233) 205 | 206 | 2.0.2 (2017-11-07) 207 | ------------------ 208 | 209 | * 4.06.0 compatibility (#221) 210 | 211 | 2.0.1 (2016-05-30) 212 | ------------------ 213 | 214 | * Fix: restore the installation of `utop.el` (#210, Louis Gesbert) 215 | 216 | 2.0.0 (2016-05-26) 217 | ------------------ 218 | 219 | * Add `-implicit-bindings` option to automatically bind expressions to names 220 | `_0`, `_1` and so on. For example, `3 + 4;;` becomes `let _0 = 3 + 4;;` 221 | (#161, #193, Fabian Hemmer) 222 | * Add tab completion for `#mod_use` (#181, Leonid Rozenberg) 223 | * Mention `#help` in `#utop_help` (#190, Fabian Hemmer) 224 | * Add `#utop_stash` and `#utop_save` to save the session to a file 225 | (#169, #199, Christopher Mcalpine and Fabian Hemmer) 226 | * Add support for reason in the emacs mode (#206, Andrea Richiardi) 227 | * Fix a bug where utop wouldn't apply ppx rewriters when running in 228 | emacs (Bug report: #192, fix: #202, Deokhwan Kim) 229 | * Refactor the use of hooks to support the various OCaml emacs mode 230 | (#201, Andrea Richiardi) 231 | * Drop support for camlp4/camlp5 232 | * Drop support for OCaml <= 4.01 233 | * Switch the build system to jbuilder 234 | * Resurect `UTop_main.interact` 235 | 236 | 1.19.3 (2016-08-15) 237 | ------------------- 238 | 239 | * fix compatibility with 4.04.0+beta1 240 | 241 | 1.19.2 (2016-04-25) 242 | ------------------- 243 | 244 | * Make ppx\_tools dependency optional 245 | 246 | 1.19.1 (2016-04-18) 247 | ------------------- 248 | 249 | * fix compatibility with 4.03.0+beta2 250 | 251 | 1.19 (2016-04-07) 252 | ----------------- 253 | 254 | * allow to configure the external editor with `UTop.set_external_editor` 255 | * add `UTop.set_margin_function` to allow users to set 256 | the margin for the toplevel outcome. It is 80 by default 257 | * better for quoted strings (`{|...|}`) 258 | * add a `#pwd` directive 259 | * experimental support for running utop in the middle of a program 260 | with `UTop_main.interact` 261 | * fix Async integration (automatic waiting of `_ Deferred.t` value). 262 | The new version is more robust against future change in Async 263 | * fix use of the non-existing `replace-in-string` function in the 264 | emacs mode (Syohei Yoshida) 265 | * fallback to Latin-1 for invalid UTF-8 sequences in the compiler output 266 | 267 | 1.18.2 (2016-03-02) 268 | ------------------- 269 | 270 | * fix compatibility with OCaml 4.03 271 | 272 | 1.18.1 (2015-11-03) 273 | ------------------- 274 | 275 | * fix compatibility with findlib 1.5.6 276 | 277 | 1.18 (2015-06-23) 278 | ----------------- 279 | 280 | * emace mode improvements (Mads Hartmann Jensen) 281 | - add `utop-minor-mode` to make integration with major modes cleaner 282 | - clean-up of the elisp code 283 | * add `UTop.end_and_accept_current_phrase` to avoid typing `;;` at the 284 | end of every phrases 285 | * fix compatibility with OCaml trunk 286 | 287 | 1.17 (2014-12-12) 288 | ----------------- 289 | 290 | * re-export `Config.load_path` as `UTop.load_path` (Peter Zotov) 291 | * enable utop-command to be buffer-local (Mads Hartmann Jensen) 292 | * fix 4.01 compatibility (Peter Zotov) 293 | 294 | 1.16 (2014-10-20) 295 | ----------------- 296 | 297 | * make camlp4 support optional 298 | * require OCaml 4.01.0 or newer 299 | * implement wrapper for -safe-string 300 | 301 | 1.15 (2014-08-30) 302 | ----------------- 303 | 304 | * fix compatibility with OCaml 4.02.0 305 | 306 | 1.14 (2014-07-05) 307 | ----------------- 308 | 309 | * fix compatibility with OCaml 4.00.1 and earlier 310 | 311 | 1.13 (2014-07-04) 312 | ----------------- 313 | 314 | * don't try to colorize the output when there is too much 315 | * add auto-completion for the `#ppx` directive 316 | * add support for -ppx, -dparsetree and -dsource 317 | * fix compatibility with OCaml 4.02 318 | * update pa_optcomp 319 | * do not display the camlp4 welcome message 320 | 321 | 1.12 (2014-04-21) 322 | ----------------- 323 | 324 | * supports -require for scripts 325 | * support for React 1.0.0 326 | * make utop.el compatible with melpa: http://melpa.milkbox.net 327 | 328 | 1.11 (2014-02-11) 329 | ----------------- 330 | 331 | * update the async hook following the renaming of `Async_core` to 332 | `Async_kernel` 333 | * fix tab completion not working on some emacs 334 | * complete `#load_rec` the same way as `#load` 335 | 336 | 1.10 (2013-12-10) 337 | ----------------- 338 | 339 | * add the `-require` command line argument to specify packages on the 340 | command line 341 | 342 | 1.9 (2013-11-26) 343 | ---------------- 344 | 345 | * automatically load all files in `$OCAML_TOPLEVEL_PATH/autoload` at 346 | startup. Can be disabled with `autoload: false` in `~/.utoprc` or 347 | `-no-autoload`. 348 | * fix #38: handle errors from custom camlp4 ast filters 349 | * fix #7: avoid a stack overflow in UTop_lexer 350 | 351 | 1.8 (2013-10-25) 352 | ---------------- 353 | 354 | * handle new syntax errors 355 | * extend `#typeof` to values and modules. Thanks to Thomas Refis for 356 | this feature 357 | 358 | 1.7 (2013-08-08) 359 | ---------------- 360 | 361 | * fix compilation with ocaml < 4.01 362 | 363 | 1.6 (2013-08-07) 364 | ---------------- 365 | 366 | * hide topfind messages by default 367 | * more predefined prompts available via `#utop_prompt_XXX` 368 | * fix a bug in `#require` when passing multiple packages 369 | * display errors in ~/.lambda-term-inputrc nicely 370 | * doc update 371 | * fix an issue when using first-class modules 372 | 373 | 1.5 (2013-04-28) 374 | ---------------- 375 | 376 | * when evaluating a region/buffer in emacs, evaluate all phrases 377 | instead of just the first one. Thanks to Matthias Andreas Benkard 378 | for this feature 379 | * change the default prompt from `#` to `$` to match the standard 380 | toplevel 381 | * add the option `UTop.show_box` to allow one to hide the completion 382 | bar 383 | * enhance the lwt/async hooks for automatically waiting on a 384 | thread/deferred. Hooks were not triggered when the type of the 385 | expression was a type alias 386 | 387 | 1.4 (2013-03-09) 388 | ---------------- 389 | 390 | * hide identifiers starting with `_`. This can be disabled with 391 | `UTop.set_hide_reserved false`. 392 | * automatically load camlp4 parsing (with original syntax) when 393 | trying to load a syntax extension 394 | * fix a small bug when using camlp4, causing an exception to be raised 395 | when pressing `Enter` in the middle of a comment 396 | 397 | 1.3 (2013-01-29) 398 | ---------------- 399 | 400 | * allow to automatically wait for ascync deferred values 401 | * added the `-short-paths` options for OCaml >= 4.01.0 402 | (and make it the default) 403 | 404 | 1.2.1 (2012-07-31) 405 | ------------------ 406 | 407 | * fix: do not expunge `Toploop` 408 | * install a non-expunged version of utop: `utop-full` 409 | 410 | 1.2 (2012-07-30) 411 | ---------------- 412 | 413 | * ocaml 4.00 compatibility 414 | * prevent findlib from being initialized twice 415 | * better highlighting of errors 416 | * automatically insert `Lwt_main.run` for 417 | toplevel expressions of type `'a Lwt.t` 418 | * better camlp4 support 419 | * parse quotations and antiquotations to 420 | handle completion inside them 421 | * better support revised syntax 422 | * emacs mode improvements 423 | * various fixes 424 | * highlight errors 425 | * add a menu 426 | * add interactive list of findlib packages 427 | * packages can be pre-loaded via the file variable 428 | `utop-package-list` 429 | * better tuareg integration 430 | * typerex integration 431 | * allow to complete using the toplevel environment 432 | in a tuareg buffer 433 | * allow to change the utop command 434 | * use the same history as the terminal mode 435 | * follow output of ocaml 436 | 437 | 1.1 (2010-08-06) 438 | ---------------- 439 | 440 | * add completion on labels 441 | * add completion on methods 442 | * smarter completion on record fields 443 | * fix a bug in the lexer 444 | * improvement for the emacs mode: 445 | * now pressing Tab really complete input 446 | * when sending input from a tuareg buffer, the cursor follow the 447 | end of buffer in all utop windows 448 | * fix usage of threads 449 | * add help 450 | * add manual pages 451 | * show more information in the prompt: 452 | * show the current value of the macro counter 453 | * show the number of key pressed since the beginning of a macro 454 | when recording a macro 455 | * show intermediate key sequence 456 | * better support for light colors terminals 457 | * add colors for module name and directives 458 | * add `UTop.smart_accept` to send only lines terminating with a `;;` token 459 | * search for compiler libraries at configure time 460 | * add a script to install compiler libraries 461 | * fix compatibility with ocaml 3.13 462 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Code of Conduct 2 | 3 | This project has adopted the [OCaml Code of Conduct](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md). 4 | 5 | # Enforcement 6 | 7 | This project follows the OCaml Code of Conduct [enforcement policy](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md#enforcement). 8 | 9 | To report any violations, please contact: 10 | 11 | * Rudi Grinberg 12 | * Etienne Millon 13 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing 2 | 3 | Thanks for contributing to UTop! 4 | 5 | ## Setting up local switches 6 | 7 | UTop comes from a `dune-workspace.dev` file to test it across all supported 8 | versions. 9 | 10 | Run `make create-switches` to create all the required switches. 11 | 12 | Now you can run `dune` with the `--workspace dev-workspace.dev` flag to run 13 | the same command across all the workspaces. The `make 14 | all-supported-ocaml-versions` command will build the project with this setup. 15 | 16 | ## Compatibility Across Versions 17 | 18 | Some code will be different from one version of OCaml to the next. If you find 19 | some that does, please abstract it away using the `UTop_compat` module. 20 | 21 | For example, the `Load_path.get_paths ()` function has changed recently to 22 | return a record with shape `{ visible: string list; hidden: string list }`, but 23 | this function used to return a single `string list`. 24 | 25 | Defining this function using pre-processor macros allows us to give the same 26 | function two different bodies on different version of the language. 27 | 28 | ```ocaml 29 | let get_load_path () = 30 | #if OCAML_VERSION >= (5, 2, 0) 31 | Load_path.((get_paths ()).visible) 32 | #else 33 | Load_path.get_paths () 34 | #endif 35 | ``` 36 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2011, Jeremie Dimino 2 | All rights reserved. 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are met: 5 | 6 | * Redistributions of source code must retain the above copyright 7 | notice, this list of conditions and the following disclaimer. 8 | * Redistributions in binary form must reproduce the above copyright 9 | notice, this list of conditions and the following disclaimer in the 10 | documentation and/or other materials provided with the distribution. 11 | * Neither the name of Jeremie Dimino nor the names of his 12 | contributors may be used to endorse or promote products derived 13 | from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND ANY 16 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL THE AUTHOR AND CONTRIBUTORS BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | .PHONY: all 4 | all: 5 | dune build 6 | 7 | .PHONY: install 8 | install: 9 | dune install $(INSTALL_ARGS) 10 | 11 | .PHONY: uninstall 12 | uninstall: 13 | dune uninstall $(INSTALL_ARGS) 14 | 15 | .PHONY: reinstall 16 | reinstall: 17 | $(MAKE) uninstall 18 | $(MAKE) install 19 | 20 | .PHONY: examples 21 | examples: 22 | dune build @examples 23 | 24 | .PHONY: test 25 | test: 26 | dune runtest 27 | 28 | .PHONY: all-supported-ocaml-versions 29 | all-supported-ocaml-versions: 30 | dune build --workspace dune-workspace.dev 31 | 32 | .PHONY: cinaps 33 | cinaps: 34 | cinaps -styler ocp-indent -i src/migrate_parsetree_versions.ml* 35 | cinaps -styler ocp-indent -i src/migrate_parsetree_40?_40?.ml* 36 | 37 | .PHONY: clean 38 | clean: 39 | rm -rf _build *.install 40 | find . -name .merlin -delete 41 | 42 | .PHONY: create-switches 43 | create-switches: 44 | opam switch create utop-412 4.12.0 45 | opam switch create utop-413 4.13.1 46 | opam switch create utop-414 4.14.1 47 | opam switch create utop-500 5.0.0 48 | opam switch create utop-510 5.1.0 49 | opam switch create utop-520 5.2.0+trunk 50 | 51 | .PHONY: install-switches 52 | install-switches: 53 | opam install --switch utop-412 --deps-only --with-test -y . 54 | opam install --switch utop-413 --deps-only --with-test -y . 55 | opam install --switch utop-414 --deps-only --with-test -y . 56 | opam install --switch utop-500 --deps-only --with-test -y . 57 | opam install --switch utop-510 --deps-only --with-test -y . 58 | opam install --switch utop-520 --deps-only --with-test -y . 59 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![OCaml-CI Build Status](https://img.shields.io/endpoint?url=https%3A%2F%2Fci.ocamllabs.io%2Fbadge%2Focaml-community%2Futop%2Fmaster&logo=ocaml&style=flat-square)](https://ci.ocamllabs.io/github/ocaml-community/utop) 2 | 3 | utop — a universal toplevel (i.e., REPL) for OCaml 4 | ================================================== 5 | 6 | utop is an improved toplevel (i.e., Read-Eval-Print Loop) for 7 | OCaml. It can run in a terminal or 8 | in Emacs. It supports line editing, history, real-time and context 9 | sensitive completion, colors, and more. 10 | 11 | It integrates with the Tuareg, caml, ReasonML and typerex modes in Emacs. 12 | 13 | ![Screenshot](screenshot.png) 14 | 15 | Installation via opam 16 | --------------------- 17 | 18 | The easiest and recommended way of installing utop is via 19 | [opam](https://opam.ocaml.org/): 20 | 21 | opam install utop 22 | 23 | If you want to build it manually, refer to the opam file which lists the 24 | dependencies. 25 | 26 | Installation from sources 27 | ------------------------- 28 | 29 | To build and install utop: 30 | 31 | make 32 | make install 33 | 34 | ### Documentation and manual pages _(optional)_ 35 | 36 | To build the documentation (currently broken): 37 | 38 | make doc 39 | 40 | It will then be installed by `make install`. 41 | 42 | ### Tests _(optional)_ 43 | 44 | To build and execute tests (currently broken): 45 | 46 | make test 47 | 48 | Usage 49 | ----- 50 | 51 | To use utop, simply run: 52 | 53 | utop 54 | 55 | utop displays a bar after the prompt which is used to show possible 56 | completions in real time. You can navigate in it using `M-left` and 57 | `M-right`, and select one completion using `M-down`. The `M` denotes 58 | the meta key, which is `Alt` on most systems. 59 | 60 | Customization 61 | ------------- 62 | 63 | ### Colors 64 | 65 | To add colors to utop, copy one of the files `utoprc-dark` or 66 | `utoprc-light` to `~/.config/utop/utoprc`. `utoprc-dark` is for terminals with 67 | dark colors (such as white on black) and `utoprc-light` is for 68 | terminals with light colors (such as black on white). 69 | 70 | ### Prompt 71 | 72 | You can customize the prompt of utop by setting the reference 73 | `UTop.prompt`. 74 | 75 | To turn off all colors and remove the line above the prompt 76 | that lists time, etc., add this to ~/.config/utop/init.ml: 77 | ```OCaml 78 | #utop_prompt_dummy;; 79 | ``` 80 | To turn off the line of boxes listing possible completions that appears under 81 | the prompt, add this to ~/.config/utop/init.ml: 82 | ```OCaml 83 | UTop.set_show_box false 84 | ``` 85 | 86 | ### Key bindings 87 | 88 | Key bindings in the terminal can be changed by writing a 89 | `~/.config/lambda-term-inputrc` file. For example: 90 | 91 | [read-line] 92 | C-left: complete-bar-prev 93 | C-right: complete-bar-next 94 | C-down: complete-bar 95 | 96 | If manual pages are correctly installed you can see a description of 97 | this file by executing: 98 | 99 | $ man 5 lambda-term-inputrc 100 | 101 | ### Vi edit mode 102 | 103 | You can turn on the vi edit mode by `#edit_mode_vi`. It currently supports 104 | three vi modes: normal, insert, visual mode, and you can get/set content 105 | with vim-like registers. 106 | 107 | This special edit mode is evolving rapidly; see the CHANGES of lambda-term for the rapidly changing information. 108 | 109 | ### UTop API 110 | 111 | UTop exposes several more settings through its API; see 112 | [documentation](http://ocaml-community.github.io/utop). 113 | 114 | Integration with Emacs 115 | ---------------------- 116 | 117 | ### Overview 118 | 119 | `utop.el` is a package that provides `utop` integration with Emacs. 120 | The package allows you to run `utop` inside Emacs and to evaluate 121 | code in it straight from your source buffers (with the help of `utop-minor-mode`). 122 | 123 | Those features are covered in more details in the ["Usage"](#usage-emacs) section. 124 | 125 | ### Requirements 126 | 127 | `utop.el` requires Emacs 26.1 or newer. You'll also have to install 128 | `utop` and make sure it's on Emacs's `exec-path`, so that it could be 129 | started from within Emacs. 130 | 131 | ### Main setup 132 | 133 | The recommended way to install `utop.el` is via Emacs's built-in package manager `package.el`. 134 | 135 | `utop.el` is available on the community-maintained 136 | [MELPA Stable](https://stable.melpa.org) and [MELPA](https://melpa.org) `package.el` repositories. 137 | If you're not using them already, please follow the setup instructions 138 | [here](https://melpa.org/#/getting-started). 139 | 140 | **Note:** Using MELPA Stable is recommended as it has the latest stable version. 141 | MELPA has a development snapshot for users who don't mind breakage but 142 | don't want to run `utop.el` from a git checkout. 143 | 144 | Once you've enabled MELPA (Stable), you can install `utop.el` using the following command: 145 | 146 | M-x package-install [RET] utop [RET] 147 | 148 | or if you'd rather keep it in your Emacs config: 149 | 150 | ```emacs-lisp 151 | (unless (package-installed-p 'utop) 152 | (package-refresh-contents) 153 | (package-install 'utop)) 154 | ``` 155 | 156 | `use-package` users can do something like this: 157 | 158 | ```emacs-lisp 159 | (use-package utop 160 | :ensure t) 161 | ``` 162 | 163 | If the installation doesn't work try refreshing the package list: 164 | 165 | M-x package-refresh-contents 166 | 167 | Alternatively, if you have installed utop via opam, you can add this 168 | to your `~/.emacs`: 169 | 170 | ```elisp 171 | ;; Add the opam lisp dir to the Emacs load path 172 | (add-to-list 173 | 'load-path 174 | (replace-regexp-in-string 175 | "\n" "/share/emacs/site-lisp" 176 | (shell-command-to-string "opam var prefix"))) 177 | 178 | ;; Automatically load utop.el 179 | (autoload 'utop "utop" "Toplevel for OCaml" t) 180 | ``` 181 | 182 | In any case, if you installed utop via opam you should add this to 183 | your `~/.emacs`: 184 | 185 | ```elisp 186 | ;; Use the opam installed utop 187 | (setq utop-command "opam exec -- utop -emacs") 188 | ``` 189 | 190 | If you use `dune` and want to launch `dune utop` in emacs, you 191 | should add this to your `~/.emacs`: 192 | 193 | ```elisp 194 | (setq utop-command "opam exec -- dune utop . -- -emacs") 195 | ``` 196 | 197 | This was tested with opam 2.1. For older versions of opam, you can 198 | copy&paste this to your `~/.emacs`: 199 | 200 | ```elisp 201 | ;; Setup environment variables using opam 202 | (dolist (var (car (read-from-string (shell-command-to-string "opam config env --sexp")))) 203 | (setenv (car var) (cadr var))) 204 | 205 | ;; Update the Emacs path 206 | (setq exec-path (append (parse-colon-path (getenv "PATH")) 207 | (list exec-directory))) 208 | 209 | ;; Update the Emacs load path 210 | (add-to-list 'load-path (expand-file-name "../../share/emacs/site-lisp" 211 | (getenv "OCAML_TOPLEVEL_PATH"))) 212 | 213 | ;; Automatically load utop.el 214 | (autoload 'utop "utop" "Toplevel for OCaml" t) 215 | ``` 216 | 217 | ### Usage 218 | 219 | 220 | You can start utop inside Emacs with: `M-x utop`. 221 | 222 | `utop.el` also ships with a minor mode that has the following key-bindings: 223 | 224 | | key-binding | function | Description | 225 | |-------------|---------------------|------------------------------| 226 | | C-c C-s | utop | Start a utop buffer | 227 | | C-x C-e | utop-eval-phrase | Evaluate the current phrase | 228 | | C-x C-r | utop-eval-region | Evaluate the selected region | 229 | | C-c C-b | utop-eval-buffer | Evaluate the current buffer | 230 | | C-c C-k | utop-kill | Kill a running utop process | 231 | | C-c C-z | utop-switch-to-repl | Switch to utop process | 232 | 233 | You can enable the minor mode using `M-x utop-minor-mode`, or you can 234 | have it enabled by default with the following configuration: 235 | 236 | ```elisp 237 | (autoload 'utop-minor-mode "utop" "Minor mode for utop" t) 238 | (add-hook 'tuareg-mode-hook 'utop-minor-mode) 239 | ``` 240 | 241 | If you plan to use utop with another major-mode than tuareg, replace 242 | `tuareg-mode-hook` by the appropriate hook. The utop minor mode will work out of 243 | the box with these modes: `tuareg-mode`, `caml-mode`, `reason-mode` and 244 | `typerex-mode`. For other modes you will need to set the following three 245 | variables: 246 | 247 | - `utop-skip-blank-and-comments` 248 | - `utop-skip-to-end-of-phrase` 249 | - `utop-discover-phrase` 250 | 251 | You can also complete text in a buffer using the environment of the 252 | toplevel. For that bind the function `utop-edit-complete` to the key 253 | you want. 254 | 255 | Common error 256 | ------------ 257 | 258 | If you get this error when running utop in a terminal or in Emacs this 259 | means that the environment variable `CAML_LD_LIBRARY_PATH` is not set 260 | correctly: 261 | 262 | Fatal error: cannot load shared library dlllwt-unix_stubs 263 | Reason: dlopen(dlllwt-unix_stubs.so, 138): image not found 264 | 265 | It should point to the directory `stublibs` inside your ocaml installation. 266 | 267 | Automatically installing toplevel printers 268 | ------------------------------------------ 269 | 270 | Utop will automatically install toplevel printers for custom 271 | types if their interface files are marked with an 272 | `[@@ocaml.toplevel_printer]` attribute. Adding this annotation to 273 | your libraries will remove the need to have a separate `top` package 274 | to install the printers. 275 | 276 | For example, in the [uri](https://github.com/mirage/ocaml-uri) 277 | library, the old printing function for `Uri.t` was: 278 | 279 | ``` 280 | val pp_hum : Format.formatter -> t -> unit 281 | ``` 282 | 283 | Just adding this annotation results in `Uri.t` values being automatically 284 | pretty printed in this version of utop. 285 | 286 | ``` 287 | val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer] 288 | ``` 289 | 290 | There should be no downsides to adding this attribute to your 291 | libraries, so we encourage community library maintainers to 292 | use this attribute to improve the out-of-the-box experience 293 | for users of their libraries within utop. 294 | 295 | Creating a custom utop-enabled toplevel 296 | --------------------------------------- 297 | 298 | ### With Dune 299 | 300 | The recommended way to build a custom utop toplevel is via 301 | [Dune][dune]. The entry point of the custom utop must call 302 | `UTop_main.main`. For instance, write the following `myutop.ml` file: 303 | 304 | ```ocaml 305 | let () = UTop_main.main () 306 | ``` 307 | 308 | and the following dune file: 309 | 310 | ```elisp 311 | (executable 312 | (name myutop) 313 | (link_flags -linkall) 314 | (libraries utop)) 315 | ``` 316 | 317 | then, to build the toplevel, run: 318 | 319 | ``` 320 | $ dune myutop.bc 321 | ``` 322 | 323 | Note the `-linkall` in the link flags. By default OCaml doesn't link 324 | unused modules. However for a toplevel you don't know in advance what 325 | the user is going to use so you must link everything. 326 | 327 | If you want to include more libraries in your custom utop, simply add 328 | them to the `(libraries ...)` field. 329 | 330 | Additionally, if you want to install this toplevel, add the two 331 | following fields to the executable stanza: 332 | 333 | ```elisp 334 | (public_name myutop) 335 | (modes byte) 336 | ``` 337 | 338 | The `(modes ...)` field is to tell dune to install the byte-code 339 | version of the executable, as currently native toplevels are not fully 340 | supported. 341 | 342 | [dune]: https://github.com/ocaml/dune 343 | 344 | ### Manually, with ocamlfind 345 | 346 | This section describe methods using `ocamlfind`. These are no longer 347 | tested, so there is no guarantee they still work. 348 | 349 | If you want to create a custom toplevel with utop instead of the 350 | classic one you need to link it with utop and its dependencies and 351 | call `UTop_main.main` in the last linked unit. You also need to pass 352 | the `-thread` switch when linking the toplevel. 353 | 354 | The easiest way to do that is by using `ocamlfind`: 355 | 356 | $ ocamlfind ocamlmktop -o myutop -thread -linkpkg -package utop myutop_main.cmo 357 | 358 | Where `myutop_main.ml` contains: 359 | 360 | ```ocaml 361 | let () = UTop_main.main () 362 | ``` 363 | 364 | You can also use the `ocamlc` sub-command instead of `ocamlmktop`. In 365 | this case you need to pass these three extra arguments: 366 | 367 | * `-linkall` to be sure all units are linked into the produced toplevel 368 | * `-package compiler-libs.toplevel` 369 | * `-predicates create_toploop` 370 | 371 | With the last option `ocamlfind` will generate a small ocaml unit, 372 | linked just before `myutop_main.cmo`, which will register at startup 373 | packages already linked in the toplevel so they are not loaded again 374 | by the `#require` directive. It does the same with the `ocamlmktop` 375 | sub-command. 376 | 377 | For example: 378 | 379 | $ ocamlfind ocamlc -o myutop -thread -linkpkg -linkall -predicates create_toploop \ 380 | -package compiler-libs.toplevel,utop myutop.cmo 381 | 382 | Note that if you are not using `ocamlfind`, you will need to do that 383 | yourself. You have to call `Topfind.don't_load` with the list of all 384 | packages linked with the toplevel. 385 | 386 | A full example using `ocamlbuild` is provided in the 387 | [examples/custom-utop](examples/custom-utop) directory. 388 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (install 2 | (section share) 3 | (files utoprc-dark utoprc-light)) 4 | 5 | (install 6 | (section share_root) 7 | (files 8 | (src/top/utop.el as emacs/site-lisp/utop.el))) 9 | 10 | (alias 11 | (name examples) 12 | (deps examples/custom-utop/myutop.bc examples/interact/test_program.bc)) 13 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | (formatting (enabled_for dune)) 3 | (name utop) 4 | 5 | (generate_opam_files) 6 | (source (github ocaml-community/utop)) 7 | (documentation https://ocaml-community.github.io/utop/) 8 | (license BSD-3-Clause) 9 | (maintainers jeremie@dimino.org) 10 | (authors "Jérémie Dimino") 11 | 12 | (package 13 | (name utop) 14 | (synopsis "Universal toplevel for OCaml") 15 | (description 16 | "utop is an improved toplevel (i.e., Read-Eval-Print Loop or REPL) for OCaml. It can run in a terminal or in Emacs. It supports line edition, history, real-time and context sensitive completion, colors, and more. It integrates with the Tuareg mode in Emacs.") 17 | (depends 18 | (ocaml (>= 4.11.0)) 19 | base-unix 20 | base-threads 21 | (ocamlfind (>= 1.7.2)) 22 | (lambda-term (and (>= 3.1.0) (< 4.0))) 23 | logs 24 | lwt 25 | lwt_react 26 | (zed (>= 3.2.0)) 27 | (react (>= 1.0.0)) 28 | (cppo (>= 1.1.2)) 29 | (alcotest :with-test) 30 | (xdg (>= 3.9.0)))) 31 | -------------------------------------------------------------------------------- /dune-workspace.dev: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (context (opam (switch utop-411))) 3 | (context (opam (switch utop-412))) 4 | (context (opam (switch utop-413))) 5 | (context (opam (switch utop-414))) 6 | (context (opam (switch utop-500))) 7 | (context (opam (switch utop-510))) 8 | (context (opam (switch utop-520))) 9 | -------------------------------------------------------------------------------- /examples/custom-utop/README.md: -------------------------------------------------------------------------------- 1 | To build the custom toplevel in this directory, run: 2 | 3 | $ dune build myutop.bc 4 | -------------------------------------------------------------------------------- /examples/custom-utop/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name myutop) 3 | (modes byte) 4 | (link_flags -linkall) 5 | (libraries utop)) 6 | -------------------------------------------------------------------------------- /examples/custom-utop/myutop.ml: -------------------------------------------------------------------------------- 1 | 2 | (* Start utop. It never returns. *) 3 | let () = UTop_main.main () 4 | -------------------------------------------------------------------------------- /examples/interact/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test_program) 3 | (modes byte) 4 | (link_flags -linkall) 5 | (libraries utop)) 6 | -------------------------------------------------------------------------------- /examples/interact/test_program.ml: -------------------------------------------------------------------------------- 1 | type t = A of int | B of string 2 | 3 | let some_value = [A 42; B "Hello, world"] 4 | 5 | let () = 6 | print_endline "Starting utop now!"; 7 | UTop_main.interact () 8 | ~unit:__MODULE__ 9 | ~loc:__POS__ 10 | ~values:[V ("some_value", some_value)] 11 | ;; 12 | -------------------------------------------------------------------------------- /examples/interact/test_program.mli: -------------------------------------------------------------------------------- 1 | (* empty *) 2 | -------------------------------------------------------------------------------- /man/dune: -------------------------------------------------------------------------------- 1 | (install 2 | (section man) 3 | (files utop.1 utop-full.1 utoprc.5)) 4 | -------------------------------------------------------------------------------- /man/utop-full.1: -------------------------------------------------------------------------------- 1 | \" utop.1 2 | \" ------ 3 | \" Copyright : (c) 2011, Jeremie Dimino 4 | \" Licence : BSD3 5 | \" 6 | \" This file is a part of utop. 7 | 8 | .TH UTOP-FULL 1 "August 2011" 9 | 10 | .SH NAME 11 | utop-full \- Universal toplevel for OCaml 12 | 13 | .SH SYNOPSIS 14 | .B utop 15 | [ 16 | .I options 17 | ] 18 | [ 19 | .I object-files 20 | ] 21 | [ 22 | .I script-file 23 | ] 24 | 25 | .SH DESCRIPTION 26 | 27 | .B utop-full 28 | is the same as 29 | .B utop (1) 30 | except that compiler libraries are available. 31 | 32 | .SH OPTIONS 33 | Same as 34 | .BR utop (1). 35 | 36 | .SH FILES 37 | Same as 38 | .BR utop (1). 39 | 40 | .SH AUTHOR 41 | Jérémie Dimino 42 | 43 | .SH "SEE ALSO" 44 | .BR utoprc (5), 45 | .BR lambda-term-inputrc (5), 46 | .BR ocaml (1). 47 | -------------------------------------------------------------------------------- /man/utop.1: -------------------------------------------------------------------------------- 1 | \" utop.1 2 | \" ------ 3 | \" Copyright : (c) 2011, Jeremie Dimino 4 | \" Licence : BSD3 5 | \" 6 | \" This file is a part of utop. 7 | 8 | .TH UTOP 1 9 | 10 | .SH NAME 11 | utop \- Universal toplevel for OCaml 12 | 13 | .SH SYNOPSIS 14 | .B utop 15 | [ 16 | .I options 17 | ] 18 | [ 19 | .I object-files 20 | ] 21 | [ 22 | .I script-file 23 | ] 24 | 25 | .SH DESCRIPTION 26 | 27 | .B utop 28 | is an enhanced toplevel for OCaml with many features, including context 29 | sensitive completion. 30 | 31 | When you start 32 | .B utop 33 | what you see is the prompt followed by a bar containing words. This is 34 | the completion bar: it contains the possible completion and is updated 35 | as you type. The highlighted word in the completion bar is the 36 | selected word. You can navigate using the keys \fBM-Left\fR and \fBM-Right\fR 37 | and select one completion using \fBM-down\fR. Here \fBM\fR represents the meta key, 38 | which is \fBAlt\fR on most systems. You can configure these bindings in the file 39 | .I ~/.config/lambda-term-inputrc 40 | - see 41 | .BR lambda-term-inputrc (5) 42 | for details. 43 | 44 | \fButop\fR supports completion on: 45 | 46 | * directives and directive arguments 47 | * identifiers 48 | * record fields 49 | * variants 50 | * function labels 51 | * object methods 52 | 53 | Colors are by default configured for terminals with dark colors, such 54 | as white on black, so the prompt may look too bright on light-colored 55 | terminals. You can change that by setting the color profile of 56 | utop. To do that, type: 57 | 58 | UTop.set_profile UTop.Light;; 59 | 60 | You can then add this line to your 61 | .I ~/.config/utop/init.ml 62 | file. 63 | 64 | To turn off \fButop\fR's advanced prompt features, add the following to \fIinit.ml\fR 65 | to turn off respectively (a) colors and the upper information line, and 66 | (b) the lower boxed list of possible completions: 67 | 68 | #utop_prompt_dummy;; 69 | UTop.set_show_box false 70 | 71 | You can enable basic syntax highlighting in utop by writing a 72 | .I ~/.utoprc 73 | file. See 74 | .BR utoprc (5) 75 | for that. 76 | 77 | Vi edit mode is enabled by the command 78 | 79 | #edit_mode_vi 80 | 81 | It currently supports three vi modes: normal, insert, visual mode, and you can 82 | get/set content with vim-like registers. 83 | 84 | .I utop.el 85 | is a package that provides 86 | .B utop 87 | integration with Emacs. The package allows you to run 88 | .B utop 89 | inside Emacs and to evaluate code in it straight from your source buffers 90 | (with the help of \fIutop-minor-mode\fR). 91 | The recommended way to install 92 | .I utop.el 93 | is via Emacs's built-in package manager \fBpackage.el\fR. 94 | More detailed installation and configuration instructions may be found 95 | on the project's code repository at \fIhttps://github.com/ocaml-community/utop\fR. 96 | 97 | You can start \fButop\fR inside Emacs with \fBM-x utop\fR. 98 | 99 | The default install also has a minor mode with the following key bindings: 100 | 101 | \fBC-c C-s\fR Start a utop buffer (\fIutop\fR) 102 | \fBC-x C-e\fR Evaluate the current phrase (\fIutop-eval-phrase\fR) 103 | \fBC-x C-r\fR Evaluate the selected region (\fIutop-eval-region\fR) 104 | \fBC-c C-b\fR Evaluate the current buffer (\fIutop-eval-buffer\fR) 105 | \fBC-c C-k\fR Kill a running utop process (\fItop-kill\fR) 106 | \fBC-c C-z\fR Switch to utop process (\fIutop-switch-to-repl\fR) 107 | 108 | then you can run \fButop\fR by pressing \fBM-x\fR and typing "utop". \fButop\fR supports 109 | completion in Emacs mode. Just press \fBTab\fR to complete a word. You can 110 | also integrate it with the tuareg, caml or typerex mode. For that add 111 | the following lines to your 112 | .I ~/.emacs 113 | file: 114 | 115 | (autoload 'utop-minor-mode "utop" "Minor mode for utop" t) 116 | (add-hook 'tuareg-mode-hook 'utop-minor-mode) 117 | 118 | .SH OPTIONS 119 | See 120 | .B utop --help 121 | for the full list of available options. There is considerable overlap 122 | with options available for 123 | .BR ocaml (1). 124 | 125 | A commonly used option is 126 | \fB-require\fI package\fR 127 | to load \fIpackage\fR into the execution environment. It is equivalent 128 | to using \fb#require\fR from inside 129 | .BR utop (1). 130 | 131 | .PP 132 | .TP 133 | .BI -absname 134 | Show absolute filenames in error message. 135 | .TP 136 | .BI -I " dir" 137 | Add \fIdir\fR to the list of include directories. 138 | .TP 139 | .BI -init " file" 140 | Load \fIfile\fR instead of the default init file. 141 | .TP 142 | .BI -labels 143 | Use commuting label mode. 144 | .TP 145 | .BI -no-app-funct 146 | Deactivate applicative functors. 147 | .TP 148 | .BI -noassert 149 | Do not compile assertion checks. 150 | .TP 151 | .BI -nolabels 152 | Ignore non-optional labels in types. 153 | .TP 154 | .BI -nostdlib 155 | Do not add the default directory to the list of include directories. 156 | .TP 157 | .BI -ppx " command" 158 | Pipe abstract syntax trees through the preprocessor \fIcommand\fR. 159 | .TP 160 | .BI -principal 161 | Check principality of type inference. 162 | .TP 163 | .BI -safe-string 164 | Make strings immutable. 165 | .TP 166 | .BI -short-paths 167 | Shorten paths in types (the default). 168 | .TP 169 | .BI -no-short-paths 170 | Do not shorten paths in types. 171 | .TP 172 | .BI -rectypes 173 | Allow arbitrary recursive types. 174 | .TP 175 | .BI -stdin 176 | Read script from standard input. 177 | .TP 178 | .BI -strict-sequence 179 | Left-hand part of a sequence must have type unit. 180 | .TP 181 | .BI -unsafe 182 | Do not compile bounds checking on array and string access. 183 | .TP 184 | .BI -version 185 | Print version and exit. 186 | .TP 187 | .BI -vnum 188 | Print version number and exit. 189 | .TP 190 | .BI -w " list" 191 | Enable or disable warnings according to \fIlist\fR. 192 | .TP 193 | .BI -warn-error " list" 194 | Enable or disable error status for warnings according to \fIlist\fR. 195 | See option \fB-w\fR for the syntax of \fIlist\fR. 196 | Default setting is \fB-a+31\fR. 197 | .TP 198 | .BI -warn-help 199 | Show description of warning numbers. 200 | .TP 201 | .BI -emacs 202 | Run in emacs mode. 203 | .TP 204 | .BI -hide-reserved 205 | Hide identifiers starting with a '_' (the default). 206 | .TP 207 | .BI -show-reserved 208 | Show identifiers starting with a '_'. 209 | .TP 210 | .BI -no-implicit-bindings 211 | Don't add implicit bindings for expressions (the default). 212 | .TP 213 | .BI -implicit-bindings 214 | Add implicit bindings: \fIexpr\fR;; -> let _0 = \fIexpr\fR;; 215 | .TP 216 | .BI -no-autoload 217 | Disable autoloading of files in 218 | .I $OCAML_TOPLEVEL_PATH/autoload. 219 | .TP 220 | .BI -require " package" 221 | Load this package. 222 | .TP 223 | .BI -dparsetree 224 | Dump OCaml AST after rewriting. 225 | .TP 226 | .BI -dsource 227 | Dump OCaml source after rewriting. 228 | .TP 229 | .BI -help 230 | Display this list of options. 231 | .TP 232 | .BI --help 233 | Display this list of options. 234 | 235 | .SH FILES 236 | .I ~/.config/utop/init.ml 237 | .RS 238 | The initialization file of the toplevel. 239 | .RE 240 | .I ~/.ocamlinit 241 | .RS 242 | The alternative initialization file of the toplevel. 243 | .RE 244 | .I ~/.utoprc 245 | .RS 246 | The configuration file for utop. See 247 | .BR utoprc (5). 248 | .RE 249 | .I ~/.config/lambda-term-inputrc 250 | .RS 251 | The file containing key bindings. See 252 | .BR lambda-term-inputrc (5). 253 | 254 | .SH AUTHOR 255 | Jérémie Dimino 256 | 257 | .SH "SEE ALSO" 258 | .BR utoprc (5), 259 | .BR lambda-term-inputrc (5), 260 | .BR ocaml (1). 261 | -------------------------------------------------------------------------------- /man/utoprc.5: -------------------------------------------------------------------------------- 1 | \" utoprc.5 2 | \" -------- 3 | \" Copyright : (c) 2011, Jeremie Dimino 4 | \" Licence : BSD3 5 | \" 6 | \" This file is a part of utop. 7 | 8 | .TH UTOPRC 5 "August 2011" 9 | 10 | .SH NAME 11 | utoprc \- Configuration file of utop 12 | 13 | .SH SYNOPSIS 14 | .B ~/.utoprc 15 | 16 | .SH DESCRIPTION 17 | 18 | This manual page describes the format of the 19 | .I ~/.utoprc 20 | file. This is a text file which contains the configuration of 21 | utop. Comments start with a '!' and empty lines are 22 | ignored. Configuration lines are of the form: 23 | 24 | : 25 | 26 | .I 27 | may contain the '*' asterisk character. In that case any key which matches 28 | the pattern is given the value after the colon. 29 | 30 | The boolean key 31 | .I autoload 32 | can be set to 33 | .I false 34 | to disable the autoloading of files in 35 | .I $OCAML_TOPLEVEL_PATH/autoload 36 | at startup. 37 | 38 | The key 39 | .I external-editor 40 | can be set to a command line. It is used to edit the input when 41 | pressing C-x C-e. It defaults to the contents of the 42 | .I EDITOR 43 | environment variable. 44 | 45 | The key 46 | .I profile 47 | may have the value 48 | .I dark 49 | or 50 | .I light. 51 | This is the same as calling 52 | .I UTop.set_profile 53 | in 54 | .I ~/.config/utop/init.ml. 55 | 56 | The following style keys are used by utop: 57 | 58 | * identifier 59 | * module 60 | * comment 61 | * doc 62 | * constant 63 | * keyword 64 | * symbol 65 | * string 66 | * char 67 | * quotation 68 | * error 69 | * directive 70 | * parenthesis 71 | * blanks 72 | 73 | For each of these keys, the following sub-keys are used: 74 | 75 | * key.foreground 76 | * key.background 77 | * key.bold 78 | * key.underline 79 | * key.reverse 80 | * key.blink 81 | 82 | .I key.foreground 83 | and 84 | .I key.background 85 | are colors, and the others are booleans. Colors may be one of the 86 | standard terminal colors: 87 | 88 | * black 89 | * red 90 | * green 91 | * yellow 92 | * blue 93 | * magenta 94 | * cyan 95 | * white 96 | * light-black 97 | * light-red 98 | * light-green 99 | * light-yellow 100 | * light-blue 101 | * light-magenta 102 | * light-cyan 103 | * light-white 104 | 105 | or X11 colors, prefixed with "x-". For example: 106 | 107 | identifier.foreground: x-goldenrod 108 | 109 | Colors can also be given by their RGB components, written #RRGGBB. For 110 | example: 111 | 112 | identifier.foreground: #5fbf7f 113 | 114 | utop will choose the nearest color of the terminal when specifying an 115 | X11 color or a color given by its RGB components. If you are using 116 | gnome-terminal or konsole, you can enable 256 colors by setting the 117 | environment variable TERM to "xterm-256color". 118 | 119 | .SH FILES 120 | .I ~/.utoprc 121 | 122 | .SH EXAMPLE 123 | profile: dark 124 | .RS 125 | .RE 126 | identifier.foreground: none 127 | .RS 128 | .RE 129 | comment.foreground: x-chocolate1 130 | .RS 131 | .RE 132 | doc.foreground: x-light-salmon 133 | .RS 134 | .RE 135 | constant.foreground: x-aquamarine 136 | .RS 137 | .RE 138 | keyword.foreground: x-cyan1 139 | .RS 140 | .RE 141 | symbol.foreground: x-cyan1 142 | .RS 143 | .RE 144 | string.foreground: x-light-salmon 145 | .RS 146 | .RE 147 | char.foreground: x-light-salmon 148 | .RS 149 | .RE 150 | quotation.foreground: x-purple 151 | .RS 152 | .RE 153 | error.foreground: x-red 154 | .RS 155 | .RE 156 | parenthesis.background: blue 157 | 158 | .SH AUTHOR 159 | Jérémie Dimino 160 | 161 | .SH "SEE ALSO" 162 | .BR utop (1). 163 | -------------------------------------------------------------------------------- /screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-community/utop/3322adaa5267b1188d14b15e85c802c21fe061cb/screenshot.png -------------------------------------------------------------------------------- /src/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name uTop) 3 | (public_name utop) 4 | (wrapped false) 5 | (modes byte) 6 | (libraries compiler-libs.toplevel findlib.top lambda-term logs.lwt threads 7 | xdg zed) 8 | (preprocess 9 | (action 10 | (run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file})))) 11 | 12 | (ocamllex uTop_lexer) 13 | -------------------------------------------------------------------------------- /src/lib/uTop.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * uTop.ml 3 | * ------- 4 | * Copyright : (c) 2011, Jeremie Dimino 5 | * Licence : BSD3 6 | * 7 | * This file is a part of utop. 8 | *) 9 | 10 | [@@@warning "-27"] 11 | 12 | open Lwt_react 13 | open LTerm_text 14 | open LTerm_geom 15 | open LTerm_style 16 | 17 | let (>>=) = Lwt.(>>=) 18 | 19 | module String_set = Set.Make(String) 20 | 21 | let version = "%%VERSION%%" 22 | 23 | (* +-----------------------------------------------------------------+ 24 | | History | 25 | +-----------------------------------------------------------------+ *) 26 | module Default_paths = UTop_private.Default_paths 27 | 28 | let history = LTerm_history.create [] 29 | let history_file_name = ref (Some (Default_paths.history_file_name)) 30 | let history_file_max_size = ref None 31 | let history_file_max_entries = ref None 32 | let stashable_session_history = UTop_history.create () 33 | 34 | (* +-----------------------------------------------------------------+ 35 | | Hooks | 36 | +-----------------------------------------------------------------+ *) 37 | 38 | let new_command_hooks = LTerm_dlist.create () 39 | let at_new_command f = ignore (LTerm_dlist.add_l f new_command_hooks) 40 | 41 | (* +-----------------------------------------------------------------+ 42 | | Config | 43 | +-----------------------------------------------------------------+ *) 44 | 45 | type ui = UTop_private.ui = Console | Emacs 46 | 47 | let get_ui () = S.value UTop_private.ui 48 | 49 | type profile = Dark | Light 50 | 51 | let profile, set_profile = S.create Dark 52 | let set_profile p = set_profile p 53 | 54 | let size = UTop_private.size 55 | 56 | let key_sequence = UTop_private.key_sequence 57 | 58 | let count = UTop_private.count 59 | 60 | let time = ref (Unix.time ()) 61 | 62 | let () = at_new_command (fun () -> time := Unix.time ()) 63 | 64 | let make_variable ?eq x = 65 | let signal, set = S.create ?eq x in 66 | let set v = set v in 67 | (signal, (fun () -> S.value signal), set) 68 | 69 | let hide_reserved, get_hide_reserved, set_hide_reserved = make_variable true 70 | let create_implicits, get_create_implicits, set_create_implicits = make_variable false 71 | let show_box, get_show_box, set_show_box = make_variable true 72 | let phrase_terminator, get_phrase_terminator, set_phrase_terminator = make_variable ";;" 73 | let auto_run_lwt, get_auto_run_lwt, set_auto_run_lwt = make_variable true 74 | let auto_run_async, get_auto_run_async, set_auto_run_async = make_variable true 75 | let topfind_verbose, get_topfind_verbose, set_topfind_verbose = make_variable false 76 | let external_editor, get_external_editor, set_external_editor = 77 | make_variable 78 | (try 79 | Sys.getenv "EDITOR" 80 | with Not_found -> 81 | "vi") 82 | 83 | (* Ugly hack until the action system of lambda-term is improved *) 84 | let end_and_accept_current_phrase : LTerm_read_line.action = 85 | Edit (Custom (fun () -> assert false)) 86 | 87 | let set_margin_function f = UTop_private.set_margin_function f 88 | 89 | (* +-----------------------------------------------------------------+ 90 | | Keywords | 91 | +-----------------------------------------------------------------+ *) 92 | 93 | let default_keywords = [ 94 | "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do"; 95 | "done"; "downto"; "else"; "end"; "exception"; "external"; 96 | "for"; "fun"; "function"; "functor"; "if"; "in"; "include"; 97 | "inherit"; "initializer"; "lazy"; "let"; "match"; "method"; "module"; 98 | "mutable"; "new"; "object"; "of"; "open"; "private"; "rec"; "sig"; 99 | "struct"; "then"; "to"; "try"; "type"; "val"; "virtual"; 100 | "when"; "while"; "with"; "try_lwt"; "finally"; "for_lwt"; "lwt"; 101 | ] 102 | 103 | let keywords = ref (String_set.of_list default_keywords) 104 | let add_keyword kwd = keywords := String_set.add kwd !keywords 105 | 106 | (* +-----------------------------------------------------------------+ 107 | | Span of Lines | 108 | +-----------------------------------------------------------------+ *) 109 | 110 | type lines = { 111 | start: int; 112 | stop: int; 113 | } 114 | 115 | (* +-----------------------------------------------------------------+ 116 | | Error reporting | 117 | +-----------------------------------------------------------------+ *) 118 | 119 | let get_message func x = 120 | let buffer = Buffer.create 1024 in 121 | let pp = Format.formatter_of_buffer buffer in 122 | UTop_private.set_margin pp; 123 | func pp x; 124 | Format.pp_print_flush pp (); 125 | Buffer.contents buffer 126 | 127 | let get_ocaml_error_message exn = 128 | let buffer = Buffer.create 1024 in 129 | let pp = Format.formatter_of_buffer buffer in 130 | UTop_private.set_margin pp; 131 | Errors.report_error pp exn; 132 | Format.pp_print_flush pp (); 133 | let str = Buffer.contents buffer in 134 | try 135 | Scanf.sscanf 136 | str 137 | "Characters %d-%d:\n%[\000-\255]" 138 | (fun start stop msg -> ((start, stop), msg, None)) 139 | with Scanf.Scan_failure(_) -> 140 | try 141 | Scanf.sscanf 142 | str 143 | "Line %d, characters %d-%d:\n%[\000-\255]" 144 | (fun line start stop msg -> ((start, stop), msg, Some{start=line; stop=line})) 145 | with Scanf.Scan_failure(_) -> 146 | try 147 | Scanf.sscanf 148 | str 149 | "Lines %d-%d, characters %d-%d:\n%[\000-\255]" 150 | (fun start_line stop_line start stop msg -> ((start, stop), 151 | msg, Some{start=start_line;stop=stop_line})) 152 | with Scanf.Scan_failure(_) -> 153 | ((0, 0), str, None) 154 | 155 | let collect_formatters buf pps f = 156 | (* First flush all formatters. *) 157 | List.iter (fun pp -> Format.pp_print_flush pp ()) pps; 158 | (* Save all formatter functions. *) 159 | let save = List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps in 160 | let restore () = 161 | List.iter2 162 | (fun pp out_functions -> 163 | Format.pp_print_flush pp (); 164 | Format.pp_set_formatter_out_functions pp out_functions) 165 | pps save 166 | in 167 | (* Output functions. *) 168 | let out_functions = 169 | let ppb = Format.formatter_of_buffer buf in 170 | Format.pp_get_formatter_out_functions ppb () 171 | in 172 | (* Replace formatter functions. *) 173 | List.iter 174 | (fun pp -> 175 | UTop_private.set_margin pp; 176 | Format.pp_set_formatter_out_functions pp out_functions) 177 | pps; 178 | try 179 | let x = f () in 180 | restore (); 181 | x 182 | with exn -> 183 | restore (); 184 | raise exn 185 | 186 | let discard_formatters pps f = 187 | (* First flush all formatters. *) 188 | List.iter (fun pp -> Format.pp_print_flush pp ()) pps; 189 | (* Save all formatter functions. *) 190 | let save = List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps in 191 | let restore () = 192 | List.iter2 193 | (fun pp out_functions -> 194 | Format.pp_print_flush pp (); 195 | Format.pp_set_formatter_out_functions pp out_functions) 196 | pps save 197 | in 198 | (* Output functions. *) 199 | let out_functions = { 200 | Format.out_string = (fun _ _ _ -> ()); out_flush = ignore; 201 | out_newline = ignore; out_spaces = ignore ; out_indent = ignore 202 | } in 203 | (* Replace formatter functions. *) 204 | List.iter (fun pp -> Format.pp_set_formatter_out_functions pp out_functions) pps; 205 | try 206 | let x = f () in 207 | restore (); 208 | x 209 | with exn -> 210 | restore (); 211 | raise exn 212 | 213 | (* +-----------------------------------------------------------------+ 214 | | Parsing | 215 | +-----------------------------------------------------------------+ *) 216 | 217 | type location = int * int 218 | 219 | type 'a result = 220 | | Value of 'a 221 | | Error of location list * string 222 | 223 | exception Need_more 224 | 225 | let input_name = "//toplevel//" 226 | 227 | let lexbuf_of_string eof str = 228 | let pos = ref 0 in 229 | let lexbuf = 230 | Lexing.from_function 231 | (fun buf len -> 232 | if !pos = String.length str then begin 233 | eof := true; 234 | 0 235 | end else begin 236 | let len = min len (String.length str - !pos) in 237 | String.blit str !pos buf 0 len; 238 | pos := !pos + len; 239 | len 240 | end) 241 | in 242 | Location.init lexbuf input_name; 243 | lexbuf 244 | 245 | let mkloc loc = 246 | (loc.Location.loc_start.Lexing.pos_cnum, 247 | loc.Location.loc_end.Lexing.pos_cnum) 248 | 249 | let parse_default parse str eos_is_error = 250 | let eof = ref false in 251 | let lexbuf = lexbuf_of_string eof str in 252 | try 253 | (* Try to parse the phrase. *) 254 | let phrase = parse lexbuf in 255 | Value phrase 256 | with 257 | | _ when !eof && not eos_is_error -> 258 | (* This is not an error, we just need more input. *) 259 | raise Need_more 260 | | End_of_file -> 261 | (* If the string is empty, do not report an error. *) 262 | raise Need_more 263 | | Lexer.Error (error, loc) -> 264 | (match Location.error_of_exn (Lexer.Error (error, loc)) with 265 | | Some (`Ok error)-> 266 | Error ([mkloc loc], get_message Location.print_report error) 267 | | _-> raise Need_more) 268 | | Syntaxerr.Error error -> begin 269 | match error with 270 | | Syntaxerr.Unclosed (opening_loc, opening, closing_loc, closing) -> 271 | Error ([mkloc opening_loc; mkloc closing_loc], 272 | Printf.sprintf "Syntax error: '%s' expected, the highlighted '%s' might be unmatched" closing opening) 273 | | Syntaxerr.Applicative_path loc -> 274 | Error ([mkloc loc], 275 | "Syntax error: applicative paths of the form F(X).t are not supported when the option -no-app-funct is set.") 276 | | Syntaxerr.Other loc -> 277 | Error ([mkloc loc], 278 | "Syntax error") 279 | | Syntaxerr.Expecting (loc, nonterm) -> 280 | Error ([mkloc loc], 281 | Printf.sprintf "Syntax error: %s expected." nonterm) 282 | | Syntaxerr.Variable_in_scope (loc, var) -> 283 | Error ([mkloc loc], 284 | Printf.sprintf "In this scoped type, variable '%s is reserved for the local type %s." var var) 285 | | Syntaxerr.Not_expecting (loc, nonterm) -> 286 | Error ([mkloc loc], 287 | Printf.sprintf "Syntax error: %s not expected" nonterm) 288 | | Syntaxerr.Ill_formed_ast (loc, s) -> 289 | Error ([mkloc loc], 290 | Printf.sprintf "Error: broken invariant in parsetree: %s" s) 291 | | Syntaxerr.Invalid_package_type (loc, err) -> 292 | Error ([mkloc loc], UTop_compat.invalid_package_error_to_string err) 293 | #if OCAML_VERSION >= (5, 0, 0) 294 | | Syntaxerr.Removed_string_set loc -> 295 | Error ([mkloc loc], 296 | "Syntax error: strings are immutable, there is no assignment \ 297 | syntax for them.\n\ 298 | Hint: Mutable sequences of bytes are available in the Bytes module.\n\ 299 | Hint: Did you mean to use 'Bytes.set'?") 300 | #endif 301 | end 302 | | Syntaxerr.Escape_error | Parsing.Parse_error -> 303 | Error ([mkloc (Location.curr lexbuf)], 304 | "Syntax error") 305 | | exn -> 306 | Error ([], "Unknown parsing error (please report it to the utop project): " ^ Printexc.to_string exn) 307 | 308 | let parse_toplevel_phrase_default = parse_default Parse.toplevel_phrase 309 | let parse_toplevel_phrase = ref parse_toplevel_phrase_default 310 | 311 | let parse_use_file_default = parse_default Parse.use_file 312 | let parse_use_file = ref parse_use_file_default 313 | 314 | (* +-----------------------------------------------------------------+ 315 | | Safety checking | 316 | +-----------------------------------------------------------------+ *) 317 | 318 | let null = Format.make_formatter (fun str ofs len -> ()) ignore 319 | 320 | let rec last head tail = 321 | match tail with 322 | | [] -> 323 | head 324 | | head :: tail -> 325 | last head tail 326 | 327 | let with_loc loc str = { 328 | Location.txt = str; 329 | Location.loc = loc; 330 | } 331 | 332 | (* Check that the given phrase can be evaluated without typing/compile 333 | errors. *) 334 | let check_phrase phrase = 335 | let open Parsetree in 336 | match phrase with 337 | | Ptop_dir _ -> 338 | None 339 | | Ptop_def [] -> 340 | None 341 | | Ptop_def (item :: items) -> 342 | let loc = { 343 | Location.loc_start = item.pstr_loc.Location.loc_start; 344 | Location.loc_end = (last item items).pstr_loc.Location.loc_end; 345 | Location.loc_ghost = false; 346 | } in 347 | (* Backup. *) 348 | let snap = Btype.snapshot () in 349 | let env = !Toploop.toplevel_env in 350 | (* Construct "let _ () = let module _ = struct end in ()" in order to test 351 | the typing and compilation of [items] without evaluating them. *) 352 | let unit = 353 | let (%.) a b = Longident.Ldot (a, b) in 354 | with_loc loc (Lident "Stdlib" %. "Unit" %. "()") 355 | in 356 | let top_def = 357 | let open Ast_helper in 358 | with_default_loc loc 359 | (fun () -> 360 | let punit = (Pat.construct unit None) in 361 | let body = (Exp.letmodule ~loc:loc 362 | (with_loc loc (Some "_")) 363 | (Mod.structure (item :: items)) 364 | (Exp.construct unit None)) in 365 | Str.eval (UTop_compat.Exp.fun_ ~loc punit body)) 366 | in 367 | let check_phrase = Ptop_def [top_def] in 368 | try 369 | let _ = 370 | discard_formatters [Format.err_formatter] (fun () -> 371 | Env.reset_cache_toplevel (); 372 | Toploop.execute_phrase false null check_phrase) 373 | in 374 | (* The phrase is safe. *) 375 | Toploop.toplevel_env := env; 376 | Btype.backtrack snap; 377 | None 378 | with exn -> 379 | (* The phrase contains errors. *) 380 | let loc, msg, line = get_ocaml_error_message exn in 381 | Toploop.toplevel_env := env; 382 | Btype.backtrack snap; 383 | Some ([loc], msg, [line]) 384 | 385 | (* +-----------------------------------------------------------------+ 386 | | Prompt | 387 | +-----------------------------------------------------------------+ *) 388 | 389 | let make_prompt ui profile count size key_sequence (recording, macro_count, macro_counter) = 390 | let tm = Unix.localtime !time in 391 | let color dark light = 392 | match profile with 393 | | Dark -> dark 394 | | Light -> light 395 | in 396 | match ui with 397 | | Emacs -> 398 | [||] 399 | | Console -> 400 | let bold = profile = Dark in 401 | let txta = 402 | if key_sequence = [] then 403 | eval [ 404 | B_bold bold; 405 | B_fg (color lcyan blue); 406 | S "─( "; 407 | B_fg (color lmagenta magenta); S (Printf.sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec); E_fg; 408 | S " )─< "; 409 | B_fg (color lyellow yellow); S (Printf.sprintf "command %d" count); E_fg; 410 | S " >─"; 411 | ] 412 | else 413 | eval [ 414 | B_bold bold; 415 | B_fg (color lcyan blue); 416 | S "─( "; 417 | B_fg (color lmagenta magenta); S (Printf.sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec); E_fg; 418 | S " )─< "; 419 | B_fg (color lyellow yellow); S (Printf.sprintf "command %d" count); E_fg; 420 | S " >─[ "; 421 | B_fg (color lgreen green); S (String.concat " " (List.map LTerm_key.to_string_compact key_sequence)); E_fg; 422 | S " ]─"; 423 | ] 424 | in 425 | let txtb = 426 | if recording then 427 | eval [ 428 | B_bold bold; 429 | B_fg (color lcyan blue); 430 | S "{ "; 431 | B_fg (color lwhite black); S (Printf.sprintf "counter: %d" macro_counter); E_fg; 432 | S " }─[ "; 433 | B_fg (color lwhite black); S (Printf.sprintf "macro: %d" macro_count); E_fg; 434 | S " ]─"; 435 | ] 436 | else 437 | eval [ 438 | B_bold bold; 439 | B_fg (color lcyan blue); 440 | S "{ "; 441 | B_fg (color lwhite black); S (Printf.sprintf "counter: %d" macro_counter); E_fg; 442 | S " }─"; 443 | ] 444 | in 445 | let second_line = 446 | eval [ 447 | S "\n"; 448 | B_bold bold; 449 | B_fg (rgb 0xe3 0xaa 0x73); 450 | S "utop"; 451 | B_fg (color lgreen green); 452 | S " # "; 453 | ] 454 | in 455 | Array.append ( 456 | if Array.length txta + Array.length txtb > size.cols then 457 | Array.sub (Array.append txta txtb) 0 size.cols 458 | else 459 | Array.concat [ 460 | txta; 461 | Array.make 462 | (size.cols - Array.length txta - Array.length txtb) 463 | (Zed_char.of_utf8 "\u{2500}", { none with foreground = Some (color lcyan blue); bold = Some bold }); 464 | txtb; 465 | ] 466 | ) second_line 467 | 468 | let default_prompt = 469 | S.l6 make_prompt 470 | UTop_private.ui 471 | profile 472 | count 473 | size 474 | key_sequence 475 | (S.l3 (fun x y z -> (x, y, z)) 476 | (Zed_macro.recording LTerm_read_line.macro) 477 | (Zed_macro.count LTerm_read_line.macro) 478 | (Zed_macro.counter LTerm_read_line.macro)) 479 | 480 | let prompt = ref default_prompt 481 | 482 | let edit_mode= ref LTerm_editor.Default 483 | 484 | let default_info = { 485 | Toploop.section = "UTop"; 486 | doc = ""; (* TODO: have some kind of documentation *) 487 | } 488 | 489 | let () = 490 | Toploop.add_directive "utop_prompt_simple" 491 | (Toploop.Directive_none 492 | (fun () -> 493 | prompt := S.map (Printf.ksprintf LTerm_text.of_utf8 "utop [%d]: ") count)) 494 | default_info; 495 | 496 | Toploop.add_directive "utop_prompt_dummy" 497 | (Toploop.Directive_none 498 | (fun () -> 499 | prompt := S.const (LTerm_text.of_utf8 "# "))) 500 | default_info; 501 | 502 | Toploop.add_directive "utop_prompt_fancy_light" 503 | (Toploop.Directive_none 504 | (fun () -> 505 | set_profile Light; 506 | prompt := default_prompt)) 507 | default_info; 508 | 509 | Toploop.add_directive "utop_prompt_fancy_dark" 510 | (Toploop.Directive_none 511 | (fun () -> 512 | set_profile Dark; 513 | prompt := default_prompt)) 514 | default_info; 515 | 516 | Toploop.add_directive "edit_mode_default" 517 | (Toploop.Directive_none 518 | (fun () -> 519 | edit_mode:= LTerm_editor.Default)) 520 | default_info; 521 | 522 | Toploop.add_directive "edit_mode_vi" 523 | (Toploop.Directive_none 524 | (fun () -> 525 | edit_mode:= LTerm_editor.Vi)) 526 | default_info 527 | 528 | (* +-----------------------------------------------------------------+ 529 | | Help | 530 | +-----------------------------------------------------------------+ *) 531 | 532 | module Bindings = Zed_input.Make (LTerm_key) 533 | module Keys_map = Map.Make (struct type t = LTerm_key.t list let compare = compare end) 534 | 535 | let name_of_action action = 536 | if action == end_and_accept_current_phrase then 537 | "end-and-accept-current-phrase" 538 | else 539 | LTerm_read_line.name_of_action action 540 | 541 | let doc_of_action action = 542 | if action == end_and_accept_current_phrase then 543 | "end the current phrase with the phrase terminator (;;) and evaluate it" 544 | else 545 | LTerm_read_line.doc_of_action action 546 | 547 | let () = 548 | Toploop.add_directive "utop_help" 549 | (Toploop.Directive_none 550 | (fun () -> 551 | print_endline "If you can't see the prompt properly try: #utop_prompt_simple 552 | 553 | utop defines the following directives: 554 | 555 | #help : list all directives 556 | #utop_bindings : list all the current key bindings 557 | #utop_macro : display the currently recorded macro 558 | #utop_stash : store all the valid commands from your current session in a file 559 | #utop_save : store the current session with a simple prompt in a file 560 | #topfind_log : display messages recorded from findlib since the beginning of the session 561 | #topfind_verbose : enable/disable topfind verbosity 562 | 563 | For a complete description of utop, look at the utop(1) manual page.")) 564 | default_info; 565 | 566 | Toploop.add_directive "utop_bindings" 567 | (Toploop.Directive_none 568 | (fun () -> 569 | let make_lines keys actions acc = 570 | match actions with 571 | | [] -> 572 | (String.concat " " (List.map LTerm_key.to_string_compact keys), 573 | "", 574 | "does nothing") 575 | :: acc 576 | | action :: actions -> 577 | let rec loop actions acc = 578 | match actions with 579 | | [] -> 580 | acc 581 | | action :: actions -> 582 | loop 583 | actions 584 | (("", 585 | name_of_action action, 586 | doc_of_action action) 587 | :: acc) 588 | in 589 | loop 590 | actions 591 | ((String.concat " " (List.map LTerm_key.to_string_compact keys), 592 | name_of_action action, 593 | doc_of_action action) 594 | :: acc) 595 | in 596 | let bindings = 597 | Bindings.fold 598 | (fun key actions map -> 599 | Keys_map.add key 600 | (List.map (fun action -> (LTerm_read_line.Edit action)) actions) map) 601 | !LTerm_edit.bindings Keys_map.empty 602 | in 603 | let bindings = Bindings.fold Keys_map.add !LTerm_read_line.bindings bindings in 604 | let table = 605 | List.rev (Keys_map.fold (fun keys action acc -> make_lines keys action acc) 606 | bindings []) 607 | in 608 | let size_key, size_name, size_doc = 609 | List.fold_left 610 | (fun (size_key, size_name, size_doc) (key, name, doc) -> 611 | (max (String.length key) size_key, 612 | max (String.length name) size_name, 613 | max (String.length doc) size_doc)) 614 | (0, 0, 0) 615 | table 616 | in 617 | let buf = Buffer.create 128 in 618 | let format_line (key, name, doc) = 619 | Buffer.clear buf; 620 | Buffer.add_string buf key; 621 | while Buffer.length buf < size_key do 622 | Buffer.add_char buf ' ' 623 | done; 624 | Buffer.add_string buf " : "; 625 | Buffer.add_string buf name; 626 | while Buffer.length buf < size_key + size_name + 3 do 627 | Buffer.add_char buf ' ' 628 | done; 629 | Buffer.add_string buf " -> "; 630 | Buffer.add_string buf doc; 631 | Buffer.add_char buf '\n'; 632 | output_string stdout (Buffer.contents buf) 633 | in 634 | List.iter format_line table; 635 | flush stdout)) 636 | default_info; 637 | 638 | Toploop.add_directive "utop_macro" 639 | (Toploop.Directive_none 640 | (fun () -> 641 | let macro = Zed_macro.contents LTerm_read_line.macro in 642 | List.iter 643 | (fun action -> 644 | output_string stdout (name_of_action action); 645 | output_char stdout '\n') 646 | macro; 647 | flush stdout)) 648 | default_info 649 | 650 | let () = 651 | Toploop.add_directive "pwd" 652 | (Toploop.Directive_none 653 | (fun () -> print_endline (Sys.getcwd ()))) 654 | default_info 655 | 656 | let make_stash_directive entry_formatter fname = 657 | if get_ui () = Emacs then 658 | print_endline "Stashing is currently not supported in Emacs" 659 | else 660 | let entries = UTop_history.contents stashable_session_history in 661 | (* remove the stash directive from its output *) 662 | let entries = match entries with [] -> [] | _ :: e -> e in 663 | let entries = List.rev entries in 664 | Printf.printf "Stashing %d entries in %s ... " (List.length entries) fname; 665 | try 666 | let oc = open_out fname in 667 | try 668 | List.iter 669 | (fun e -> 670 | let line = entry_formatter e in 671 | output_string oc line; 672 | output_char oc '\n') 673 | entries; 674 | close_out oc; 675 | Printf.printf "Done.\n"; 676 | with exn -> 677 | close_out oc; 678 | raise exn 679 | with exn -> 680 | Printf.printf "Error with file %s: %s\n" fname @@ Printexc.to_string exn 681 | 682 | let () = 683 | let fn = make_stash_directive begin function 684 | | UTop_history.Input i -> 685 | i 686 | | Output out | Error out | Bad_input out | Warnings out -> 687 | Printf.sprintf "(* %s *)" out 688 | end 689 | in 690 | Toploop.add_directive "utop_stash" (Toploop.Directive_string fn) default_info 691 | 692 | let () = 693 | let fn = make_stash_directive begin function 694 | | UTop_history.Input i | Bad_input i -> 695 | Printf.sprintf "# %s" i 696 | | Output out | Error out | Warnings out -> 697 | out 698 | end 699 | in 700 | Toploop.add_directive "utop_save" (Toploop.Directive_string fn) default_info 701 | 702 | (* +-----------------------------------------------------------------+ 703 | | Findlib stuff | 704 | +-----------------------------------------------------------------+ *) 705 | 706 | let print_error msg = 707 | Lazy.force LTerm.stdout >>= fun term -> 708 | LTerm.set_style term !UTop_private.error_style >>= fun () -> 709 | Lwt_io.print msg >>= fun () -> 710 | LTerm.set_style term LTerm_style.none >>= fun () -> 711 | LTerm.flush term 712 | 713 | let handle_findlib_error = function 714 | | Failure msg -> 715 | Lwt_main.run (print_error msg) 716 | | Fl_package_base.No_such_package(pkg, reason) -> 717 | Lwt_main.run (print_error (Printf.sprintf "No such package: %s%s\n" pkg (if reason <> "" then " - " ^ reason else ""))) 718 | | Fl_package_base.Package_loop pkg -> 719 | Lwt_main.run (print_error (Printf.sprintf "Package requires itself: %s\n" pkg)) 720 | | exn -> 721 | raise exn 722 | 723 | let topfind_log, set_topfind_log = S.create ~eq:(fun _ _ -> false) [] 724 | 725 | let () = 726 | let real_log = !Topfind.log in 727 | Topfind.log := fun str -> 728 | set_topfind_log (str :: S.value topfind_log); 729 | if S.value topfind_verbose then real_log str 730 | 731 | let () = 732 | Toploop.add_directive 733 | "topfind_log" 734 | (Toploop.Directive_none 735 | (fun () -> 736 | List.iter (fun str -> print_string str; print_char '\n') 737 | (S.value topfind_log); 738 | flush stdout)) 739 | default_info; 740 | 741 | Toploop.add_directive 742 | "topfind_verbose" 743 | (Toploop.Directive_bool set_topfind_verbose) 744 | default_info 745 | 746 | let split_words str = 747 | let len = String.length str in 748 | let is_sep = function 749 | | ' ' | '\t' | '\r' | '\n' | ',' -> true 750 | | _ -> false 751 | in 752 | let rec skip acc i = 753 | if i = len then 754 | acc 755 | else 756 | if is_sep str.[i] then 757 | skip acc (i + 1) 758 | else 759 | extract acc i (i + 1) 760 | and extract acc i j = 761 | if j = len then 762 | (String.sub str i (j - i)) :: acc 763 | else 764 | if is_sep str.[j] then 765 | skip (String.sub str i (j - i) :: acc) (j + 1) 766 | else 767 | extract acc i (j + 1) 768 | in 769 | List.rev (skip [] 0) 770 | 771 | let require packages = 772 | try 773 | let eff_packages = Findlib.package_deep_ancestors !Topfind.predicates packages in 774 | Topfind.load eff_packages 775 | with exn -> 776 | handle_findlib_error exn 777 | 778 | let () = 779 | Toploop.add_directive 780 | "require" 781 | (Toploop.Directive_string 782 | (fun str -> require (split_words str))) 783 | default_info 784 | 785 | (* +-----------------------------------------------------------------+ 786 | | Backports | 787 | +-----------------------------------------------------------------+ *) 788 | 789 | let use_output command = 790 | let fn = Filename.temp_file "ocaml" "_toploop.ml" in 791 | Misc.try_finally ~always:(fun () -> 792 | try Sys.remove fn with Sys_error _ -> ()) 793 | (fun () -> 794 | match 795 | Printf.ksprintf Sys.command "%s > %s" 796 | command 797 | (Filename.quote fn) 798 | with 799 | | 0 -> 800 | ignore (Toploop.use_file Format.std_formatter fn : bool) 801 | | n -> 802 | Format.printf "Command exited with code %d.@." n) 803 | 804 | let () = 805 | let name = "use_output" in 806 | if UTop_compat.toploop_get_directive name = None then 807 | Toploop.add_directive 808 | name 809 | (Toploop.Directive_string use_output) 810 | default_info 811 | 812 | (* +-----------------------------------------------------------------+ 813 | | Initialization | 814 | +-----------------------------------------------------------------+ *) 815 | 816 | let () = 817 | (* "utop" is an internal library so it is not passed as "-package" 818 | to "ocamlfind ocamlmktop". *) 819 | Topfind.don't_load_deeply ["utop"]; 820 | Topfind.add_predicates ["byte"; "toploop"]; 821 | (* Add findlib path so Topfind is available and it won't be 822 | initialized twice if the user does [#use "topfind"]. *) 823 | Topdirs.dir_directory (Findlib.package_directory "findlib"); 824 | (* Make UTop accessible. *) 825 | Topdirs.dir_directory (Findlib.package_directory "utop") 826 | 827 | (* +-----------------------------------------------------------------+ 828 | | Compiler-libs re-exports | 829 | +-----------------------------------------------------------------+ *) 830 | 831 | let get_load_path = UTop_compat.get_load_path 832 | 833 | let set_load_path = UTop_compat.set_load_path 834 | 835 | module Private = struct 836 | let fix_string str = 837 | let len = String.length str in 838 | if len = 0 then 839 | str 840 | else 841 | let ofs, _, _ = Zed_utf8.next_error str 0 in 842 | if ofs = len then 843 | str 844 | else begin 845 | let buf = Buffer.create (len + 128) in 846 | if ofs > 0 then Buffer.add_substring buf str 0 ofs; 847 | let rec loop ofs = 848 | Zed_utf8.add buf (Uchar.of_char str.[ofs]); 849 | let ofs1 = ofs + 1 in 850 | if ofs1 < len then 851 | let ofs2, _, _ = Zed_utf8.next_error str ofs1 in 852 | if ofs1 < ofs2 then 853 | Buffer.add_substring buf str ofs1 (ofs2 - ofs1); 854 | if ofs2 < len then 855 | loop ofs2 856 | else 857 | Buffer.contents buf 858 | else 859 | Buffer.contents buf 860 | in 861 | loop ofs 862 | end 863 | end 864 | -------------------------------------------------------------------------------- /src/lib/uTop.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * uTop.mli 3 | * -------- 4 | * Copyright : (c) 2011, Jeremie Dimino 5 | * Licence : BSD3 6 | * 7 | * This file is a part of utop. 8 | *) 9 | 10 | (** UTop configuration. *) 11 | 12 | open React 13 | 14 | val version : string 15 | (** Version of utop. *) 16 | 17 | val count : int React.signal 18 | (** The number of commands already executed. *) 19 | 20 | val keywords : Set.Make(String).t ref 21 | (** The set of OCaml keywords. *) 22 | 23 | val add_keyword : string -> unit 24 | (** Add a new OCaml keyword. *) 25 | 26 | val require : string list -> unit 27 | (** Load all the given findlib packages *) 28 | 29 | type ui = Console | Emacs 30 | (** The user interface in use. *) 31 | 32 | val get_ui : unit -> ui 33 | (** Returns the user interface in use. *) 34 | 35 | val hide_reserved : bool signal 36 | (** If [true] (the default) identifiers starting with a '_' will be hidden from the 37 | output. i.e. the following phrase won't produces any output: 38 | 39 | {[ 40 | let _x = 1 41 | ]} 42 | 43 | This is for hidding variables created by code generators for internal use. It can 44 | also be set/unset by the command line options [-hide-reserved] and [-show-reserved]. 45 | *) 46 | 47 | val get_hide_reserved : unit -> bool 48 | (** Returns the value of {!hide_reserved}. *) 49 | 50 | val set_hide_reserved : bool -> unit 51 | (** Modifies {!hide_reserved}. *) 52 | 53 | val create_implicits : bool signal 54 | (** If [true] (not the default) expressions entered in the toplevel are 55 | automatically bound, for example: 56 | 57 | {[ 58 | # 3 + 4;; 59 | _0 : int = 7 60 | # _0 + 10;; 61 | _1 : int = 17 62 | ]} 63 | *) 64 | 65 | val get_create_implicits : unit -> bool 66 | (** Returns the value of {!create_implicits}. *) 67 | 68 | val set_create_implicits : bool -> unit 69 | (** Modifies {!create_implicits}. *) 70 | 71 | val topfind_verbose : bool signal 72 | (** If [false] (the default) messages from findlib are hidden. This is only effective 73 | with findlib >= 1.4. *) 74 | 75 | val get_topfind_verbose : unit -> bool 76 | (** Returns the value of {!topfind_verbose}. *) 77 | 78 | val set_topfind_verbose : bool -> unit 79 | (** Modifies {!topfind_verbose}. *) 80 | 81 | val topfind_log : string list signal 82 | (** List of messages logged by findlib since the beginning of the session. This 83 | requires findlib >= 1.4. *) 84 | 85 | val show_box : bool signal 86 | (** If [true] (the default) the completion bar is displayed. *) 87 | 88 | val get_show_box : unit -> bool 89 | (** Returns the value of {!show_box}. *) 90 | 91 | val set_show_box : bool -> unit 92 | (** Modifies {!show_box}. *) 93 | 94 | val set_margin_function : (LTerm_geom.size -> int option) -> unit 95 | (** Margin of the standard and error formatters as a function of the screen size. 96 | 97 | The default is: 98 | 99 | {[ 100 | fun size -> Some (min 80 size.cols) 101 | ]} 102 | *) 103 | 104 | val phrase_terminator : string signal 105 | (** The phrase terminator, ";;". *) 106 | 107 | val get_phrase_terminator : unit -> string 108 | (** Returns the value of {!phrase_terminator}. *) 109 | 110 | val set_phrase_terminator : string -> unit 111 | (** Modifies {!phrase_terminator}. *) 112 | 113 | val auto_run_lwt : bool signal 114 | (** If [true] (the default) toplevel lwt expressions are 115 | automatically run with [Lwt_main.run]. i.e. if you type: 116 | 117 | {[ 118 | Lwt_io.printl "Hello, world" 119 | ]} 120 | 121 | this will be replaced by: 122 | 123 | {[ 124 | Lwt_main.run (Lwt_io.printl "Hello, world") 125 | ]} 126 | *) 127 | 128 | val get_auto_run_lwt : unit -> bool 129 | (** Returns the value of {!auto_run_lwt}. *) 130 | 131 | val set_auto_run_lwt : bool -> unit 132 | (** Modifies {!auto_run_lwt}. *) 133 | 134 | val auto_run_async : bool signal 135 | (** If [true] (the default) toplevel Async expressions are 136 | automatically run with in a separate thread with 137 | [Thread_safe.block_on_async_exn]. i.e. if you type: 138 | 139 | {[ 140 | after (Time.Span.of_s 1.0) 141 | ]} 142 | 143 | this will be replaced by: 144 | 145 | {[ 146 | Thread_safe.block_on_async_exn (fun () -> after (Time.Span.of_s 1.0)) 147 | ]} 148 | *) 149 | 150 | val get_auto_run_async : unit -> bool 151 | (** Returns the value of {!auto_run_async}. *) 152 | 153 | val set_auto_run_async : bool -> unit 154 | (** Modifies {!auto_run_async}. *) 155 | 156 | val end_and_accept_current_phrase : LTerm_read_line.action 157 | (** Action that add the phrase terminator at the end of the current phrase 158 | and accepts it. For instance to avoid typing [;;], add this to your 159 | ~/.config/utop/init.ml: 160 | 161 | {[ 162 | #require "lambda-term";; 163 | LTerm_read_line.bind 164 | [ { control = false; meta = false; shift = false; code = Enter } ] 165 | [ UTop.end_and_accept_current_phrase ] 166 | ]} 167 | *) 168 | 169 | (** External editor command. [None] for default. *) 170 | val external_editor : string signal 171 | val set_external_editor : string -> unit 172 | val get_external_editor : unit -> string 173 | 174 | (** {6 History} *) 175 | 176 | val history : LTerm_history.t 177 | (** The history used by utop. You can configure limits using the 178 | [LTerm_history] module. 179 | 180 | For example if you want to limit the history to 1000 line, add 181 | these lines to your ~/.config/utop/init.ml file: 182 | 183 | {[ 184 | #require "lambda-term";; 185 | LTerm_history.set_max_entries UTop.history 1000;; 186 | ]} 187 | *) 188 | 189 | val history_file_name : string option ref 190 | (** Name of the history file. If [None], no history will be loaded 191 | or saved. *) 192 | 193 | val history_file_max_size : int option ref 194 | (** Maximum size of the history file. If [None] (the default) the 195 | maximum size of [history] will be used. *) 196 | 197 | val history_file_max_entries : int option ref 198 | (** Maximum entries to store in the history file. If [None] (the 199 | default) the maximum number of entries if [history] will be 200 | used. *) 201 | 202 | val stashable_session_history : UTop_history.t 203 | (** A history consisting of inputs and resulting values or errors of the 204 | current session. Because stashing is supposed to produce a valid OCaml 205 | file which will behave roughly the same as the console, it is best if 206 | this history never gets truncated. While this will certainly lead to a 207 | slight memory leaking problem, UTop sessions are rarely long enough to 208 | make it a serious issue. *) 209 | 210 | (** {6 Console specific configuration} *) 211 | 212 | type profile = Dark | Light 213 | (** Profile for colors. *) 214 | 215 | val profile : profile React.signal 216 | (** The color profile. It defaults to {!Dark}. This is used by the 217 | default prompt to choose colors. *) 218 | 219 | val set_profile : profile -> unit 220 | (** Sets the color profile. *) 221 | 222 | val size : LTerm_geom.size React.signal 223 | (** The current size of the terminal. This is used only in the 224 | console UI. *) 225 | 226 | val key_sequence : LTerm_key.t list React.signal 227 | (** The current key sequence entered by the user. This is used only 228 | in the console UI. *) 229 | 230 | val time : float ref 231 | (** The time of the beginning of the current command. *) 232 | 233 | val prompt : LTerm_text.t React.signal ref 234 | (** The prompt. *) 235 | 236 | (** {6 Edit mode configuration} *) 237 | 238 | val edit_mode : LTerm_editor.mode ref 239 | (** The edit mode. *) 240 | 241 | (** {6 Hooks} *) 242 | 243 | val new_command_hooks : (unit -> unit) LTerm_dlist.t 244 | (** Functions called before each new command. *) 245 | 246 | val at_new_command : (unit -> unit) -> unit 247 | (** [at_new_command f] adds [f] to the hooks executed before each 248 | new commands. *) 249 | 250 | (** {6 Parsing} *) 251 | 252 | type location = int * int 253 | (** Type of a string-location. It is composed of a start and stop 254 | offsets (in bytes). *) 255 | 256 | type lines = { 257 | start: int; 258 | stop: int; 259 | } 260 | (** Type for a range of lines in a buffer from start to stop. *) 261 | 262 | (** Result of a function processing a programx. *) 263 | type 'a result = 264 | | Value of 'a 265 | (** The function succeeded and returned this value. *) 266 | | Error of location list * string 267 | (** The function failed. Arguments are a list of locations to 268 | highlight in the source and an error message. *) 269 | 270 | exception Need_more 271 | (** Exception raised by a parser when it need more data. *) 272 | 273 | val parse_use_file : (string -> bool -> Parsetree.toplevel_phrase list result) ref 274 | 275 | val parse_use_file_default : string -> bool -> Parsetree.toplevel_phrase list result 276 | (** The default parser for toplevel regions. It uses the standard 277 | ocaml parser. *) 278 | 279 | val parse_toplevel_phrase : (string -> bool -> Parsetree.toplevel_phrase result) ref 280 | (** [parse_toplevel_phrase] is the function used to parse a phrase 281 | typed in the toplevel. 282 | 283 | Its arguments are: 284 | - [input]: the string to parse 285 | - [eos_is_error] 286 | 287 | If [eos_is_error] is [true] and the parser reach the end of 288 | input, then {!Parse_failure} should be returned. 289 | 290 | If [eos_is_error] is [false] and the parser reach the end of 291 | input, the exception {!Need_more} must be thrown. 292 | 293 | Except for {!Need_more}, the function must not raise any 294 | exception. *) 295 | 296 | val parse_toplevel_phrase_default : string -> bool -> Parsetree.toplevel_phrase result 297 | (** The default parser for toplevel phrases. It uses the standard 298 | ocaml parser. *) 299 | 300 | val parse_default : (Lexing.lexbuf -> 'a) -> string -> bool -> 'a result 301 | (** The default parser. It uses the standard ocaml parser. *) 302 | 303 | val input_name : string 304 | (** The name you must use in location to let ocaml know that it is 305 | from the toplevel. *) 306 | 307 | val lexbuf_of_string : bool ref -> string -> Lexing.lexbuf 308 | (** [lexbuf_of_string eof str] is the same as [Lexing.from_string 309 | str] except that if the lexer reach the end of [str] then [eof] is 310 | set to [true]. *) 311 | 312 | (** {6 Helpers} *) 313 | 314 | val get_message : (Format.formatter -> 'a -> unit) -> 'a -> string 315 | (** [get_message printer x] applies [printer] on [x] and 316 | returns everything it prints as a string. *) 317 | 318 | val get_ocaml_error_message : exn -> location * string * (lines option) 319 | (** [get_ocaml_error_message exn] returns the location and error 320 | message for the exception [exn] which must be an exception from 321 | the compiler. *) 322 | 323 | val check_phrase : Parsetree.toplevel_phrase -> (location list * string * lines option list) option 324 | (** [check_phrase phrase] checks that [phrase] can be executed 325 | without typing or compilation errors. It returns [None] if 326 | [phrase] is OK and an error message otherwise. 327 | 328 | If the result is [None] it is guaranteed that 329 | [Toploop.execute_phrase] won't raise any exception. *) 330 | 331 | val collect_formatters : Buffer.t -> Format.formatter list -> (unit -> 'a) -> 'a 332 | (** [collect_formatters buf pps f] executes [f] and redirect 333 | everything it prints on [pps] to [buf]. *) 334 | 335 | val discard_formatters : Format.formatter list -> (unit -> 'a) -> 'a 336 | (** [discard_formatters pps f] executes [f], dropping everything it 337 | prints on [pps]. *) 338 | 339 | val split_words : string -> string list 340 | 341 | (** {6 compiler-libs reexports} *) 342 | 343 | val get_load_path : unit -> string list 344 | val set_load_path : string list -> unit 345 | (** [get_load_path] and [set_load_path] manage the include directories. 346 | 347 | The internal variable contains the list of directories added by findlib-required packages 348 | and [#directory] directives. *) 349 | 350 | (**/**) 351 | 352 | module Private : sig 353 | val fix_string : string -> string 354 | end 355 | -------------------------------------------------------------------------------- /src/lib/uTop_compat.ml: -------------------------------------------------------------------------------- 1 | let get_desc x = 2 | #if OCAML_VERSION >= (4, 14, 0) 3 | Types.get_desc x 4 | #else 5 | x.Types.desc 6 | #endif 7 | 8 | let toploop_get_directive name = 9 | #if OCAML_VERSION >= (4, 13, 0) 10 | Toploop.get_directive name 11 | #else 12 | try Some (Hashtbl.find Toploop.directive_table name) with Not_found -> None 13 | #endif 14 | 15 | let toploop_all_directive_names () = 16 | #if OCAML_VERSION >= (4, 13, 0) 17 | Toploop.all_directive_names () 18 | #else 19 | Hashtbl.fold (fun dir _ acc -> dir::acc) Toploop.directive_table [] 20 | #endif 21 | 22 | let get_load_path () = 23 | #if OCAML_VERSION >= (5, 2, 0) 24 | let {Load_path.visible; hidden} = Load_path.get_paths () in 25 | visible @ hidden 26 | #else 27 | Load_path.get_paths () 28 | #endif 29 | 30 | let set_load_path visible = 31 | #if OCAML_VERSION >= (5, 2, 0) 32 | Load_path.init ~auto_include:Load_path.no_auto_include ~visible ~hidden:[] 33 | #elif OCAML_VERSION >= (5, 0, 0) 34 | Load_path.init ~auto_include:Load_path.no_auto_include visible 35 | #else 36 | Load_path.init visible 37 | #endif 38 | 39 | let toploop_use_silently fmt name = 40 | #if OCAML_VERSION >= (4, 14, 0) 41 | Toploop.use_silently fmt (match name with "" -> Stdin | _ -> File name) 42 | #else 43 | Toploop.use_silently fmt name 44 | #endif 45 | 46 | let toploop_set_paths () = 47 | #if OCAML_VERSION >= (5, 0, 0) 48 | Toploop.set_paths ~auto_include:Load_path.no_auto_include () 49 | #else 50 | Toploop.set_paths () 51 | #endif 52 | 53 | let toploop_load_file ppf fn = 54 | #if OCAML_VERSION >= (4, 13, 0) 55 | Toploop.load_file ppf fn 56 | #else 57 | Topdirs.load_file ppf fn 58 | #endif 59 | 60 | (** Returns whether the given path is persistent. *) 61 | let rec is_persistent_path = function 62 | | Path.Pident id -> Ident.persistent id 63 | | Path.Pdot (p, _) -> is_persistent_path p 64 | | Path.Papply (_, p) -> is_persistent_path p 65 | #if OCAML_VERSION >= (5, 1, 0) 66 | | Path.Pextra_ty (p, _) -> is_persistent_path p 67 | #endif 68 | 69 | #if OCAML_VERSION >= (5, 2, 0) 70 | let inline_code = 71 | #if OCAML_VERSION >= (5, 3, 0) 72 | (Format_doc.compat Misc.Style.inline_code) 73 | #else 74 | Misc.Style.inline_code 75 | #endif 76 | #endif 77 | 78 | let invalid_package_error_to_string err = 79 | #if OCAML_VERSION >= (5, 2, 0) 80 | (* NOTE: from https://github.com/ocaml/ocaml/blob/9b059b1e7a66e9d2f04d892a4de34c418cd96f69/parsing/parse.ml#L149 *) 81 | let invalid ppf ipt = match ipt with 82 | | Syntaxerr.Parameterized_types -> 83 | Format.fprintf ppf "parametrized types are not supported" 84 | | Constrained_types -> 85 | Format.fprintf ppf "constrained types are not supported" 86 | | Private_types -> 87 | Format.fprintf ppf "private types are not supported" 88 | | Not_with_type -> 89 | Format.fprintf ppf "only %a constraints are supported" 90 | inline_code "with type t =" 91 | | Neither_identifier_nor_with_type -> 92 | Format.fprintf ppf 93 | "only module type identifier and %a constraints are supported" 94 | inline_code "with type" 95 | in 96 | let buf = Buffer.create 128 in 97 | let fmt = Format.formatter_of_buffer buf in 98 | Format.fprintf fmt "Invalid package type: %a%!" invalid err; 99 | Buffer.contents buf 100 | #else 101 | err 102 | #endif 103 | 104 | module Exp = struct 105 | open Ast_helper 106 | #if OCAML_VERSION >= (5, 2, 0) 107 | open Parsetree 108 | let fun_ ~loc p e = 109 | let args = [{ 110 | pparam_loc=loc; 111 | pparam_desc=Pparam_val (Nolabel, None, p); 112 | }] in 113 | (Exp.function_ args None (Pfunction_body e)) 114 | #else 115 | let fun_ ~loc p e = Exp.fun_ ~loc Nolabel None p e 116 | #endif 117 | end 118 | 119 | let abstract_type_kind = 120 | #if OCAML_VERSION >= (5, 2, 0) 121 | Types.(Type_abstract Definition) 122 | #else 123 | Types.Type_abstract 124 | #endif 125 | 126 | let find_in_path_normalized = 127 | #if OCAML_VERSION >= (5, 2, 0) 128 | Misc.find_in_path_normalized 129 | #else 130 | Misc.find_in_path_uncap 131 | #endif 132 | 133 | let visible_paths_for_cmt_infos (cmt_infos: Cmt_format.cmt_infos) = 134 | #if OCAML_VERSION >= (5, 2, 0) 135 | cmt_infos.cmt_loadpath.visible 136 | #else 137 | cmt_infos.cmt_loadpath 138 | #endif 139 | 140 | let add_cmi_hook f = 141 | let default_load = !Persistent_env.Persistent_signature.load in 142 | #if OCAML_VERSION >= (5, 2, 0) 143 | let load ~allow_hidden ~unit_name = 144 | let res = default_load ~unit_name ~allow_hidden in 145 | #else 146 | let load ~unit_name = 147 | let res = default_load ~unit_name in 148 | #endif 149 | (match res with None -> () | Some x -> f x.cmi); 150 | res 151 | in 152 | Persistent_env.Persistent_signature.load := load 153 | 154 | -------------------------------------------------------------------------------- /src/lib/uTop_complete.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * uTop_complete.ml 3 | * ---------------- 4 | * Copyright : (c) 2011, Jeremie Dimino 5 | * Licence : BSD3 6 | * 7 | * This file is a part of utop. 8 | *) 9 | 10 | [@@@warning "-9-27-32"] 11 | 12 | open Types 13 | open LTerm_read_line 14 | open UTop_compat 15 | open UTop_token 16 | 17 | module String_set = Set.Make(String) 18 | module String_map = Map.Make(String) 19 | 20 | let set_of_list = List.fold_left (fun set x -> String_set.add x set) String_set.empty 21 | 22 | (* +-----------------------------------------------------------------+ 23 | | Utils | 24 | +-----------------------------------------------------------------+ *) 25 | 26 | (* Transform a non-empty list of strings into a long-identifier. *) 27 | let longident_of_list = function 28 | | [] -> 29 | invalid_arg "UTop_complete.longident_of_list" 30 | | component :: rest -> 31 | let rec loop acc = function 32 | | [] -> acc 33 | | component :: rest -> loop (Longident.Ldot(acc, component)) rest 34 | in 35 | loop (Longident.Lident component) rest 36 | 37 | (* Check whether an identifier is a valid one. *) 38 | let is_valid_identifier id = 39 | id <> "" && 40 | (match id.[0] with 41 | | 'A' .. 'Z' | 'a' .. 'z' | '_' -> true 42 | | _ -> false) 43 | 44 | let add id set = if is_valid_identifier id then String_set.add id set else set 45 | 46 | let lookup_env f x env = 47 | try 48 | Some (f x env) 49 | with Not_found | Env.Error _ -> 50 | None 51 | 52 | (* +-----------------------------------------------------------------+ 53 | | Parsing | 54 | +-----------------------------------------------------------------+ *) 55 | 56 | (* The following functions takes a list of tokens in reverse order. *) 57 | 58 | type value_or_field = Value | Field 59 | (* Either a value, or a record field. *) 60 | 61 | (* Parse something of the form [M1.M2. ... .Mn.id] or 62 | [field.M1.M2. ... .Mn.id] *) 63 | let parse_longident tokens = 64 | let rec loop acc tokens = 65 | match tokens with 66 | | (Symbol ".", _) :: (Uident id, _) :: tokens -> 67 | loop (id :: acc) tokens 68 | | (Symbol ".", _) :: (Lident id, _) :: tokens -> 69 | (Field, 70 | match acc with 71 | | [] -> None 72 | | l -> Some (longident_of_list l)) 73 | | _ -> 74 | (Value, 75 | match acc with 76 | | [] -> None 77 | | l -> Some (longident_of_list l)) 78 | in 79 | match tokens with 80 | | ((Comment (_, false) | String (_, false) | Quotation (_, false)), _) :: _ -> 81 | (* An unterminated command, string, or quotation. *) 82 | None 83 | | ((Uident id | Lident id), { idx1 = start }) :: tokens -> 84 | (* An identifier. *) 85 | let kind, path = loop [] tokens in 86 | Some (kind, path, start, id) 87 | | (Blanks, { idx2 = stop }) :: tokens -> 88 | (* Some blanks at the end. *) 89 | let kind, path = loop [] tokens in 90 | Some (kind, path, stop, "") 91 | | (_, { idx2 = stop }) :: _ -> 92 | (* Otherwise complete after the last token. *) 93 | let kind, path = loop [] tokens in 94 | Some (kind, path, stop, "") 95 | | [] -> 96 | None 97 | 98 | (* Parse something of the form [M1.M2. ... .Mn.id#m1#m2# ... #mp#m] *) 99 | let parse_method tokens = 100 | (* Collect [M1.M2. ... .Mn.id] and returns the corresponding 101 | longidentifier. *) 102 | let rec loop_uidents acc tokens = 103 | match tokens with 104 | | (Symbol ".", _) :: (Uident id, _) :: tokens -> 105 | loop_uidents (id :: acc) tokens 106 | | _ -> 107 | longident_of_list acc 108 | in 109 | (* Collect [m1#m2# ... #mp] *) 110 | let rec loop_methods acc tokens = 111 | match tokens with 112 | | (Lident meth, _) :: (Symbol "#", _) :: tokens -> 113 | loop_methods (meth :: acc) tokens 114 | | (Lident id, _) :: tokens -> 115 | Some (loop_uidents [id] tokens, acc) 116 | | _ -> 117 | None 118 | in 119 | match tokens with 120 | | (Lident meth, { idx1 = start }) :: (Symbol "#", _) :: tokens -> begin 121 | match loop_methods [] tokens with 122 | | None -> None 123 | | Some (path, meths) -> Some (path, meths, start, meth) 124 | end 125 | | (Symbol "#", { idx2 = stop }) :: tokens 126 | | (Blanks, { idx2 = stop }) :: (Symbol "#", _) :: tokens -> begin 127 | match loop_methods [] tokens with 128 | | None -> None 129 | | Some (path, meths) -> Some (path, meths, stop, "") 130 | end 131 | | _ -> 132 | None 133 | 134 | type label_kind = Required | Optional 135 | (* Kind of labels: required or optional. *) 136 | 137 | type fun_or_new = Fun | New 138 | (* Either a function application, either an object creation. *) 139 | 140 | (* Parse something of the form [M1.M2. ... .Mn.id#m1#m2# ... #mp expr1 ... exprq ~label] 141 | or [new M1.M2. ... .Mn.id expr1 ... exprq ~label] *) 142 | let parse_label tokens = 143 | (* Collect [M1.M2. ... .Mn] *) 144 | let rec loop_uidents acc_uidents acc_methods tokens = 145 | match tokens with 146 | | (Lident "new", _) :: _ -> 147 | Some (New, longident_of_list acc_uidents, acc_methods) 148 | | ((Lident id | Uident id), _) :: _ when String_set.mem id !UTop.keywords -> 149 | Some (Fun, longident_of_list acc_uidents, acc_methods) 150 | | (Symbol ".", _) :: (Uident id, _) :: tokens -> 151 | loop_uidents (id :: acc_uidents) acc_methods tokens 152 | | (Symbol ("~" | "?" | ":" | "." | "#" | "!" | "`"), _) :: tokens -> 153 | search tokens 154 | | (Symbol ")", _) :: tokens -> 155 | skip tokens "(" [] 156 | | (Symbol "}", _) :: tokens -> 157 | skip tokens "{" [] 158 | | (Symbol "]", _) :: tokens -> 159 | skip tokens "[" [] 160 | | (Symbol _, _) :: _ -> 161 | Some (Fun, longident_of_list acc_uidents, acc_methods) 162 | | [] -> 163 | Some (Fun, longident_of_list acc_uidents, acc_methods) 164 | | _ -> 165 | search tokens 166 | and loop_methods acc tokens = 167 | match tokens with 168 | | ((Lident id | Uident id), _) :: _ when String_set.mem id !UTop.keywords -> 169 | None 170 | | (Symbol ("~" | "?" | ":" | "." | "#" | "!" | "`"), _) :: tokens -> 171 | search tokens 172 | | (Symbol ")", _) :: tokens -> 173 | skip tokens "(" [] 174 | | (Symbol "}", _) :: tokens -> 175 | skip tokens "{" [] 176 | | (Symbol "]", _) :: tokens -> 177 | skip tokens "[" [] 178 | | (Symbol _, _) :: _ -> 179 | None 180 | | (Lident id, _) :: (Symbol "#", _) :: tokens -> 181 | loop_methods (id :: acc) tokens 182 | | (Lident id, _) :: tokens -> 183 | loop_uidents [id] acc tokens 184 | | [] -> 185 | None 186 | | _ -> 187 | search tokens 188 | and search tokens = 189 | match tokens with 190 | | ((Lident id | Uident id), _) :: _ when String_set.mem id !UTop.keywords -> 191 | None 192 | | (Symbol ("~" | "?" | ":" | "." | "#" | "!" | "`"), _) :: tokens -> 193 | search tokens 194 | | (Symbol ")", _) :: tokens -> 195 | skip tokens "(" [] 196 | | (Symbol "}", _) :: tokens -> 197 | skip tokens "{" [] 198 | | (Symbol "]", _) :: tokens -> 199 | skip tokens "[" [] 200 | | (Symbol _, _) :: _ -> 201 | None 202 | | (Lident id, _) :: (Symbol "#", _) :: tokens -> 203 | loop_methods [id] tokens 204 | | (Lident id, _) :: tokens -> 205 | loop_uidents [id] [] tokens 206 | | _ :: tokens -> 207 | search tokens 208 | | [] -> 209 | None 210 | and skip tokens top stack = 211 | match tokens with 212 | | (Symbol symbol, _) :: tokens when symbol = top -> begin 213 | match stack with 214 | | [] -> search tokens 215 | | top :: stack -> skip tokens top stack 216 | end 217 | | (Symbol ")", _) :: tokens -> 218 | skip tokens "(" (top :: stack) 219 | | (Symbol "}", _) :: tokens -> 220 | skip tokens "{" (top :: stack) 221 | | (Symbol "]", _) :: tokens -> 222 | skip tokens "[" (top :: stack) 223 | | _ :: tokens -> 224 | skip tokens top stack 225 | | [] -> 226 | None 227 | in 228 | match tokens with 229 | | (Lident label, { idx1 = start }) :: (Symbol "~", _) :: tokens -> begin 230 | match search tokens with 231 | | None -> None 232 | | Some (kind, id, meths) -> Some (kind, id, meths, Required, start, label) 233 | end 234 | | (Symbol "~", { idx2 = stop }) :: tokens -> begin 235 | match search tokens with 236 | | None -> None 237 | | Some (kind, id, meths) -> Some (kind, id, meths, Required, stop, "") 238 | end 239 | | (Lident label, { idx1 = start }) :: (Symbol "?", _) :: tokens -> begin 240 | match search tokens with 241 | | None -> None 242 | | Some (kind, id, meths) -> Some (kind, id, meths, Optional, start, label) 243 | end 244 | | (Symbol "?", { idx2 = stop }) :: tokens -> begin 245 | match search tokens with 246 | | None -> None 247 | | Some (kind, id, meths) -> Some (kind, id, meths, Optional, stop, "") 248 | end 249 | | _ -> 250 | None 251 | 252 | (* +-----------------------------------------------------------------+ 253 | | Directive listing | 254 | +-----------------------------------------------------------------+ *) 255 | 256 | let list_directives phrase_terminator = 257 | String_map.bindings 258 | (List.fold_left 259 | (fun map dir -> 260 | let suffix = 261 | match toploop_get_directive dir with 262 | | Some (Toploop.Directive_none _) -> phrase_terminator 263 | | Some (Toploop.Directive_string _) -> " \"" 264 | | Some (Toploop.Directive_bool _ | Toploop.Directive_int _ | Toploop.Directive_ident _) -> " " 265 | | None -> assert false 266 | in 267 | String_map.add dir suffix map) 268 | String_map.empty 269 | (toploop_all_directive_names ())) 270 | 271 | (* +-----------------------------------------------------------------+ 272 | | File listing | 273 | +-----------------------------------------------------------------+ *) 274 | 275 | type file_kind = Directory | File 276 | 277 | let basename name = 278 | let name' = Filename.basename name in 279 | if name' = "." && not (Zed_utf8.ends_with name ".") then 280 | "" 281 | else 282 | name' 283 | 284 | let add_files filter acc dir = 285 | Array.fold_left 286 | (fun map name -> 287 | let absolute_name = Filename.concat dir name in 288 | if try Sys.is_directory absolute_name with Sys_error _ -> false then 289 | String_map.add (Filename.concat name "") Directory map 290 | else if filter name then 291 | String_map.add name File map 292 | else 293 | map) 294 | acc 295 | (try Sys.readdir dir with Sys_error _ -> [||]) 296 | 297 | let list_directories dir = 298 | String_set.elements 299 | (Array.fold_left 300 | (fun set name -> 301 | let absolute_name = Filename.concat dir name in 302 | if try Sys.is_directory absolute_name with Sys_error _ -> false then 303 | String_set.add name set 304 | else 305 | set) 306 | String_set.empty 307 | (try Sys.readdir (if dir = "" then Filename.current_dir_name else dir) with Sys_error _ -> [||])) 308 | 309 | let path () = 310 | let path_separator = 311 | match Sys.os_type with 312 | | "Unix" | "Cygwin" -> ':' 313 | | "Win32" -> ';' 314 | | _ -> assert false in 315 | let split str sep = 316 | let rec split_rec pos = 317 | if pos >= String.length str then [] else begin 318 | match try Some (String.index_from str pos sep) 319 | with Not_found -> None with 320 | | Some newpos -> 321 | String.sub str pos (newpos - pos) :: 322 | split_rec (newpos + 1) 323 | | None -> 324 | [String.sub str pos (String.length str - pos)] 325 | end in 326 | split_rec 0 327 | in 328 | try 329 | split (Sys.getenv "PATH") path_separator 330 | with Not_found -> [] 331 | 332 | (* +-----------------------------------------------------------------+ 333 | | Names listing | 334 | +-----------------------------------------------------------------+ *) 335 | 336 | module Path_map = Map.Make(struct type t = Path.t let compare = compare end) 337 | module Longident_map = Map.Make(struct type t = Longident.t let compare = compare end) 338 | 339 | (* All names accessible without a path. *) 340 | let global_names = ref None 341 | let global_names_revised = ref None 342 | 343 | (* All names accessible with a path, by path. *) 344 | let local_names_by_path = ref Path_map.empty 345 | 346 | (* All names accessible with a path, by long identifier. *) 347 | let local_names_by_longident = ref Longident_map.empty 348 | 349 | (* All record fields accessible without a path. *) 350 | let global_fields = ref None 351 | 352 | (* All record fields accessible with a path, by path. *) 353 | let local_fields_by_path = ref Path_map.empty 354 | 355 | (* All record fields accessible with a path, by long identifier. *) 356 | let local_fields_by_longident = ref Longident_map.empty 357 | 358 | (* All visible modules according to Config.load_path. *) 359 | let visible_modules = ref None 360 | 361 | let reset () = 362 | visible_modules := None; 363 | global_names := None; 364 | global_names_revised := None; 365 | local_names_by_path := Path_map.empty; 366 | local_names_by_longident := Longident_map.empty; 367 | global_fields := None; 368 | local_fields_by_path := Path_map.empty; 369 | local_fields_by_longident := Longident_map.empty 370 | 371 | let get_cached var f = 372 | match !var with 373 | | Some x -> 374 | x 375 | | None -> 376 | let x = f () in 377 | var := Some x; 378 | x 379 | 380 | (* List all visible modules. *) 381 | let visible_modules () = 382 | get_cached visible_modules 383 | (fun () -> 384 | List.fold_left 385 | (fun acc dir -> 386 | try 387 | Array.fold_left 388 | (fun acc fname -> 389 | if Filename.check_suffix fname ".cmi" then 390 | String_set.add (String.capitalize_ascii (Filename.chop_suffix fname ".cmi")) acc 391 | else 392 | acc) 393 | acc 394 | (Sys.readdir (if dir = "" then Filename.current_dir_name else dir)) 395 | with Sys_error _ -> 396 | acc) 397 | String_set.empty @@ UTop_compat.get_load_path () 398 | ) 399 | 400 | let field_name { ld_id = id } = Ident.name id 401 | let constructor_name { cd_id = id } = Ident.name id 402 | 403 | let add_fields_of_type decl acc = 404 | match decl.type_kind with 405 | | Type_variant _ -> 406 | acc 407 | | Type_record (fields, _) -> 408 | List.fold_left (fun acc field -> add (field_name field) acc) acc fields 409 | #if OCAML_VERSION >= (5, 2, 0) 410 | | Type_abstract _ -> 411 | #else 412 | | Type_abstract -> 413 | #endif 414 | acc 415 | | Type_open -> 416 | acc 417 | 418 | let add_names_of_type decl acc = 419 | match decl.type_kind with 420 | #if OCAML_VERSION >= (4, 13, 0) 421 | | Type_variant (constructors, _) -> 422 | #else 423 | | Type_variant constructors -> 424 | #endif 425 | List.fold_left (fun acc cstr -> add (constructor_name cstr) acc) acc constructors 426 | | Type_record (fields, _) -> 427 | List.fold_left (fun acc field -> add (field_name field) acc) acc fields 428 | #if OCAML_VERSION >= (5, 2, 0) 429 | | Type_abstract _ -> 430 | #else 431 | | Type_abstract -> 432 | #endif 433 | acc 434 | | Type_open -> 435 | acc 436 | 437 | let path_of_mty_alias = function 438 | | Mty_alias path -> path 439 | | _ -> assert false 440 | 441 | let rec names_of_module_type = function 442 | | Mty_signature decls -> 443 | List.fold_left 444 | (fun acc decl -> match decl with 445 | | Sig_value (id, _, _) 446 | | Sig_typext (id, _, _, _) 447 | | Sig_module (id, _, _, _, _) 448 | | Sig_modtype (id, _, _) 449 | | Sig_class (id, _, _, _) 450 | | Sig_class_type (id, _, _, _) -> 451 | add (Ident.name id) acc 452 | | Sig_type (id, decl, _, _) -> 453 | add_names_of_type decl (add (Ident.name id) acc)) 454 | String_set.empty decls 455 | | Mty_ident path -> begin 456 | match lookup_env Env.find_modtype path !Toploop.toplevel_env with 457 | | Some { mtd_type = None } -> String_set.empty 458 | | Some { mtd_type = Some module_type } -> names_of_module_type module_type 459 | | None -> String_set.empty 460 | end 461 | | Mty_alias _ as mty_alias -> begin 462 | let path = path_of_mty_alias mty_alias in 463 | match lookup_env Env.find_module path !Toploop.toplevel_env with 464 | | None -> String_set.empty 465 | | Some { md_type = module_type } -> names_of_module_type module_type 466 | end 467 | | _ -> 468 | String_set.empty 469 | 470 | let rec fields_of_module_type = function 471 | | Mty_signature decls -> 472 | List.fold_left 473 | (fun acc decl -> match decl with 474 | | Sig_value _ 475 | | Sig_typext _ 476 | | Sig_module _ 477 | | Sig_modtype _ 478 | | Sig_class _ 479 | | Sig_class_type _ -> 480 | acc 481 | | Sig_type (_, decl, _, _) -> 482 | add_fields_of_type decl acc) 483 | String_set.empty decls 484 | | Mty_ident path -> begin 485 | match lookup_env Env.find_modtype path !Toploop.toplevel_env with 486 | | Some { mtd_type = None } -> String_set.empty 487 | | Some { mtd_type = Some module_type } -> fields_of_module_type module_type 488 | | None -> String_set.empty 489 | end 490 | | Mty_alias _ as mty_alias -> begin 491 | let path = path_of_mty_alias mty_alias in 492 | match lookup_env Env.find_module path !Toploop.toplevel_env with 493 | | None -> String_set.empty 494 | | Some { md_type = module_type } -> fields_of_module_type module_type 495 | end 496 | | _ -> 497 | String_set.empty 498 | 499 | let find_module path env = (Env.find_module path env).md_type 500 | 501 | let names_of_module longident = 502 | try 503 | Longident_map.find longident !local_names_by_longident 504 | with Not_found -> 505 | match lookup_env Env.find_module_by_name longident !Toploop.toplevel_env with 506 | | Some(path, {md_type; _}) -> 507 | let names = names_of_module_type md_type in 508 | local_names_by_path := Path_map.add path names !local_names_by_path; 509 | local_names_by_longident := Longident_map.add longident names !local_names_by_longident; 510 | names 511 | | None -> 512 | local_names_by_longident := Longident_map.add longident String_set.empty !local_names_by_longident; 513 | String_set.empty 514 | 515 | let fields_of_module longident = 516 | try 517 | Longident_map.find longident !local_fields_by_longident 518 | with Not_found -> 519 | match lookup_env Env.find_module_by_name longident !Toploop.toplevel_env with 520 | | Some(path, {md_type; _}) -> 521 | let fields = fields_of_module_type md_type in 522 | local_fields_by_path := Path_map.add path fields !local_fields_by_path; 523 | local_fields_by_longident := Longident_map.add longident fields !local_fields_by_longident; 524 | fields 525 | | None -> 526 | local_fields_by_longident := Longident_map.add longident String_set.empty !local_fields_by_longident; 527 | String_set.empty 528 | 529 | let list_global_names () = 530 | let rec loop acc = function 531 | | Env.Env_empty -> acc 532 | | Env.Env_value_unbound _-> acc 533 | | Env.Env_module_unbound _-> acc 534 | | Env.Env_value(summary, id, _) -> 535 | loop (add (Ident.name id) acc) summary 536 | | Env.Env_type(summary, id, decl) -> 537 | loop (add_names_of_type decl (add (Ident.name id) acc)) summary 538 | | Env.Env_extension(summary, id, _) -> 539 | loop (add (Ident.name id) acc) summary 540 | | Env.Env_module(summary, id, _, _) -> 541 | loop (add (Ident.name id) acc) summary 542 | | Env.Env_modtype(summary, id, _) -> 543 | loop (add (Ident.name id) acc) summary 544 | | Env.Env_class(summary, id, _) -> 545 | loop (add (Ident.name id) acc) summary 546 | | Env.Env_cltype(summary, id, _) -> 547 | loop (add (Ident.name id) acc) summary 548 | | Env.Env_functor_arg(summary, id) -> 549 | loop (add (Ident.name id) acc) summary 550 | | Env.Env_persistent (summary, id) -> 551 | loop (add (Ident.name id) acc) summary 552 | | Env.Env_constraints (summary, _) -> 553 | loop acc summary 554 | | Env.Env_copy_types summary -> 555 | loop acc summary 556 | | Env.Env_open(summary, path) -> 557 | match try Some (Path_map.find path !local_names_by_path) with Not_found -> None with 558 | | Some names -> 559 | loop (String_set.union acc names) summary 560 | | None -> 561 | match lookup_env find_module path !Toploop.toplevel_env with 562 | | Some module_type -> 563 | let names = names_of_module_type module_type in 564 | local_names_by_path := Path_map.add path names !local_names_by_path; 565 | loop (String_set.union acc names) summary 566 | | None -> 567 | local_names_by_path := Path_map.add path String_set.empty !local_names_by_path; 568 | loop acc summary 569 | in 570 | (* Add names of the environment: *) 571 | let acc = loop String_set.empty (Env.summary !Toploop.toplevel_env) in 572 | (* Add accessible modules: *) 573 | String_set.union acc (visible_modules ()) 574 | 575 | let global_names () = get_cached global_names list_global_names 576 | 577 | let replace x y set = 578 | if String_set.mem x set then 579 | String_set.add y (String_set.remove x set) 580 | else 581 | set 582 | 583 | let list_global_fields () = 584 | let rec loop acc = function 585 | | Env.Env_empty -> acc 586 | | Env.Env_value_unbound _-> acc 587 | | Env.Env_module_unbound _-> acc 588 | | Env.Env_value(summary, id, _) -> 589 | loop (add (Ident.name id) acc) summary 590 | | Env.Env_type(summary, id, decl) -> 591 | loop (add_fields_of_type decl (add (Ident.name id) acc)) summary 592 | | Env.Env_extension(summary, id, _) -> 593 | loop (add (Ident.name id) acc) summary 594 | | Env.Env_module(summary, id, _, _) -> 595 | loop (add (Ident.name id) acc) summary 596 | | Env.Env_functor_arg(summary, id) -> 597 | loop (add (Ident.name id) acc) summary 598 | | Env.Env_modtype(summary, id, _) -> 599 | loop (add (Ident.name id) acc) summary 600 | | Env.Env_class(summary, id, _) -> 601 | loop (add (Ident.name id) acc) summary 602 | | Env.Env_cltype(summary, id, _) -> 603 | loop (add (Ident.name id) acc) summary 604 | | Env.Env_persistent (summary, id) -> 605 | loop (add (Ident.name id) acc) summary 606 | | Env.Env_constraints (summary, _) -> 607 | loop acc summary 608 | | Env.Env_copy_types summary -> 609 | loop acc summary 610 | | Env.Env_open(summary, path) -> 611 | match try Some (Path_map.find path !local_fields_by_path) with Not_found -> None with 612 | | Some fields -> 613 | loop (String_set.union acc fields) summary 614 | | None -> 615 | match lookup_env find_module path !Toploop.toplevel_env with 616 | | Some module_type -> 617 | let fields = fields_of_module_type module_type in 618 | local_fields_by_path := Path_map.add path fields !local_fields_by_path; 619 | loop (String_set.union acc fields) summary 620 | | None -> 621 | local_fields_by_path := Path_map.add path String_set.empty !local_fields_by_path; 622 | loop acc summary 623 | in 624 | (* Add fields of the environment: *) 625 | let acc = loop String_set.empty (Env.summary !Toploop.toplevel_env) in 626 | (* Add accessible modules: *) 627 | String_set.union acc (visible_modules ()) 628 | 629 | let global_fields () = get_cached global_fields list_global_fields 630 | 631 | (* +-----------------------------------------------------------------+ 632 | | Listing methods | 633 | +-----------------------------------------------------------------+ *) 634 | 635 | let rec find_method meth type_expr = 636 | match get_desc type_expr with 637 | | Tlink type_expr -> 638 | find_method meth type_expr 639 | | Tobject (type_expr, _) -> 640 | find_method meth type_expr 641 | | Tfield (name, _, type_expr, rest) -> 642 | if name = meth then 643 | Some type_expr 644 | else 645 | find_method meth rest 646 | | Tpoly (type_expr, _) -> 647 | find_method meth type_expr 648 | | Tconstr (path, _, _) -> begin 649 | match lookup_env Env.find_type path !Toploop.toplevel_env with 650 | | None 651 | | Some { type_manifest = None } -> 652 | None 653 | | Some { type_manifest = Some type_expr } -> 654 | find_method meth type_expr 655 | end 656 | | _ -> 657 | None 658 | 659 | let rec methods_of_type acc type_expr = 660 | match get_desc type_expr with 661 | | Tlink type_expr -> 662 | methods_of_type acc type_expr 663 | | Tobject (type_expr, _) -> 664 | methods_of_type acc type_expr 665 | | Tfield (name, _, _, rest) -> 666 | methods_of_type (add name acc) rest 667 | | Tpoly (type_expr, _) -> 668 | methods_of_type acc type_expr 669 | | Tconstr (path, _, _) -> begin 670 | match lookup_env Env.find_type path !Toploop.toplevel_env with 671 | | None 672 | | Some { type_manifest = None } -> 673 | acc 674 | | Some { type_manifest = Some type_expr } -> 675 | methods_of_type acc type_expr 676 | end 677 | | _ -> 678 | acc 679 | 680 | let rec find_object meths type_expr = 681 | match meths with 682 | | [] -> 683 | Some type_expr 684 | | meth :: meths -> 685 | match find_method meth type_expr with 686 | | Some type_expr -> 687 | find_object meths type_expr 688 | | None -> 689 | None 690 | 691 | let methods_of_object longident meths = 692 | match lookup_env Env.find_value_by_name longident !Toploop.toplevel_env with 693 | | None -> 694 | [] 695 | | Some (path, { val_type = type_expr }) -> 696 | match find_object meths type_expr with 697 | | None -> 698 | [] 699 | | Some type_expr -> 700 | String_set.elements (methods_of_type String_set.empty type_expr) 701 | 702 | (* +-----------------------------------------------------------------+ 703 | | Listing labels | 704 | +-----------------------------------------------------------------+ *) 705 | 706 | let rec labels_of_type acc type_expr = 707 | match get_desc type_expr with 708 | | Tlink te -> 709 | labels_of_type acc te 710 | | Tpoly (te, _) -> 711 | labels_of_type acc te 712 | | Tarrow(label, _, te, _) -> 713 | (match label with 714 | | Nolabel -> 715 | labels_of_type acc te 716 | | Optional label -> 717 | labels_of_type (String_map.add label Optional acc) te 718 | | Labelled label -> 719 | labels_of_type (String_map.add label Required acc) te) 720 | | Tconstr(path, _, _) -> begin 721 | match lookup_env Env.find_type path !Toploop.toplevel_env with 722 | | None 723 | | Some { type_manifest = None } -> 724 | String_map.bindings acc 725 | | Some { type_manifest = Some type_expr } -> 726 | labels_of_type acc type_expr 727 | end 728 | | _ -> 729 | String_map.bindings acc 730 | 731 | let labels_of_function longident meths = 732 | match lookup_env Env.find_value_by_name longident !Toploop.toplevel_env with 733 | | None -> 734 | [] 735 | | Some (path, { val_type = type_expr }) -> 736 | match find_object meths type_expr with 737 | | None -> 738 | [] 739 | | Some type_expr -> 740 | labels_of_type String_map.empty type_expr 741 | 742 | let labels_of_newclass longident = 743 | match lookup_env Env.find_class_by_name longident !Toploop.toplevel_env with 744 | | None -> 745 | [] 746 | | Some (path, { cty_new = None }) -> 747 | [] 748 | | Some (path, { cty_new = Some type_expr }) -> 749 | labels_of_type String_map.empty type_expr 750 | 751 | (* +-----------------------------------------------------------------+ 752 | | Tokens processing | 753 | +-----------------------------------------------------------------+ *) 754 | 755 | (* Filter blanks and comments except for the last token. *) 756 | let filter tokens = 757 | let rec aux acc = function 758 | | [] -> acc 759 | | [((Blanks | Comment (_, true)), loc)] -> (Blanks, loc) :: acc 760 | | ((Blanks | Comment (_, true)), _) :: rest -> aux acc rest 761 | | x :: rest -> aux (x :: acc) rest 762 | in 763 | List.rev (aux [] tokens) 764 | 765 | (* Reverse and filter blanks and comments except for the last 766 | token. *) 767 | let rec rev_filter acc tokens = 768 | match tokens with 769 | | [] -> acc 770 | | [((Blanks | Comment (_, true)), loc)] -> (Blanks, loc) :: acc 771 | | ((Blanks | Comment (_, true)), _) :: rest -> rev_filter acc rest 772 | | x :: rest -> rev_filter (x :: acc) rest 773 | 774 | (* Find the current context. *) 775 | let rec find_context tokens = function 776 | | [] -> 777 | Some (rev_filter [] tokens) 778 | | [(Quotation (items, false), _)] -> 779 | find_context_in_quotation items 780 | | _ :: rest -> 781 | find_context tokens rest 782 | 783 | and find_context_in_quotation = function 784 | | [] -> 785 | None 786 | | [(Quot_anti { a_closing = None; a_contents = tokens }, _)] -> 787 | find_context tokens tokens 788 | | _ :: rest -> 789 | find_context_in_quotation rest 790 | 791 | (* +-----------------------------------------------------------------+ 792 | | Completion | 793 | +-----------------------------------------------------------------+ *) 794 | 795 | let complete ~phrase_terminator ~input = 796 | let true_name, false_name = ("true", "false") in 797 | let tokens = UTop_lexer.lex_string input in 798 | (* Filter blanks and comments. *) 799 | let tokens = filter tokens in 800 | match tokens with 801 | 802 | (* Completion on directive names. *) 803 | | [(Symbol "#", { idx2 = stop })] 804 | | [(Symbol "#", _); (Blanks, { idx2 = stop })] -> 805 | (stop, list_directives phrase_terminator) 806 | | [(Symbol "#", _); ((Lident src | Uident src), { idx1 = start })] -> 807 | (start, lookup_assoc src (list_directives phrase_terminator)) 808 | 809 | (* Complete with ";;" when possible. *) 810 | | [(Symbol "#", _); ((Lident _ | Uident _), _); (String (_, true), { idx2 = stop })] 811 | | [(Symbol "#", _); ((Lident _ | Uident _), _); (String (_, true), _); (Blanks, { idx2 = stop })] -> 812 | (stop, [(phrase_terminator, "")]) 813 | | [(Symbol "#", _); ((Lident _ | Uident _), _); (String (_, true), _); (Symbol sym, { idx1 = start })] -> 814 | if Zed_utf8.starts_with phrase_terminator sym then 815 | (start, [(phrase_terminator, "")]) 816 | else 817 | (0, []) 818 | 819 | (* Completion on #require. *) 820 | | [(Symbol "#", _); (Lident "require", _); (String (tlen, false), loc)] -> 821 | let pkg = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in 822 | let pkgs = lookup pkg (Fl_package_base.list_packages ()) in 823 | (loc.idx1 + 1, List.map (fun pkg -> (pkg, "\"" ^ phrase_terminator)) (List.sort compare pkgs)) 824 | 825 | | [(Symbol "#", _); (Lident "typeof", _); (String (tlen, false), loc)] -> 826 | let prefix = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in 827 | begin match Parse.longident (Lexing.from_string prefix) with 828 | | Longident.Ldot (lident, last_prefix) -> 829 | let set = names_of_module lident in 830 | let compls = lookup last_prefix (String_set.elements set) in 831 | let start = loc.idx1 + 1 + (String.length prefix - String.length last_prefix) in 832 | (start, List.map (fun w -> (w, "")) compls) 833 | | _ -> 834 | let set = global_names () in 835 | let compls = lookup prefix (String_set.elements set) in 836 | (loc.idx1 + 1, List.map (fun w -> (w, "")) compls) 837 | end 838 | 839 | (* Completion on #load. *) 840 | | [(Symbol "#", _); (Lident ("load" | "load_rec"), _); (String (tlen, false), loc)] -> 841 | let file = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in 842 | let filter name = Filename.check_suffix name ".cma" || Filename.check_suffix name ".cmo" in 843 | let map = 844 | if Filename.is_relative file then 845 | let dir = Filename.dirname file in 846 | List.fold_left 847 | (fun acc d -> add_files filter acc (Filename.concat d dir)) 848 | String_map.empty 849 | (Filename.current_dir_name :: 850 | (UTop_compat.get_load_path ()) 851 | ) 852 | 853 | else 854 | add_files filter String_map.empty (Filename.dirname file) 855 | in 856 | let list = String_map.bindings map in 857 | let name = basename file in 858 | let result = lookup_assoc name list in 859 | (loc.idx2 - Zed_utf8.length name, 860 | List.map (function (w, Directory) -> (w, "") | (w, File) -> (w, "\"" ^ phrase_terminator)) result) 861 | 862 | (* Completion on #ppx. *) 863 | | [(Symbol "#", _); (Lident ("ppx"), _); (String (tlen, false), loc)] -> 864 | let file = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in 865 | let filter ~dir_ok name = 866 | try 867 | Unix.access name [Unix.X_OK]; 868 | let kind = (Unix.stat name).Unix.st_kind in 869 | let basename = Filename.basename name in 870 | (kind = Unix.S_REG && String.length basename >= 4 && 871 | String.sub basename 0 4 = "ppx_") || 872 | (dir_ok && kind = Unix.S_DIR) 873 | with Unix.Unix_error _ -> false 874 | in 875 | let map = 876 | if Filename.dirname file = "." && not (Filename.is_implicit file) then 877 | let dir = Filename.dirname file in 878 | add_files (filter ~dir_ok:true) String_map.empty dir 879 | else 880 | List.fold_left 881 | (fun acc dir -> add_files (fun name -> 882 | filter ~dir_ok:false (Filename.concat dir name)) acc dir) 883 | String_map.empty (path ()) 884 | in 885 | let list = String_map.bindings map in 886 | let name = basename file in 887 | let result = lookup_assoc name list in 888 | (loc.idx2 - Zed_utf8.length name, 889 | List.map (function (w, Directory) -> (w, "") | (w, File) -> (w, "\"" ^ phrase_terminator)) result) 890 | 891 | (* Completion on #use and #mod_use *) 892 | | [(Symbol "#", _); (Lident "use", _); (String (tlen, false), loc)] 893 | | [(Symbol "#", _); (Lident "mod_use", _); (String (tlen, false), loc)] -> 894 | let file = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in 895 | let filter name = 896 | match try Some (String.rindex name '.') with Not_found -> None with 897 | | None -> 898 | true 899 | | Some idx -> 900 | let ext = String.sub name (idx + 1) (String.length name - (idx + 1)) in 901 | ext = "ml" 902 | in 903 | let map = 904 | if Filename.is_relative file then 905 | let dir = Filename.dirname file in 906 | List.fold_left 907 | (fun acc d -> add_files filter acc (Filename.concat d dir)) 908 | String_map.empty 909 | (Filename.current_dir_name :: 910 | (UTop_compat.get_load_path ()) 911 | ) 912 | else 913 | add_files filter String_map.empty (Filename.dirname file) 914 | in 915 | let list = String_map.bindings map in 916 | let name = basename file in 917 | let result = lookup_assoc name list in 918 | (loc.idx2 - Zed_utf8.length name, 919 | List.map (function (w, Directory) -> (w, "") | (w, File) -> (w, "\"" ^ phrase_terminator)) result) 920 | 921 | (* Completion on #directory and #cd. *) 922 | | [(Symbol "#", _); (Lident ("cd" | "directory"), _); (String (tlen, false), loc)] -> 923 | let file = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in 924 | let list = list_directories (Filename.dirname file) in 925 | let name = basename file in 926 | let result = lookup name list in 927 | (loc.idx2 - Zed_utf8.length name, List.map (function dir -> (dir, "")) result) 928 | 929 | (* Generic completion on directives. *) 930 | | [(Symbol "#", _); ((Lident dir | Uident dir), _); (Blanks, { idx2 = stop })] -> 931 | (stop, 932 | match toploop_get_directive dir with 933 | | Some (Toploop.Directive_none _) -> [(phrase_terminator, "")] 934 | | Some (Toploop.Directive_string _) -> [(" \"", "")] 935 | | Some (Toploop.Directive_bool _) -> [(true_name, phrase_terminator); (false_name, phrase_terminator)] 936 | | Some (Toploop.Directive_int _) -> [] 937 | | Some (Toploop.Directive_ident _) -> List.map (fun w -> (w, "")) (String_set.elements (global_names ())) 938 | | None -> []) 939 | | (Symbol "#", _) :: ((Lident dir | Uident dir), _) :: tokens -> begin 940 | match toploop_get_directive dir with 941 | | Some (Toploop.Directive_none _) -> 942 | (0, []) 943 | | Some (Toploop.Directive_string _) -> 944 | (0, []) 945 | | Some (Toploop.Directive_bool _) -> begin 946 | match tokens with 947 | | [(Lident id, { idx1 = start })] -> 948 | (start, lookup_assoc id [(true_name, phrase_terminator); (false_name, phrase_terminator)]) 949 | | _ -> 950 | (0, []) 951 | end 952 | | Some (Toploop.Directive_int _) -> 953 | (0, []) 954 | | Some (Toploop.Directive_ident _) -> begin 955 | match parse_longident (List.rev tokens) with 956 | | Some (Value, None, start, id) -> 957 | (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (global_names ())))) 958 | | Some (Value, Some longident, start, id) -> 959 | (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (names_of_module longident)))) 960 | | _ -> 961 | (0, []) 962 | end 963 | | None -> 964 | (0, []) 965 | end 966 | 967 | (* Completion on identifiers. *) 968 | | _ -> 969 | match find_context tokens tokens with 970 | | None -> 971 | (0, []) 972 | | Some [] -> 973 | (0, List.map (fun w -> (w, "")) (String_set.elements (String_set.union !UTop.keywords (global_names ())))) 974 | | Some tokens -> 975 | match parse_method tokens with 976 | | Some (longident, meths, start, meth) -> 977 | (start, List.map (fun w -> (w, "")) (lookup meth (methods_of_object longident meths))) 978 | | None -> 979 | match parse_label tokens with 980 | | Some (Fun, longident, meths, Optional, start, label) -> 981 | (start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (List.filter (function (w, Optional) -> true | (w, Required) -> false) (labels_of_function longident meths)))) 982 | | Some (Fun, longident, meths, Required, start, label) -> 983 | (start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (labels_of_function longident meths))) 984 | | Some (New, longident, meths, Optional, start, label) -> 985 | (start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (List.filter (function (w, Optional) -> true | (w, Required) -> false) (labels_of_newclass longident)))) 986 | | Some (New, longident, meths, Required, start, label) -> 987 | (start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (labels_of_newclass longident))) 988 | | None -> 989 | match parse_longident tokens with 990 | | None -> 991 | (0, []) 992 | | Some (Value, None, start, id) -> 993 | (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (String_set.union !UTop.keywords (global_names ()))))) 994 | | Some (Value, Some longident, start, id) -> 995 | (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (names_of_module longident)))) 996 | | Some (Field, None, start, id) -> 997 | (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (global_fields ())))) 998 | | Some (Field, Some longident, start, id) -> 999 | (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (fields_of_module longident)))) 1000 | 1001 | let complete ~phrase_terminator ~input = 1002 | try 1003 | (complete ~phrase_terminator ~input : int * (string * string) list) 1004 | with Cmi_format.Error _ -> 1005 | (0, []) 1006 | -------------------------------------------------------------------------------- /src/lib/uTop_complete.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * uTop_complete.mli 3 | * ----------------- 4 | * Copyright : (c) 2011, Jeremie Dimino 5 | * Licence : BSD3 6 | * 7 | * This file is a part of utop. 8 | *) 9 | 10 | (** OCaml completion. *) 11 | 12 | val complete : phrase_terminator : string -> input : string -> int * (string * string) list 13 | (** [complete ~phrase_terminator ~input] returns the start 14 | of the completed word in [input] and the list of possible 15 | completions with their suffixes. *) 16 | 17 | val reset : unit -> unit 18 | (** Reset global cache. It must be called before each interactive 19 | read line. *) 20 | -------------------------------------------------------------------------------- /src/lib/uTop_history.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * uTop_history.ml 3 | * ----------------- 4 | * Copyright : (c) 2017, Fabian Hemmer 5 | * Licence : BSD3 6 | * 7 | * This file is a part of utop. 8 | *) 9 | 10 | type entry = 11 | | Input of string 12 | | Output of string 13 | | Error of string 14 | | Warnings of string 15 | | Bad_input of string 16 | and t = entry list ref 17 | 18 | let create () : t = 19 | ref [] 20 | 21 | let contents (t : t) = 22 | !t 23 | 24 | let strip_colors s = 25 | let len = String.length s in 26 | let find_escape offset = 27 | try 28 | let i = String.index_from s offset '\027' in 29 | if i = len - 1 || s.[i + 1] <> '[' then 30 | None 31 | else 32 | Some i 33 | with 34 | | Not_found -> None 35 | in 36 | let find_color_escapes offset = 37 | let rec aux acc offset = 38 | match find_escape offset with 39 | | None -> (offset, len) :: acc 40 | | Some esc_offset -> 41 | try 42 | let i = String.index_from s esc_offset 'm' in 43 | aux ((offset, esc_offset) :: acc) (i + 1) 44 | with 45 | | Not_found -> (offset, len) :: acc 46 | in 47 | aux [] offset 48 | in 49 | find_color_escapes 0 50 | |> List.rev_map (fun (i, j) -> String.sub s i (j - i)) 51 | |> String.concat "" 52 | 53 | let add history v = 54 | history := v :: !history 55 | 56 | let add_input history input = 57 | add history @@ Input (String.trim input) 58 | 59 | let add_output history output = 60 | let output = String.trim output in 61 | if output <> "" then (* directives produce empty output *) 62 | add history @@ Output output 63 | 64 | let add_error history error = 65 | add history @@ Error (strip_colors @@ String.trim error) 66 | 67 | let add_bad_input history input = 68 | add history @@ Bad_input (String.trim input) 69 | 70 | let add_warnings history warnings = 71 | let warnings = String.trim warnings in 72 | if warnings <> "" then 73 | add history @@ Warnings warnings 74 | -------------------------------------------------------------------------------- /src/lib/uTop_history.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * uTop_history.mli 3 | * ------- 4 | * Copyright : (c) 2017, Fabian Hemmer 5 | * Licence : BSD3 6 | * 7 | * This file is a part of utop. 8 | *) 9 | 10 | 11 | (** Type of a history entry *) 12 | type entry = 13 | | Input of string 14 | | Output of string 15 | | Error of string 16 | | Warnings of string 17 | | Bad_input of string 18 | 19 | type t 20 | 21 | val create : unit -> t 22 | (** Create a new, empty history *) 23 | 24 | val contents : t -> entry list 25 | (** Get the contents of the given history *) 26 | 27 | val add_input : t -> string -> unit 28 | (** Add an input *) 29 | 30 | val add_output : t -> string -> unit 31 | (** Add an output *) 32 | 33 | val add_error : t -> string -> unit 34 | (** Add an error *) 35 | 36 | val add_warnings : t -> string -> unit 37 | (** Add a warning *) 38 | 39 | val add_bad_input : t -> string -> unit 40 | (** Add an input that resulted in an error *) 41 | -------------------------------------------------------------------------------- /src/lib/uTop_lexer.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * uTop_lexer.mli 3 | * -------------- 4 | * Copyright : (c) 2012, Jeremie Dimino 5 | * Licence : BSD3 6 | * 7 | * This file is a part of utop. 8 | *) 9 | 10 | val lex_string : string -> (UTop_token.t * UTop_token.location) list 11 | (** [lex_string str] returns all the tokens contained in 12 | [str]. *) 13 | -------------------------------------------------------------------------------- /src/lib/uTop_lexer.mll: -------------------------------------------------------------------------------- 1 | (* 2 | * uTop_lexer.mll 3 | * -------------- 4 | * Copyright : (c) 2011, Jeremie Dimino 5 | * Licence : BSD3 6 | * 7 | * This file is a part of utop. 8 | *) 9 | 10 | (* Lexer for the OCaml language. *) 11 | 12 | { 13 | open Lexing 14 | open UTop_token 15 | 16 | let mkloc idx1 idx2 ofs1 ofs2 = { 17 | idx1 = idx1; 18 | idx2 = idx2; 19 | ofs1 = ofs1; 20 | ofs2 = ofs2; 21 | } 22 | 23 | (* Only for ascii-only lexemes. *) 24 | let lexeme_loc idx lexbuf = 25 | let ofs1 = lexeme_start lexbuf and ofs2 = lexeme_end lexbuf in 26 | { 27 | idx1 = idx; 28 | idx2 = idx + (ofs2 - ofs1); 29 | ofs1 = ofs1; 30 | ofs2 = ofs2; 31 | } 32 | 33 | let _merge_loc l1 l2 = { 34 | idx1 = l1.idx1; 35 | idx2 = l2.idx2; 36 | ofs1 = l1.ofs1; 37 | ofs2 = l2.ofs2; 38 | } 39 | 40 | } 41 | 42 | let uchar = ['\x00' - '\x7f'] | _ [ '\x80' - '\xbf' ]* 43 | 44 | let blank = [' ' '\009' '\012'] 45 | let lowercase = ['a'-'z' '_'] 46 | let uppercase = ['A'-'Z'] 47 | let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9'] 48 | let lident = lowercase identchar* 49 | let uident = uppercase identchar* 50 | let ident = (lowercase|uppercase) identchar* 51 | 52 | let hexa_char = ['0'-'9' 'A'-'F' 'a'-'f'] 53 | let decimal_literal = 54 | ['0'-'9'] ['0'-'9' '_']* 55 | let hex_literal = 56 | '0' ['x' 'X'] hexa_char ['0'-'9' 'A'-'F' 'a'-'f' '_']* 57 | let oct_literal = 58 | '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']* 59 | let bin_literal = 60 | '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']* 61 | let int_literal = 62 | decimal_literal | hex_literal | oct_literal | bin_literal 63 | let float_literal = 64 | ['0'-'9'] ['0'-'9' '_']* 65 | ('.' ['0'-'9' '_']* )? 66 | (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? 67 | 68 | let symbolchar = 69 | ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] 70 | 71 | rule tokens idx acc = parse 72 | | eof 73 | { (idx, None, List.rev acc) } 74 | | ('\n' | blank)+ 75 | { let loc = lexeme_loc idx lexbuf in 76 | tokens loc.idx2 ((Blanks, loc) :: acc) lexbuf } 77 | | lident 78 | { let src = lexeme lexbuf in 79 | let loc = lexeme_loc idx lexbuf in 80 | let tok = 81 | match src with 82 | | ("true" | "false") -> 83 | Constant src 84 | | _ -> 85 | Lident src 86 | in 87 | tokens loc.idx2 ((tok, loc) :: acc) lexbuf } 88 | | uident 89 | { let src = lexeme lexbuf in 90 | let loc = lexeme_loc idx lexbuf in 91 | let tok = Uident src in 92 | tokens loc.idx2 ((tok, loc) :: acc) lexbuf } 93 | | int_literal "l" 94 | | int_literal "L" 95 | | int_literal "n" 96 | | int_literal 97 | | float_literal 98 | { let loc = lexeme_loc idx lexbuf in 99 | let tok = Constant (lexeme lexbuf) in 100 | tokens loc.idx2 ((tok, loc) :: acc) lexbuf } 101 | | '"' 102 | { let ofs = lexeme_start lexbuf in 103 | let item, idx2= cm_string (idx + 1) lexbuf in 104 | let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in 105 | tokens idx2 ((item, loc) :: acc) lexbuf } 106 | | '{' (lowercase* as tag) '|' 107 | { let ofs = lexeme_start lexbuf in 108 | let delim_len = String.length tag + 2 in 109 | let idx2, terminated = quoted_string (idx + delim_len) tag false lexbuf in 110 | let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in 111 | tokens idx2 ((String (delim_len, terminated), loc) :: acc) lexbuf } 112 | | "'" [^'\'' '\\'] "'" 113 | | "'\\" ['\\' '"' 'n' 't' 'b' 'r' ' ' '\'' 'x' '0'-'9'] eof 114 | | "'\\" ['\\' '"' 'n' 't' 'b' 'r' ' ' '\''] "'" 115 | | "'\\" (['0'-'9'] ['0'-'9'] | 'x' hexa_char) eof 116 | | "'\\" (['0'-'9'] ['0'-'9'] ['0'-'9'] | 'x' hexa_char hexa_char) eof 117 | | "'\\" (['0'-'9'] ['0'-'9'] ['0'-'9'] | 'x' hexa_char hexa_char) "'" 118 | { let loc = lexeme_loc idx lexbuf in 119 | tokens loc.idx2 ((Char, loc) :: acc) lexbuf } 120 | | "'\\" uchar 121 | { let loc = mkloc idx (idx + 3) (lexeme_start lexbuf) (lexeme_end lexbuf) in 122 | tokens loc.idx2 ((Error, loc) :: acc) lexbuf } 123 | | "(*)" 124 | { let loc = lexeme_loc idx lexbuf in 125 | tokens loc.idx2 ((Comment (Comment_reg, true), loc) :: acc) lexbuf } 126 | | "(**)" 127 | { let loc = lexeme_loc idx lexbuf in 128 | tokens loc.idx2 ((Comment (Comment_doc, true), loc) :: acc) lexbuf } 129 | | "(**" 130 | { let ofs = lexeme_start lexbuf in 131 | let idx2, terminated = comment (idx + 3) 0 false lexbuf in 132 | let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in 133 | tokens idx2 ((Comment (Comment_doc, terminated), loc) :: acc) lexbuf } 134 | | "(*" 135 | { let ofs = lexeme_start lexbuf in 136 | let idx2, terminated = comment (idx + 2) 0 false lexbuf in 137 | let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in 138 | tokens idx2 ((Comment (Comment_reg, terminated), loc) :: acc) lexbuf } 139 | | "" 140 | { symbol idx acc lexbuf } 141 | 142 | and symbol idx acc = parse 143 | | "(" | ")" 144 | | "[" | "]" 145 | | "{" | "}" 146 | | "`" 147 | | "#" 148 | | "," 149 | | ";" | ";;" 150 | | symbolchar+ 151 | { let loc = lexeme_loc idx lexbuf in 152 | let tok = Symbol (lexeme lexbuf) in 153 | tokens loc.idx2 ((tok, loc) :: acc) lexbuf } 154 | | uchar as uchar 155 | { let uChar= Zed_utf8.unsafe_extract uchar 0 in 156 | if Zed_char.is_combining_mark uChar then 157 | let tok, loc= List.hd acc 158 | and tl= List.tl acc in 159 | let tok= match tok with 160 | | Symbol str-> Symbol (str ^ (lexeme lexbuf)) 161 | | Lident str-> Lident (str ^ (lexeme lexbuf)) 162 | | Uident str-> Uident (str ^ (lexeme lexbuf)) 163 | | Constant str-> Constant (str ^ (lexeme lexbuf)) 164 | | _-> tok 165 | in 166 | let loc= { loc with ofs2= lexeme_end lexbuf } in 167 | tokens loc.idx2 ((tok, loc) :: tl) lexbuf 168 | else 169 | let loc = mkloc idx (idx + 1) (lexeme_start lexbuf) (lexeme_end lexbuf) in 170 | tokens loc.idx2 ((Error, loc) :: acc) lexbuf 171 | } 172 | 173 | and cm_string idx= parse 174 | | '"' 175 | { (String (1, true), idx+1) } 176 | | "\\\\" 177 | | "\\\"" 178 | { let idx2, terminated= string (idx + 2) false lexbuf in 179 | (String (1, terminated), idx2) 180 | } 181 | | uchar as uchar 182 | { 183 | let uChar= Zed_utf8.unsafe_extract uchar 0 in 184 | if Zed_char.is_combining_mark uChar then 185 | cm_string idx lexbuf 186 | else 187 | let idx2, terminated= string (idx + 1) true lexbuf in 188 | (String (1, terminated), idx2) 189 | } 190 | | eof 191 | { (String (1, false), idx) } 192 | 193 | and comment idx depth combining= parse 194 | | "(*" 195 | { comment (idx + 2) (depth + 1) false lexbuf } 196 | | "*)" 197 | { if depth = 0 then 198 | (idx + 2, true) 199 | else 200 | comment (idx + 2) (depth - 1) false lexbuf } 201 | | '"' 202 | { let idx, terminated = string (idx + 1) false lexbuf in 203 | if terminated then 204 | comment idx depth false lexbuf 205 | else 206 | (idx, false) } 207 | | uchar as uchar 208 | { let uChar= Zed_utf8.unsafe_extract uchar 0 in 209 | if not combining then 210 | if Zed_char.is_combining_mark uChar then 211 | comment (idx + 1) depth false lexbuf 212 | else 213 | comment (idx + 1) depth true lexbuf 214 | else 215 | if Zed_char.is_combining_mark uChar then 216 | comment idx depth true lexbuf 217 | else 218 | comment (idx + 1) depth true lexbuf 219 | } 220 | | eof 221 | { (idx, false) } 222 | 223 | and string idx combining= parse 224 | | '"' 225 | { (idx + 1, true) } 226 | | "\\\\" 227 | | "\\\"" 228 | { string (idx + 2) false lexbuf } 229 | | uchar as uchar 230 | { let uChar= Zed_utf8.unsafe_extract uchar 0 in 231 | if not combining then 232 | if Zed_char.is_combining_mark uChar then 233 | string (idx + 1) false lexbuf 234 | else 235 | string (idx + 1) true lexbuf 236 | else 237 | if Zed_char.is_combining_mark uChar then 238 | string idx true lexbuf 239 | else 240 | string (idx + 1) true lexbuf 241 | } 242 | | eof 243 | { (idx, false) } 244 | 245 | and quoted_string idx tag combining= parse 246 | | '|' (lowercase* as tag2) '}' 247 | { let idx = idx + 2 + String.length tag2 in 248 | if tag = tag2 then 249 | (idx, true) 250 | else 251 | quoted_string idx tag false lexbuf } 252 | | eof 253 | { (idx, false) } 254 | | uchar as uchar 255 | { let uChar= Zed_utf8.unsafe_extract uchar 0 in 256 | if not combining then 257 | if Zed_char.is_combining_mark uChar then 258 | quoted_string (idx + 1) tag false lexbuf 259 | else 260 | quoted_string (idx + 1) tag true lexbuf 261 | else 262 | if Zed_char.is_combining_mark uChar then 263 | quoted_string idx tag true lexbuf 264 | else 265 | quoted_string (idx + 1) tag true lexbuf 266 | } 267 | 268 | { 269 | let lex_string str = 270 | let _, _, items = tokens 0 [] (Lexing.from_string str) in 271 | items 272 | } 273 | -------------------------------------------------------------------------------- /src/lib/uTop_main.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * uTop_main.mli 3 | * ------------- 4 | * Copyright : (c) 2012, Jeremie Dimino 5 | * Licence : BSD3 6 | * 7 | * This file is a part of utop. 8 | *) 9 | 10 | val main : unit -> unit 11 | (** Start utop. *) 12 | 13 | exception Term of int 14 | (** Exception raised when a signal that should terminate the process 15 | is received. The argument is the signal number. 16 | 17 | utop raises this exception for SIGHUP and SIGTERM by default. *) 18 | 19 | type value = V : string * _ -> value 20 | 21 | val interact 22 | : ?search_path:string list 23 | -> ?build_dir:string 24 | -> unit:string 25 | -> loc:(string * int * int * int) 26 | -> values:value list 27 | -> unit 28 | -> unit 29 | -------------------------------------------------------------------------------- /src/lib/uTop_private.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * uTop_private.ml 3 | * --------------- 4 | * Copyright : (c) 2011, Jeremie Dimino 5 | * Licence : BSD3 6 | * 7 | * This file is a part of utop. 8 | *) 9 | 10 | open Lwt_react 11 | 12 | module Default_paths = struct 13 | let ( / ) = Filename.concat 14 | let xdg = Xdg.create ~env:Sys.getenv_opt () 15 | 16 | let resolve ~legacy ~filename = 17 | if Sys.file_exists legacy then 18 | legacy 19 | else 20 | filename 21 | 22 | let history_file_name = 23 | resolve 24 | ~legacy:(LTerm_resources.home / ".utop-history") 25 | ~filename:(Xdg.state_dir xdg / "utop-history") 26 | 27 | let config_file_name = 28 | resolve 29 | ~legacy:(LTerm_resources.home / ".utoprc") 30 | ~filename:(Xdg.config_dir xdg / "utoprc") 31 | end 32 | 33 | let size, set_size = 34 | let ev, set_size = E.create () in 35 | let init = S.const { LTerm_geom.rows = 25; LTerm_geom.cols = 80 } in 36 | (S.switch (S.hold ~eq:( == ) init ev), set_size) 37 | 38 | let key_sequence, set_key_sequence = 39 | let ev, set_key_sequence = E.create () in 40 | let init = (S.const ([] : LTerm_key.t list)) in 41 | (S.switch (S.hold ~eq:( == ) init ev), set_key_sequence) 42 | 43 | let count, set_count = S.create (-1) 44 | 45 | type ui = Console | Emacs 46 | 47 | let ui, set_ui = S.create Console 48 | 49 | let error_style = ref LTerm_style.none 50 | 51 | (* Config from $XDG_CONFIG_HOME/utop/utoprc *) 52 | let autoload = ref true 53 | 54 | let margin_function, set_margin_function = 55 | S.create ~eq:( == ) (fun (size : LTerm_geom.size) -> Some (min 80 size.cols)) 56 | 57 | let margin = S.app margin_function size 58 | 59 | let set_margin pp = 60 | match S.value margin with 61 | | None -> () 62 | | Some n -> if Format.pp_get_margin pp () <> n then Format.pp_set_margin pp n 63 | -------------------------------------------------------------------------------- /src/lib/uTop_styles.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * uTop_styles.ml 3 | * -------------- 4 | * Copyright : (c) 2011, Jeremie Dimino 5 | * Licence : BSD3 6 | * 7 | * This file is a part of utop. 8 | *) 9 | 10 | open UTop_token 11 | 12 | let return, (>>=) = Lwt.return, Lwt.(>>=) 13 | 14 | module String_set = Set.Make (String) 15 | module Default_paths = UTop_private.Default_paths 16 | 17 | type styles = { 18 | mutable style_keyword : LTerm_style.t; 19 | mutable style_symbol : LTerm_style.t; 20 | mutable style_ident : LTerm_style.t; 21 | mutable style_module : LTerm_style.t; 22 | mutable style_constant : LTerm_style.t; 23 | mutable style_char : LTerm_style.t; 24 | mutable style_string : LTerm_style.t; 25 | mutable style_quotation : LTerm_style.t; 26 | mutable style_comment : LTerm_style.t; 27 | mutable style_doc : LTerm_style.t; 28 | mutable style_blanks : LTerm_style.t; 29 | mutable style_error : LTerm_style.t; 30 | mutable style_directive : LTerm_style.t; 31 | mutable style_paren : LTerm_style.t; 32 | mutable style_font : string option; 33 | mutable style_foreground : LTerm_style.color option; 34 | mutable style_background : LTerm_style.color option; 35 | mutable style_cursor : LTerm_style.color option; 36 | } 37 | 38 | let styles = { 39 | style_keyword = LTerm_style.none; 40 | style_symbol = LTerm_style.none; 41 | style_ident = LTerm_style.none; 42 | style_module = LTerm_style.none; 43 | style_constant = LTerm_style.none; 44 | style_char = LTerm_style.none; 45 | style_string = LTerm_style.none; 46 | style_quotation = LTerm_style.none; 47 | style_comment = LTerm_style.none; 48 | style_doc = LTerm_style.none; 49 | style_blanks = LTerm_style.none; 50 | style_error = LTerm_style.none; 51 | style_directive = LTerm_style.none; 52 | style_paren = LTerm_style.none; 53 | style_font = None; 54 | style_foreground = None; 55 | style_background = None; 56 | style_cursor = None; 57 | } 58 | 59 | let load () = 60 | let fn = Default_paths.config_file_name in 61 | Lwt.catch 62 | (fun () -> 63 | LTerm_resources.load fn >>= fun res -> 64 | styles.style_keyword <- LTerm_resources.get_style "keyword" res; 65 | styles.style_symbol <- LTerm_resources.get_style "symbol" res; 66 | styles.style_ident <- LTerm_resources.get_style "identifier" res; 67 | styles.style_module <- LTerm_resources.get_style "module" res; 68 | styles.style_constant <- LTerm_resources.get_style "constant" res; 69 | styles.style_char <- LTerm_resources.get_style "char" res; 70 | styles.style_string <- LTerm_resources.get_style "string" res; 71 | styles.style_quotation <- LTerm_resources.get_style "quotation" res; 72 | styles.style_comment <- LTerm_resources.get_style "comment" res; 73 | styles.style_doc <- LTerm_resources.get_style "doc" res; 74 | styles.style_blanks <- LTerm_resources.get_style "blanks" res; 75 | styles.style_error <- LTerm_resources.get_style "error" res; 76 | styles.style_directive <- LTerm_resources.get_style "directive" res; 77 | styles.style_paren <- LTerm_resources.get_style "parenthesis" res; 78 | styles.style_font <- (match LTerm_resources.get "font" res with 79 | | "" -> None 80 | | str -> Some str); 81 | styles.style_foreground <- LTerm_resources.get_color "foreground" res; 82 | styles.style_background <- LTerm_resources.get_color "background" res; 83 | styles.style_cursor <- LTerm_resources.get_color "cursor" res; 84 | (match String.lowercase_ascii (LTerm_resources.get "profile" res) with 85 | | "light" -> UTop.set_profile UTop.Light 86 | | "dark" -> UTop.set_profile UTop.Dark 87 | | "" -> () 88 | | str -> raise (LTerm_resources.Error (Printf.sprintf "invalid profile %S" str))); 89 | UTop_private.error_style := styles.style_error; 90 | UTop_private.autoload := LTerm_resources.get_bool "autoload" res <> Some false; 91 | (match LTerm_resources.get "external-editor" res with 92 | | "" -> () 93 | | s -> UTop.set_external_editor s); 94 | return ()) 95 | (function 96 | | Unix.Unix_error(Unix.ENOENT, _, _) -> 97 | return () 98 | | Unix.Unix_error (error, func, _arg) -> 99 | Logs_lwt.err (fun m -> m "cannot load styles from %S: %s: %s" fn func (Unix.error_message error)) 100 | | exn -> Lwt.fail exn) 101 | 102 | let stylise_filter_layout stylise tokens = 103 | let aux acc = function 104 | | (Comment (Comment_reg, _), loc) -> 105 | stylise loc styles.style_comment; 106 | acc 107 | | (Comment (Comment_doc, _), loc) -> 108 | stylise loc styles.style_doc; 109 | acc 110 | | (Blanks, loc) -> 111 | stylise loc styles.style_blanks; 112 | acc 113 | | x -> x :: acc 114 | in 115 | List.rev (List.fold_left aux [] tokens) 116 | 117 | let rec stylise_rec stylise tokens = 118 | match tokens with 119 | | [] -> 120 | () 121 | | (Symbol _, loc) :: tokens -> 122 | stylise loc styles.style_symbol; 123 | stylise_rec stylise tokens 124 | | (Lident id, loc) :: tokens -> 125 | stylise loc 126 | (if String_set.mem id !UTop.keywords then 127 | styles.style_keyword 128 | else 129 | styles.style_ident); 130 | stylise_rec stylise tokens 131 | | (Uident id, loc) :: tokens when String_set.mem id !UTop.keywords -> 132 | stylise loc styles.style_keyword; 133 | stylise_rec stylise tokens 134 | | (Uident _id, loc1) :: (Symbol ".", loc2) :: tokens -> 135 | stylise loc1 styles.style_module; 136 | stylise loc2 styles.style_symbol; 137 | stylise_rec stylise tokens 138 | | (Uident _id, loc) :: tokens -> 139 | stylise loc styles.style_ident; 140 | stylise_rec stylise tokens 141 | | (Constant _, loc) :: tokens -> 142 | stylise loc styles.style_constant; 143 | stylise_rec stylise tokens 144 | | (Char, loc) :: tokens -> 145 | stylise loc styles.style_char; 146 | stylise_rec stylise tokens 147 | | (String _, loc) :: tokens -> 148 | stylise loc styles.style_string; 149 | stylise_rec stylise tokens 150 | | (Quotation (items, _), _) :: tokens -> 151 | stylise_quotation_items stylise items; 152 | stylise_rec stylise tokens 153 | | (Error, loc) :: tokens -> 154 | stylise loc styles.style_error; 155 | stylise_rec stylise tokens 156 | | ((Comment _ | Blanks), _) :: _ -> 157 | assert false 158 | 159 | and stylise_quotation_items stylise items = 160 | match items with 161 | | [] -> 162 | () 163 | | (Quot_data, loc) :: items -> 164 | stylise loc styles.style_quotation; 165 | stylise_quotation_items stylise items 166 | | (Quot_anti anti, _) :: items -> 167 | stylise anti.a_opening styles.style_symbol; 168 | (match anti.a_name with 169 | | None -> 170 | () 171 | | Some (loc1, loc2) -> 172 | stylise loc1 styles.style_module; 173 | stylise loc2 styles.style_symbol); 174 | let tokens = stylise_filter_layout stylise anti.a_contents in 175 | stylise_rec stylise tokens; 176 | (match anti.a_closing with 177 | | None -> 178 | () 179 | | Some loc -> 180 | stylise loc styles.style_symbol); 181 | stylise_quotation_items stylise items 182 | 183 | let stylise stylise tokens = 184 | let tokens = stylise_filter_layout stylise tokens in 185 | match tokens with 186 | | (Symbol "#", loc) :: tokens -> begin 187 | stylise loc styles.style_directive; 188 | match tokens with 189 | | ((Lident id | Uident id), loc) :: tokens -> 190 | stylise loc 191 | (if String_set.mem id !UTop.keywords then 192 | styles.style_keyword 193 | else 194 | styles.style_directive); 195 | stylise_rec stylise tokens 196 | | tokens -> 197 | stylise_rec stylise tokens 198 | end 199 | | tokens -> 200 | stylise_rec stylise tokens 201 | -------------------------------------------------------------------------------- /src/lib/uTop_styles.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * uTop_styles.mli 3 | * --------------- 4 | * Copyright : (c) 2011, Jeremie Dimino 5 | * Licence : BSD3 6 | * 7 | * This file is a part of utop. 8 | *) 9 | 10 | (** Styled loaded from ~/.utoprc *) 11 | 12 | (** Type of utop styles. *) 13 | type styles = { 14 | mutable style_keyword : LTerm_style.t; 15 | mutable style_symbol : LTerm_style.t; 16 | mutable style_ident : LTerm_style.t; 17 | mutable style_module : LTerm_style.t; 18 | mutable style_constant : LTerm_style.t; 19 | mutable style_char : LTerm_style.t; 20 | mutable style_string : LTerm_style.t; 21 | mutable style_quotation : LTerm_style.t; 22 | mutable style_comment : LTerm_style.t; 23 | mutable style_doc : LTerm_style.t; 24 | mutable style_blanks : LTerm_style.t; 25 | mutable style_error : LTerm_style.t; 26 | mutable style_directive : LTerm_style.t; 27 | mutable style_paren : LTerm_style.t; 28 | mutable style_font : string option; 29 | mutable style_foreground : LTerm_style.color option; 30 | mutable style_background : LTerm_style.color option; 31 | mutable style_cursor : LTerm_style.color option; 32 | } 33 | 34 | val styles : styles 35 | (** The styles in use. *) 36 | 37 | val load : unit -> unit Lwt.t 38 | (** Load resources into [styles]. *) 39 | 40 | val stylise : (UTop_token.location -> LTerm_style.t -> unit) -> (UTop_token.t * UTop_token.location) list -> unit 41 | (** [stylise apply tokens] calls [apply] on all token locations with 42 | the associated style. *) 43 | -------------------------------------------------------------------------------- /src/lib/uTop_token.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * uTop_token.ml 3 | * ------------- 4 | * Copyright : (c) 2011, Jeremie Dimino 5 | * Licence : BSD3 6 | * 7 | * This file is a part of utop. 8 | *) 9 | 10 | (** Tokens. 11 | 12 | The type of tokens is semi-structured: parentheses construct and 13 | quotations are nested and others tokens are flat list. *) 14 | 15 | (** Locations in the source string, which is encoded in UTF-8. *) 16 | type location = { 17 | idx1 : int; 18 | (** Start position in unicode characters. *) 19 | idx2 : int; 20 | (** Stop position in unicode characters. *) 21 | ofs1 : int; 22 | (** Start position in bytes. *) 23 | ofs2 : int; 24 | (** Stop position in bytes. *) 25 | } 26 | 27 | type t = 28 | | Symbol of string 29 | | Lident of string 30 | | Uident of string 31 | | Constant of string 32 | | Char 33 | | String of int * bool 34 | (** [String (quote_size, terminated)]. *) 35 | | Comment of comment_kind * bool 36 | (** [Comment (kind, terminated)]. *) 37 | | Blanks 38 | | Error 39 | | Quotation of (quotation_item * location) list * bool 40 | (** [Quotation (items, terminated)]. *) 41 | 42 | and comment_kind = 43 | | Comment_reg 44 | (** Regular comment. *) 45 | | Comment_doc 46 | (** Documentation comment. *) 47 | 48 | and quotation_item = 49 | | Quot_data 50 | | Quot_anti of antiquotation 51 | 52 | and antiquotation = { 53 | a_opening : location; 54 | (** Location of the opening [$]. *) 55 | a_closing : location option; 56 | (** Location of the closing [$]. *) 57 | a_name : (location * location) option; 58 | (** Location of the name and colon if any. *) 59 | a_contents : (t * location) list; 60 | (** Contents of the location. *) 61 | } 62 | -------------------------------------------------------------------------------- /src/top/Eldev: -------------------------------------------------------------------------------- 1 | (eldev-use-package-archive 'melpa) 2 | -------------------------------------------------------------------------------- /src/top/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names utop) 3 | (libraries utop) 4 | (modes byte) 5 | (link_flags -linkall)) 6 | 7 | (rule 8 | (with-stdout-to 9 | info-ocamlcommon.txt 10 | (run %{bin:ocamlobjinfo} %{lib:compiler-libs.common:ocamlcommon.cma}))) 11 | 12 | (rule 13 | (with-stdout-to 14 | info-ocamlbytecomp.txt 15 | (run %{bin:ocamlobjinfo} %{lib:compiler-libs.bytecomp:ocamlbytecomp.cma}))) 16 | 17 | (rule 18 | (with-stdout-to 19 | info-ocamltoplevel.txt 20 | (run %{bin:ocamlobjinfo} %{lib:compiler-libs.toplevel:ocamltoplevel.cma}))) 21 | 22 | (rule 23 | (with-stdout-to 24 | info-utop.txt 25 | (run %{bin:ocamlobjinfo} %{dep:utop.bc}))) 26 | 27 | (rule 28 | (with-stdout-to 29 | modules.txt 30 | (run ./expunge/modules.exe %{dep:info-utop.txt} %{dep:info-ocamlcommon.txt} 31 | %{dep:info-ocamlbytecomp.txt} %{dep:info-ocamltoplevel.txt}))) 32 | 33 | (rule 34 | (targets utop-expunged.bc) 35 | (action 36 | (run %{ocaml_where}/expunge%{ext_exe} %{dep:utop.bc} %{targets} 37 | %{read-lines:modules.txt}))) 38 | 39 | (install 40 | (section bin) 41 | (files 42 | (utop-expunged.bc as utop) 43 | (utop.bc as utop-full))) 44 | -------------------------------------------------------------------------------- /src/top/expunge/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name modules)) 3 | -------------------------------------------------------------------------------- /src/top/expunge/modules.ml: -------------------------------------------------------------------------------- 1 | open StdLabels 2 | 3 | let input_lines ic = 4 | let rec loop acc = 5 | match input_line ic with 6 | | exception End_of_file -> List.rev acc 7 | | line -> loop (line :: acc) 8 | in 9 | loop [] 10 | 11 | let lines_of_info fn = 12 | let ic = open_in fn in 13 | Fun.protect 14 | (fun () -> input_lines ic) 15 | ~finally:(fun () -> close_in_noerr ic) 16 | 17 | module S = Set.Make(String) 18 | 19 | let main ~src ~cma_files = 20 | let modules = 21 | lines_of_info src 22 | |> List.map ~f:(fun line -> 23 | try 24 | Scanf.sscanf line "\t%[0-9a-f]\t%s" 25 | (fun a b -> assert (String.length a = 32); [b]) 26 | with _ -> []) 27 | |> List.concat 28 | |> S.of_list 29 | in 30 | let modules_to_exclude = 31 | List.map cma_files ~f:(fun fn -> 32 | lines_of_info fn 33 | |> List.map ~f:(fun line -> 34 | try 35 | Scanf.sscanf line "Unit name: %s" (fun s -> [s]) 36 | with _ -> []) 37 | |> List.concat) 38 | |> List.concat 39 | |> S.of_list 40 | |> S.remove "Topmain" 41 | |> S.remove "Toploop" 42 | |> S.remove "Topdirs" 43 | in 44 | let modules_to_keep = S.diff modules modules_to_exclude in 45 | S.iter print_endline modules_to_keep 46 | 47 | let () = 48 | match Array.to_list Sys.argv with 49 | | _ :: src :: cma_files -> 50 | main ~src ~cma_files 51 | | _ -> 52 | failwith "invalid command line" 53 | -------------------------------------------------------------------------------- /src/top/utop.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * uTop_start.ml 3 | * ------------- 4 | * Copyright : (c) 2012, Jeremie Dimino 5 | * Licence : BSD3 6 | * 7 | * This file is a part of utop. 8 | *) 9 | 10 | let () = UTop_main.main () 11 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_lib) 3 | (modes byte) 4 | (libraries alcotest utop)) 5 | -------------------------------------------------------------------------------- /test/test_lib.ml: -------------------------------------------------------------------------------- 1 | let test_fix_string = 2 | let test ~name input ~expected = 3 | (name, `Quick, fun () -> 4 | let got = UTop.Private.fix_string input in 5 | Alcotest.check Alcotest.string __LOC__ expected got 6 | ) 7 | in 8 | ( "fix_string" 9 | , [ test ~name:"small" "x" ~expected:"x" 10 | ; test ~name:"empty" "" ~expected:"" 11 | ] 12 | ) 13 | 14 | let () = Alcotest.run "utop" [test_fix_string] 15 | -------------------------------------------------------------------------------- /test/test_lib.mli: -------------------------------------------------------------------------------- 1 | (* empty *) 2 | -------------------------------------------------------------------------------- /utop.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Universal toplevel for OCaml" 4 | description: 5 | "utop is an improved toplevel (i.e., Read-Eval-Print Loop or REPL) for OCaml. It can run in a terminal or in Emacs. It supports line edition, history, real-time and context sensitive completion, colors, and more. It integrates with the Tuareg mode in Emacs." 6 | maintainer: ["jeremie@dimino.org"] 7 | authors: ["Jérémie Dimino"] 8 | license: "BSD-3-Clause" 9 | homepage: "https://github.com/ocaml-community/utop" 10 | doc: "https://ocaml-community.github.io/utop/" 11 | bug-reports: "https://github.com/ocaml-community/utop/issues" 12 | depends: [ 13 | "dune" {>= "2.7"} 14 | "ocaml" {>= "4.11.0"} 15 | "base-unix" 16 | "base-threads" 17 | "ocamlfind" {>= "1.7.2"} 18 | "lambda-term" {>= "3.1.0" & < "4.0"} 19 | "logs" 20 | "lwt" 21 | "lwt_react" 22 | "zed" {>= "3.2.0"} 23 | "react" {>= "1.0.0"} 24 | "cppo" {>= "1.1.2"} 25 | "alcotest" {with-test} 26 | "xdg" {>= "3.9.0"} 27 | "odoc" {with-doc} 28 | ] 29 | build: [ 30 | ["dune" "subst"] {dev} 31 | [ 32 | "dune" 33 | "build" 34 | "-p" 35 | name 36 | "-j" 37 | jobs 38 | "@install" 39 | "@runtest" {with-test} 40 | "@doc" {with-doc} 41 | ] 42 | ] 43 | dev-repo: "git+https://github.com/ocaml-community/utop.git" 44 | -------------------------------------------------------------------------------- /utoprc-dark: -------------------------------------------------------------------------------- 1 | ! -*- conf-xdefaults -*- 2 | 3 | ! Copy this file to $XDG_CONFIG_HOME/utoprc (~/.config/utoprc) 4 | 5 | ! Common resources 6 | 7 | profile: dark 8 | identifier.foreground: none 9 | module.foreground: x-palegreen 10 | comment.foreground: x-chocolate1 11 | doc.foreground: x-light-salmon 12 | constant.foreground: x-aquamarine 13 | keyword.foreground: x-cyan1 14 | symbol.foreground: x-cyan1 15 | string.foreground: x-light-salmon 16 | char.foreground: x-light-salmon 17 | quotation.foreground: x-purple 18 | error.foreground: red 19 | directive.foreground: x-lightsteelblue 20 | parenthesis.background: blue 21 | 22 | ! uncomment the next line to disable autoload files 23 | ! autoload: false 24 | -------------------------------------------------------------------------------- /utoprc-light: -------------------------------------------------------------------------------- 1 | ! -*- conf-xdefaults -*- 2 | 3 | ! Copy this file to $XDG_CONFIG_HOME/utoprc (~/.config/utoprc) 4 | 5 | ! Common resources 6 | 7 | profile: light 8 | identifier.foreground: none 9 | module.foreground: x-forestgreen 10 | comment.foreground: x-firebrick 11 | doc.foreground: x-violetred4 12 | constant.foreground: x-darkcyan 13 | keyword.foreground: x-purple 14 | symbol.foreground: x-purple 15 | string.foreground: x-violetred4 16 | char.foreground: x-violetred4 17 | quotation.foreground: x-purple 18 | error.foreground: red 19 | directive.foreground: x-mediumorchid4 20 | parenthesis.background: light-blue 21 | 22 | ! uncomment the next line to disable autoload files 23 | ! autoload: false 24 | --------------------------------------------------------------------------------